robur/opam-mirror
4
0
Fork 0
Code Issues 6 Pull requests 2 Projects Releases Packages Wiki Activity Actions

remove key-hex, it is the default now

Browse source
This commit is contained in:
Hannes Mehnert 2022-09-22 13:20:11 +02:00
parent 7ec50fe588
commit 8dbd3ed663
2 changed files with 21 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
mirage/config.ml
View file

@ -3,14 +3,6 @@ open Mirage
type http_client = HTTP_client type http_client = HTTP_client
let http_client = typ HTTP_client let http_client = typ HTTP_client
let key_hex =
let doc =
Key.Arg.info
~doc:"File system keys should be stored as human-readable (hex) characters"
["key-hex"]
in
Key.(create "key-hex" Arg.(flag doc))
let check = let check =
let doc = let doc =
Key.Arg.info Key.Arg.info
@ -48,7 +40,7 @@ let tls_authenticator =
let mirror = let mirror =
foreign "Unikernel.Make" foreign "Unikernel.Make"
~keys:[ Key.v key_hex ; Key.v check ; Key.v remote ; Key.v hook_url ; Key.v tls_authenticator ; Key.v port ] ~keys:[ Key.v check ; Key.v remote ; Key.v hook_url ; Key.v tls_authenticator ; Key.v port ]
~packages:[ ~packages:[
package ~min:"0.1.0" ~sublibs:[ "mirage" ] "paf" ; package ~min:"0.1.0" ~sublibs:[ "mirage" ] "paf" ;
package "h2" ; package "h2" ;
@ -57,7 +49,7 @@ let mirror =
package ~min:"3.7.0" "git-paf" ; package ~min:"3.7.0" "git-paf" ;
package "opam-file-format" ; package "opam-file-format" ;
package ~min:"2.1.0" ~sublibs:[ "gz" ] "tar" ; package ~min:"2.1.0" ~sublibs:[ "gz" ] "tar" ;
package "tar-mirage" ; package ~pin:"git+https://github.com/hannesm/ocaml-tar.git#kv-rw" "tar-mirage" ;
] ]
(block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> http_client @-> job) (block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> http_client @-> job)
@ -92,19 +84,5 @@ let program_block_size =
let block = block_of_file "tar" let block = block_of_file "tar"
(*
let kv_rw =
let block = block_of_file "db" in
chamelon ~program_block_size block
*)
(* let kv_rw = direct_kv_rw "/tmp/mirror" *)
(*
let kv_ro =
let block = block_of_file "tar" in
archive block
*)
let () = register "mirror" let () = register "mirror"
[ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ http_client ] [ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ http_client ]

62
mirage/unikernel.ml
View file

