From 023fb4283d36dba12b4e04341d9af2e09ec2e0ec Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 7 Sep 2022 09:08:45 +0200 Subject: [PATCH] use tar and extend the block device --- mirage/config.ml | 9 +++++++-- mirage/http_mirage_client.ml | 7 +------ mirage/unikernel.ml | 15 ++++++++------- 3 files changed, 16 insertions(+), 15 deletions(-) diff --git a/mirage/config.ml b/mirage/config.ml index 31945a5..f3ffd35 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -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 ] diff --git a/mirage/http_mirage_client.ml b/mirage/http_mirage_client.ml index 07c6472..82f91a3 100644 --- a/mirage/http_mirage_client.ml +++ b/mirage/http_mirage_client.ml @@ -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 = diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index a1e4788..acc253a 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -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