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

unikernel: new flag --check to only check data (and hashes) on disk

Browse source
This commit is contained in:
Hannes Mehnert 2022-09-01 09:30:11 +02:00
parent c16f2288ed
commit a1e4b71eb9
2 changed files with 51 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
mirage/config.ml
View file

@ -3,8 +3,17 @@ open Mirage
type http_client = HTTP_client type http_client = HTTP_client
let http_client = typ HTTP_client let http_client = typ HTTP_client
let check =
let doc =
Key.Arg.info
~doc:"Only check the cache"
["check"]
in
Key.(create "check" Arg.(flag doc))
let remote = let remote =
let doc = Key.Arg.info let doc =
Key.Arg.info
~doc:"Remote repository url, use suffix #foo to specify a branch 'foo': \ ~doc:"Remote repository url, use suffix #foo to specify a branch 'foo': \
https://github.com/ocaml/opam-repository.git" https://github.com/ocaml/opam-repository.git"
["remote"] ["remote"]
@ -20,7 +29,7 @@ let tls_authenticator =
let mirror = let mirror =
foreign "Unikernel.Make" foreign "Unikernel.Make"
~keys:[ Key.v remote ; Key.v tls_authenticator ] ~keys:[ Key.v check ; Key.v remote ; Key.v tls_authenticator ]
~packages:[ ~packages:[
package "paf" ; package "paf" ;
package "h2" ; package "h2" ;

22
mirage/unikernel.ml
View file

@ -359,14 +359,18 @@ module Make
let one_request = Http_mirage_client.one_request ~alpn_protocol:HTTP.alpn_protocol let one_request = Http_mirage_client.one_request ~alpn_protocol:HTTP.alpn_protocol
~authenticator:HTTP.authenticator ~authenticator:HTTP.authenticator
let start kv _time _pclock stack git_ctx http_ctx = let start kv _time _pclock _stack git_ctx http_ctx =
Disk.init kv >>= fun disk ->
if Key_gen.check () then begin
Logs.info (fun m -> m "done");
Lwt.return_unit
end else
Git.connect git_ctx >>= fun (store, upstream) -> Git.connect git_ctx >>= fun (store, upstream) ->
Git.pull store upstream >>= function Git.pull store upstream >>= function
| Error `Msg msg -> Lwt.fail_with msg | Error `Msg msg -> Lwt.fail_with msg
| Ok msg -> | Ok msg ->
Logs.info (fun m -> m "git: %s" msg); Logs.info (fun m -> m "git: %s" msg);
Git.find_urls store >>= fun urls -> Git.find_urls store >>= fun urls ->
Disk.init kv >>= fun disk ->
let pool = Lwt_pool.create 20 (Fun.const Lwt.return_unit) in let pool = Lwt_pool.create 20 (Fun.const Lwt.return_unit) 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 () ->
@ -376,12 +380,22 @@ module Make
| false -> Lwt.return false) | false -> Lwt.return false)
csums (Lwt.return true) >>= function csums (Lwt.return true) >>= function
| true -> | true ->
Logs.info (fun m -> m "ignoring %s (already present)" url); Logs.debug (fun m -> m "ignoring %s (already present)" url);
Lwt.return_unit Lwt.return_unit
| false -> | false ->
Logs.info (fun m -> m "downloading %s" url); Logs.info (fun m -> m "downloading %s" url);
one_request ~ctx:http_ctx url >>= function one_request ~ctx:http_ctx url >>= function
| Ok (resp, Some str) -> Disk.write disk str csums | Ok (resp, Some str) ->
Logs.info (fun m -> m "downloaded %s" url);
if resp.status = `OK then
Disk.write disk str csums
else begin
Logs.warn (fun m -> m "received for %s: %a (reason %s) (headers %a)"
url H2.Status.pp_hum resp.status resp.reason
H2.Headers.pp_hum resp.headers
);
Lwt.return_unit
end
| _ -> Lwt.return_unit) | _ -> Lwt.return_unit)
(SM.bindings urls) >|= fun () -> (SM.bindings urls) >|= fun () ->
Logs.info (fun m -> m "done") Logs.info (fun m -> m "done")