@ -226,37 +226,24 @@ module Make
type t = { type t = {
mutable md5s : string SM.t ; mutable md5s : string SM.t ;
mutable sha512s : string SM.t ; mutable sha512s : string SM.t ;
key_hex : bool ;
dev : KV.t ; dev : KV.t ;
} }
let empty key_hex dev = { md5s = SM.empty ; sha512s = SM.empty ; key_hex ; dev } let empty dev = { md5s = SM.empty ; sha512s = SM.empty ; dev }
let key t d = let key t d =
let d = Cstruct.to_string d in let d = Cstruct.to_string d in
if t.key_hex then hex_to_string d else d hex_to_string d
let key_to_string t d = if t.key_hex then d else hex_to_string d
let key_of_string t v =
if t.key_hex then
Ok v
else
match hex_of_string v with
| Error `Msg msg ->
Logs.err (fun m -> m "error %s while decoding hex %s" msg v);
Error `Bad_request
| Ok bin -> Ok bin
(* on disk, we use a flat file system where the filename is the sha256 of the data *) (* 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 *) (* 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 *) (* 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) *) (* a write will compute the hashes and save the data (also validating potential other hashes) *)
let init ?(key_hex = false) dev = let init dev =
KV.list dev Mirage_kv.Key.empty >>= function 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 -> Logs.err (fun m -> m "error %a listing kv" KV.pp_error e); assert false
| Ok entries -> | Ok entries ->
let t = empty key_hex dev in let t = empty dev in
Lwt_list.iter_s (fun (name, typ) -> Lwt_list.iter_s (fun (name, typ) ->
match typ with match typ with
| `Dictionary -> | `Dictionary ->
@ -275,12 +262,11 @@ module Make
and sha512s = SM.add sha512 name t.sha512s and sha512s = SM.add sha512 name t.sha512s
in in
t.md5s <- md5s ; t.sha512s <- sha512s; t.md5s <- md5s ; t.sha512s <- sha512s;
Logs.info (fun m -> m "added %s" (key_to_string t name)); Logs.info (fun m -> m "added %s" name);
Lwt.return_unit Lwt.return_unit
end else begin end else begin
Logs.err (fun m -> m "corrupt data, expected %s, read %s (should remove)" Logs.err (fun m -> m "corrupt data, expected %s, read %s (should remove)"
(key_to_string t name) name (hex_to_string (Cstruct.to_string digest)));
(hex_to_string (Cstruct.to_string digest)));
(*KV.remove dev (Mirage_kv.Key.v name) >|= function (*KV.remove dev (Mirage_kv.Key.v name) >|= function
| Ok () -> () | Ok () -> ()
| Error e -> | Error e ->
@ -290,7 +276,7 @@ module Make
end end
| Error e -> | Error e ->
Logs.err (fun m -> m "error %a reading %s" Logs.err (fun m -> m "error %a reading %s"
KV.pp_error e (key_to_string t name)); KV.pp_error e name);
Lwt.return_unit) Lwt.return_unit)
entries >|= fun () -> entries >|= fun () ->
t t
@ -306,12 +292,12 @@ module Make
let v' = let v' =
match h with `MD5 -> md5 | `SHA256 -> sha256 | `SHA512 -> sha512 | _ -> assert false match h with `MD5 -> md5 | `SHA256 -> sha256 | `SHA512 -> sha512 | _ -> assert false
in in
let v = if t.key_hex then hex_to_string v else v in let v = hex_to_string v in
if String.equal v v' then if String.equal v v' then
true true
else begin else begin
Logs.err (fun m -> m "%s hash mismatch %s: expected %s, got %s" url Logs.err (fun m -> m "%s hash mismatch %s: expected %s, got %s" url
(hash_to_string h) (key_to_string t v) (key_to_string t v')); (hash_to_string h) v v');
false false
end) hm end) hm
then begin then begin
@ -319,17 +305,15 @@ module Make
| Ok () -> | Ok () ->
t.md5s <- SM.add md5 sha256 t.md5s; t.md5s <- SM.add md5 sha256 t.md5s;
t.sha512s <- SM.add sha512 sha256 t.sha512s; t.sha512s <- SM.add sha512 sha256 t.sha512s;
Logs.debug (fun m -> m "wrote %s (%d bytes)" (key_to_string t sha256) Logs.debug (fun m -> m "wrote %s (%d bytes)" sha256
(String.length data)) (String.length data))
| Error e -> | Error e ->
Logs.err (fun m -> m "error %a while writing %s (key %s)" Logs.err (fun m -> m "error %a while writing %s (key %s)"
KV.pp_write_error e url (key_to_string t sha256)) KV.pp_write_error e url sha256)
end else end else
Lwt.return_unit Lwt.return_unit
let find_key t h v = let find_key t h key =
let ( let* ) = Result.bind in
let* key = key_of_string t v in
match match
match h with match h with
| `MD5 -> SM.find_opt key t.md5s | `MD5 -> SM.find_opt key t.md5s
@ -348,13 +332,12 @@ module Make
| Ok Some `Value -> true | Ok Some `Value -> true
| Ok Some `Dictionary -> | Ok Some `Dictionary ->
Logs.err (fun m -> m "unexpected dictionary for %s %s" Logs.err (fun m -> m "unexpected dictionary for %s %s"
(hash_to_string h) (key_to_string t v)); (hash_to_string h) v);
false false
| Ok None -> false | Ok None -> false
| Error e -> | Error e ->
Logs.err (fun m -> m "exists %s %s returned %a" Logs.err (fun m -> m "exists %s %s returned %a"
(hash_to_string h) (key_to_string t v) (hash_to_string h) v KV.pp_error e);
KV.pp_error e);
false false
let read t h v = let read t h v =
@ -497,10 +480,7 @@ stamp: %S
Logs.err (fun m -> m "error %s while updating git" msg); Logs.err (fun m -> m "error %s while updating git" msg);
Lwt.return None Lwt.return None
| Ok (commit, msg) -> | Ok (commit, msg) ->
(* let l = Encore.to_lavoisier Git_commit.format in Logs.info (fun m -> m "git: %s" msg);
let bytes = Encore.Lavoisier.emit_string commit l in *)
let bytes = "foo" in
Logs.info (fun m -> m "git: %s (%d bytes)" msg (String.length bytes));
let commit_id = commit_id commit let commit_id = commit_id commit
and modified = modified commit and modified = modified commit
in in
@ -683,20 +663,16 @@ stamp: %S
let start block _time _pclock stack git_ctx http_ctx = let start block _time _pclock stack git_ctx http_ctx =
KV.connect block >>= fun kv -> KV.connect block >>= fun kv ->
let key_hex = Key_gen.key_hex () in Disk.init kv >>= fun disk ->
Disk.init ~key_hex kv >>= fun disk ->
if Key_gen.check () then Lwt.return_unit if Key_gen.check () then Lwt.return_unit
else else
Git.connect git_ctx >>= fun (store, upstream) -> Git.connect git_ctx >>= fun (store, upstream) ->
Git.pull store upstream >>= function Git.pull store upstream >>= function
| Error `Msg msg -> Lwt.fail_with msg | Error `Msg msg -> Lwt.fail_with msg
| Ok (commit, msg) -> | Ok (commit, msg) ->
(* let l = Encore.to_lavoisier Git_commit.format in Logs.info (fun m -> m "git: %s" msg);
let bytes = Encore.Lavoisier.emit_string commit l in *)
let bytes = "foo" in
Logs.info (fun m -> m "git: %s (%d bytes)" msg (String.length bytes));
Serve.create commit store >>= fun serve -> Serve.create commit store >>= fun serve ->
Paf.init ~port:(Key_gen.port ()) (Stack.tcp stack) >>= fun t -> Paf.init ~port:(Key_gen.port ()) (S1tack.tcp stack) >>= fun t ->
let update store = download_archives disk http_ctx store in let update store = download_archives disk http_ctx store in
let service = let service =
Paf.http_service Paf.http_service