robur/opam-mirror
4
0
Fork 0
Code Issues 6 Pull requests 2 Projects Releases Packages Wiki Activity Actions

Update to mirage.4.6.0

Browse source
This commit is contained in:
Calascibetta Romain 2024-07-15 12:22:57 +02:00
parent e002bf8730
commit c2ffbdb891
2 changed files with 143 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

111
mirage/config.ml
View file

@ -1,82 +1,41 @@
open Mirage open Mirage
let check = let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"
let doc =
Key.Arg.info ~doc:"Only check the cache" ["check"]
in
Key.(create "check" Arg.(flag doc))
let verify_sha256 = let ssh_key =
let doc = Runtime_arg.create ~pos:__POS__
Key.Arg.info ~doc:"Verify the SHA256 checksums of the cache contents, and \ {|let open Cmdliner in
re-build the other checksum caches." let doc = Arg.info ~doc:"The private SSH key (rsa:<seed> or ed25519:<b64-key>)." ["ssh-key"] in
["verify-sha256"] Arg.(value & opt (some string) None doc)|}
in
Key.(create "verify-sha256" Arg.(flag doc))
let remote = let ssh_authenticator =
let doc = Runtime_arg.create ~pos:__POS__
Key.Arg.info {|let open Cmdliner in
~doc:"Remote repository url, use suffix #foo to specify a branch 'foo': \ let doc = Arg.info ~doc:"SSH authenticator." ["ssh-auth"] in
https://github.com/ocaml/opam-repository.git" Arg.(value & opt (some string) None doc)|}
["remote"]
in
Key.(create "remote" Arg.(opt string "https://github.com/ocaml/opam-repository.git#master" doc))
let parallel_downloads = let ssh_password =
let doc = Runtime_arg.create ~pos:__POS__
Key.Arg.info {|let open Cmdliner in
~doc:"Amount of parallel HTTP downloads" let doc = Arg.info ~doc:"The private SSH password." [ "ssh-password" ] in
["parallel-downloads"] Arg.(value & opt (some string) None doc)|}
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 tls_authenticator = let tls_authenticator =
(* this will not look the same in the help printout *) Runtime_arg.create ~pos:__POS__
let doc = "TLS host authenticator. See git_http in lib/mirage/mirage.mli for a description of the format." {|let open Cmdliner in
in 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 let doc = Arg.info ~doc ["tls-authenticator"] in
Key.(create "tls-authenticator" Arg.(opt (some string) None doc)) Arg.(value & 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))
let mirror = let mirror =
foreign "Unikernel.Make" main "Unikernel.Make"
~keys:[ Key.v check ; Key.v verify_sha256 ; Key.v remote ; ~runtime_args:[ setup ]
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 ;
]
~packages:[ ~packages:[
package ~min:"0.3.0" ~sublibs:[ "mirage" ] "paf" ; package ~min:"0.3.0" ~sublibs:[ "mirage" ] "paf" ;
package "h2" ; package "h2" ;
package "hex" ; package "hex" ;
package "httpaf" ; package "httpaf" ;
package "git-kv" ; package ~max:"0.0.5" "git-kv" ;
package ~min:"3.10.0" "git-paf" ; package ~min:"3.10.0" "git-paf" ;
package "opam-file-format" ; package "opam-file-format" ;
package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ; package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ;
@ -87,23 +46,17 @@ let mirror =
(block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job) (block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job)
let stack = generic_stackv4v6 default_network let stack = generic_stackv4v6 default_network
let he = generic_happy_eyeballs stack
let dns = generic_dns_client stack let dns = generic_dns_client stack he
let tcp = tcpv4v6_of_stackv4v6 stack let tcp = tcpv4v6_of_stackv4v6 stack
let block = block_of_file "tar"
let git_client, alpn_client = let git_client, alpn_client =
let happy_eyeballs = generic_happy_eyeballs stack dns in let git = mimic_happy_eyeballs stack he dns in
let git = mimic_happy_eyeballs stack dns happy_eyeballs in merge_git_clients (git_ssh ~key:ssh_key ~authenticator:ssh_authenticator ~password:ssh_password tcp git)
merge_git_clients (git_tcp tcp git) (merge_git_clients (git_tcp tcp git)
(git_http ~authenticator:tls_authenticator tcp git), (git_http ~authenticator:tls_authenticator tcp git)),
paf_client ~pclock:default_posix_clock tcp (mimic_happy_eyeballs stack dns happy_eyeballs) paf_client tcp (mimic_happy_eyeballs stack he dns)
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 () = register "mirror" 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 ]

134
mirage/unikernel.ml
View file

@ -2,6 +2,90 @@ open Lwt.Infix
let argument_error = 64 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 module Make
(BLOCK : Mirage_block.S) (BLOCK : Mirage_block.S)
(Time : Mirage_time.S) (Time : Mirage_time.S)
@ -772,8 +856,8 @@ module Make
Logs.err (fun m -> m "%a" Store.pp_error e); Logs.err (fun m -> m "%a" Store.pp_error e);
exit 2) exit 2)
let repo commit = let repo remote commit =
let upstream = List.hd (String.split_on_char '#' (Key_gen.remote ())) in let upstream = List.hd (String.split_on_char '#' remote) in
Fmt.str Fmt.str
{|opam-version: "2.0" {|opam-version: "2.0"
upstream: "%s#%s" upstream: "%s#%s"
@ -797,16 +881,16 @@ stamp: %S
mutable index : string ; mutable index : string ;
} }
let create git_kv = let create remote git_kv =
commit_id git_kv >>= fun commit_id -> commit_id git_kv >>= fun commit_id ->
modified git_kv >>= fun modified -> 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 -> Tarball.of_git repo git_kv >|= fun index ->
{ commit_id ; modified ; repo ; index } { commit_id ; modified ; repo ; index }
let update_lock = Lwt_mutex.create () 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 () -> Lwt_mutex.with_lock update_lock (fun () ->
Logs.info (fun m -> m "pulling the git repository"); Logs.info (fun m -> m "pulling the git repository");
Git_kv.pull git_kv >>= function Git_kv.pull git_kv >>= function
@ -820,7 +904,7 @@ stamp: %S
commit_id git_kv >>= fun commit_id -> commit_id git_kv >>= fun commit_id ->
modified git_kv >>= fun modified -> modified git_kv >>= fun modified ->
Logs.info (fun m -> m "git: %s" commit_id); 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 -> Tarball.of_git repo git_kv >|= fun index ->
t.commit_id <- commit_id ; t.commit_id <- commit_id ;
t.modified <- modified ; t.modified <- modified ;
@ -967,11 +1051,11 @@ stamp: %S
let bad_archives = SSet.of_list Bad.archives 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 *) (* FIXME: handle resuming partial downloads *)
Git.find_urls store >>= fun urls -> Git.find_urls store >>= fun urls ->
let urls = SM.filter (fun k _ -> not (SSet.mem k bad_archives)) urls in 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 let idx = ref 0 in
Lwt_list.iter_p (fun (url, csums) -> Lwt_list.iter_p (fun (url, csums) ->
Lwt_pool.use pool @@ fun () -> Lwt_pool.use pool @@ fun () ->
@ -1016,14 +1100,14 @@ stamp: %S
| Error e -> | Error e ->
Logs.warn (fun m -> m "failed to dump git: %a" Cache.pp_write_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 Cache.read git_dump >>= function
| Ok None -> Lwt.return (Error ()) | Ok None -> Lwt.return (Error ())
| Error e -> | Error e ->
Logs.warn (fun m -> m "failed to read git state: %a" Cache.pp_error e); Logs.warn (fun m -> m "failed to read git state: %a" Cache.pp_error e);
Lwt.return (Error ()) Lwt.return (Error ())
| Ok Some data -> | 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 | Ok git_kv -> Ok git_kv
| Error `Msg msg -> | Error `Msg msg ->
Logs.err (fun m -> m "error restoring git state: %s" 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) 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 -> 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 git_start =
let cache_size = Int64.(mul 2L sectors_cache) in let cache_size = Int64.(mul 2L sectors_cache) in
Int64.(sub info.size_sectors (add cache_size sectors_git)) Int64.(sub info.size_sectors (add cache_size sectors_git))
@ -1047,41 +1131,41 @@ stamp: %S
Cache.connect sha512s >>= fun sha512s -> Cache.connect sha512s >>= fun sha512s ->
Cache.connect git_dump >>= fun git_dump -> Cache.connect git_dump >>= fun git_dump ->
Logs.info (fun m -> m "Available bytes in tar storage: %Ld" (KV.free kv)); 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 -> Disk.init ~verify_sha256 kv md5s sha512s >>= fun disk ->
if Key_gen.check () then if check then
Lwt.return_unit Lwt.return_unit
else else
begin begin
Logs.info (fun m -> m "Initializing git state. This may take a while..."); 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 ()) Lwt.return (Error ())
else else
restore_git git_dump git_ctx) >>= function restore_git ~remote git_dump git_ctx) >>= function
| Ok git_kv -> Lwt.return git_kv | Ok git_kv -> Lwt.return git_kv
| Error () -> | 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 () -> dump_git git_dump git_kv >|= fun () ->
git_kv git_kv
end >>= fun git_kv -> end >>= fun git_kv ->
Logs.info (fun m -> m "Done initializing git state!"); Logs.info (fun m -> m "Done initializing git state!");
Serve.commit_id git_kv >>= fun commit_id -> Serve.commit_id git_kv >>= fun commit_id ->
Logs.info (fun m -> m "git: %s" commit_id); Logs.info (fun m -> m "git: %s" commit_id);
Serve.create git_kv >>= fun serve -> Serve.create remote git_kv >>= fun serve ->
Paf.init ~port:(Key_gen.port ()) (Stack.tcp stack) >>= fun t -> Paf.init ~port (Stack.tcp stack) >>= fun t ->
let update () = let update () =
Serve.update_git serve git_kv >>= function Serve.update_git ~remote serve git_kv >>= function
| None | Some [] -> Lwt.return_unit | None | Some [] -> Lwt.return_unit
| Some _changes -> | Some _changes ->
dump_git git_dump git_kv >>= fun () -> dump_git git_dump git_kv >>= fun () ->
download_archives disk http_ctx git_kv download_archives parallel_downloads disk http_ctx git_kv
in in
let service = let service =
Paf.http_service Paf.http_service
~error_handler:(fun _ ?request:_ _ _ -> ()) ~error_handler:(fun _ ?request:_ _ _ -> ())
(Serve.dispatch serve disk (Key_gen.hook_url ()) update) (Serve.dispatch serve disk hook_url update)
in in
let `Initialized th = Paf.serve service t 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 () -> Lwt.async (fun () ->
let rec go () = let rec go () =
Time.sleep_ns (Duration.of_hour 1) >>= fun () -> Time.sleep_ns (Duration.of_hour 1) >>= fun () ->
@ -1089,6 +1173,6 @@ stamp: %S
go () go ()
in in
go ()); go ());
download_archives disk http_ctx git_kv >>= fun () -> download_archives parallel_downloads disk http_ctx git_kv >>= fun () ->
(th >|= fun _v -> ()) (th >|= fun _v -> ())
end end