uniquify urls in respect to sha256 checksums (#21)

this reduces 19139 urls down to 18563 urls

mirage/archive_checksum.ml

@@ -1,5 +1,3 @@
-
-
 module Hash = struct
   type t = (* OpamHash.kind = *) [ `MD5 | `SHA256 | `SHA512 ]
 

mirage/opam_file.ml

@@ -35,12 +35,31 @@ let extract_url_checksum filename items =
     List.find_opt
       (function { pelem = Variable ({ pelem = "checksum" ; _ }, _); _ } -> true | _ -> false)
       items
+  and mirrors =
+    List.find_opt
+      (function { pelem = Variable ({ pelem = "mirrors" ; _ }, _); _ } -> true | _ -> false)
+      items
   in
   let url =
     match url, archive with
     | Some { pelem = Variable (_, { pelem = String url ; _ }) ; _ }, None -> Ok url
     | None, Some { pelem = Variable (_, { pelem = String url ; _ }); _ } -> Ok url
     | _ -> Error (`Msg "neither 'src' nor 'archive' present")
+  and mirrors = match mirrors with
+    | None -> []
+    | Some { pelem = Variable (_, { pelem = String url ; _ }) ; _ } -> [ url ]
+    | Some { pelem = Variable (_, { pelem = List { pelem = urls ; _ } ; _ }) } ->
+      List.fold_left (fun acc -> function
+          | { pelem = String url ; _ } -> url :: acc
+          | v ->
+            Logs.err (fun m -> m "bad mirror data (expected a string in the list): %s"
+                         (OpamPrinter.FullPos.value v));
+            acc)
+        [] urls
+    | Some v ->
+      Logs.err (fun m -> m "bad mirror data (expected string or string list): %s"
+                   (OpamPrinter.FullPos.items [ v ]));
+      []
   in
   let csum, csum_errs =
     match checksum with
@@ -79,7 +98,7 @@ let extract_url_checksum filename items =
     | _ -> Error (`Msg "couldn't find or decode 'checksum'"), []
   in
   (match url, csum with
-   | Ok url, Ok csum -> Ok (url, csum)
+   | Ok url, Ok csum -> Ok (url, csum, mirrors)
    | Error _ as e, _
    | _, (Error _ as e) -> e), csum_errs
 

mirage/unikernel.ml

@@ -9,6 +9,14 @@ module K = struct
     let doc = Arg.info ~doc:"Only check the cache" ["check"] in
     Mirage_runtime.register_arg Arg.(value & flag doc)
 
+  let skip_download =
+    let doc = Arg.info ~doc:"Skip downloading archives" ["skip-download"] in
+    Mirage_runtime.register_arg Arg.(value & flag doc)
+
+  let upstream_caches =
+    let doc = Arg.info ~doc:"Upstream caches (e.g. https://opam.ocaml.org/cache)" ["upstream-cache"] in
+    Mirage_runtime.register_arg Arg.(value & opt_all string [] doc)
+
   let skip_verify_sha256 =
     let doc = Arg.info
         ~doc:"Skip verification of the SHA256 checksums of the cache contents, \
@@ -132,31 +140,66 @@ module Make
       in
       Lwt_stream.from more
 
+    let sha256s = Hashtbl.create 13
+
+    let empty () = Hashtbl.clear sha256s
+
     let find_urls acc path data =
       if Mirage_kv.Key.basename path = "opam" then
         let path = Mirage_kv.Key.to_string path in
         let url_csums, errs = Opam_file.extract_urls path data in
         List.iter (fun (`Msg msg) -> add_parse_error path msg) errs;
