add --verify to force verification of the on-disk data

by default, do not compute hashes unless requested or required

README.md

@@ -3,5 +3,4 @@
 This unikernel periodically (at startup, on request, every hour) updates the
 provided opam-repository and downloads all referenced archives. It acts as
 an opam-repository including archive mirror. Only archives with appropriate
-checksums are stored. On startup, all data present on the block device is
+checksums are stored.
-validated.

mirage/config.ml

@@ -5,12 +5,16 @@ let http_client = typ HTTP_client
 
 let check =
   let doc =
-    Key.Arg.info
+    Key.Arg.info ~doc:"Only check the cache" ["check"]
-      ~doc:"Only check the cache"
-      ["check"]
   in
   Key.(create "check" Arg.(flag doc))
 
+let verify =
+  let doc =
+    Key.Arg.info ~doc:"Verify the cache contents" ["verify"]
+  in
+  Key.(create "verify" Arg.(flag doc))
+
 let remote =
   let doc =
     Key.Arg.info
@@ -53,7 +57,7 @@ let sectors_cache =
 
 let mirror =
   foreign "Unikernel.Make"
-    ~keys:[ Key.v check ; Key.v remote ; Key.v parallel_downloads ; Key.v hook_url ; Key.v tls_authenticator ; Key.v port ; Key.v sectors_cache ]
+    ~keys:[ Key.v check ; Key.v verify ; Key.v remote ; Key.v parallel_downloads ; Key.v hook_url ; Key.v tls_authenticator ; Key.v port ; Key.v sectors_cache ]
     ~packages:[
       package ~min:"0.1.0" ~sublibs:[ "mirage" ] "paf" ;
       package "h2" ;

mirage/unikernel.ml

@@ -235,12 +235,9 @@ module Make
         Logs.warn (fun m -> m "Failed to write 'sha512s': %a" Cache.pp_write_error e);
         Lwt.return_unit
 
-
     (* on disk, we use a flat file system where the filename is the sha256 of the data *)
-    (* on startup, we read + validate all data, and also store in the overlays (md5/sha512) the pointers *)
+    let init ~verify dev dev_md5s dev_sha512s =
-    (* the read can be md5/sha256/sha512 sum, and will output the data requested *)
+      Logs.info (fun m -> m "init with verify %B" verify);
-    (* a write will compute the hashes and save the data (also validating potential other hashes) *)
-    let init dev dev_md5s dev_sha512s =
       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 ->
@@ -249,53 +246,70 @@ module Make
         (match r with
          | Ok Some s -> Result.iter (fun md5s -> t.md5s <- md5s) (unmarshal_sm s)
          | Ok None -> Logs.debug (fun m -> m "No md5s cached")
-         | Error e -> Logs.debug (fun m -> m "Error reading md5s cache: %a" Cache.pp_error e));
+         | 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 -> Result.iter (fun sha512s -> t.sha512s <- sha512s) (unmarshal_sm s)
          | Ok None -> Logs.debug (fun m -> m "No sha512s cached")
-         | Error e -> Logs.debug (fun m -> m "Error reading sha512s cache: %a" Cache.pp_error e));
+         | 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
-        Lwt_list.iteri_s (fun idx (name, typ) ->
+        let idx = ref 1 in
-            if idx mod 10 = 0 then Gc.full_major () ;
+        Lwt_list.iter_s (fun (name, typ) ->
+            if !idx mod 10 = 0 then Gc.full_major () ;
             match typ with
             | `Dictionary ->
               Logs.warn (fun m -> m "unexpected dictionary at %s" name);
               Lwt.return_unit
             | `Value ->
-              KV.get dev (Mirage_kv.Key.v name) >>= function
+              let ( >|?= ) x f = Lwt_result.iter (fun v -> Lwt.return (f v)) x in
-              | Ok data ->
+              let _data = ref None in
-                let cs = Cstruct.of_string data in
+              let read_data () =
-                let digest = Mirage_crypto.Hash.digest `SHA256 cs in
+                match !_data with
-                if String.equal name (key t digest) then begin
+                | Some cs -> Lwt.return (Ok cs)
-                  if not (SSet.mem name md5s) then begin
+                | None ->
-                    let md5 = Mirage_crypto.Hash.digest `MD5 cs |> key t in
+                  incr idx;
-                    let md5s = SM.add md5 name t.md5s in
+                  KV.get dev (Mirage_kv.Key.v name) >|= function
-                    t.md5s <- md5s
-                  end;
-                  if not (SSet.mem name sha512s) then begin
-                    let sha512 = Mirage_crypto.Hash.digest `SHA512 cs |> key t in
-                    let sha512s = SM.add sha512 name t.sha512s in
-                    t.sha512s <- sha512s
-                  end;
-                  Logs.debug (fun m -> m "added %s" name);
-                  Lwt.return_unit
-                end else begin
-                  Logs.err (fun m -> m "corrupt data, expected %s, read %s (should remove)"
-                               name (hex_to_string (Cstruct.to_string digest)));
-                  (*KV.remove dev (Mirage_kv.Key.v name) >|= function
-                  | Ok () -> ()
                   | Error e ->
-                    Logs.err (fun m -> m "error %a while removing %s"
+                    Logs.err (fun m -> m "error %a reading %s"
-                                 KV.pp_write_error e (key_to_string t name)) *)
+                                 KV.pp_error e name);
+                    Error ()
+                  | Ok data ->
+                    let cs = Cstruct.of_string data in
+                    _data := Some cs;
+                    Ok cs
+              in
+              begin
+                if verify then begin
+                  read_data () >|?= fun cs ->
+                  let digest = Mirage_crypto.Hash.digest `SHA256 cs in
+                  if not (String.equal name (key t digest)) then
+                    Logs.err (fun m -> m "corrupt data, expected %s, read %s (should remove)"
+                                 name (hex_to_string (Cstruct.to_string digest)));
+                end else
                   Lwt.return_unit
-                end
+              end >>= fun () ->
-              | Error e ->
+              begin
-                Logs.err (fun m -> m "error %a reading %s"
+                if not (SSet.mem name md5s) then begin
-                             KV.pp_error e name);
+                  read_data () >|?= fun cs ->
-                Lwt.return_unit)
+                  let md5 = Mirage_crypto.Hash.digest `MD5 cs |> key t in
-          entries >|= fun () ->
+                  let md5s = SM.add md5 name t.md5s in
+                  t.md5s <- md5s
+                end else
+                  Lwt.return_unit
+              end >>= fun () ->
+              begin
+                if not (SSet.mem name sha512s) then begin
+                  read_data () >|?= fun cs ->
+                  let sha512 = Mirage_crypto.Hash.digest `SHA512 cs |> key t in
+                  let sha512s = SM.add sha512 name t.sha512s in
+                  t.sha512s <- sha512s
+                end else
+                  Lwt.return_unit
+              end >|= fun () ->
+              Logs.info (fun m -> m "added %s" name))
+          entries >>= fun () ->
+        update_caches t >|= fun () ->
         t
 
     let write t ~url data hm =
@@ -685,8 +699,9 @@ stamp: %S
     Cache.connect b2 >>= fun md5s ->
     Cache.connect b3 >>= fun sha512s ->
     Logs.info (fun m -> m "Available bytes in tar storage: %Ld" (KV.free kv));
-    Disk.init kv md5s sha512s >>= fun disk ->
+    Disk.init ~verify:(Key_gen.verify ()) kv md5s sha512s >>= fun disk ->
-    if Key_gen.check () then Lwt.return_unit
+    if Key_gen.check () then
+      Lwt.return_unit
     else
       Git_kv.connect git_ctx (Key_gen.remote ()) >>= fun git_kv ->
       Serve.commit_id git_kv >>= fun commit_id ->