robur/opam-mirror
4
0
Fork 0
Code Issues 6 Pull requests 2 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
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 doc = Key.Arg.info
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"]
@ -20,7 +29,7 @@ let tls_authenticator =
let mirror =
foreign "Unikernel.Make"
~keys:[ Key.v remote ; Key.v tls_authenticator ]
~keys:[ Key.v check ; Key.v remote ; Key.v tls_authenticator ]
~packages:[
package "paf" ;
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
~authenticator:HTTP.authenticator
let start kv _time _pclock stack git_ctx http_ctx =
Git.connect git_ctx >>= fun (store, upstream) ->
Git.pull store upstream >>= function
| Error `Msg msg -> Lwt.fail_with msg
| Ok msg ->
Logs.info (fun m -> m "git: %s" msg);
Git.find_urls store >>= fun urls ->
Disk.init kv >>= fun disk ->
let pool = Lwt_pool.create 20 (Fun.const Lwt.return_unit) in
Lwt_list.iter_p (fun (url, csums) ->
Lwt_pool.use pool @@ fun () ->
HM.fold (fun h v r ->
r >>= function
| true -> Disk.exists disk h (hex_to_string v)
| false -> Lwt.return false)
csums (Lwt.return true) >>= function
| true ->
Logs.info (fun m -> m "ignoring %s (already present)" url);
Lwt.return_unit
| false ->
Logs.info (fun m -> m "downloading %s" url);
one_request ~ctx:http_ctx url >>= function
| Ok (resp, Some str) -> Disk.write disk str csums
| _ -> Lwt.return_unit)
(SM.bindings urls) >|= fun () ->
Logs.info (fun m -> m "done")
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.pull store upstream >>= function
| Error `Msg msg -> Lwt.fail_with msg
| Ok msg ->
Logs.info (fun m -> m "git: %s" msg);
Git.find_urls store >>= fun urls ->
let pool = Lwt_pool.create 20 (Fun.const Lwt.return_unit) in
Lwt_list.iter_p (fun (url, csums) ->
Lwt_pool.use pool @@ fun () ->
HM.fold (fun h v r ->
r >>= function
| true -> Disk.exists disk h (hex_to_string v)
| false -> Lwt.return false)
csums (Lwt.return true) >>= function
| true ->
Logs.debug (fun m -> m "ignoring %s (already present)" url);
Lwt.return_unit
| false ->
Logs.info (fun m -> m "downloading %s" url);
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