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

by default, do not compute hashes unless requested or required
This commit is contained in:
Hannes Mehnert 2022-09-26 21:49:47 +02:00
parent 24dda11659
commit b26e23c462
3 changed files with 65 additions and 47 deletions

View file

@ -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.

View file

@ -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" ;

View file

@ -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 ->