From 456340562d86b1b7a0c21d136006308421d7e67e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= <reynir@reynir.dk>
Date: Fri, 1 Nov 2024 14:35:08 +0100
Subject: [PATCH 01/16] Use swapfs

---
 mirage/config.ml     |  1 +
 mirage/partitions.ml | 43 +++++++++++++++-------
 mirage/unikernel.ml  | 87 ++++++++++++++++++++++++++++++++++++--------
 3 files changed, 102 insertions(+), 29 deletions(-)

diff --git a/mirage/config.ml b/mirage/config.ml
index ec220b9..399f977 100644
--- a/mirage/config.ml
+++ b/mirage/config.ml
@@ -18,6 +18,7 @@ let mirror =
       package "gptar" ;
       package "oneffs" ;
       package "digestif" ;
+      package "swapfs" ;
     ]
     (block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> alpn_client @-> job)
 
diff --git a/mirage/partitions.ml b/mirage/partitions.ml
index 2c1d19f..575f79b 100644
--- a/mirage/partitions.ml
+++ b/mirage/partitions.ml
@@ -7,12 +7,14 @@ module Make(BLOCK : Mirage_block.S) = struct
 
   type partitions = {
     tar : Part.t ;
+    swap : Part.t ;
     git_dump : Part.t ;
     md5s : Part.t ;
     sha512s : Part.t ;
   }
 
   (* I just made these ones up... *)
+  let swap_guid = Uuidm.of_string "76515dc1-953f-4c59-8b41-90011bdddfcd" |> Option.get
   let tar_guid = Uuidm.of_string "53cd6812-46cc-474e-a141-30b3aed85f53" |> Option.get
   let cache_guid = Uuidm.of_string "22ab9cf5-6e51-45c2-998a-862e23aab264" |> Option.get
   let git_guid = Uuidm.of_string "30faa50a-4c9d-47ff-a1a5-ecfb3401c027" |> Option.get
@@ -54,33 +56,37 @@ module Make(BLOCK : Mirage_block.S) = struct
   let connect block =
     let* info = BLOCK.get_info block in
     let* gpt = read_partition_table info block in
-    let tar, git_dump, md5s, sha512s =
+    let tar, swap, git_dump, md5s, sha512s =
       match
         List.fold_left
