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

revise startup, address urls pointing to same sha256 and support mirrors (upstream and in opam file) #24

Merged
hannes merged 7 commits from startup into main 2024-11-20 10:38:22 +00:00
Conversation 1 Commits 7 Files changed 3 +26 -10
1 changed files with 26 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files
Showing only changes of commit ec45a6a77a - Show all commits

36
mirage/unikernel.ml
View file

@ -14,7 +14,15 @@ module K = struct
Mirage_runtime.register_arg Arg.(value & flag doc) Mirage_runtime.register_arg Arg.(value & flag doc)
let upstream_caches = let upstream_caches =
let doc = Arg.info ~doc:"Upstream caches (e.g. https://opam.ocaml.org/cache)" ["upstream-cache"] in let doc =
"Upstream caches (e.g. https://opam.ocaml.org/cache). \
For each package first the declared url is attempted. Then, \
if any, all the declared mirrors are attempted. \
Finally, the upstream caches are attempted. \
Note that this does not change the \"archive-mirrors:\" value \
in the /repo endpoint."
in
let doc = Arg.info ~doc ["upstream-cache"] in
Mirage_runtime.register_arg Arg.(value & opt_all string [] doc) Mirage_runtime.register_arg Arg.(value & opt_all string [] doc)
let skip_verify_sha256 = let skip_verify_sha256 =
@ -184,15 +192,17 @@ module Make
url', SSet.add url mirrors url', SSet.add url mirrors
in in
SM.update url (function SM.update url (function
| None -> Some (csums, SSet.union mirrors (upstream csums)) | None -> Some (csums, mirrors, upstream csums)
| Some (csums', mirrors') -> | Some (csums', mirrors', upstream_caches') ->
if HM.for_all (fun h v -> if HM.for_all (fun h v ->
match HM.find_opt h csums with match HM.find_opt h csums with
| None -> true | Some v' -> String.equal v v') | None -> true | Some v' -> String.equal v v')
csums' csums'
then then
Some (HM.union (fun _h v _v' -> Some v) csums csums', Some (HM.union (fun _h v _v' -> Some v) csums csums',
SSet.union mirrors mirrors') SSet.union mirrors mirrors',
SSet.union (upstream csums) upstream_caches'
)
else begin else begin
add_parse_error path (Fmt.str add_parse_error path (Fmt.str
"mismatching hashes for %s: %s vs %s" "mismatching hashes for %s: %s vs %s"
@ -959,7 +969,7 @@ stamp: %S
remaining_downloads := SM.cardinal urls; remaining_downloads := SM.cardinal urls;
archives := SM.cardinal urls; archives := SM.cardinal urls;
let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in
Lwt_list.iter_p (fun (url, (csums, mirrors)) -> Lwt_list.iter_p (fun (url, (csums, mirrors, upstream_caches)) ->
Lwt_pool.use pool @@ fun () -> Lwt_pool.use pool @@ fun () ->
HM.fold (fun h v r -> HM.fold (fun h v r ->
r >>= function r >>= function
@ -970,17 +980,23 @@ stamp: %S
decr remaining_downloads; decr remaining_downloads;
Lwt.return_unit Lwt.return_unit
| false -> | false ->
let rec download url mirrors = let rec download url mirrors upstream_caches =
let retry () = let retry () =
if SSet.is_empty mirrors then begin if SSet.is_empty mirrors && SSet.is_empty upstream_caches then begin
decr remaining_downloads; decr remaining_downloads;
Lwt.return_unit Lwt.return_unit
end else end else if SSet.is_empty mirrors then
let elt, upstream_caches =
let e = SSet.min_elt upstream_caches in
e, SSet.remove e upstream_caches
in
download elt mirrors upstream_caches
else
let elt, mirrors = let elt, mirrors =
let e = SSet.min_elt mirrors in let e = SSet.min_elt mirrors in
e, SSet.remove e mirrors e, SSet.remove e mirrors
in in
download elt mirrors download elt mirrors upstream_caches
in in
let quux, body_init = Disk.init_write disk csums in let quux, body_init = Disk.init_write disk csums in
add_to_active url (Ptime.v (Pclock.now_d_ps ())); add_to_active url (Ptime.v (Pclock.now_d_ps ()));
@ -1008,7 +1024,7 @@ stamp: %S
else else
retry () retry ()
in in
download url mirrors) download url mirrors upstream_caches)
(SM.bindings urls) >>= fun () -> (SM.bindings urls) >>= fun () ->
Disk.update_caches disk >|= fun () -> Disk.update_caches disk >|= fun () ->
Logs.info (fun m -> m "downloading of %d urls done" (SM.cardinal urls)) Logs.info (fun m -> m "downloading of %d urls done" (SM.cardinal urls))