mirage/archive_checksum.ml

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

mirage/opam_file.ml

@@ -35,31 +35,12 @@ 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
@@ -98,7 +79,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, mirrors)
+   | Ok url, Ok csum -> Ok (url, csum)
    | Error _ as e, _
    | _, (Error _ as e) -> e), csum_errs
 

mirage/unikernel.ml

@@ -9,14 +9,6 @@ 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, \
@@ -140,66 +132,31 @@ 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;
-        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) ->
+        List.fold_left (fun acc (url, csums) ->
             if HM.cardinal csums = 0 then
               (add_parse_error path ("no checksums for " ^ url);
                acc)
-            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
+            else
               SM.update url (function
-                  | None -> Some (csums, SSet.union mirrors (upstream csums))
-                  | Some (csums', mirrors') ->
+                  | None -> Some csums
+                  | Some csums' ->
                     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',
-                            SSet.union mirrors mirrors')
+                      Some (HM.union (fun _h v _v' -> Some v) csums csums')
                     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
-            end) acc url_csums
+                    end) acc) acc url_csums
       else
         acc
 
@@ -297,7 +254,6 @@ 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)
@@ -647,7 +603,6 @@ 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
@@ -960,7 +915,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, mirrors)) ->
+    Lwt_list.iter_p (fun (url, csums) ->
         Lwt_pool.use pool @@ fun () ->
         HM.fold (fun h v r ->
             r >>= function
@@ -971,46 +926,29 @@ stamp: %S
           decr remaining_downloads;
           Lwt.return_unit
         | false ->
-          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;
+          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));
                 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)
+              | 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)
       (SM.bindings urls) >>= fun () ->
     Disk.update_caches disk >|= fun () ->
     Logs.info (fun m -> m "downloading of %d urls done" (SM.cardinal urls))