-          (fun (tar, git_dump, md5s, sha512s) p ->
+          (fun (tar, swap, git_dump, md5s, sha512s) p ->
              if String.equal p.Gpt.Partition.name
                  (utf16be_of_ascii "tar")
              then
-               (Some p, git_dump, md5s, sha512s)
+               (Some p, swap, git_dump, md5s, sha512s)
              else if String.equal p.name
                  (utf16be_of_ascii "git_dump")
              then
-               (tar, Some p, md5s, sha512s)
+               (tar, swap, Some p, md5s, sha512s)
              else if String.equal p.name
                  (utf16be_of_ascii "md5s")
              then
-               (tar, git_dump, Some p, sha512s)
+               (tar, swap, git_dump, Some p, sha512s)
              else if String.equal p.name
                  (utf16be_of_ascii "sha512s")
              then
-               (tar, git_dump, md5s, Some p)
+               (tar, swap, git_dump, md5s, Some p)
+             else if String.equal p.name
+                 (utf16be_of_ascii "swap")
+             then
+               (tar, Some p, git_dump, md5s, sha512s)
              else
                Format.kasprintf failwith "Unknown partition %S" p.name)
-          (None, None, None, None)
+          (None, None, None, None, None)
           gpt.partitions
       with
-      | (Some tar, Some git_dump, Some md5s, Some sha512s) ->
-        (tar, git_dump, md5s, sha512s)
+      | (Some tar, Some swap, Some git_dump, Some md5s, Some sha512s) ->
+        (tar, swap, git_dump, md5s, sha512s)
       | _ ->
         failwith "not all partitions found :("
     in
@@ -91,11 +97,11 @@ module Make(BLOCK : Mirage_block.S) = struct
       let (part, _after) = Part.subpartition len after in
       part
     in
-    let tar = get_part tar and git_dump = get_part git_dump
+    let tar = get_part tar and swap = get_part swap and git_dump = get_part git_dump
     and md5s = get_part md5s and sha512s = get_part sha512s in
-    { tar ; git_dump ; md5s ; sha512s }
+    { tar ; swap; git_dump ; md5s ; sha512s }
 
-  let format block ~sectors_cache ~sectors_git =
+  let format block ~sectors_cache ~sectors_git ~sectors_swap =
     let* { size_sectors; sector_size; _ } = BLOCK.get_info block in
     let ( let*? ) = Lwt_result.bind in
     (* ocaml-gpt uses a fixed size partition entries table. Create an empty GPT
@@ -144,18 +150,27 @@ module Make(BLOCK : Mirage_block.S) = struct
         (Int64.pred md5s.starting_lba)
       |> Result.get_ok
     in
+    let swap =
+      Gpt.Partition.make
+        ~name:(utf16be_of_ascii "swap")
+        ~type_guid:swap_guid
+        ~attributes
+        (Int64.sub git_dump.starting_lba sectors_swap)
+        (Int64.pred git_dump.starting_lba)
+      |> Result.get_ok
+    in
     let tar =
       Gpt.Partition.make
         ~name:(utf16be_of_ascii "tar")
         ~type_guid:tar_guid
         ~attributes
         empty.first_usable_lba
-        (Int64.pred git_dump.starting_lba)
+        (Int64.pred swap.starting_lba)
       |> Result.get_ok
     in
     let gpt =
       let partitions =
-        [ tar; git_dump; md5s; sha512s ]
+        [ tar; swap; git_dump; md5s; sha512s ]
       in
       Gpt.make ~sector_size ~disk_sectors:size_sectors partitions
       |> Result.get_ok
diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index be5b29e..e95436e 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -53,6 +53,11 @@ module K = struct
     let doc = Arg.info ~doc ["sectors-git"] in
     Mirage_runtime.register_arg Arg.(value & opt int64 Int64.(mul 40L (mul 2L 1024L)) doc)
 
+  let sectors_swap =
+    let doc = "Number of sectors reserved for swap. Only used with --initialize-disk" in
+    let doc = Arg.info ~doc ["sectors-swap"] in
+    Mirage_runtime.register_arg Arg.(value & opt int64 Int64.(mul 1024L 2048L) doc)
+
   let initialize_disk =
     let doc = "Initialize the disk with a partition table. THIS IS DESTRUCTIVE!" in
     let doc = Arg.info ~doc ["initialize-disk"] in
@@ -75,6 +80,7 @@ module Make
   module Part = Partitions.Make(BLOCK)
   module KV = Tar_mirage.Make_KV_RW(Pclock)(Part)
   module Cache = OneFFS.Make(Part)
+  module Swap = Swapfs.Make(Part)
   module Store = Git_kv.Make(Pclock)
 
   module SM = Map.Make(String)
@@ -189,13 +195,14 @@ module Make
       dev : KV.t ;
       dev_md5s : Cache.t ;
       dev_sha512s : Cache.t ;
+      dev_swap : Swap.t ;
     }
 
     let pending = Mirage_kv.Key.v "pending"
 
     let to_delete = Mirage_kv.Key.v "to-delete"
 
-    let empty dev dev_md5s dev_sha512s = { md5s = SM.empty ; sha512s = SM.empty ; dev; dev_md5s; dev_sha512s }
+    let empty dev dev_md5s dev_sha512s dev_swap = { md5s = SM.empty ; sha512s = SM.empty ; dev; dev_md5s; dev_sha512s ; dev_swap }
 
     let marshal_sm (sm : string SM.t) =
       let version = char_of_int 1 in
@@ -355,7 +362,10 @@ module Make
             Lwt.return_ok (digests, `Fixed_body (size, offset))
           | `Unknown ->
             active_add_bytes url (String.length data);
-            Lwt.return_ok (digests, `Unknown data)
+            let h = Swap.empty t.dev_swap in
+            Swap.append h data >|= function
+            | Ok () -> Ok (digests, `Unknown h)
+            | Error swap_err -> Error (`Swap swap_err)
           end
         | `Fixed_body (size, offset) ->
           KV.set_partial t.dev key ~offset data
@@ -364,9 +374,11 @@ module Make
           let offset = Optint.Int63.(add offset (of_int len)) in
           active_add_bytes url len;
           Lwt.return_ok (digests, `Fixed_body (size, offset))
-        | `Unknown body ->
+        | `Unknown h ->
           active_add_bytes url (String.length data);
-          Lwt.return_ok (digests, `Unknown (body ^ data))
+          Swap.append h data >|= function
+          | Ok () -> Ok (digests, `Unknown h)
+          | Error swap_err -> Error (`Swap swap_err)
 
     let check_csums_digests csums digests =
       let csums' = Archive_checksum.digests_to_hm digests in
@@ -376,7 +388,32 @@ module Make
         (fun (h, csum) -> String.equal csum (HM.find h csums))
         common_bindings
 
-    let finalize_write t (hash, csum) ~url (body : [ `Unknown of string | `Fixed_body of int64 * Optint.Int63.t | `Init ]) csums digests =
+    let set_from_handle dev dest h =
+      let size = Optint.Int63.of_int64 (Swap.size h) in
+      KV.allocate dev dest size >>= fun r ->
+      let rec loop offset =
+        if offset = Swap.size h then
+          Lwt.return_ok ()
+        else
+          let length = Int64.(to_int (min 4096L (sub (Swap.size h) offset))) in
+          Swap.get_partial h ~offset ~length >>= fun r ->
+          match r with
+          | Error e -> Lwt.return (Error (`Swap e))
+          | Ok data ->
+            KV.set_partial dev dest ~offset:(Optint.Int63.of_int64 offset) data
+            >>= fun r ->
+            match r with
+            | Error e -> Lwt.return (Error (`Write_error e))
+            | Ok () ->
+              loop Int64.(add offset (of_int length))
+      in
+      match r with
+      | Ok () ->
+        loop 0L
+      | Error e ->
+        Lwt.return (Error (`Write_error e))
+
+    let finalize_write t (hash, csum) ~url (body : [ `Unknown of Swap.handle | `Fixed_body of int64 * Optint.Int63.t | `Init ]) csums digests =
       let sizes_match, body_size_in_header =
         match body with
         | `Fixed_body (reported, actual) -> Optint.Int63.(equal (of_int64 reported) actual), true
@@ -390,12 +427,18 @@ module Make
         and sha512 = Ohex.encode Digestif.SHA512.(to_raw_string (get digests.sha512)) in
         let dest = Mirage_kv.Key.v sha256 in
         begin match body with
-        | `Unknown body ->
+        | `Unknown h ->
           Logs.info (fun m -> m "downloaded %s, now writing" url);
-          KV.set t.dev dest body
+          Lwt_result.bind
+            (Lwt.finalize (fun () -> set_from_handle t.dev source h)
+               (fun () -> Swap.free h))
+            (fun () ->
+               KV.rename t.dev ~source ~dest
+               |> Lwt_result.map_error (fun e -> `Write_error e))
         | `Fixed_body (_reported_size, _actual_size) ->
           Logs.info (fun m -> m "downloaded %s" url);
           KV.rename t.dev ~source ~dest
+          |> Lwt_result.map_error (fun e -> `Write_error e)
         | `Init -> assert false
         end >|= function
         | Ok () ->
@@ -403,9 +446,13 @@ module Make
           t.md5s <- SM.add md5 sha256 t.md5s;
           t.sha512s <- SM.add sha512 sha256 t.sha512s
         | Error e ->
-          Logs.err (fun m -> m "Write failure for %s: %a" url KV.pp_write_error e);
+          let pp_error ppf = function
+            | `Write_error e -> KV.pp_write_error ppf e
+            | `Swap e -> Swap.pp_error ppf e
+          in
+          Logs.err (fun m -> m "Write failure for %s: %a" url pp_error e);
           add_failed url (Ptime.v (Pclock.now_d_ps ()))
-            (Fmt.str "Write failure for %s: %a" url KV.pp_write_error e)
+            (Fmt.str "Write failure for %s: %a" url pp_error e)
       else begin
         (if sizes_match then begin
            add_failed url (Ptime.v (Pclock.now_d_ps ()))
@@ -447,11 +494,11 @@ module Make
       end
 
     (* on disk, we use a flat file system where the filename is the sha256 of the data *)
-    let init ~verify_sha256 dev dev_md5s dev_sha512s =
+    let init ~verify_sha256 dev dev_md5s dev_sha512s dev_swap =
       KV.list dev Mirage_kv.Key.empty >>= function
       | Error e -> Logs.err (fun m -> m "error %a listing kv" KV.pp_error e); assert false
       | Ok entries ->
-        let t = empty dev dev_md5s dev_sha512s in
+        let t = empty dev dev_md5s dev_sha512s dev_swap in
         Cache.read t.dev_md5s >>= fun r ->
         (match r with
          | Ok Some s ->
@@ -946,6 +993,14 @@ stamp: %S
                 add_failed url (Ptime.v (Pclock.now_d_ps ()))
                   (Fmt.str "write error: %a" KV.pp_write_error e);
                 Lwt.return_unit
+              | Error `Swap e ->
+                Logs.err (fun m -> m "%s: swap error %a %a"
+                             url
+                             Mirage_kv.Key.pp (Disk.pending_key quux)
+                             Swap.pp_error e);
+                add_failed url (Ptime.v (Pclock.now_d_ps ()))
+                  (Fmt.str "swap error: %a" Swap.pp_error e);
+                Lwt.return_unit
               | Ok (digests, body) ->
                 Disk.finalize_write disk quux ~url body csums digests
             end
@@ -980,13 +1035,14 @@ stamp: %S
 
   module Paf = Paf_mirage.Make(Stack.TCP)
 
-  let start_mirror { Part.tar; git_dump; md5s; sha512s } stack git_ctx http_ctx =
+  let start_mirror { Part.tar; swap; git_dump; md5s; sha512s } stack git_ctx http_ctx =
     KV.connect tar >>= fun kv ->
     Cache.connect git_dump >>= fun git_dump ->
     Cache.connect md5s >>= fun md5s ->
     Cache.connect sha512s >>= fun sha512s ->
+    Swap.connect swap >>= fun swap ->
     Logs.info (fun m -> m "Available bytes in tar storage: %Ld" (KV.free kv));
-    Disk.init ~verify_sha256:(K.verify_sha256 ()) kv md5s sha512s >>= fun disk ->
+    Disk.init ~verify_sha256:(K.verify_sha256 ()) kv md5s sha512s swap >>= fun disk ->
     let remote = K.remote () in
     if K.check () then
       Lwt.return_unit
@@ -1035,9 +1091,10 @@ stamp: %S
   let start block _time _pclock stack git_ctx http_ctx =
     let initialize_disk = K.initialize_disk ()
     and sectors_cache = K.sectors_cache ()
-    and sectors_git = K.sectors_git () in
+    and sectors_git = K.sectors_git ()
+    and sectors_swap = K.sectors_swap () in
     if initialize_disk then
-      Part.format block ~sectors_cache ~sectors_git >>= function
+      Part.format block ~sectors_cache ~sectors_git ~sectors_swap >>= function
       | Ok () ->
         Logs.app (fun m -> m "Successfully initialized the disk! You may restart now without --initialize-disk.");
         Lwt.return_unit
-- 
2.47.0


From e59f02a16f41ec7f58c8dad1bfef61e8bcc66bf7 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 16:13:36 +0100
Subject: [PATCH 02/16] always use swap, remove the pending / to_delete stuff

---
 mirage/archive_checksum.ml |   2 +-
 mirage/unikernel.ml        | 203 ++++---------------------------------
 2 files changed, 23 insertions(+), 182 deletions(-)

diff --git a/mirage/archive_checksum.ml b/mirage/archive_checksum.ml
index fbff9a8..9e308b3 100644
--- a/mirage/archive_checksum.ml
+++ b/mirage/archive_checksum.ml
@@ -52,7 +52,7 @@ let update_digests { md5; sha256; sha512 } data =
 
 let init_write csums =
   let hash, csum = HM.max_binding csums in
-  (hash, csum), Ok (empty_digests, `Init)
+  (hash, csum), empty_digests
 
 let digests_to_hm digests =
   HM.empty
diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index e95436e..6c203fc 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -198,10 +198,6 @@ module Make
       dev_swap : Swap.t ;
     }
 
-    let pending = Mirage_kv.Key.v "pending"
-
-    let to_delete = Mirage_kv.Key.v "to-delete"
-
     let empty dev dev_md5s dev_sha512s dev_swap = { md5s = SM.empty ; sha512s = SM.empty ; dev; dev_md5s; dev_sha512s ; dev_swap }
 
     let marshal_sm (sm : string SM.t) =
@@ -267,118 +263,28 @@ module Make
           in
           read_more a Optint.Int63.zero
 
-    (*
-    module HM_running = struct
-
-      let empty h =
-        let module H = (val Mirage_crypto.Hash.module_of h) in
-        (* We need MD5, SHA256 and SHA512. [h] is likely one of the
-           aforementioned and in that case we don't compute the same hash twice
-        *)
-        HM.empty
-        |> HM.add `MD5 Mirage_crypto.Hash.MD5.empty
-        |> HM.add `SHA256 Mirage_crypto.Hash.SHA256.empty
-        |> HM.add `SHA512 Mirage_crypto.Hash.SHA512.empty
-        |> HM.add h H.empty
-
-      let feed t data =
-        HM.map (fun h v ->
-            let module H = (val Mirage_crypto.Hash.module_of h) in
-            H.feed v data)
-          t
-
-      let get =
-        HM.map (fun h v ->
-            let module H = (val Mirage_crypto.Hash.module_of h) in
-            H.get v)
-
-
-    end
-       *)
-
-    let content_length_of_string s =
-      match Int64.of_string s with
-      | len when len >= 0L -> `Fixed len
-      | _ | exception _ -> `Bad_response
-
-    let body_length headers =
-      match H2.Headers.get_multi headers "content-length" with
-      | [] -> `Unknown
-      | [ x ] ->  content_length_of_string x
-      | hd :: tl ->
-        (* if there are multiple content-length headers we require them all to be
-         * exactly equal. *)
-        if List.for_all (String.equal hd) tl then
-          content_length_of_string hd
-        else
-          `Bad_response
-
-    let body_length (response : Http_mirage_client.response) =
-      if response.status <> `OK then
-        `Bad_response
-      else
-        body_length response.headers
-
-    let pending_key (hash, csum) =
-      match hash with
+    let key_of_hash_csum (hash, csum) = match hash with
       | `SHA512 ->
         (* We can't use hex because the filename would become too long for tar *)
-        Mirage_kv.Key.(pending / hash_to_string hash / Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false csum)
+        Mirage_kv.Key.(v (hash_to_string hash) / Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false csum)
       | _ ->
-        Mirage_kv.Key.(pending / hash_to_string hash / Ohex.encode csum)
+        Mirage_kv.Key.(v (hash_to_string hash) / Ohex.encode csum)
 
-    let to_delete_key (hash, csum) =
-      let rand = "random" in (* FIXME: generate random string *)
-      let encoded_csum =
-        match hash with
-        | `SHA512 ->
-          (* We can't use hex because the filename would become too long for tar *)
-          Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false csum
-        | _ ->
-          Ohex.encode csum
-      in
-      Mirage_kv.Key.(to_delete / hash_to_string hash / (encoded_csum ^ "." ^ rand))
+    let init_write t csums =
+      let quux, csums = Archive_checksum.init_write csums in
+      let swap = Swap.empty t.dev_swap in
+      quux, Ok (csums, swap)
 
     let write_partial t (hash, csum) url =
       (* XXX: we may be in trouble if different hash functions are used for the same archive *)
-      let key = pending_key (hash, csum) in
       let ( >>>= ) = Lwt_result.bind in
       fun response r data ->
-        Lwt.return r >>>= fun (digests, acc) ->
+        Lwt.return r >>>= fun (digests, swap) ->
         let digests = Archive_checksum.update_digests digests data in
-        match acc with
-        | `Init ->
-          begin match body_length response with
-          | `Bad_response -> Lwt.return (Error `Bad_response)
-          | `Fixed size ->
-            KV.allocate t.dev key (Optint.Int63.of_int64 size)
-            |> Lwt_result.map_error (fun e -> `Write_error e)
-            >>>= fun () ->
-            KV.set_partial t.dev key ~offset:Optint.Int63.zero data
-            |> Lwt_result.map_error (fun e -> `Write_error e) >>>= fun () ->
-            let len = String.length data in
-            let offset = Optint.Int63.of_int len in
-            active_length url len (Int64.to_string size ^ " bytes");
-            Lwt.return_ok (digests, `Fixed_body (size, offset))
-          | `Unknown ->
-            active_add_bytes url (String.length data);
-            let h = Swap.empty t.dev_swap in
-            Swap.append h data >|= function
-            | Ok () -> Ok (digests, `Unknown h)
-            | Error swap_err -> Error (`Swap swap_err)
-          end
-        | `Fixed_body (size, offset) ->
-          KV.set_partial t.dev key ~offset data
-          |> Lwt_result.map_error (fun e -> `Write_error e) >>>= fun () ->
-          let len = String.length data in
-          let offset = Optint.Int63.(add offset (of_int len)) in
-          active_add_bytes url len;
-          Lwt.return_ok (digests, `Fixed_body (size, offset))
-        | `Unknown h ->
-          active_add_bytes url (String.length data);
-          Swap.append h data >|= function
-          | Ok () -> Ok (digests, `Unknown h)
-          | Error swap_err -> Error (`Swap swap_err)
+        active_add_bytes url (String.length data);
+        Swap.append swap data >|= function
+        | Ok () -> Ok (digests, swap)
+        | Error swap_err -> Error (`Swap swap_err)
 
     let check_csums_digests csums digests =
       let csums' = Archive_checksum.digests_to_hm digests in
@@ -413,34 +319,16 @@ module Make
       | Error e ->
         Lwt.return (Error (`Write_error e))
 
-    let finalize_write t (hash, csum) ~url (body : [ `Unknown of Swap.handle | `Fixed_body of int64 * Optint.Int63.t | `Init ]) csums digests =
-      let sizes_match, body_size_in_header =
-        match body with
-        | `Fixed_body (reported, actual) -> Optint.Int63.(equal (of_int64 reported) actual), true
-        | `Unknown _ -> true, false
-        | `Init -> assert false
-      in
-      let source = pending_key (hash, csum) in
-      if check_csums_digests csums digests && sizes_match then
+    let finalize_write t (hash, csum) ~url swap csums digests =
+      if check_csums_digests csums digests then
         let sha256 = Ohex.encode Digestif.SHA256.(to_raw_string (get digests.sha256))
         and md5 = Ohex.encode Digestif.MD5.(to_raw_string (get digests.md5))
         and sha512 = Ohex.encode Digestif.SHA512.(to_raw_string (get digests.sha512)) in
         let dest = Mirage_kv.Key.v sha256 in
-        begin match body with
-        | `Unknown h ->
-          Logs.info (fun m -> m "downloaded %s, now writing" url);
-          Lwt_result.bind
-            (Lwt.finalize (fun () -> set_from_handle t.dev source h)
-               (fun () -> Swap.free h))
-            (fun () ->
-               KV.rename t.dev ~source ~dest
-               |> Lwt_result.map_error (fun e -> `Write_error e))
-        | `Fixed_body (_reported_size, _actual_size) ->
-          Logs.info (fun m -> m "downloaded %s" url);
-          KV.rename t.dev ~source ~dest
-          |> Lwt_result.map_error (fun e -> `Write_error e)
-        | `Init -> assert false
-        end >|= function
+        Logs.info (fun m -> m "downloaded %s, now writing" url);
+        (Lwt.finalize (fun () -> set_from_handle t.dev dest swap)
+           (fun () -> Swap.free swap))
+        >|= function
         | Ok () ->
           remove_active url;
           t.md5s <- SM.add md5 sha256 t.md5s;
@@ -453,45 +341,7 @@ module Make
           Logs.err (fun m -> m "Write failure for %s: %a" url pp_error e);
           add_failed url (Ptime.v (Pclock.now_d_ps ()))
             (Fmt.str "Write failure for %s: %a" url pp_error e)
-      else begin
-        (if sizes_match then begin
-           add_failed url (Ptime.v (Pclock.now_d_ps ()))
-             (Fmt.str "Bad checksum %s:%s: computed %s expected %s" url
-                        (hash_to_string hash)
-                        (Ohex.encode (Archive_checksum.get digests hash))
-                        (Ohex.encode csum));
-           Logs.err (fun m -> m "Bad checksum %s:%s: computed %s expected %s" url
-                        (hash_to_string hash)
-                        (Ohex.encode (Archive_checksum.get digests hash))
-                        (Ohex.encode csum))
-         end else match body with
-           | `Fixed_body (reported, actual) ->
-             add_failed url (Ptime.v (Pclock.now_d_ps ()))
-               (Fmt.str "Size mismatch %s: received %a bytes expected %Lu bytes"
-                  url Optint.Int63.pp actual reported);
-             Logs.err (fun m -> m "Size mismatch %s: received %a bytes expected %Lu bytes"
-                          url Optint.Int63.pp actual reported)
-           | `Unknown _ -> assert false
-           | `Init -> assert false);
-        if body_size_in_header then
-          (* if the checksums mismatch we want to delete the file. We are only
-             able to do so if it was the latest created file, so we expect and
-             error. Ideally, we want to match for `Append_only or other errors *)
-          KV.remove t.dev source >>= function
-          | Ok () -> Lwt.return_unit
-          | Error e ->
-            (* we failed to delete the file so we mark it for deletion *)
-            let dest = to_delete_key (hash, csum) in
-            Logs.warn (fun m -> m "Failed to remove %a: %a. Moving it to %a"
-                          Mirage_kv.Key.pp source KV.pp_write_error e Mirage_kv.Key.pp dest);
-            KV.rename t.dev ~source ~dest >|= function
-            | Ok () -> ()
-            | Error e ->
-              Logs.warn (fun m -> m "Error renaming file %a -> %a: %a"
-                            Mirage_kv.Key.pp source Mirage_kv.Key.pp dest KV.pp_write_error e)
-        else
-          Lwt.return_unit
-      end
+      else Lwt.return_unit
 
     (* on disk, we use a flat file system where the filename is the sha256 of the data *)
     let init ~verify_sha256 dev dev_md5s dev_sha512s dev_swap =
@@ -516,12 +366,6 @@ module Make
         let md5s = SSet.of_list (List.map snd (SM.bindings t.md5s))
         and sha512s = SSet.of_list (List.map snd (SM.bindings t.sha512s)) in
         let idx = ref 1 in
-        (* XXX: should we do something about pending downloads?? *)
-        let entries =
-          List.filter (fun (p, _) ->
-              not (Mirage_kv.Key.equal p pending || Mirage_kv.Key.equal p to_delete))
-            entries
-        in
         Lwt_list.iter_s (fun (path, typ) ->
             if !idx mod 10 = 0 then Gc.full_major () ;
             match typ with
@@ -961,7 +805,6 @@ stamp: %S
     let idx = ref 0 in
     Lwt_list.iter_p (fun (url, csums) ->
         Lwt_pool.use pool @@ fun () ->
-        (* FIXME: check pending and to-delete *)
         HM.fold (fun h v r ->
             r >>= function
             | true -> Disk.exists disk h (hex_to_key v)
@@ -974,7 +817,7 @@ stamp: %S
           incr idx;
           if !idx mod 10 = 0 then Gc.full_major () ;
           Logs.info (fun m -> m "downloading %s" url);
-          let quux, body_init = Archive_checksum.init_write csums in
+          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) ->
@@ -986,17 +829,15 @@ stamp: %S
                   (Fmt.str "%a %s" H2.Status.pp_hum resp.status resp.reason);
                 Lwt.return_unit
               | Error `Write_error e ->
-                Logs.err (fun m -> m "%s: write error %a %a"
+                Logs.err (fun m -> m "%s: write error %a"
                               url
-                              Mirage_kv.Key.pp (Disk.pending_key quux)
                               KV.pp_write_error e);
                 add_failed url (Ptime.v (Pclock.now_d_ps ()))
                   (Fmt.str "write error: %a" KV.pp_write_error e);
                 Lwt.return_unit
               | Error `Swap e ->
-                Logs.err (fun m -> m "%s: swap error %a %a"
+                Logs.err (fun m -> m "%s: swap error %a"
                              url
-                             Mirage_kv.Key.pp (Disk.pending_key quux)
                              Swap.pp_error e);
                 add_failed url (Ptime.v (Pclock.now_d_ps ()))
                   (Fmt.str "swap error: %a" Swap.pp_error e);
-- 
2.47.0


From 7689397ac36a8127b9e79bc294363d5b610bf19d Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 16:14:09 +0100
Subject: [PATCH 03/16] remove bad archive list

---
 mirage/bad.ml       | 195 --------------------------------------------
 mirage/unikernel.ml |   3 -
 2 files changed, 198 deletions(-)
 delete mode 100644 mirage/bad.ml

diff --git a/mirage/bad.ml b/mirage/bad.ml
deleted file mode 100644
index 8b40ea2..0000000
--- a/mirage/bad.ml
+++ /dev/null
@@ -1,195 +0,0 @@
-let archives =
-  let too_big =
-    [ "https://github.com/Opsian/opsian-ocaml/releases/download/0.1/0.1.tar.gz" ]
-
-  and hash_mismatch = [
-    "http://cdn.skylable.com/source/libres3-1.3.tar.gz" ;
-    "http://cdn.skylable.com/source/libres3-0.3.tar.gz" ;
-    "http://cdn.skylable.com/source/libres3-1.2.tar.gz" ;
-    "http://cdn.skylable.com/source/libres3-0.9.tar.gz" ;
-    "http://cdn.skylable.com/source/libres3-0.2.tar.gz" ;
-    "http://cdn.skylable.com/source/libres3-1.0.tar.gz" ;
-    "http://cdn.skylable.com/source/libres3-1.1.tar.gz" ;
-    "http://cdn.skylable.com/source/libres3-0.1.tar.gz" ;
-    "https://github.com/lemaetech/http-cookie/releases/download/v3.0.0/http-cookie-v3.0.0.tbz" ;
-    "http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.4.tar.gz" ;
-    "http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.2.tar.gz" ;
-    "http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.3.tar.gz" ;
-    "http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.5.tar.gz" ;
-    "http://oqamldebug.forge.ocamlcore.org/oqamldebug-0.9.1.tar.gz" ;
-    "https://github.com/OCamlPro/ezjs_fetch/archive/0.1.tar.gz" ;
-    "http://github.com/OCamlPro/typerex-build/archive/1.99.13-beta.tar.gz" ;
-    "https://github.com/mirage/dyntype/tarball/dyntype-0.8.5" ;
-    "https://github.com/mirage/dyntype/tarball/dyntype-0.8.3" ;
-    "https://github.com/mirage/dyntype/tarball/dyntype-0.8.2" ;
-    "https://github.com/mirage/dyntype/tarball/dyntype-0.8.4" ;
-    "https://github.com/mirage/mirage-http-unix/archive/v1.0.0.tar.gz" ;
-    "http://github.com/OCamlPro/typerex-build/archive/1.99.15-beta.tar.gz" ;
-    "http://github.com/OCamlPro/typerex-build/archive/1.99.14-beta.tar.gz" ;
-    "https://github.com/paulpatault/ocamlog/archive/v0.1.tar.gz" ;
-    "https://github.com/pveber/OCaml-R/archive/pre-nyc-refactoring.tar.gz" ;
-    "https://github.com/paulpatault/ocamlog/archive/v0.2.tar.gz" ;
-    "http://github.com/OCamlPro/typerex-build/archive/1.99.16-beta.tar.gz" ;
-    "https://github.com/FStarLang/kremlin/archive/v0.9.6.0.zip" ;
-    "https://gitlab.com/dailambda/plebeia/-/archive/2.0.2/plebeia-2.0.2.tar.gz" ;
-    "https://github.com/mirleft/ocaml-tls/archive/0.5.0.tar.gz" ;
-    "https://github.com/eth-sri/ELINA/archive/1.3.tar.gz" ;
-    "https://gitlab.com/trustworthy-refactoring/refactorer/-/archive/0.1/refactorer-0.1.zip" ;
-    "https://github.com/completium/archetype-lang/archive/1.3.3.tar.gz" ;
-    "https://github.com/chetmurthy/pa_ppx/archive/0.01.tar.gz" ;
-    "https://github.com/chambart/ocaml-1/archive/lto.tar.gz" ;
-    "https://github.com/Kappa-Dev/KaSim/archive/v3.5-250915.tar.gz" ;
-    "https://github.com/bsansouci/bsb-native/archive/1.9.4.tar.gz";
-    "https://github.com/sanette/oplot/archive/0.7.tar.gz";
-    "https://github.com/ulrikstrid/ocaml-cookie/releases/download/0.1.8/session-cookie-lwt-0.1.8.tbz";
-  ]
-
-  and bad_request = [
-    "http://cgit.freedesktop.org/cairo-ocaml/snapshot/cairo-ocaml-1.2.0.tar.gz"
-  ]
-
-  and not_found = [
-    "http://pw374.github.io/distrib/frag/frag-0.1.0.tar.gz" ;
-    "http://pw374.github.io/distrib/glical/glical-0.0.3.tar.gz" ;
-    "http://pw374.github.io/distrib/glical/glical-0.0.4.tar.gz" ;
-    "http://pw374.github.io/distrib/glical/glical-0.0.1.tar.gz" ;
-    "http://pw374.github.io/distrib/glical/glical-0.0.2.tar.gz" ;
-    "http://pw374.github.io/distrib/glical/glical-0.0.5.tar.gz" ;
-    "http://pw374.github.io/distrib/glical/glical-0.0.7.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.1.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.0.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.2.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.7.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.3.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.8.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.4.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.1.5.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.2.0.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.2.1.tar.gz" ;
-    "http://pw374.github.io/distrib/mpp/mpp-0.3.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.3.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.4.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.5.4.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.5.5.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.5.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.6.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.6.2.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.6.3.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.6.4.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.6.5.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.7.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.7.1.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.7.2.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.7.4.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.7.3.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.7.5.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.8.2.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.8.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.8.1.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.9.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.9.1.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.9.7.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.0.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.0.1.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.1.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.1.1.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.1.2.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.2.0.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.2.1.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.2.2.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.2.4.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.2.5.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.2.6.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.2.3.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.3.0.tar.gz" ;
-    "http://zoggy.github.com/ocamldot/ocamldot-1.0.tar.gz" ;
-    "http://zoggy.github.io/stog/stog-0.4.tar.gz" ;
-    "http://zoggy.github.io/genet/genet-0.6.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.6.1.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.9.4.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.9.6.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.9.5.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-0.9.3.tar.gz" ;
-    "http://pw374.github.io/distrib/omd/omd-1.1.3.tar.gz" ;
-    "http://coccinelle.lip6.fr/distrib/coccinelle-1.0.0-rc22.tgz" ;
-    "http://coccinelle.lip6.fr/distrib/coccinelle-1.0.0-rc21.tgz" ;
-    "http://coccinelle.lip6.fr/distrib/coccinelle-1.0.0.tgz" ;
-    "http://proverif.inria.fr/proverif1.96pl1.tar.gz" ;
-    "http://proverif.inria.fr/proverif1.97.tar.gz" ;
-    "http://proverif.inria.fr/proverif1.98.tar.gz" ;
-    "http://proverif.inria.fr/proverif1.97pl3.tar.gz" ;
-    "http://proverif.inria.fr/proverif1.98pl1.tar.gz" ;
-    "http://proverif.inria.fr/proverif1.97pl1.tar.gz" ;
-    "https://github.com/jrochel/eliom/archive/6.4.0.tar.gz" ;
-    "https://github.com/drjdn/ocaml_lua_parser/archive/1.0.1.tar.gz" ;
-    "https://github.com/sagotch/To.ml/archive/v1.0.0.tar.gz" ;
-    "https://zoggy.github.io/ocaml-rdf/ocaml-rdf-0.9.0.tar.gz" ;
-    "https://github.com/sagotch/To.ml/archive/v2.1.0.tar.gz" ;
-    "https://github.com/sagotch/To.ml/archive/v2.0.0.tar.gz" ;
-    "https://zoggy.github.io/ocaml-taglog/taglog-0.1.0.tar.gz" ;
-    "https://zoggy.github.io/ocaml-taglog/taglog-0.2.0.tar.gz" ;
-    "https://zoggy.github.io/ocf/ocf-0.3.0.tar.gz" ;
-    "https://zoggy.github.io/ojs-base/ojs-base-0.1.0.tar.gz" ;
-    "https://zoggy.github.io/stog/plugins/stog-writing-0.8.0.tar.gz" ;
-    "https://zoggy.github.io/stog/stog-0.13.0.tar.gz" ;
-    "https://zoggy.github.io/ocaml-taglog/taglog-0.3.0.tar.gz" ;
-    "https://zoggy.github.io/ocf/ocf-0.1.0.tar.gz" ;
-    "https://opam.ocaml.org/cache/md5/24/24b163eb77e6832747dccd6cc8a5d57c" ;
-  ]
-
-  and forbidden = [
-    "https://gforge.inria.fr/frs/download.php/33440/heptagon-1.00.06.tar.gz" ;
-    "https://gforge.inria.fr/frs/download.php/file/33677/dose3-3.2.2.tar.gz" ;
-    "https://gforge.inria.fr/frs/download.php/file/34920/javalib-2.3.1.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/36092/javalib-2.3.2.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/36093/sawja-1.5.2.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/37154/javalib-2.3.4.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/37403/sawja-1.5.3.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/36307/javalib-2.3.3.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/37655/javalib-2.3.5.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/37656/sawja-1.5.4.tar.bz2" ;
-    "https://gforge.inria.fr/frs/download.php/file/34921/sawja-1.5.1.tar.bz2" ;
-  ]
-
-  and three_o_o = [
-    "https://github.com/Gbury/dolmen/archive/v0.4.tar.gz" ;
-    "https://github.com/Stevendeo/Pilat/archive/1.3.tar.gz" ;
-    "https://github.com/OCamlPro/ocp-indent/archive/1.5.tar.gz" ;
-    "https://github.com/backtracking/combine/archive/release-0.6.zip" ;
-    "https://github.com/cakeplus/pa_comprehension/archive/0.4.tar.gz" ;
-    "https://github.com/cakeplus/mparser/archive/1.0.tar.gz" ;
-    "https://github.com/chenyukang/rubytt/archive/v0.1.tar.gz" ;
-    "https://github.com/cakeplus/pa_where/archive/0.4.tar.gz" ;
-    "https://github.com/metaocaml/ber-metaocaml/archive/ber-n102.tar.gz" ;
-    "https://github.com/cakeplus/pa_solution/archive/0.5.tar.gz" ;
-    "https://github.com/cakeplus/mparser/archive/1.2.1.tar.gz" ;
-    "https://github.com/cakeplus/pa_solution/archive/0.7.tar.gz" ;
-    "https://github.com/cakeplus/pa_solution/archive/0.6.tar.gz" ;
-    "https://github.com/mirage/mirage-tcpip/archive/v2.8.1.tar.gz" ;
-    "https://github.com/modlfo/pla/archive/v1.4.tar.gz" ;
-    "https://github.com/murmour/pa_qualified/archive/0.5.tar.gz" ;
-    "https://github.com/ocaml-ppx/ocamlformat/archive/v0.2.tar.gz" ;
-    "https://github.com/murmour/pa_qualified/archive/0.6.tar.gz" ;
-    "https://github.com/ocaml-ppx/ocamlformat/archive/support.0.2.tar.gz" ;
-    "https://github.com/ocaml/oloop/archive/0.1.2.tar.gz" ;
-    "https://github.com/cakeplus/mparser/archive/1.0.1.tar.gz" ;
-    "https://github.com/cakeplus/mparser/archive/1.1.tar.gz" ;
-    "https://github.com/savonet/ocaml-ffmpeg/archive/v1.0.0-rc1.tar.gz" ;
-    "https://github.com/ocaml/opam2web/archive/2.0.tar.gz" ;
-    "https://github.com/savonet/ocaml-ffmpeg/archive/v1.0.0.tar.gz" ;
-  ]
-
-  and five_o_three = [ "https://gitlab.com/gasche/build_path_prefix_map/repository/0.2/archive.tar.gz" ]
-
-  and is_ftp = [ "ftp://ftp.netbsd.org/pub/pkgsrc/distfiles/wyrd-1.4.6.tar.gz" ]
-
-  and connect_fails = [
-    "http://godi.0ok.org/godi-backup/shcaml-0.1.3.tar.gz" ;
-    "http://www.first.in-berlin.de/software/tools/apalogretrieve/apalogretrieve-0-9-6_4.tgz" ;
-    "https://cavale.enseeiht.fr/osdp/osdp-0.5.4.tgz" ;
-    "https://cavale.enseeiht.fr/osdp/osdp-0.6.0.tgz" ;
-    "https://cavale.enseeiht.fr/osdp/osdp-1.0.0.tgz" ;
-  ]
-  in
-
-  too_big @ hash_mismatch @ bad_request @ not_found @ forbidden @ three_o_o @ five_o_three @ is_ftp @ connect_fails
diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 6c203fc..8df6922 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -795,12 +795,9 @@ stamp: %S
 
   end
 
-  let bad_archives = SSet.of_list Bad.archives
-
   let download_archives parallel_downloads disk http_client store =
     (* FIXME: handle resuming partial downloads *)
     Git.find_urls store >>= fun urls ->
-    let urls = SM.filter (fun k _ -> not (SSet.mem k bad_archives)) urls in
     let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in
     let idx = ref 0 in
     Lwt_list.iter_p (fun (url, csums) ->
-- 
2.47.0


From f48cc19fc4e96e34c07b70af7a31f5acec5c22f3 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 16:46:01 +0100
Subject: [PATCH 04/16] drop superfluous 'unknown'

---
 mirage/unikernel.ml | 17 +++++------------
 1 file changed, 5 insertions(+), 12 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 8df6922..ab0a774 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -163,23 +163,16 @@ module Make
   let active_downloads = ref SM.empty
 
   let add_to_active url ts =
-    active_downloads := SM.add url (ts, 0, "unknown size") !active_downloads
+    active_downloads := SM.add url (ts, 0) !active_downloads
 
   let remove_active url =
     active_downloads := SM.remove url !active_downloads
 
-  let active_length url written length =
-    match SM.find_opt url !active_downloads with
-    | None -> ()
-    | Some (ts, written', _) ->
-      active_downloads := SM.add url (ts, written + written', length)
-          !active_downloads
-
   let active_add_bytes url written =
     match SM.find_opt url !active_downloads with
     | None -> ()
-    | Some (ts, written', l) ->
-      active_downloads := SM.add url (ts, written + written', l)
+    | Some (ts, written') ->
+      active_downloads := SM.add url (ts, written + written')
           !active_downloads
 
   let failed_downloads = ref SM.empty
@@ -628,8 +621,8 @@ stamp: %S
       let active_downloads =
         let header = "<h2>Active downloads</h2><ul>" in
         let content =
-          SM.fold (fun url (ts, bytes_written, length_or_unknown) acc ->
-              ("<li>" ^ Ptime.to_rfc3339 ?tz_offset_s:None ts ^ ": " ^ url ^ " " ^ string_of_int bytes_written ^ " bytes written to disk, " ^ length_or_unknown ^ "</li>")
+          SM.fold (fun url (ts, bytes_written) acc ->
+              ("<li>" ^ Ptime.to_rfc3339 ?tz_offset_s:None ts ^ ": " ^ url ^ " " ^ string_of_int bytes_written ^ " bytes written to disk</li>")
               ^ acc)
             !active_downloads ""
         in
-- 
2.47.0


From 4bec3bfbd8f9cd26e9159ca90cb3a7061d213744 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 16:50:42 +0100
Subject: [PATCH 05/16] restore checksum failure error

---
 mirage/unikernel.ml | 20 ++++++++++++--------
 1 file changed, 12 insertions(+), 8 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index ab0a774..2102a15 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -256,13 +256,6 @@ module Make
           in
           read_more a Optint.Int63.zero
 
-    let key_of_hash_csum (hash, csum) = match hash with
-      | `SHA512 ->
-        (* We can't use hex because the filename would become too long for tar *)
-        Mirage_kv.Key.(v (hash_to_string hash) / Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false csum)
-      | _ ->
-        Mirage_kv.Key.(v (hash_to_string hash) / Ohex.encode csum)
-
     let init_write t csums =
       let quux, csums = Archive_checksum.init_write csums in
       let swap = Swap.empty t.dev_swap in
@@ -334,7 +327,18 @@ module Make
           Logs.err (fun m -> m "Write failure for %s: %a" url pp_error e);
           add_failed url (Ptime.v (Pclock.now_d_ps ()))
             (Fmt.str "Write failure for %s: %a" url pp_error e)
-      else Lwt.return_unit
+      else begin
+        add_failed url (Ptime.v (Pclock.now_d_ps ()))
+          (Fmt.str "Bad checksum %s:%s: computed %s expected %s" url
+             (hash_to_string hash)
+             (Ohex.encode (Archive_checksum.get digests hash))
+             (Ohex.encode csum));
+        Logs.err (fun m -> m "Bad checksum %s:%s: computed %s expected %s" url
+                     (hash_to_string hash)
+                     (Ohex.encode (Archive_checksum.get digests hash))
+                     (Ohex.encode csum));
+        Lwt.return_unit
+      end
 
     (* on disk, we use a flat file system where the filename is the sha256 of the data *)
     let init ~verify_sha256 dev dev_md5s dev_sha512s dev_swap =
-- 
2.47.0


From 2312092e42db6ea595b72ac2bf4664ac2f390f0f Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 17:17:37 +0100
Subject: [PATCH 06/16] first write to a temporary filename, and rename later

---
 mirage/unikernel.ml | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 2102a15..1e1307b 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -312,8 +312,12 @@ module Make
         and sha512 = Ohex.encode Digestif.SHA512.(to_raw_string (get digests.sha512)) in
         let dest = Mirage_kv.Key.v sha256 in
         Logs.info (fun m -> m "downloaded %s, now writing" url);
-        (Lwt.finalize (fun () -> set_from_handle t.dev dest swap)
-           (fun () -> Swap.free swap))
+        let temp = Mirage_kv.Key.(v "pending" // dest) in
+        Lwt_result.bind
+          (Lwt.finalize (fun () -> set_from_handle t.dev temp swap)
+             (fun () -> Swap.free swap))
+          (fun () -> KV.rename t.dev ~source:temp ~dest
+                     |> Lwt_result.map_error (fun e -> `Write_error e))
         >|= function
         | Ok () ->
           remove_active url;
-- 
2.47.0


From a9b8f181928e3669d6383582b846fea2635b03b2 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 17:17:52 +0100
Subject: [PATCH 07/16] stream git contents, also make the tarball and the
 find_urls in one go

---
 mirage/unikernel.ml | 150 +++++++++++++++++++++++---------------------
 1 file changed, 78 insertions(+), 72 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 1e1307b..9b53550 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -102,62 +102,67 @@ module Make
       hm ""
 
   module Git = struct
-    let find_contents store =
-      let rec go store path acc =
-        Store.list store path >>= function
-        | Error e ->
-          Logs.err (fun m -> m "error %a while listing %a"
-                       Store.pp_error e Mirage_kv.Key.pp path);
-          Lwt.return acc
-        | Ok steps ->
-          Lwt_list.fold_left_s (fun acc (step, _) ->
-              Store.exists store step >>= function
+    let contents store =
+      let explore = ref [ Mirage_kv.Key.empty ] in
+      let more () =
+        let rec go () =
+          match !explore with
+          | [] -> Lwt.return None
+          | step :: tl ->
+            explore := tl;
+            Store.exists store step >>= function
+            | Error e ->
+              Logs.err (fun m -> m "error %a for exists %a" Store.pp_error e
+                           Mirage_kv.Key.pp step);
+              go ()
+            | Ok None ->
+              Logs.warn (fun m -> m "no typ for %a" Mirage_kv.Key.pp step);
+              go ()
+            | Ok Some `Value -> Lwt.return (Some step)
+            | Ok Some `Dictionary ->
+              Store.list store step >>= function
               | Error e ->
-                Logs.err (fun m -> m "error %a for exists %a" Store.pp_error e
-                             Mirage_kv.Key.pp step);
-                Lwt.return acc
-              | Ok None ->
-                Logs.warn (fun m -> m "no typ for %a" Mirage_kv.Key.pp step);
-                Lwt.return acc
-              | Ok Some `Value -> Lwt.return (step :: acc)
-              | Ok Some `Dictionary -> go store step acc) acc steps
+                Logs.err (fun m -> m "error %a while listing %a"
+                             Store.pp_error e Mirage_kv.Key.pp step);
+                go ()
+              | Ok steps ->
+                explore := !explore @ List.map fst steps;
+                go ()
+        in
+        go ()
       in
-      go store Mirage_kv.Key.empty []
+      Lwt_stream.from more
+
+    let find_urls acc path data =
+      if Mirage_kv.Key.basename path = "opam" then
+        (* TODO: parser errors are logged (should be reported to status page) *)
+        (try
+           let url_csums = Opam_file.extract_urls (Mirage_kv.Key.to_string path) data in
+           List.fold_left (fun acc (url, csums) ->
+               if HM.cardinal csums = 0 then
+                 (Logs.warn (fun m -> m "no checksums for %s, ignoring" url); acc)
+               else
+                 SM.update url (function
+                     | 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')
+                       else begin
+                         Logs.warn (fun m -> m "mismatching hashes for %s: %s vs %s"
+                                       url (hm_to_s csums') (hm_to_s csums));
+                         None
+                       end) acc) acc url_csums
+         with exn ->
+           Logs.warn (fun m -> m "some error in %a, ignoring %s"
+                         Mirage_kv.Key.pp path (Printexc.to_string exn));
+           acc)
+      else
+        acc
 
-    let find_urls store =
-      find_contents store >>= fun paths ->
-      let opam_paths =
-        List.filter (fun p -> Mirage_kv.Key.basename p = "opam") paths
-      in
-      Lwt_list.fold_left_s (fun acc path ->
-          Store.get store path >|= function
-          | Ok data ->
-            (* TODO report parser errors *)
-            (try
-               let url_csums = Opam_file.extract_urls (Mirage_kv.Key.to_string path) data in
-               List.fold_left (fun acc (url, csums) ->
-                   if HM.cardinal csums = 0 then
-                     (Logs.warn (fun m -> m "no checksums for %s, ignoring" url); acc)
-                   else
-                     SM.update url (function
-                         | 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')
-                           else begin
-                             Logs.warn (fun m -> m "mismatching hashes for %s: %s vs %s"
-                                           url (hm_to_s csums') (hm_to_s csums));
-                             None
-                           end) acc) acc url_csums
-             with _ ->
-               Logs.warn (fun m -> m "some error in %a, ignoring" Mirage_kv.Key.pp path);
-               acc)
-          | Error e -> Logs.warn (fun m -> m "Store.get: %a" Store.pp_error e); acc)
-        SM.empty opam_paths
   end
 
   let active_downloads = ref SM.empty
@@ -506,22 +511,23 @@ module Make
         then Tar.High (High.inj (Lwt.return_ok None))
         else begin closed := true; Tar.High (High.inj (Lwt.return_ok (Some  data))) end
 
-    let entries_of_git ~mtime store repo =
-      Git.find_contents store >>= fun paths ->
-      let entries = Lwt_stream.of_list paths in
+    let entries_of_git ~mtime store repo urls =
+      let entries = Git.contents store in
       let to_entry path =
         Store.get store path >|= function
         | Ok data ->
           let data =
             if Mirage_kv.Key.(equal path (v "repo"))
-            then repo else data in
+            then repo else data
+          in
           let file_mode = 0o644
           and mod_time = Int64.of_int mtime
           and user_id = 0
           and group_id = 0
           and size = String.length data in
           let hdr = Tar.Header.make ~file_mode ~mod_time ~user_id ~group_id
-            (Mirage_kv.Key.to_string path) (Int64.of_int size) in
+              (Mirage_kv.Key.to_string path) (Int64.of_int size) in
+          urls := Git.find_urls !urls path data;
           Some (Some Tar.Header.Ustar, hdr, once data)
         | Error _ -> None in
       let entries = Lwt_stream.filter_map_s to_entry entries in
@@ -530,12 +536,13 @@ module Make
     let of_git repo store =
       let now = Ptime.v (Pclock.now_d_ps ()) in
       let mtime = Option.value ~default:0 Ptime.(Span.to_int_s (to_span now)) in
-      entries_of_git ~mtime store repo >>= fun entries ->
+      let urls = ref SM.empty in
+      entries_of_git ~mtime store repo urls >>= fun entries ->
       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
       to_buffer buf t >|= function
-      | Ok () -> Buffer.contents buf
+      | Ok () -> Buffer.contents buf, !urls
       | Error (`Msg msg) -> failwith msg
   end
 
@@ -588,8 +595,8 @@ stamp: %S
       commit_id git_kv >>= fun commit_id ->
       modified git_kv >>= fun modified ->
       let repo = repo remote commit_id in
-      Tarball.of_git repo git_kv >|= fun index ->
-      { commit_id ; modified ; repo ; index }
+      Tarball.of_git repo git_kv >|= fun (index, urls) ->
+      { commit_id ; modified ; repo ; index }, urls
 
     let update_lock = Lwt_mutex.create ()
 
@@ -602,18 +609,18 @@ stamp: %S
             Lwt.return None
           | Ok [] ->
             Logs.info (fun m -> m "git changes are empty");
-            Lwt.return (Some [])
+            Lwt.return (Some ([], SM.empty))
           | Ok changes ->
             commit_id git_kv >>= fun commit_id ->
             modified git_kv >>= fun modified ->
             Logs.info (fun m -> m "git: %s" commit_id);
             let repo = repo remote commit_id in
-            Tarball.of_git repo git_kv >|= fun index ->
+            Tarball.of_git repo git_kv >|= fun (index, urls) ->
             t.commit_id <- commit_id ;
             t.modified <- modified ;
             t.repo <- repo ;
             t.index <- index;
-            Some changes)
+            Some (changes, urls))
 
     let status disk =
       (* report status:
@@ -796,9 +803,8 @@ stamp: %S
 
   end
 
-  let download_archives parallel_downloads disk http_client store =
+  let download_archives parallel_downloads disk http_client urls =
     (* FIXME: handle resuming partial downloads *)
-    Git.find_urls store >>= fun urls ->
     let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in
     let idx = ref 0 in
     Lwt_list.iter_p (fun (url, csums) ->
@@ -901,14 +907,14 @@ stamp: %S
       Logs.info (fun m -> m "Done initializing git state!");
       Serve.commit_id git_kv >>= fun commit_id ->
       Logs.info (fun m -> m "git: %s" commit_id);
-      Serve.create remote git_kv >>= fun serve ->
+      Serve.create remote git_kv >>= fun (serve, urls) ->
       Paf.init ~port:(K.port ()) (Stack.tcp stack) >>= fun t ->
       let update () =
         Serve.update_git ~remote serve git_kv >>= function
-        | None | Some [] -> Lwt.return_unit
-        | Some _changes ->
+        | None | Some ([], _) -> Lwt.return_unit
+        | Some (_changes, urls) ->
           dump_git git_dump git_kv >>= fun () ->
-          download_archives (K.parallel_downloads ()) disk http_ctx git_kv
+          download_archives (K.parallel_downloads ()) disk http_ctx urls
       in
       let service =
         Paf.http_service
@@ -924,7 +930,7 @@ stamp: %S
             go ()
           in
           go ());
-      download_archives (K.parallel_downloads ()) disk http_ctx git_kv >>= fun () ->
+      download_archives (K.parallel_downloads ()) disk http_ctx urls >>= fun () ->
       (th >|= fun _v -> ())
 
   let start block _time _pclock stack git_ctx http_ctx =
-- 
2.47.0


From 1e35bfefbd5775a75166eb35e5ab29367399aa1e Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 17:25:08 +0100
Subject: [PATCH 08/16] initialization: potentially rename bad data

---
 mirage/unikernel.ml | 63 ++++++++++++++++++++++++++++-----------------
 1 file changed, 39 insertions(+), 24 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 9b53550..11098ee 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -380,19 +380,7 @@ module Make
               Lwt.return_unit
             | `Value ->
               let open Digestif in
-              let sha256_final =
-                if verify_sha256 then
-                  let f s =
-                    let digest = SHA256.(to_raw_string (get s)) in
-                    if not (String.equal (Mirage_kv.Key.basename path) (Ohex.encode digest)) then
-                      Logs.err (fun m -> m "corrupt SHA256 data for %a, \
-                                            computed %s (should remove)"
-                                   Mirage_kv.Key.pp path (Ohex.encode digest))
-                  in
-                  Some f
-                else
-                  None
-              and md5_final =
+              let md5_final =
                 if not (SSet.mem (Mirage_kv.Key.basename path) md5s) then
                   let f s =
                     let digest = MD5.(to_raw_string (get s)) in
@@ -411,26 +399,53 @@ module Make
                 else
                   None
               in
-              match sha256_final, md5_final, sha512_final with
-              | None, None, None -> Lwt.return_unit
-              | _ ->
+              let sha256_final =
+                let need_to_compute = md5_final <> None || sha512_final <> None || verify_sha256 in
+                if need_to_compute then
+                  let f s =
+                    let digest = SHA256.(to_raw_string (get s)) in
+                    if not (String.equal (Mirage_kv.Key.basename path) (Ohex.encode digest)) then
+                      begin
+                        Logs.err (fun m -> m "corrupt SHA256 data for %a, \
+                                              computed %s (will rename)"
+                                     Mirage_kv.Key.pp path (Ohex.encode digest));
+                        false
+                      end else true
+                  in
+                  Some f
+                else
+                  None
+              in
+              match sha256_final with
+              | None -> Lwt.return_unit
+              | Some f ->
                 read_chunked t `SHA256 path
                   (fun (sha256, md5, sha512) data ->
                      Lwt.return
-                       (Option.map (fun t -> SHA256.feed_string t data) sha256,
+                       (SHA256.feed_string sha256 data,
                         Option.map (fun t -> MD5.feed_string t data) md5,
                         Option.map (fun t -> SHA512.feed_string t data) sha512))
-                  (Option.map (fun _ -> SHA256.empty) sha256_final,
+                  (SHA256.empty,
                    Option.map (fun _ -> MD5.empty) md5_final,
-                   Option.map (fun _ -> SHA512.empty) sha512_final) >|= function
+                   Option.map (fun _ -> SHA512.empty) sha512_final) >>= function
                 | Error e ->
                   Logs.err (fun m -> m "error %a of %a while computing digests"
-                               KV.pp_error e Mirage_kv.Key.pp path)
+                               KV.pp_error e Mirage_kv.Key.pp path);
+                  Lwt.return_unit
                 | Ok (sha256, md5, sha512) ->
-                  Option.iter (fun f -> f (Option.get sha256)) sha256_final;
-                  Option.iter (fun f -> f (Option.get md5)) md5_final;
-                  Option.iter (fun f -> f (Option.get sha512)) sha512_final;
-                  Logs.info (fun m -> m "added %a" Mirage_kv.Key.pp path))
+                  if not (f sha256) then
+                    (* bad sha256! *)
+                    KV.rename t.dev ~source:path ~dest:(Mirage_kv.Key.(v "delete" // path)) >|= function
+                    | Ok () -> ()
+                    | Error we ->
+                      Logs.err (fun m -> m "error %a while renaming %a" KV.pp_write_error we
+                                   Mirage_kv.Key.pp path)
+                  else begin
+                    Option.iter (fun f -> f (Option.get md5)) md5_final;
+                    Option.iter (fun f -> f (Option.get sha512)) sha512_final;
+                    Logs.info (fun m -> m "added %a" Mirage_kv.Key.pp path);
+                    Lwt.return_unit
+                  end)
           entries >>= fun () ->
         update_caches t >|= fun () ->
         t
-- 
2.47.0


From a47193f147dc67a0e75eeb1358e55a8786822099 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 17:33:50 +0100
Subject: [PATCH 09/16] tweaks

---
 mirage/unikernel.ml | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 11098ee..4fac591 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -126,7 +126,7 @@ module Make
                              Store.pp_error e Mirage_kv.Key.pp step);
                 go ()
               | Ok steps ->
-                explore := !explore @ List.map fst steps;
+                explore := List.map fst steps @ !explore;
                 go ()
         in
         go ()
@@ -286,6 +286,12 @@ module Make
         common_bindings
 
     let set_from_handle dev dest h =
+      (* TODO: we need a function in tar which
+         (a) takes a path
+         (b) takes a function that reads (from the swap) and writes (to the tar)
+         (c) once the function is finished, it writes the tar header
+         -> this would allow us to avoid the rename stuff below
+      *)
       let size = Optint.Int63.of_int64 (Swap.size h) in
       KV.allocate dev dest size >>= fun r ->
       let rec loop offset =
-- 
2.47.0


From 9c50538877f794623ba3fcdd95ed00f43badacd2 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 18:27:27 +0100
Subject: [PATCH 10/16] record and preserve opam file parsing issues

---
 mirage/opam_file.ml | 76 +++++++++++++++++++++++----------------
 mirage/unikernel.ml | 88 ++++++++++++++++++++++++++-------------------
 2 files changed, 97 insertions(+), 67 deletions(-)

diff --git a/mirage/opam_file.ml b/mirage/opam_file.ml
index e08f252..1489523 100644
--- a/mirage/opam_file.ml
+++ b/mirage/opam_file.ml
@@ -13,17 +13,22 @@ let hex_of_string s =
 let decode_digest filename str =
   let hex h s =
     match hex_of_string s with
-    | Ok d -> Some (h, d)
-    | Error `Msg msg ->
-      Log.warn (fun m -> m "%s invalid hex (%s) %s" filename msg s); None
+    | Ok d -> Ok (h, d)
+    | Error `Msg msg as e ->
+      Log.warn (fun m -> m "%s invalid hex (%s) %s" filename msg s);
+      e
   in
   match String.split_on_char '=' str with
   | [ data ] -> hex `MD5 data
   | [ "md5" ; data ] -> hex `MD5 data
   | [ "sha256" ; data ] -> hex `SHA256 data
   | [ "sha512" ; data ] -> hex `SHA512 data
-  | [ hash ; _ ] -> Log.warn (fun m -> m "%s unknown hash %s" filename hash); None
-  | _ -> Log.warn (fun m -> m "%s unexpected hash format %S" filename str); None
+  | [ hash ; _ ] ->
+    Log.warn (fun m -> m "%s unknown hash %s" filename hash);
+    Error (`Msg ("unknown hash " ^ hash))
+  | _ ->
+    Log.warn (fun m -> m "%s unexpected hash format %S" filename str);
+    Error (`Msg ("unexpected hash format " ^ str))
 
 let extract_url_checksum filename items =
   let open OpamParserTypes.FullPos in
@@ -42,64 +47,73 @@ let extract_url_checksum filename items =
   in
   let url =
     match url, archive with
-    | Some { pelem = Variable (_, { pelem = String url ; _ }) ; _ }, None -> Some url
-    | None, Some { pelem = Variable (_, { pelem = String url ; _ }); _ } -> Some url
+    | Some { pelem = Variable (_, { pelem = String url ; _ }) ; _ }, None -> Ok url
+    | None, Some { pelem = Variable (_, { pelem = String url ; _ }); _ } -> Ok url
     | _ ->
-      Log.warn (fun m -> m "%s neither src nor archive present" filename); None
+      Log.warn (fun m -> m "%s neither src nor archive present" filename);
+      Error (`Msg "neither 'src' nor 'archive' present")
   in
-  let csum =
+  let csum, csum_errs =
     match checksum with
     | Some { pelem = Variable (_, { pelem = List { pelem = csums ; _ } ; _ }); _ } ->
-      let csums =
-        List.fold_left (fun acc ->
+      let csums, errs =
+        List.fold_left (fun (csums, errs) ->
             function
             | { pelem = String csum ; _ } ->
               begin match decode_digest filename csum with
-                | None -> acc
-                | Some (h, v) ->
+                | Error e -> csums, e :: errs
+                | Ok (h, v) ->
                   HM.update h (function
                       | None -> Some v
                       | Some v' when String.equal v v' -> None
                       | Some v' ->
                         Log.warn (fun m -> m "for %s, hash %s, multiple keys are present: %s %s"
-                                     (Option.value ~default:"NONE" url) (hash_to_string h) (Ohex.encode v) (Ohex.encode v'));
+                                     (Result.value ~default:"NONE" url) (hash_to_string h) (Ohex.encode v) (Ohex.encode v'));
                         None)
-                    acc
+                    csums, errs
               end
-            | _ -> acc) HM.empty csums
+            | v ->
+              csums, `Msg (Fmt.str "bad checksum data: %s" (OpamPrinter.FullPos.value v)) :: errs)
+          (HM.empty, []) csums
       in
-      Some csums
+      if HM.is_empty csums then
+        match errs with
+        | hd :: tl -> Error hd, tl
+        | [] -> Error (`Msg "empty checksums"), []
+      else
+        Ok csums, errs
     | Some { pelem = Variable (_, { pelem = String csum ; _ }) ; _ } ->
       begin match decode_digest filename csum with
-        | None -> None
-        | Some (h, v) -> Some (HM.singleton h v)
+        | Error _ as e -> e, []
+        | Ok (h, v) -> Ok (HM.singleton h v), []
       end
     | _ ->
       Log.warn (fun m -> m "couldn't decode checksum in %s" filename);
-      None
+      Error (`Msg "couldn't find or decode 'checksum'"), []
   in
-  match url, csum with
-  | Some url, Some cs -> Some (url, cs)
-  | _ -> None
+  (match url, csum with
+   | Ok url, Ok csum -> Ok (url, csum)
+   | Error _ as e, _
+   | _, (Error _ as e) -> e), csum_errs
 
 let extract_checksums_and_urls filename opam =
   let open OpamParserTypes.FullPos in
-  List.fold_left (fun acc ->
+  List.fold_left (fun (csum_urls, errs) ->
       function
       | { pelem = Section ({ section_kind = { pelem = "url" ; _ } ; section_items = { pelem = items ; _ } ; _ }) ; _} ->
         begin match extract_url_checksum filename items with
-          | None -> acc
-          | Some url -> url :: acc
+          | Error `Msg msg, errs' -> csum_urls, `Msg ("url: " ^ msg) :: errs' @ errs
+          | Ok url, errs' -> url :: csum_urls, errs' @ errs
         end
       | { pelem = Section ({ section_kind = { pelem = "extra-source" ; _ } ; section_name = Some { pelem ; _ } ;  section_items = { pelem = items ; _ };  _ }) ; _} ->
         begin
           Log.debug (fun m -> m "extracting for extra-source %s in %s" filename pelem);
           match extract_url_checksum filename items with
-          | None -> acc
-          | Some url -> url :: acc
+          | Error `Msg msg, errs' -> csum_urls, `Msg ("extra-source " ^ pelem ^ " " ^ msg) :: errs' @ errs
+          | Ok url, errs' -> url :: csum_urls, errs' @ errs
         end
-      | _ -> acc)
-    [] opam.file_contents
+      | _ -> csum_urls, errs)
+    ([], []) opam.file_contents
 
 let extract_urls filename str =
   (* in an opam file, there may be:
@@ -121,6 +135,6 @@ let extract_urls filename str =
   in
   if unavailable then
     (Log.debug (fun m -> m "%s is marked unavailable, skipping" filename);
-     [])
+     [], [])
   else
     extract_checksums_and_urls filename opamfile
diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 4fac591..fe86de3 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -101,6 +101,11 @@ module Make
         hash_to_string h ^ "=" ^ Ohex.encode v ^ "\n" ^ acc)
       hm ""
 
+  let parse_errors = ref SM.empty
+
+  let add_parse_error filename error =
+    parse_errors := SM.add filename error !parse_errors
+
   module Git = struct
     let contents store =
       let explore = ref [ Mirage_kv.Key.empty ] in
@@ -135,31 +140,32 @@ module Make
 
     let find_urls acc path data =
       if Mirage_kv.Key.basename path = "opam" then
-        (* TODO: parser errors are logged (should be reported to status page) *)
-        (try
-           let url_csums = Opam_file.extract_urls (Mirage_kv.Key.to_string path) data in
-           List.fold_left (fun acc (url, csums) ->
-               if HM.cardinal csums = 0 then
-                 (Logs.warn (fun m -> m "no checksums for %s, ignoring" url); acc)
-               else
-                 SM.update url (function
-                     | 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')
-                       else begin
-                         Logs.warn (fun m -> m "mismatching hashes for %s: %s vs %s"
-                                       url (hm_to_s csums') (hm_to_s csums));
-                         None
-                       end) acc) acc url_csums
-         with exn ->
-           Logs.warn (fun m -> m "some error in %a, ignoring %s"
-                         Mirage_kv.Key.pp path (Printexc.to_string exn));
-           acc)
+        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) ->
+            if HM.cardinal csums = 0 then
+              (Logs.warn (fun m -> m "no checksums for %s, ignoring" url);
+               add_parse_error path ("no checksums for " ^ url);
+               acc)
+            else
+              SM.update url (function
+                  | 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')
+                    else begin
+                      Logs.warn (fun m -> m "mismatching hashes for %s: %s vs %s"
+                                    url (hm_to_s csums') (hm_to_s csums));
+                      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
       else
         acc
 
@@ -654,27 +660,37 @@ stamp: %S
           (SM.cardinal disk.Disk.md5s)
           (KV.free disk.Disk.dev)
       in
+      let sort_by_ts a b = Ptime.compare a b in
       let active_downloads =
         let header = "<h2>Active downloads</h2><ul>" in
         let content =
-          SM.fold (fun url (ts, bytes_written) acc ->
-              ("<li>" ^ Ptime.to_rfc3339 ?tz_offset_s:None ts ^ ": " ^ url ^ " " ^ string_of_int bytes_written ^ " bytes written to disk</li>")
-              ^ acc)
-            !active_downloads ""
+          SM.bindings !active_downloads |>
+          List.sort (fun (_, (a, _)) (_, (b, _)) -> sort_by_ts a b) |>
+          List.map (fun (url, (ts, bytes_written)) ->
+              "<li>" ^ Ptime.to_rfc3339 ?tz_offset_s:None ts ^ ": " ^ url ^ " " ^ string_of_int bytes_written ^ " bytes written to swap</li>")
         in
-        header ^ content ^ "</ul>"
+        header ^ String.concat "" content ^ "</ul>"
       and failed_downloads =
         let header = "<h2>Failed downloads</h2><ul>" in
         let content =
-          SM.fold (fun url (ts, reason) acc ->
-              ("<li>" ^ Ptime.to_rfc3339 ?tz_offset_s:None ts ^ ": " ^ url ^ " " ^ reason ^ "</li>")
-              ^ acc)
-            !failed_downloads ""
+          SM.bindings !failed_downloads |>
+          List.sort (fun (_, (a, _)) (_, (b, _)) -> sort_by_ts a b) |>
+          List.map (fun (url, (ts, reason)) ->
+              "<li>" ^ Ptime.to_rfc3339 ?tz_offset_s:None ts ^ ": " ^ url ^ " " ^ reason ^ "</li>")
         in
-        header ^ content ^ "</ul>"
+        header ^ String.concat "" content ^ "</ul>"
+      and parse_errors =
+        let header = "<h2>Parse errors</h2><ul>" in
+        let content =
+          SM.bindings !parse_errors |>
+          List.sort (fun (a, _) (b, _) -> String.compare a b) |>
+          List.map (fun (filename, reason) ->
+              "<li>" ^ filename ^ ": " ^ reason ^ "</li>")
+        in
+        header ^ String.concat "" content ^ "</ul>"
       in
       "<html><head><title>Opam-mirror status page</title></head><body><h1>Opam mirror status</h1><div>"
-      ^ String.concat "</div><div>" [ archive_stats ; active_downloads ; failed_downloads ]
+      ^ String.concat "</div><div>" [ archive_stats ; active_downloads ; failed_downloads ; parse_errors ]
         ^ "</div></body></html>"
 
     let not_modified request (modified, etag) =
-- 
2.47.0


From 8ba4cfae00674d8a3ba0fe74e65604e8a64baf8c Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Mon, 4 Nov 2024 18:43:50 +0100
Subject: [PATCH 11/16] group download failures by error

---
 mirage/unikernel.ml | 59 +++++++++++++++++++++++++++++++++------------
 1 file changed, 44 insertions(+), 15 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index fe86de3..29f0cd9 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -192,6 +192,36 @@ module Make
     remove_active url;
     failed_downloads := SM.add url (ts, reason) !failed_downloads
 
+  let pp_failed ppf = function
+    | `Write_error e ->
+      Fmt.pf ppf "write error: %a" KV.pp_write_error e
+    | `Swap e ->
+      Fmt.pf ppf "swap error: %a" Swap.pp_error e
+    | `Bad_checksum (hash, computed, expected) ->
+      Fmt.pf ppf "%s checksum: computed %s expected %s"
+        (hash_to_string hash)
+        (Ohex.encode computed)
+        (Ohex.encode expected)
+    | `Bad_response (status, reason) ->
+      Fmt.pf ppf "bad response: %a %s" H2.Status.pp_hum status reason
+    | `Mimic me ->
+      Fmt.pf ppf "mimic: %a" Mimic.pp_error me
+
+  let compare_failed a b = match a, b with
+    | `Write_error _, `Write_error _ -> 0
+    | `Write_error _, _ -> 1
+    | _, `Write_error _ -> -1
+    | `Swap _, `Swap _ -> 0
+    | `Swap _, _ -> 1
+    | _, `Swap _ -> -1
+    | `Bad_checksum _, `Bad_checksum _ -> 0
+    | `Bad_checksum _, _ -> 1
+    | _, `Bad_checksum _ -> -1
+    | `Bad_response _, `Bad_response _ -> 0
+    | `Bad_response _, _ -> 1
+    | _, `Bad_response _ -> -1
+    | `Mimic _, `Mimic _ -> 0
+
   module Disk = struct
     type t = {
       mutable md5s : string SM.t ;
@@ -346,14 +376,12 @@ module Make
             | `Swap e -> Swap.pp_error ppf e
           in
           Logs.err (fun m -> m "Write failure for %s: %a" url pp_error e);
-          add_failed url (Ptime.v (Pclock.now_d_ps ()))
-            (Fmt.str "Write failure for %s: %a" url pp_error e)
+          match e with
+          | `Write_error e -> add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Write_error e)
+          | `Swap e -> add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Swap e)
       else begin
         add_failed url (Ptime.v (Pclock.now_d_ps ()))
-          (Fmt.str "Bad checksum %s:%s: computed %s expected %s" url
-             (hash_to_string hash)
-             (Ohex.encode (Archive_checksum.get digests hash))
-             (Ohex.encode csum));
+          (`Bad_checksum (hash, Archive_checksum.get digests hash, csum));
         Logs.err (fun m -> m "Bad checksum %s:%s: computed %s expected %s" url
                      (hash_to_string hash)
                      (Ohex.encode (Archive_checksum.get digests hash))
@@ -674,9 +702,13 @@ stamp: %S
         let header = "<h2>Failed downloads</h2><ul>" in
         let content =
           SM.bindings !failed_downloads |>
-          List.sort (fun (_, (a, _)) (_, (b, _)) -> sort_by_ts a b) |>
+          List.sort (fun (_, (a, reasona)) (_, (b, reasonb)) ->
+              match compare_failed reasona reasonb with
+              | 0 -> sort_by_ts a b
+              | n -> n) |>
           List.map (fun (url, (ts, reason)) ->
-              "<li>" ^ Ptime.to_rfc3339 ?tz_offset_s:None ts ^ ": " ^ url ^ " " ^ reason ^ "</li>")
+              Fmt.str "<li>%s: %s error %a"
+                (Ptime.to_rfc3339 ?tz_offset_s:None ts) url pp_failed reason)
         in
         header ^ String.concat "" content ^ "</ul>"
       and parse_errors =
@@ -867,28 +899,25 @@ stamp: %S
                 Logs.warn (fun m -> m "%s: %a (reason %s)"
                               url H2.Status.pp_hum resp.status resp.reason);
                 add_failed url (Ptime.v (Pclock.now_d_ps ()))
-                  (Fmt.str "%a %s" H2.Status.pp_hum resp.status resp.reason);
+                  (`Bad_response (resp.status, resp.reason));
                 Lwt.return_unit
               | Error `Write_error e ->
                 Logs.err (fun m -> m "%s: write error %a"
                               url
                               KV.pp_write_error e);
-                add_failed url (Ptime.v (Pclock.now_d_ps ()))
-                  (Fmt.str "write error: %a" KV.pp_write_error e);
+                add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Write_error e);
                 Lwt.return_unit
               | Error `Swap e ->
                 Logs.err (fun m -> m "%s: swap error %a"
                              url
                              Swap.pp_error e);
-                add_failed url (Ptime.v (Pclock.now_d_ps ()))
-                  (Fmt.str "swap error: %a" Swap.pp_error 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 ->
-            add_failed url (Ptime.v (Pclock.now_d_ps ()))
-              (Fmt.str "mimic error: %a" Mimic.pp_error me);
+            add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Mimic me);
             Lwt.return_unit)
       (SM.bindings urls) >>= fun () ->
     Disk.update_caches disk >|= fun () ->
-- 
2.47.0


From 37008e81f3c7d5ce128a0007c4d9e4a9fc5cccd1 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Wed, 6 Nov 2024 12:57:43 +0100
Subject: [PATCH 12/16] organize failures into sections

---
 mirage/unikernel.ml | 79 ++++++++++++++++++++++++++++-----------------
 1 file changed, 49 insertions(+), 30 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 29f0cd9..415024b 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -194,33 +194,32 @@ module Make
 
   let pp_failed ppf = function
     | `Write_error e ->
-      Fmt.pf ppf "write error: %a" KV.pp_write_error e
+      KV.pp_write_error ppf e
     | `Swap e ->
-      Fmt.pf ppf "swap error: %a" Swap.pp_error e
+      Swap.pp_error ppf e
     | `Bad_checksum (hash, computed, expected) ->
       Fmt.pf ppf "%s checksum: computed %s expected %s"
         (hash_to_string hash)
         (Ohex.encode computed)
         (Ohex.encode expected)
     | `Bad_response (status, reason) ->
-      Fmt.pf ppf "bad response: %a %s" H2.Status.pp_hum status reason
+      Fmt.pf ppf "%a %s" H2.Status.pp_hum status reason
     | `Mimic me ->
-      Fmt.pf ppf "mimic: %a" Mimic.pp_error me
+      Mimic.pp_error ppf me
 
-  let compare_failed a b = match a, b with
-    | `Write_error _, `Write_error _ -> 0
-    | `Write_error _, _ -> 1
-    | _, `Write_error _ -> -1
-    | `Swap _, `Swap _ -> 0
-    | `Swap _, _ -> 1
-    | _, `Swap _ -> -1
-    | `Bad_checksum _, `Bad_checksum _ -> 0
-    | `Bad_checksum _, _ -> 1
-    | _, `Bad_checksum _ -> -1
-    | `Bad_response _, `Bad_response _ -> 0
-    | `Bad_response _, _ -> 1
-    | _, `Bad_response _ -> -1
-    | `Mimic _, `Mimic _ -> 0
+  let key_of_failed = function
+    | `Write_error _ -> `Write_error
+    | `Swap _ -> `Swap
+    | `Bad_checksum _ -> `Bad_checksum
+    | `Bad_response _ -> `Bad_response
+    | `Mimic _ -> `Mimic
+
+  let pp_key ppf = function
+    | `Write_error -> Fmt.pf ppf "Write error"
+    | `Swap -> Fmt.pf ppf "Swap error"
+    | `Bad_checksum -> Fmt.pf ppf "Bad checksum"
+    | `Bad_response -> Fmt.pf ppf "Bad response"
+    | `Mimic -> Fmt.pf ppf "Mimic"
 
   module Disk = struct
     type t = {
@@ -677,14 +676,15 @@ stamp: %S
             t.index <- index;
             Some (changes, urls))
 
-    let status disk =
+    let status t disk =
       (* report status:
          - archive size (can we easily measure?) and number of "good" elements
          - list of current downloads
          - list of failed downloads
       *)
       let archive_stats =
-        Fmt.str "<ul><li>%u validated archives on disk</li><li>%Lu bytes free</li></ul>"
+        Fmt.str "<ul><li>commit %s</li><li>last modified %s</li><li>repo %s</li><li>%u validated archives on disk</li><li>%Lu bytes free</li></ul>"
+          t.commit_id t.modified t.repo
           (SM.cardinal disk.Disk.md5s)
           (KV.free disk.Disk.dev)
       in
@@ -699,18 +699,37 @@ stamp: %S
         in
         header ^ String.concat "" content ^ "</ul>"
       and failed_downloads =
-        let header = "<h2>Failed downloads</h2><ul>" in
+        let header = "<h2>Failed downloads</h2>" in
+        let group_by xs =
+          let t = Hashtbl.create 7 in
+          List.iter (fun ((_, (_, reason)) as e) ->
+              let k = key_of_failed reason in
+              let els = Option.value ~default:[] (Hashtbl.find_opt t k) in
+              Hashtbl.replace t k (e :: els))
+            xs;
+          Hashtbl.fold (fun k els acc ->
+              let sorted =
+                List.sort (fun (_, (tsa, _)) (_, (tsb, _)) ->
+                    sort_by_ts tsa tsb)
+                  els
+              in
+              (k, sorted) :: acc)
+            t []
+        in
         let content =
           SM.bindings !failed_downloads |>
-          List.sort (fun (_, (a, reasona)) (_, (b, reasonb)) ->
-              match compare_failed reasona reasonb with
-              | 0 -> sort_by_ts a b
-              | n -> n) |>
-          List.map (fun (url, (ts, reason)) ->
-              Fmt.str "<li>%s: %s error %a"
-                (Ptime.to_rfc3339 ?tz_offset_s:None ts) url pp_failed reason)
+          group_by |>
+          List.map (fun (key, els) ->
+              let header = Fmt.str "<h3>%a</h3><ul>" pp_key key in
+              let content =
+                List.map (fun (url, (ts, reason)) ->
+                    Fmt.str "<li>%s: %s error %a"
+                      (Ptime.to_rfc3339 ?tz_offset_s:None ts) url pp_failed reason)
+                  els
+              in
+              header ^ String.concat "" content ^ "</ul>")
         in
-        header ^ String.concat "" content ^ "</ul>"
+        header ^ String.concat "" content
       and parse_errors =
         let header = "<h2>Parse errors</h2><ul>" in
         let content =
@@ -778,7 +797,7 @@ stamp: %S
         let resp = Httpaf.Response.create ~headers `OK in
         Httpaf.Reqd.respond_with_string reqd resp data
       | [ ""; x ] when String.equal x "status" ->
-        let data = status store in
+        let data = status t store in
         let mime_type = "text/html" in
         let headers = [
           "content-type", mime_type ;
-- 
2.47.0


From be87d19797b3ab87902ebd9b25a9dc43c6a01dbe Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Wed, 6 Nov 2024 13:08:28 +0100
Subject: [PATCH 13/16] reset errors, and sort failures

---
 mirage/unikernel.ml | 22 ++++++++++++++++++++++
 1 file changed, 22 insertions(+)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index 415024b..a8f5e06 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -103,6 +103,8 @@ module Make
 
   let parse_errors = ref SM.empty
 
+  let reset_parse_errors () = parse_errors := SM.empty
+
   let add_parse_error filename error =
     parse_errors := SM.add filename error !parse_errors
 
@@ -188,6 +190,8 @@ module Make
 
   let failed_downloads = ref SM.empty
 
+  let reset_failed_downloads () = failed_downloads := SM.empty
+
   let add_failed url ts reason =
     remove_active url;
     failed_downloads := SM.add url (ts, reason) !failed_downloads
@@ -214,6 +218,21 @@ module Make
     | `Bad_response _ -> `Bad_response
     | `Mimic _ -> `Mimic
 
+  let compare_failed_key a b = match a, b with
+    | `Write_error, `Write_error -> 0
+    | `Write_error, _ -> -1
+    | _, `Write_error -> 1
+    | `Swap, `Swap -> 0
+    | `Swap, _ -> -1
+    | _, `Swap -> 1
+    | `Bad_checksum, `Bad_checksum -> 0
+    | `Bad_checksum, _ -> -1
+    | _, `Bad_checksum -> 1
+    | `Bad_response, `Bad_response -> 0
+    | `Bad_response, _ -> -1
+    | _, `Bad_response -> 1
+    | `Mimic, `Mimic -> 0
+
   let pp_key ppf = function
     | `Write_error -> Fmt.pf ppf "Write error"
     | `Swap -> Fmt.pf ppf "Swap error"
@@ -669,6 +688,7 @@ stamp: %S
             modified git_kv >>= fun modified ->
             Logs.info (fun m -> m "git: %s" commit_id);
             let repo = repo remote commit_id in
+            reset_parse_errors ();
             Tarball.of_git repo git_kv >|= fun (index, urls) ->
             t.commit_id <- commit_id ;
             t.modified <- modified ;
@@ -719,6 +739,7 @@ stamp: %S
         let content =
           SM.bindings !failed_downloads |>
           group_by |>
+          List.sort (fun (a, _) (b, _) -> compare_failed_key a b) |>
           List.map (fun (key, els) ->
               let header = Fmt.str "<h3>%a</h3><ul>" pp_key key in
               let content =
@@ -893,6 +914,7 @@ stamp: %S
 
   let download_archives parallel_downloads disk http_client urls =
     (* FIXME: handle resuming partial downloads *)
+    reset_failed_downloads ();
     let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in
     let idx = ref 0 in
     Lwt_list.iter_p (fun (url, csums) ->
-- 
2.47.0


From c3d5c740757b8c5494be673f0935ba82ae367133 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Wed, 6 Nov 2024 13:15:10 +0100
Subject: [PATCH 14/16] use K.remote, not the entire repo

---
 mirage/unikernel.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index a8f5e06..fea9028 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -704,7 +704,7 @@ stamp: %S
       *)
       let archive_stats =
         Fmt.str "<ul><li>commit %s</li><li>last modified %s</li><li>repo %s</li><li>%u validated archives on disk</li><li>%Lu bytes free</li></ul>"
-          t.commit_id t.modified t.repo
+          t.commit_id t.modified (K.remote ())
           (SM.cardinal disk.Disk.md5s)
           (KV.free disk.Disk.dev)
       in
-- 
2.47.0


From 1e75be69002858566cb5ef0ae6af7ddd7ca28be2 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Fri, 8 Nov 2024 13:46:05 +0100
Subject: [PATCH 15/16] remove logging from opam_file (now reported to status)

---
 mirage/opam_file.ml | 31 ++++++++-----------------------
 1 file changed, 8 insertions(+), 23 deletions(-)

diff --git a/mirage/opam_file.ml b/mirage/opam_file.ml
index 1489523..dea9bb6 100644
--- a/mirage/opam_file.ml
+++ b/mirage/opam_file.ml
@@ -1,6 +1,3 @@
-let src = Logs.Src.create "opam-file.opam-mirror" ~doc:"Opam file decoding in opam-mirror"
-module Log = (val Logs.src_log src : Logs.LOG)
-
 module HM = Archive_checksum.HM
 
 let hash_to_string = Archive_checksum.Hash.to_string
@@ -14,21 +11,15 @@ let decode_digest filename str =
   let hex h s =
     match hex_of_string s with
     | Ok d -> Ok (h, d)
-    | Error `Msg msg as e ->
-      Log.warn (fun m -> m "%s invalid hex (%s) %s" filename msg s);
-      e
+    | Error _ as e -> e
   in
   match String.split_on_char '=' str with
   | [ data ] -> hex `MD5 data
   | [ "md5" ; data ] -> hex `MD5 data
   | [ "sha256" ; data ] -> hex `SHA256 data
   | [ "sha512" ; data ] -> hex `SHA512 data
-  | [ hash ; _ ] ->
-    Log.warn (fun m -> m "%s unknown hash %s" filename hash);
-    Error (`Msg ("unknown hash " ^ hash))
-  | _ ->
-    Log.warn (fun m -> m "%s unexpected hash format %S" filename str);
-    Error (`Msg ("unexpected hash format " ^ str))
+  | [ hash ; _ ] -> Error (`Msg ("unknown hash " ^ hash))
+  | _ -> Error (`Msg ("unexpected hash format " ^ str))
 
 let extract_url_checksum filename items =
   let open OpamParserTypes.FullPos in
@@ -49,9 +40,7 @@ let extract_url_checksum filename items =
     match url, archive with
     | Some { pelem = Variable (_, { pelem = String url ; _ }) ; _ }, None -> Ok url
     | None, Some { pelem = Variable (_, { pelem = String url ; _ }); _ } -> Ok url
-    | _ ->
-      Log.warn (fun m -> m "%s neither src nor archive present" filename);
-      Error (`Msg "neither 'src' nor 'archive' present")
+    | _ -> Error (`Msg "neither 'src' nor 'archive' present")
   in
   let csum, csum_errs =
     match checksum with
@@ -67,8 +56,8 @@ let extract_url_checksum filename items =
                       | None -> Some v
                       | Some v' when String.equal v v' -> None
                       | Some v' ->
-                        Log.warn (fun m -> m "for %s, hash %s, multiple keys are present: %s %s"
-                                     (Result.value ~default:"NONE" url) (hash_to_string h) (Ohex.encode v) (Ohex.encode v'));
+                        Logs.warn (fun m -> m "for %s, hash %s, multiple keys are present: %s %s"
+                                      (Result.value ~default:"NONE" url) (hash_to_string h) (Ohex.encode v) (Ohex.encode v'));
                         None)
                     csums, errs
               end
@@ -87,9 +76,7 @@ let extract_url_checksum filename items =
         | Error _ as e -> e, []
         | Ok (h, v) -> Ok (HM.singleton h v), []
       end
-    | _ ->
-      Log.warn (fun m -> m "couldn't decode checksum in %s" filename);
-      Error (`Msg "couldn't find or decode 'checksum'"), []
+    | _ -> Error (`Msg "couldn't find or decode 'checksum'"), []
   in
   (match url, csum with
    | Ok url, Ok csum -> Ok (url, csum)
@@ -107,7 +94,6 @@ let extract_checksums_and_urls filename opam =
         end
       | { pelem = Section ({ section_kind = { pelem = "extra-source" ; _ } ; section_name = Some { pelem ; _ } ;  section_items = { pelem = items ; _ };  _ }) ; _} ->
         begin
-          Log.debug (fun m -> m "extracting for extra-source %s in %s" filename pelem);
           match extract_url_checksum filename items with
           | Error `Msg msg, errs' -> csum_urls, `Msg ("extra-source " ^ pelem ^ " " ^ msg) :: errs' @ errs
           | Ok url, errs' -> url :: csum_urls, errs' @ errs
@@ -134,7 +120,6 @@ let extract_urls filename str =
       opamfile.file_contents
   in
   if unavailable then
-    (Log.debug (fun m -> m "%s is marked unavailable, skipping" filename);
-     [], [])
+     [], []
   else
     extract_checksums_and_urls filename opamfile
-- 
2.47.0


From 1f9e3e6e23c2398ea905782ce2168c9db6b0cc48 Mon Sep 17 00:00:00 2001
From: Hannes Mehnert <hannes@mehnert.org>
Date: Fri, 8 Nov 2024 13:51:33 +0100
Subject: [PATCH 16/16] log less, now that status is around

---
 mirage/unikernel.ml | 99 +++++++++------------------------------------
 1 file changed, 18 insertions(+), 81 deletions(-)

diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
index fea9028..48dbb40 100644
--- a/mirage/unikernel.ml
+++ b/mirage/unikernel.ml
@@ -118,20 +118,12 @@ module Make
           | step :: tl ->
             explore := tl;
             Store.exists store step >>= function
-            | Error e ->
-              Logs.err (fun m -> m "error %a for exists %a" Store.pp_error e
-                           Mirage_kv.Key.pp step);
-              go ()
-            | Ok None ->
-              Logs.warn (fun m -> m "no typ for %a" Mirage_kv.Key.pp step);
-              go ()
+            | Error e -> go ()
+            | Ok None -> go ()
             | Ok Some `Value -> Lwt.return (Some step)
             | Ok Some `Dictionary ->
               Store.list store step >>= function
-              | Error e ->
-                Logs.err (fun m -> m "error %a while listing %a"
-                             Store.pp_error e Mirage_kv.Key.pp step);
-                go ()
+              | Error e -> go ()
               | Ok steps ->
                 explore := List.map fst steps @ !explore;
                 go ()
@@ -147,8 +139,7 @@ module Make
         List.iter (fun (`Msg msg) -> add_parse_error path msg) errs;
         List.fold_left (fun acc (url, csums) ->
             if HM.cardinal csums = 0 then
-              (Logs.warn (fun m -> m "no checksums for %s, ignoring" url);
-               add_parse_error path ("no checksums for " ^ url);
+              (add_parse_error path ("no checksums for " ^ url);
                acc)
             else
               SM.update url (function
@@ -161,8 +152,6 @@ module Make
                     then
                       Some (HM.union (fun _h v _v' -> Some v) csums csums')
                     else begin
-                      Logs.warn (fun m -> m "mismatching hashes for %s: %s vs %s"
-                                    url (hm_to_s csums') (hm_to_s csums));
                       add_parse_error path (Fmt.str
                                               "mismatching hashes for %s: %s vs %s"
                                               url (hm_to_s csums') (hm_to_s csums));
@@ -265,11 +254,11 @@ module Make
     let update_caches t =
       Cache.write t.dev_md5s (marshal_sm t.md5s) >>= fun r ->
       (match r with
-       | Ok () -> Logs.info (fun m -> m "Set 'md5s'")
+       | Ok () -> ()
        | Error e -> Logs.warn (fun m -> m "Failed to write 'md5s': %a" Cache.pp_write_error e));
       Cache.write t.dev_sha512s (marshal_sm t.sha512s) >>= fun r ->
       match r with
-      | Ok () -> Logs.info (fun m -> m "Set 'sha512s'"); Lwt.return_unit
+      | Ok () -> Lwt.return_unit
       | Error e ->
         Logs.warn (fun m -> m "Failed to write 'sha512s': %a" Cache.pp_write_error e);
         Lwt.return_unit
@@ -295,8 +284,6 @@ module Make
       | Ok key ->
         KV.size t.dev key >>= function
         | Error e ->
-          Logs.err (fun m -> m "error %a while reading %s %a"
-                       KV.pp_error e (hash_to_string h) Mirage_kv.Key.pp v);
           Lwt.return (Error (`Not_found key))
         | Ok len ->
           let chunk_size = 4096 in
@@ -307,8 +294,6 @@ module Make
                 f a data >>= fun a ->
                 read_more a Optint.Int63.(add offset (of_int chunk_size))
               | Error e ->
-                Logs.err (fun m -> m "error %a while reading %s %a"
-                             KV.pp_error e (hash_to_string h) Mirage_kv.Key.pp v);
                 Lwt.return (Error e)
             else
               Lwt.return (Ok a)
@@ -376,7 +361,6 @@ module Make
         and md5 = Ohex.encode Digestif.MD5.(to_raw_string (get digests.md5))
         and sha512 = Ohex.encode Digestif.SHA512.(to_raw_string (get digests.sha512)) in
         let dest = Mirage_kv.Key.v sha256 in
-        Logs.info (fun m -> m "downloaded %s, now writing" url);
         let temp = Mirage_kv.Key.(v "pending" // dest) in
         Lwt_result.bind
           (Lwt.finalize (fun () -> set_from_handle t.dev temp swap)
@@ -388,29 +372,18 @@ module Make
           remove_active url;
           t.md5s <- SM.add md5 sha256 t.md5s;
           t.sha512s <- SM.add sha512 sha256 t.sha512s
-        | Error e ->
-          let pp_error ppf = function
-            | `Write_error e -> KV.pp_write_error ppf e
-            | `Swap e -> Swap.pp_error ppf e
-          in
-          Logs.err (fun m -> m "Write failure for %s: %a" url pp_error e);
-          match e with
-          | `Write_error e -> add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Write_error e)
-          | `Swap e -> add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Swap e)
+        | Error `Write_error e -> add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Write_error e)
+        | Error `Swap e -> add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Swap e)
       else begin
         add_failed url (Ptime.v (Pclock.now_d_ps ()))
           (`Bad_checksum (hash, Archive_checksum.get digests hash, csum));
-        Logs.err (fun m -> m "Bad checksum %s:%s: computed %s expected %s" url
-                     (hash_to_string hash)
-                     (Ohex.encode (Archive_checksum.get digests hash))
-                     (Ohex.encode csum));
         Lwt.return_unit
       end
 
     (* on disk, we use a flat file system where the filename is the sha256 of the data *)
     let init ~verify_sha256 dev dev_md5s dev_sha512s dev_swap =
       KV.list dev Mirage_kv.Key.empty >>= function
-      | Error e -> Logs.err (fun m -> m "error %a listing kv" KV.pp_error e); assert false
+      | Error e -> invalid_arg (Fmt.str "error %a listing kv" KV.pp_error e)
       | Ok entries ->
         let t = empty dev dev_md5s dev_sha512s dev_swap in
         Cache.read t.dev_md5s >>= fun r ->
@@ -418,24 +391,20 @@ module Make
          | Ok Some s ->
            if not verify_sha256 then
              Result.iter (fun md5s -> t.md5s <- md5s) (unmarshal_sm s)
-         | Ok None -> Logs.debug (fun m -> m "No md5s cached")
+         | Ok None -> ()
          | Error e -> Logs.warn (fun m -> m "Error reading md5s cache: %a" Cache.pp_error e));
         Cache.read t.dev_sha512s >>= fun r ->
         (match r with
          | Ok Some s ->
            if not verify_sha256 then
              Result.iter (fun sha512s -> t.sha512s <- sha512s) (unmarshal_sm s)
-         | Ok None -> Logs.debug (fun m -> m "No sha512s cached")
+         | Ok None -> ()
          | Error e -> Logs.warn (fun m -> m "Error reading sha512s cache: %a" Cache.pp_error e));
         let md5s = SSet.of_list (List.map snd (SM.bindings t.md5s))
         and sha512s = SSet.of_list (List.map snd (SM.bindings t.sha512s)) in
-        let idx = ref 1 in
         Lwt_list.iter_s (fun (path, typ) ->
-            if !idx mod 10 = 0 then Gc.full_major () ;
             match typ with
-            | `Dictionary ->
-              Logs.warn (fun m -> m "unexpected dictionary at %a" Mirage_kv.Key.pp path);
-              Lwt.return_unit
+            | `Dictionary -> Lwt.return_unit
             | `Value ->
               let open Digestif in
               let md5_final =
@@ -501,7 +470,6 @@ module Make
                   else begin
                     Option.iter (fun f -> f (Option.get md5)) md5_final;
                     Option.iter (fun f -> f (Option.get sha512)) sha512_final;
-                    Logs.info (fun m -> m "added %a" Mirage_kv.Key.pp path);
                     Lwt.return_unit
                   end)
           entries >>= fun () ->
@@ -514,15 +482,9 @@ module Make
       | Ok x ->
         KV.exists t.dev x >|= function
         | Ok Some `Value -> true
-        | Ok Some `Dictionary ->
-          Logs.err (fun m -> m "unexpected dictionary for %s %a"
-                       (hash_to_string h) Mirage_kv.Key.pp v);
-          false
+        | Ok Some `Dictionary -> false
         | Ok None -> false
-        | Error e ->
-          Logs.err (fun m -> m "exists %s %a returned %a"
-                       (hash_to_string h) Mirage_kv.Key.pp v KV.pp_error e);
-          false
+        | Error _ -> false
 
     let last_modified t h v =
       match find_key t h v with
@@ -530,10 +492,7 @@ module Make
       | Ok x ->
         KV.last_modified t.dev x >|= function
         | Ok data -> Ok data
-        | Error e ->
-          Logs.err (fun m -> m "error %a while last_modified %s %a"
-                       KV.pp_error e (hash_to_string h) Mirage_kv.Key.pp v);
-          Error `Not_found
+        | Error _ -> Error `Not_found
 
     let size t h v =
       match find_key t h v with
@@ -541,10 +500,7 @@ module Make
       | Ok x ->
         KV.size t.dev x >|= function
         | Ok s -> Ok s
-        | Error e ->
-          Logs.err (fun m -> m "error %a while size %s %a"
-                       KV.pp_error e (hash_to_string h) Mirage_kv.Key.pp v);
-          Error `Not_found
+        | Error _ -> Error `Not_found
     end
 
   module Tarball = struct
@@ -802,7 +758,6 @@ stamp: %S
         else *)
     let dispatch t store hook_url update _flow _conn reqd =
       let request = Httpaf.Reqd.request reqd in
-      Logs.info (fun f -> f "requested %s" request.Httpaf.Request.target);
       match String.split_on_char '/' request.Httpaf.Request.target with
       | [ ""; x ] when String.equal x hook_url ->
         Lwt.async update;
@@ -865,15 +820,12 @@ stamp: %S
         begin
           match hash_of_string hash_algo with
           | Error `Msg msg ->
-            Logs.warn (fun m -> m "error decoding hash algo: %s" msg);
             not_found reqd request.Httpaf.Request.target
           | Ok h ->
             let hash = Mirage_kv.Key.v hash in
             Lwt.async (fun () ->
                 (Disk.last_modified store h hash >|= function
-                  | Error _ ->
-                    Logs.warn (fun m -> m "error retrieving last modified");
-                    t.modified
+                  | Error _ -> t.modified
                   | Ok v -> ptime_to_http_date v) >>= fun last_modified ->
                 if not_modified request (last_modified, Mirage_kv.Key.basename hash) then
                   let resp = Httpaf.Response.create `Not_modified in
@@ -882,7 +834,6 @@ stamp: %S
                 else
                   Disk.size store h hash >>= function
                   | Error _ ->
-                    Logs.warn (fun m -> m "error retrieving size");
                     not_found reqd request.Httpaf.Request.target;
                     Lwt.return_unit
                   | Ok size ->
@@ -916,7 +867,6 @@ stamp: %S
     (* FIXME: handle resuming partial downloads *)
     reset_failed_downloads ();
     let pool = Lwt_pool.create parallel_downloads (Fun.const Lwt.return_unit) in
-    let idx = ref 0 in
     Lwt_list.iter_p (fun (url, csums) ->
         Lwt_pool.use pool @@ fun () ->
         HM.fold (fun h v r ->
@@ -924,34 +874,21 @@ stamp: %S
             | true -> Disk.exists disk h (hex_to_key v)
             | false -> Lwt.return false)
           csums (Lwt.return true) >>= function
-        | true ->
-          Logs.debug (fun m -> m "ignoring %s (already present)" url);
-          Lwt.return_unit
+        | true -> Lwt.return_unit
         | false ->
-          incr idx;
-          if !idx mod 10 = 0 then Gc.full_major () ;
-          Logs.info (fun m -> m "downloading %s" url);
           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) ->
             begin match r with
               | Error `Bad_response ->
-                Logs.warn (fun m -> m "%s: %a (reason %s)"
-                              url H2.Status.pp_hum resp.status resp.reason);
                 add_failed url (Ptime.v (Pclock.now_d_ps ()))
                   (`Bad_response (resp.status, resp.reason));
                 Lwt.return_unit
               | Error `Write_error e ->
-                Logs.err (fun m -> m "%s: write error %a"
-                              url
-                              KV.pp_write_error e);
                 add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Write_error e);
                 Lwt.return_unit
               | Error `Swap e ->
-                Logs.err (fun m -> m "%s: swap error %a"
-                             url
-                             Swap.pp_error e);
                 add_failed url (Ptime.v (Pclock.now_d_ps ())) (`Swap e);
                 Lwt.return_unit
               | Ok (digests, body) ->
-- 
2.47.0