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" ;

66
mirage/unikernel.ml
View file

@ -359,30 +359,44 @@ 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 =
Git.connect git_ctx >>= fun (store, upstream) -> Disk.init kv >>= fun disk ->
Git.pull store upstream >>= function if Key_gen.check () then begin
| Error `Msg msg -> Lwt.fail_with msg Logs.info (fun m -> m "done");
| Ok msg -> Lwt.return_unit
Logs.info (fun m -> m "git: %s" msg); end else
Git.find_urls store >>= fun urls -> Git.connect git_ctx >>= fun (store, upstream) ->
Disk.init kv >>= fun disk -> Git.pull store upstream >>= function
let pool = Lwt_pool.create 20 (Fun.const Lwt.return_unit) in | Error `Msg msg -> Lwt.fail_with msg
Lwt_list.iter_p (fun (url, csums) -> | Ok msg ->
Lwt_pool.use pool @@ fun () -> Logs.info (fun m -> m "git: %s" msg);
HM.fold (fun h v r -> Git.find_urls store >>= fun urls ->
r >>= function let pool = Lwt_pool.create 20 (Fun.const Lwt.return_unit) in
| true -> Disk.exists disk h (hex_to_string v) Lwt_list.iter_p (fun (url, csums) ->
| false -> Lwt.return false) Lwt_pool.use pool @@ fun () ->
csums (Lwt.return true) >>= function HM.fold (fun h v r ->
| true -> r >>= function
Logs.info (fun m -> m "ignoring %s (already present)" url); | true -> Disk.exists disk h (hex_to_string v)
Lwt.return_unit | false -> Lwt.return false)
| false -> csums (Lwt.return true) >>= function
Logs.info (fun m -> m "downloading %s" url); | true ->
one_request ~ctx:http_ctx url >>= function Logs.debug (fun m -> m "ignoring %s (already present)" url);
| Ok (resp, Some str) -> Disk.write disk str csums Lwt.return_unit
| _ -> Lwt.return_unit) | false ->
(SM.bindings urls) >|= fun () -> Logs.info (fun m -> m "downloading %s" url);
Logs.info (fun m -> m "done") one_request ~ctx:http_ctx url >>= function
| 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)
(SM.bindings urls) >|= fun () ->
Logs.info (fun m -> m "done")
end end