Update to mirage.4.6.0
This commit is contained in:
parent
e002bf8730
commit
c2ffbdb891
2 changed files with 143 additions and 106 deletions
111
mirage/config.ml
111
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:<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 block = block_of_file "tar"
|
||||
|
||||
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 = 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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue