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

use tar and extend the block device

Browse source
This commit is contained in:
Hannes Mehnert 2022-09-07 09:08:45 +02:00
parent 640451bfaa
commit 023fb4283d
3 changed files with 16 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
mirage/config.ml
View file

@ -57,8 +57,9 @@ let mirror =
package ~min:"3.7.0" "git-paf" ;
package "opam-file-format" ;
package ~min:"2.1.0" ~sublibs:[ "gz" ] "tar" ;
package "tar-mirage" ;
]
(kv_ro @-> time @-> pclock @-> stackv4v6 @-> git_client @-> http_client @-> job)
(block @-> time @-> pclock @-> stackv4v6 @-> git_client @-> http_client @-> job)
let stack = generic_stackv4v6 default_network
@ -89,6 +90,8 @@ let program_block_size =
let doc = Key.Arg.info [ "program-block-size" ] in
Key.(create "program_block_size" Arg.(opt int 16 doc))
let block = block_of_file "tar"
(*
let kv_rw =
let block = block_of_file "db" in
@ -97,9 +100,11 @@ let kv_rw =
(* let kv_rw = direct_kv_rw "/tmp/mirror" *)
(*
let kv_ro =
let block = block_of_file "tar" in
archive block
*)
let () = register "mirror"
[ mirror $ kv_ro $ default_time $ default_posix_clock $ stack $ git_client $ http_client ]
[ mirror $ block $ default_time $ default_posix_clock $ stack $ git_client $ http_client ]

7
mirage/http_mirage_client.ml
View file

@ -129,7 +129,6 @@ let prepare_http_1_1_headers headers host user_pass body_length =
add_authentication ~add headers user_pass
let single_http_1_1_request ~sleep ?config flow user_pass host meth path headers body =
Logs.info (fun m -> m "http 1.1 request %s path %s" host path);
let body_length = Option.map String.length body in
let headers = prepare_http_1_1_headers headers host user_pass body_length in
let req = Httpaf.Request.create ~headers meth path in
@ -167,9 +166,7 @@ let single_http_1_1_request ~sleep ?config flow user_pass host meth path headers
Lwt.async (fun () -> Paf.run (module HTTP_1_1) ~sleep conn flow) ;
Option.iter (Httpaf.Body.write_string request_body) body ;
Httpaf.Body.close_writer request_body ;
finished >|= fun r ->
Logs.info (fun m -> m "http 1.1 request %s path %s finished" host path);
r
finished
let prepare_h2_headers headers host user_pass body_length =
let headers = H2.Headers.of_list headers in
@ -179,7 +176,6 @@ let prepare_h2_headers headers host user_pass body_length =
add_authentication ~add headers user_pass
let single_h2_request ~sleep ?config ~scheme flow user_pass host meth path headers body =
Logs.info (fun m -> m "http2 request %s path %s" host path);
let body_length = Option.map String.length body in
let headers = prepare_h2_headers headers host user_pass body_length in
let req = H2.Request.create ~scheme ~headers meth path in
@ -225,7 +221,6 @@ let single_h2_request ~sleep ?config ~scheme flow user_pass host meth path heade
H2.Body.Writer.close request_body ;
finished >|= fun v ->
H2.Client_connection.shutdown conn ;
Logs.info (fun m -> m "http2 request %s path %s finished" host path);
v
let decode_uri ~ctx uri =

15
mirage/unikernel.ml
View file

@ -3,13 +3,15 @@ open Lwt.Infix
let argument_error = 64
module Make
(KV : Mirage_kv.RO)
(BLOCK : Mirage_block.S)
(Time : Mirage_time.S)
(Pclock : Mirage_clock.PCLOCK)
(Stack : Tcpip.Stack.V4V6)
(_ : sig end)
(HTTP : Http_mirage_client.S) = struct
module KV = Tar_mirage.Make_KV_RW(BLOCK)
module Store = Irmin_mirage_git.Mem.KV.Make(Irmin.Contents.String)
module Sync = Irmin.Sync.Make(Store)
@ -311,9 +313,7 @@ module Make
false
end) hm
then begin
Logs.warn (fun m -> m "should set %s" (key_to_string t sha256));
Lwt.return_unit
(* KV.set t.dev (Mirage_kv.Key.v sha256) data >|= function
KV.set t.dev (Mirage_kv.Key.v sha256) data >|= function
| Ok () ->
t.md5s <- SM.add md5 sha256 t.md5s;
t.sha512s <- SM.add sha512 sha256 t.sha512s;
@ -321,7 +321,7 @@ module Make
(String.length data))
| Error e ->
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 (key_to_string t sha256))
end else
Lwt.return_unit
@ -656,7 +656,7 @@ stamp: %S
Logs.debug (fun m -> m "ignoring %s (already present)" url);
Lwt.return_unit
| false ->
Logs.debug (fun m -> m "downloading %s" url);
Logs.info (fun m -> m "downloading %s" url);
Http_mirage_client.one_request
~alpn_protocol:HTTP.alpn_protocol
~authenticator:HTTP.authenticator
@ -676,7 +676,8 @@ stamp: %S
module Paf = Paf_mirage.Make(Time)(Stack.TCP)
let start kv _time _pclock stack git_ctx http_ctx =
let start block _time _pclock stack git_ctx http_ctx =
KV.connect block >>= fun kv ->
let key_hex = Key_gen.key_hex () in
Disk.init ~key_hex kv >>= fun disk ->
if Key_gen.check () then Lwt.return_unit