-        List.fold_left (fun acc (url, csums) ->
+        let upstream hm =
+          List.fold_left (fun set (hash, hash_value) ->
+              List.fold_left (fun set cache_url ->
+                  let url =
+                    cache_url ^ "/" ^ Archive_checksum.Hash.to_string hash ^
+                    "/" ^ String.sub hash_value 0 2 ^ "/" ^ hash_value
+                  in
+                  SSet.add url set)
+                set (K.upstream_caches ()))
+            SSet.empty (HM.bindings hm)
+        in
+        List.fold_left (fun acc (url, csums, mirrors) ->
             if HM.cardinal csums = 0 then
               (add_parse_error path ("no checksums for " ^ url);
                acc)
-            else
+            else begin
+              let url' =
+                match HM.find_opt `SHA256 csums with
+                | None -> url
+                | Some hash ->
+                  match Hashtbl.find_opt sha256s hash with
+                  | None -> Hashtbl.add sha256s hash url; url
+                  | Some url' ->
+                    if not (String.equal url url') then
+                      Logs.warn (fun m -> m "same hash for url %s and %s" url url');
+                    url'
+              in
+              let mirrors = SSet.of_list mirrors in
+              let url, mirrors =
+                if String.equal url url' then
+                  url, mirrors
+                else
+                  url', SSet.add url mirrors
+              in
               SM.update url (function
-                  | None -> Some csums
-                  | Some csums' ->
+                  | None -> Some (csums, SSet.union mirrors (upstream csums))
+                  | Some (csums', mirrors') ->
                     if HM.for_all (fun h v ->
                         match HM.find_opt h csums with
                         | None -> true | Some v' -> String.equal v v')
                         csums'
                     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')
                     else begin
                       add_parse_error path (Fmt.str
                                               "mismatching hashes for %s: %s vs %s"
                                               url (hm_to_s csums') (hm_to_s csums));
                       None
-                    end) acc) acc url_csums
+                    end) acc
+            end) acc url_csums
       else
         acc
 
@@ -254,6 +297,7 @@ module Make
       { md5s = SM.empty ; sha512s = SM.empty ; checked = Some KS.empty ; dev; dev_md5s; dev_sha512s ; dev_swap }
 
     let add_checked t path =
+      Logs.info (fun m -> m "add checked %a" Mirage_kv.Key.pp path);
       match t.checked with
       | None -> ()
       | Some s -> t.checked <- Some (KS.add path s)
@@ -603,6 +647,7 @@ module Make
       let mtime = Option.value ~default:0 Ptime.(Span.to_int_s (to_span now)) in
       let urls = ref SM.empty in
       entries_of_git ~mtime store repo urls >>= fun entries ->
+      Git.empty ();
       let t = Tar.out ~level:Ustar entries in
       let t = Tar_gz.out_gzipped ~level:4 ~mtime:(Int32.of_int mtime) Gz.Unix t in
       let buf = Buffer.create 1024 in
@@ -915,7 +960,7 @@ stamp: %S
     remaining_downloads := SM.cardinal urls;
     archives := SM.cardinal urls;
     let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in
-    Lwt_list.iter_p (fun (url, csums) ->
+    Lwt_list.iter_p (fun (url, (csums, mirrors)) ->
         Lwt_pool.use pool @@ fun () ->
         HM.fold (fun h v r ->
             r >>= function
@@ -926,29 +971,46 @@ stamp: %S
           decr remaining_downloads;
           Lwt.return_unit
         | false ->
-          let quux, body_init = Disk.init_write disk csums in
-          add_to_active url (Ptime.v (Pclock.now_d_ps ()));
-          Http_mirage_client.request http_client url (Disk.write_partial disk quux url) body_init >>= function
-          | Ok (resp, r) ->
-            decr remaining_downloads;
-            begin match r with
-              | Error `Bad_response ->
-                add_failed url (Ptime.v (Pclock.now_d_ps ()))
-                  (`Bad_response (resp.status, resp.reason));
+          let rec download url mirrors =
+            Logs.info (fun m -> m "downloading %s (%u mirrors)" url (SSet.cardinal mirrors));
+            let retry () =
+              if SSet.is_empty mirrors then begin
+                decr remaining_downloads;
                 Lwt.return_unit
-              | Error `Write_error e ->
-                add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Write_error e);
-                Lwt.return_unit
-              | Error `Swap e ->
-                add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Swap e);
-                Lwt.return_unit
-              | Ok (digests, body) ->
-                Disk.finalize_write disk quux ~url body csums digests
-            end
-          | Error me ->
-            decr remaining_downloads;
-            add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Mimic me);
-            Lwt.return_unit)
+              end else
+                let elt, mirrors =
+                  let e = SSet.min_elt mirrors in
+                  e, SSet.remove e mirrors
+                in
+                download elt mirrors
+            in
+            let quux, body_init = Disk.init_write disk csums in
+            add_to_active url (Ptime.v (Pclock.now_d_ps ()));
+            if not (K.skip_download ()) then
+              Http_mirage_client.request http_client url (Disk.write_partial disk quux url) body_init >>= function
+              | Ok (resp, r) ->
+                begin match r with
+                  | Error `Bad_response ->
+                    add_failed url (Ptime.v (Pclock.now_d_ps ()))
+                      (`Bad_response (resp.status, resp.reason));
+                    retry ()
+                  | Error `Write_error e ->
+                    add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Write_error e);
+                    retry ()
+                  | Error `Swap e ->
+                    add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Swap e);
+                    retry ()
+                  | Ok (digests, body) ->
+                    decr remaining_downloads;
+                    Disk.finalize_write disk quux ~url body csums digests
+                end
+              | Error me ->
+                add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Mimic me);
+                retry ()
+            else
+              retry ()
+          in
+          download url mirrors)
       (SM.bindings urls) >>= fun () ->
     Disk.update_caches disk >|= fun () ->
     Logs.info (fun m -> m "downloading of %d urls done" (SM.cardinal urls))