diff --git a/README.md b/README.md index 3c0e7bc..5a7dd53 100644 --- a/README.md +++ b/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 -validated. +checksums are stored. diff --git a/mirage/config.ml b/mirage/config.ml index 7d18f2f..3f5180f 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -5,12 +5,16 @@ let http_client = typ HTTP_client let check = let doc = - Key.Arg.info - ~doc:"Only check the cache" - ["check"] + Key.Arg.info ~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" ; diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index d1a736b..1e95885 100644 --- a/mirage/unikernel.ml +++ b/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 *) - (* the read can be md5/sha256/sha512 sum, and will output the data requested *) - (* a write will compute the hashes and save the data (also validating potential other hashes) *) - let init dev dev_md5s dev_sha512s = + let init ~verify dev dev_md5s dev_sha512s = + Logs.info (fun m -> m "init with verify %B" verify); 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) -> - if idx mod 10 = 0 then Gc.full_major () ; + let idx = ref 1 in + 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 - | Ok data -> - let cs = Cstruct.of_string data in - let digest = Mirage_crypto.Hash.digest `SHA256 cs in - if String.equal name (key t digest) then begin - if not (SSet.mem name md5s) then begin - let md5 = Mirage_crypto.Hash.digest `MD5 cs |> key t in - let md5s = SM.add md5 name t.md5s in - 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 () -> () + let ( >|?= ) x f = Lwt_result.iter (fun v -> Lwt.return (f v)) x in + let _data = ref None in + let read_data () = + match !_data with + | Some cs -> Lwt.return (Ok cs) + | None -> + incr idx; + KV.get dev (Mirage_kv.Key.v name) >|= function | Error e -> - Logs.err (fun m -> m "error %a while removing %s" - KV.pp_write_error e (key_to_string t name)) *) + Logs.err (fun m -> m "error %a reading %s" + 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 - | Error e -> - Logs.err (fun m -> m "error %a reading %s" - KV.pp_error e name); - Lwt.return_unit) - entries >|= fun () -> + end >>= fun () -> + begin + if not (SSet.mem name md5s) then begin + read_data () >|?= fun cs -> + let md5 = Mirage_crypto.Hash.digest `MD5 cs |> key t in + 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 -> - if Key_gen.check () then Lwt.return_unit + Disk.init ~verify:(Key_gen.verify ()) kv md5s sha512s >>= fun disk -> + 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 ->