diff --git a/mirage/config.ml b/mirage/config.ml index e39e4a2..2c87042 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -28,6 +28,13 @@ let remote = in Key.(create "remote" Arg.(opt string "https://github.com/ocaml/opam-repository.git#master" doc)) +let hook_url = + let doc = + Key.Arg.info + ~doc:"URL to conduct an update of the git repository" ["hook-url"] + in + Key.(create "hook-url" Arg.(opt string "update" doc)) + let port = let doc = Key.Arg.info ~doc:"HTTP listen port." ["port"] in Key.(create "port" Arg.(opt int 80 doc)) @@ -41,7 +48,7 @@ let tls_authenticator = let mirror = foreign "Unikernel.Make" - ~keys:[ Key.v key_hex ; Key.v check ; Key.v remote ; Key.v tls_authenticator ; Key.v port ] + ~keys:[ Key.v key_hex ; Key.v check ; Key.v remote ; Key.v hook_url ; Key.v tls_authenticator ; Key.v port ] ~packages:[ package ~min:"0.1.0" ~sublibs:[ "mirage" ] "paf" ; package "h2" ; diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index da2983a..dfbc33b 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -451,9 +451,7 @@ module Make Fmt.to_to_string (Irmin.Type.pp Store.Hash.t) (Store.Commit.hash commit) let repo commit = - let upstream = List.hd (String.split_on_char '#' (Key_gen.remote ())) - and commit = commit_id commit - in + let upstream = List.hd (String.split_on_char '#' (Key_gen.remote ())) in Fmt.str {|opam-version: "2.0" upstream: "%s#%s" @@ -470,18 +468,42 @@ stamp: %S ptime_to_http_date ptime type t = { - commit_id : string ; - modified : string ; - repo : string ; - index : string ; + mutable commit_id : string ; + mutable modified : string ; + mutable repo : string ; + mutable index : string ; } - let create commit repo index = + let create commit store = let commit_id = commit_id commit and modified = modified commit in + let repo = repo commit_id in + Tarball.of_git repo store >|= fun index -> { commit_id ; modified ; repo ; index } + let update_lock = Lwt_mutex.create () + + let update_git t git_ctx = + Lwt_mutex.with_lock update_lock (fun () -> + Git.connect git_ctx >>= fun (store, upstream) -> + Git.pull store upstream >>= function + | Error `Msg msg -> + Logs.err (fun m -> m "error %s while updating git" msg); + Lwt.return None + | Ok (commit, msg) -> + Logs.info (fun m -> m "git: %s" msg); + let commit_id = commit_id commit + and modified = modified commit + in + let repo = repo commit_id in + Tarball.of_git repo store >|= fun index -> + t.commit_id <- commit_id ; + t.modified <- modified ; + t.repo <- repo ; + t.index <- index; + Some store) + let not_modified request (modified, etag) = match Httpaf.Headers.get request.Httpaf.Request.headers "if-modified-since" with | Some ts -> String.equal ts modified @@ -517,10 +539,26 @@ stamp: %S let resp = Httpaf.Response.create `Not_modified in respond_with_empty reqd resp else *) - let dispatch t store _flow _conn reqd = + let dispatch t store hook_url git_ctx update _flow _conn reqd = let request = Httpaf.Reqd.request reqd in Logs.info (fun f -> f "requested %s" request.Httpaf.Request.target); match String.split_on_char '/' request.Httpaf.Request.target with + | [ ""; x ] when String.equal x hook_url -> + Lwt.async (fun () -> + update_git t git_ctx >>= function + | None -> Lwt.return_unit + | Some store -> update store); + let data = "Update in progress" in + let mime_type = "text/plain" in + let headers = [ + "content-type", mime_type ; + "etag", t.commit_id ; + "last-modified", t.modified ; + "content-length", string_of_int (String.length data) ; + ] in + let headers = Httpaf.Headers.of_list headers in + let resp = Httpaf.Response.create ~headers `OK in + Httpaf.Reqd.respond_with_string reqd resp data | [ ""; "repo" ] -> if not_modified request (t.modified, t.commit_id) then let resp = Httpaf.Response.create `Not_modified in @@ -640,14 +678,13 @@ stamp: %S | Error `Msg msg -> Lwt.fail_with msg | Ok (commit, msg) -> Logs.info (fun m -> m "git: %s" msg); - let repo = Serve.repo commit in - Tarball.of_git repo store >>= fun index -> - let serve = Serve.create commit repo index in + Serve.create commit store >>= fun serve -> Paf.init ~port:(Key_gen.port ()) (Stack.tcp stack) >>= fun t -> + let update store = download_archives disk http_ctx store in let service = Paf.http_service ~error_handler:(fun _ ?request:_ _ _ -> ()) - (Serve.dispatch serve disk) + (Serve.dispatch serve disk (Key_gen.hook_url ()) git_ctx update) in let `Initialized th = Paf.serve service t in Logs.info (fun f -> f "listening on %d/HTTP" (Key_gen.port ()));