From c2ffbdb891cbb0eb8a4f224131308b9d164b5aa7 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 15 Jul 2024 12:22:57 +0200 Subject: [PATCH] Update to mirage.4.6.0 --- mirage/config.ml | 115 +++++++++++-------------------------- mirage/unikernel.ml | 134 +++++++++++++++++++++++++++++++++++--------- 2 files changed, 143 insertions(+), 106 deletions(-) diff --git a/mirage/config.ml b/mirage/config.ml index 15e75a8..4369a8f 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -1,82 +1,41 @@ open Mirage -let check = - let doc = - Key.Arg.info ~doc:"Only check the cache" ["check"] - in - Key.(create "check" Arg.(flag doc)) +let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup" -let verify_sha256 = - let doc = - Key.Arg.info ~doc:"Verify the SHA256 checksums of the cache contents, and \ - re-build the other checksum caches." - ["verify-sha256"] - in - Key.(create "verify-sha256" Arg.(flag doc)) +let ssh_key = + Runtime_arg.create ~pos:__POS__ + {|let open Cmdliner in + let doc = Arg.info ~doc:"The private SSH key (rsa: or ed25519:)." ["ssh-key"] in + Arg.(value & opt (some string) None doc)|} -let remote = - let doc = - Key.Arg.info - ~doc:"Remote repository url, use suffix #foo to specify a branch 'foo': \ - https://github.com/ocaml/opam-repository.git" - ["remote"] - in - Key.(create "remote" Arg.(opt string "https://github.com/ocaml/opam-repository.git#master" doc)) +let ssh_authenticator = + Runtime_arg.create ~pos:__POS__ + {|let open Cmdliner in + let doc = Arg.info ~doc:"SSH authenticator." ["ssh-auth"] in + Arg.(value & opt (some string) None doc)|} -let parallel_downloads = - let doc = - Key.Arg.info - ~doc:"Amount of parallel HTTP downloads" - ["parallel-downloads"] - in - Key.(create "parallel-downloads" Arg.(opt int 20 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)) +let ssh_password = + Runtime_arg.create ~pos:__POS__ + {|let open Cmdliner in + let doc = Arg.info ~doc:"The private SSH password." [ "ssh-password" ] in + Arg.(value & opt (some string) None doc)|} let tls_authenticator = - (* this will not look the same in the help printout *) - let doc = "TLS host authenticator. See git_http in lib/mirage/mirage.mli for a description of the format." - in - let doc = Key.Arg.info ~doc ["tls-authenticator"] in - Key.(create "tls-authenticator" Arg.(opt (some string) None doc)) - -let sectors_cache = - let doc = "Number of sectors reserved for each checksum cache (md5, sha512)." in - let doc = Key.Arg.info ~doc ["sectors-cache"] in - Key.(create "sectors-cache" Arg.(opt int64 Int64.(mul 4L 2048L) doc)) - -let sectors_git = - let doc = "Number of sectors reserved for git dump." in - let doc = Key.Arg.info ~doc ["sectors-git"] in - Key.(create "sectors-git" Arg.(opt int64 Int64.(mul 40L (mul 2L 1024L)) doc)) - -let ignore_local_git = - let doc = "Ignore restoring locally saved git repository." in - let doc = Key.Arg.info ~doc ["ignore-local-git"] in - Key.(create "ignore-local-git" Arg.(flag doc)) + Runtime_arg.create ~pos:__POS__ + {|let open Cmdliner in + let doc = "TLS host authenticator. See git_http in lib/mirage/mirage.mli for a description of the format." in + let doc = Arg.info ~doc ["tls-authenticator"] in + Arg.(value & opt (some string) None doc)|} let mirror = - foreign "Unikernel.Make" - ~keys:[ Key.v check ; Key.v verify_sha256 ; Key.v remote ; - Key.v parallel_downloads ; Key.v hook_url ; Key.v tls_authenticator ; - Key.v port ; Key.v sectors_cache ; Key.v sectors_git ; - Key.v ignore_local_git ; - ] + main "Unikernel.Make" + ~runtime_args:[ setup ] ~packages:[ package ~min:"0.3.0" ~sublibs:[ "mirage" ] "paf" ; package "h2" ; package "hex" ; package "httpaf" ; - package "git-kv" ; + package ~max:"0.0.5" "git-kv" ; package ~min:"3.10.0" "git-paf" ; package "opam-file-format" ; package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ; @@ -87,23 +46,17 @@ let mirror = (block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job) let stack = generic_stackv4v6 default_network - -let dns = generic_dns_client stack - +let he = generic_happy_eyeballs stack +let dns = generic_dns_client stack he let tcp = tcpv4v6_of_stackv4v6 stack - -let git_client, alpn_client = - let happy_eyeballs = generic_happy_eyeballs stack dns in - let git = mimic_happy_eyeballs stack dns happy_eyeballs in - merge_git_clients (git_tcp tcp git) - (git_http ~authenticator:tls_authenticator tcp git), - paf_client ~pclock:default_posix_clock tcp (mimic_happy_eyeballs stack dns happy_eyeballs) - -let program_block_size = - let doc = Key.Arg.info [ "program-block-size" ] in - Key.(create "program_block_size" Arg.(opt int 16 doc)) - let block = block_of_file "tar" +let git_client, alpn_client = + let git = mimic_happy_eyeballs stack he dns in + merge_git_clients (git_ssh ~key:ssh_key ~authenticator:ssh_authenticator ~password:ssh_password tcp git) + (merge_git_clients (git_tcp tcp git) + (git_http ~authenticator:tls_authenticator tcp git)), + paf_client tcp (mimic_happy_eyeballs stack he dns) + let () = register "mirror" - [ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ alpn_client ] + [ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ alpn_client ] diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index 5bbb9ba..0a4cb34 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -2,6 +2,90 @@ open Lwt.Infix let argument_error = 64 +module K = struct + open Cmdliner + + let check = + let doc = Arg.info ~doc:"Only check the cache" ["check"] in + Arg.(value & flag doc) + + let verify_sha256 = + let doc = Arg.info + ~doc:"Verify the SHA256 checksums of the cache contents, and \ + re-build the other checksum caches." + ["verify-sha256"] + in + Arg.(value & flag doc) + + let remote = + let doc = Arg.info + ~doc:"Remote repository url, use suffix #foo to specify a branch 'foo': \ + https://github.com/ocaml/opam-repository.git" + ["remote"] + in + Arg.(value & opt string "https://github.com/ocaml/opam-repository.git#master" doc) + + let parallel_downloads = + let doc = Arg.info + ~doc:"Amount of parallel HTTP downloads" + ["parallel-downloads"] + in + Arg.(value & opt int 20 doc) + + let hook_url = + let doc = Arg.info + ~doc:"URL to conduct an update of the git repository" ["hook-url"] + in + Arg.(value & opt string "update" doc) + + let port = + let doc = Arg.info ~doc:"HTTP listen port." ["port"] in + Arg.(value & opt int 80 doc) + + let sectors_cache = + let doc = "Number of sectors reserved for each checksum cache (md5, sha512)." in + let doc = Arg.info ~doc ["sectors-cache"] in + Arg.(value & opt int64 Int64.(mul 4L 2048L) doc) + + let sectors_git = + let doc = "Number of sectors reserved for git dump." in + let doc = Arg.info ~doc ["sectors-git"] in + Arg.(value & opt int64 Int64.(mul 40L (mul 2L 1024L)) doc) + + let ignore_local_git = + let doc = "Ignore restoring locally saved git repository." in + let doc = Arg.info ~doc ["ignore-local-git"] in + Arg.(value & flag doc) + + type t = + { check : bool + ; verify_sha256 : bool + ; remote : string + ; parallel_downloads : int + ; hook_url : string + ; port : int + ; sectors_cache : int64 + ; sectors_git : int64 + ; ignore_local_git : bool } + + let v check verify_sha256 remote parallel_downloads hook_url port + sectors_cache sectors_git ignore_local_git = + { check; verify_sha256; remote; parallel_downloads; hook_url; port + ; sectors_cache; sectors_git; ignore_local_git } + + let setup = + Term.(const v + $ check + $ verify_sha256 + $ remote + $ parallel_downloads + $ hook_url + $ port + $ sectors_cache + $ sectors_git + $ ignore_local_git) +end + module Make (BLOCK : Mirage_block.S) (Time : Mirage_time.S) @@ -772,8 +856,8 @@ module Make Logs.err (fun m -> m "%a" Store.pp_error e); exit 2) - let repo commit = - let upstream = List.hd (String.split_on_char '#' (Key_gen.remote ())) in + let repo remote commit = + let upstream = List.hd (String.split_on_char '#' remote) in Fmt.str {|opam-version: "2.0" upstream: "%s#%s" @@ -797,16 +881,16 @@ stamp: %S mutable index : string ; } - let create git_kv = + let create remote git_kv = commit_id git_kv >>= fun commit_id -> modified git_kv >>= fun modified -> - let repo = repo commit_id in + let repo = repo remote commit_id in Tarball.of_git repo git_kv >|= fun index -> { commit_id ; modified ; repo ; index } let update_lock = Lwt_mutex.create () - let update_git t git_kv = + let update_git ~remote t git_kv = Lwt_mutex.with_lock update_lock (fun () -> Logs.info (fun m -> m "pulling the git repository"); Git_kv.pull git_kv >>= function @@ -820,7 +904,7 @@ stamp: %S commit_id git_kv >>= fun commit_id -> modified git_kv >>= fun modified -> Logs.info (fun m -> m "git: %s" commit_id); - let repo = repo commit_id in + let repo = repo remote commit_id in Tarball.of_git repo git_kv >|= fun index -> t.commit_id <- commit_id ; t.modified <- modified ; @@ -967,11 +1051,11 @@ stamp: %S let bad_archives = SSet.of_list Bad.archives - let download_archives disk http_client store = + let download_archives parallel_downloads disk http_client store = (* FIXME: handle resuming partial downloads *) Git.find_urls store >>= fun urls -> let urls = SM.filter (fun k _ -> not (SSet.mem k bad_archives)) urls in - let pool = Lwt_pool.create (Key_gen.parallel_downloads ()) (Fun.const Lwt.return_unit) in + let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in let idx = ref 0 in Lwt_list.iter_p (fun (url, csums) -> Lwt_pool.use pool @@ fun () -> @@ -1016,14 +1100,14 @@ stamp: %S | Error e -> Logs.warn (fun m -> m "failed to dump git: %a" Cache.pp_write_error e) - let restore_git git_dump git_ctx = + let restore_git ~remote git_dump git_ctx = Cache.read git_dump >>= function | Ok None -> Lwt.return (Error ()) | Error e -> Logs.warn (fun m -> m "failed to read git state: %a" Cache.pp_error e); Lwt.return (Error ()) | Ok Some data -> - Git_kv.of_octets git_ctx ~remote:(Key_gen.remote ()) data >|= function + Git_kv.of_octets git_ctx ~remote data >|= function | Ok git_kv -> Ok git_kv | Error `Msg msg -> Logs.err (fun m -> m "error restoring git state: %s" msg); @@ -1031,10 +1115,10 @@ stamp: %S module Paf = Paf_mirage.Make(Stack.TCP) - let start block _time _pclock stack git_ctx http_ctx = + let start block _time _pclock stack git_ctx http_ctx + { K.check; verify_sha256; remote; parallel_downloads; hook_url + ; port; sectors_cache; sectors_git; ignore_local_git } = BLOCK.get_info block >>= fun info -> - let sectors_cache = Key_gen.sectors_cache () in - let sectors_git = Key_gen.sectors_git () in let git_start = let cache_size = Int64.(mul 2L sectors_cache) in Int64.(sub info.size_sectors (add cache_size sectors_git)) @@ -1047,41 +1131,41 @@ stamp: %S Cache.connect sha512s >>= fun sha512s -> Cache.connect git_dump >>= fun git_dump -> Logs.info (fun m -> m "Available bytes in tar storage: %Ld" (KV.free kv)); - Disk.init ~verify_sha256:(Key_gen.verify_sha256 ()) kv md5s sha512s >>= fun disk -> - if Key_gen.check () then + Disk.init ~verify_sha256 kv md5s sha512s >>= fun disk -> + if check then Lwt.return_unit else begin Logs.info (fun m -> m "Initializing git state. This may take a while..."); - (if Key_gen.ignore_local_git () then + (if ignore_local_git then Lwt.return (Error ()) else - restore_git git_dump git_ctx) >>= function + restore_git ~remote git_dump git_ctx) >>= function | Ok git_kv -> Lwt.return git_kv | Error () -> - Git_kv.connect git_ctx (Key_gen.remote ()) >>= fun git_kv -> + Git_kv.connect git_ctx remote >>= fun git_kv -> dump_git git_dump git_kv >|= fun () -> git_kv end >>= fun git_kv -> Logs.info (fun m -> m "Done initializing git state!"); Serve.commit_id git_kv >>= fun commit_id -> Logs.info (fun m -> m "git: %s" commit_id); - Serve.create git_kv >>= fun serve -> - Paf.init ~port:(Key_gen.port ()) (Stack.tcp stack) >>= fun t -> + Serve.create remote git_kv >>= fun serve -> + Paf.init ~port (Stack.tcp stack) >>= fun t -> let update () = - Serve.update_git serve git_kv >>= function + Serve.update_git ~remote serve git_kv >>= function | None | Some [] -> Lwt.return_unit | Some _changes -> dump_git git_dump git_kv >>= fun () -> - download_archives disk http_ctx git_kv + download_archives parallel_downloads disk http_ctx git_kv in let service = Paf.http_service ~error_handler:(fun _ ?request:_ _ _ -> ()) - (Serve.dispatch serve disk (Key_gen.hook_url ()) update) + (Serve.dispatch serve disk hook_url update) in let `Initialized th = Paf.serve service t in - Logs.info (fun f -> f "listening on %d/HTTP" (Key_gen.port ())); + Logs.info (fun f -> f "listening on %d/HTTP" port); Lwt.async (fun () -> let rec go () = Time.sleep_ns (Duration.of_hour 1) >>= fun () -> @@ -1089,6 +1173,6 @@ stamp: %S go () in go ()); - download_archives disk http_ctx git_kv >>= fun () -> + download_archives parallel_downloads disk http_ctx git_kv >>= fun () -> (th >|= fun _v -> ()) end