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:
parent
24dda11659
commit
b26e23c462
3 changed files with 65 additions and 47 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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" ;
|
||||
|
|
|
|||
|
|
@ -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 () -> ()
|
||||
| Error e ->
|
||||
Logs.err (fun m -> m "error %a while removing %s"
|
||||
KV.pp_write_error e (key_to_string t name)) *)
|
||||
Lwt.return_unit
|
||||
end
|
||||
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 reading %s"
|
||||
KV.pp_error e name);
|
||||
Lwt.return_unit)
|
||||
entries >|= fun () ->
|
||||
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 >>= 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 ->
|
||||
|
|
|
|||
Loading…
Reference in a new issue