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

115
mirage/config.ml
View file

@ -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:<seed> or ed25519:<b64-key>)." ["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 ]

134
mirage/unikernel.ml
View file

@ -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