From 5f761b38fbf91971ba592465ed1ed29f4f30e6b1 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Thu, 20 Oct 2022 16:09:05 +0200 Subject: [PATCH] Upgrade opam-mirror with last release of git and new version of git-kv --- mirage/config.ml | 8 +- mirage/http_mirage_client.ml | 340 ---------------------------------- mirage/http_mirage_client.mli | 35 ---- mirage/unikernel.ml | 28 ++- 4 files changed, 18 insertions(+), 393 deletions(-) delete mode 100644 mirage/http_mirage_client.ml delete mode 100644 mirage/http_mirage_client.mli diff --git a/mirage/config.ml b/mirage/config.ml index aae9e0b..20333b2 100644 --- a/mirage/config.ml +++ b/mirage/config.ml @@ -66,11 +66,11 @@ let mirror = Key.v parallel_downloads ; Key.v hook_url ; Key.v tls_authenticator ; Key.v port ; Key.v sectors_cache ; Key.v sectors_git ; ] ~packages:[ - package ~min:"0.2.0" ~sublibs:[ "mirage" ] "paf" ; + package ~min:"0.3.0" ~sublibs:[ "mirage" ] "paf" ; package "h2" ; package "httpaf" ; package ~pin:"git+https://git.robur.io/robur/git-kv.git#main" "git-kv" ; - package ~min:"3.7.0" "git-paf" ; + package ~min:"3.10.0" "git-paf" ; package "opam-file-format" ; package ~min:"2.1.0" ~sublibs:[ "gz" ] "tar" ; package ~pin:"git+https://github.com/hannesm/ocaml-tar.git#kv-rw-kv-5" "tar-mirage" ; @@ -86,11 +86,13 @@ let dns = generic_dns_client stack let tcp = tcpv4v6_of_stackv4v6 stack let http_client = + let packages = + [ package ~pin:"git+https://git.robur.io/robur/http-mirage-client.git#main" "http-mirage-client" ] in let connect _ modname = function | [ _time; _pclock; _tcpv4v6; ctx ] -> Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx | _ -> assert false in - impl ~connect "Http_mirage_client.Make" + impl ~packages ~connect "Http_mirage_client.Make" (time @-> pclock @-> tcpv4v6 @-> git_client @-> http_client) (* XXX(dinosaure): [git_client] seems bad but it becames from a long discussion when a "mimic" device seems not accepted by everyone. We can copy [git_happy_eyeballs] diff --git a/mirage/http_mirage_client.ml b/mirage/http_mirage_client.ml deleted file mode 100644 index f33093b..0000000 --- a/mirage/http_mirage_client.ml +++ /dev/null @@ -1,340 +0,0 @@ -let http_scheme = Mimic.make ~name:"http-scheme" -let http_port = Mimic.make ~name:"http-port" -let http_hostname = Mimic.make ~name:"http-hostname" -let tls_config = Mimic.make ~name:"tls-config" - -open Lwt.Infix - -module type S = sig - val connect : Mimic.ctx -> Mimic.ctx Lwt.t - val alpn_protocol : Mimic.flow -> string option - val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result -end - -module Make - (Time : Mirage_time.S) - (Pclock : Mirage_clock.PCLOCK) - (TCP : Tcpip.Tcp.S) - (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct - module TCP = struct - include TCP - type endpoint = Happy_eyeballs.t * string * int - type nonrec write_error = - [ `Write of write_error | `Connect of string | `Closed ] - let pp_write_error ppf = function - | `Connect err -> Fmt.string ppf err - | `Write err -> pp_write_error ppf err - | `Closed as err -> pp_write_error ppf err - - let write flow cs = - let open Lwt.Infix in - write flow cs >>= function - | Ok _ as v -> Lwt.return v - | Error err -> Lwt.return_error (`Write err) - - let writev flow css = - writev flow css >>= function - | Ok _ as v -> Lwt.return v - | Error err -> Lwt.return_error (`Write err) - - let connect (happy_eyeballs, hostname, port) = - Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function - | Error (`Msg err) -> Lwt.return_error (`Connect err) - | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow - end - - let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP) - - module TLS = struct - type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int - - include Tls_mirage.Make (TCP) - - let connect (happy_eyeballs, cfg, hostname, port) = - let peer_name = - Result.(to_option (bind (Domain_name.of_string hostname) Domain_name.host)) in - Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function - | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow - | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err)) - end - - let tls_edn, tls_protocol = - Mimic.register ~name:"tls" (module TLS) - - let connect ctx = - let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with - | "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port) - | _ -> Lwt.return_none in - let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = match http_scheme with - | "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port) - | _ -> Lwt.return_none in - let ctx = Mimic.fold tcp_edn - Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs - ; req http_scheme; req http_hostname; dft http_port 80 ] - ~k:k0 ctx in - Lwt.return (Mimic.fold tls_edn - Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs - ; req http_scheme; req http_hostname; dft http_port 443 - ; req tls_config ] - ~k:k1 ctx) - - let alpn_protocol flow = - let module M = (val (Mimic.repr tls_protocol)) in - match flow with - | M.T flow -> - ( match TLS.epoch flow with - | Ok { Tls.Core.alpn_protocol; _ } -> alpn_protocol - | Error _ -> None ) - | _ -> None - - let authenticator = - let module V = Ca_certs_nss.Make (Pclock) in - V.authenticator () -end - -module Version = Httpaf.Version -module Status = H2.Status -module Headers = H2.Headers - -type response = - { version : Version.t - ; status : Status.t - ; reason : string - ; headers : Headers.t } - -module HTTP_1_1 = struct - include Httpaf.Client_connection - let yield_reader _ = assert false - let next_read_operation t = - (next_read_operation t :> [ `Close | `Read | `Yield ]) -end - -let add_authentication ~add headers = function - | None -> headers - | Some (user, pass) -> - let data = Base64.encode_string (user ^ ":" ^ pass) in - add headers "authorization" ("Basic " ^ data) - -let prepare_http_1_1_headers headers host user_pass body_length = - let headers = Httpaf.Headers.of_list headers in - let add = Httpaf.Headers.add_unless_exists in - let headers = add headers "user-agent" ("http-mirage-client/%%VERSION%%") in - let headers = add headers "host" host in - let headers = add headers "connection" "close" in - let headers = match body_length with - | None -> headers - | Some v -> add headers "content-length" (string_of_int v) in - add_authentication ~add headers user_pass - -let single_http_1_1_request ?config flow user_pass host meth path headers body = - 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 - let finished, notify_finished = Lwt.wait () in - let wakeup = let w = ref false in - fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in - let response_handler response body = - let buf = Buffer.create 0x100 in - let rec on_eof () = - let response = - { version= response.Httpaf.Response.version - ; status = (response.Httpaf.Response.status :> H2.Status.t) - ; reason = response.Httpaf.Response.reason - ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in - wakeup (Ok (response, Some (Buffer.contents buf))) - and on_read ba ~off ~len = - Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ; - Httpaf.Body.schedule_read body ~on_read ~on_eof in - let on_eof () = - let response = - { version= response.Httpaf.Response.version - ; status = (response.Httpaf.Response.status :> H2.Status.t) - ; reason = response.Httpaf.Response.reason - ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in - wakeup (Ok (response, None)) in - Httpaf.Body.schedule_read body ~on_read ~on_eof in - let error_handler e = - let err = match e with - | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x)) - | `Invalid_response_body_length _ -> Error (`Msg ("Invalid response body length")) - | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in - wakeup err in - let request_body, conn = Httpaf.Client_connection.request ?config req ~error_handler - ~response_handler in - Lwt.async (fun () -> Paf.run (module HTTP_1_1) conn flow) ; - Option.iter (Httpaf.Body.write_string request_body) body ; - Httpaf.Body.close_writer request_body ; - finished - -let prepare_h2_headers headers host user_pass body_length = - let headers = H2.Headers.of_list headers in - let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in - let headers = add headers ":authority" host in - let headers = add headers "content-length" (string_of_int (Option.value ~default:0 body_length)) in - add_authentication ~add headers user_pass - -let single_h2_request ?config ~scheme flow user_pass host meth path headers body = - 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 - let finished, notify_finished = Lwt.wait () in - let wakeup = let w = ref false in - fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in - let response_handler response response_body = - let buf = Buffer.create 0x100 in - let rec on_eof () = - let response = - { version= { major= 2; minor= 0; } - ; status = response.H2.Response.status - ; reason = "" - ; headers= response.H2.Response.headers } in - wakeup (Ok (response, Some (Buffer.contents buf))) - and on_read ba ~off ~len = - Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ; - H2.Body.Reader.schedule_read response_body - ~on_read ~on_eof in - let on_eof () = - let response = - { version= { major= 2; minor= 0; } - ; status = response.H2.Response.status - ; reason = "" - ; headers= response.H2.Response.headers } in - wakeup (Ok (response, None)) in - H2.Body.Reader.schedule_read response_body - ~on_read ~on_eof in - let error_handler e = - let err = match e with - | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x)) - | `Invalid_response_body_length _ -> Error (`Msg "Invalid response body length") - | `Protocol_error (err, msg) -> - let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in - Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum err msg - | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in - wakeup err in - let conn = H2.Client_connection.create ?config ?push_handler:None - ~error_handler in - let request_body = H2.Client_connection.request conn req ~error_handler ~response_handler in - Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow) ; - Option.iter (H2.Body.Writer.write_string request_body) body ; - H2.Body.Writer.close request_body ; - finished >|= fun v -> - H2.Client_connection.shutdown conn ; - v - -let decode_uri ~ctx uri = - let ( >>= ) = Result.bind in - match String.split_on_char '/' uri with - | proto :: "" :: user_pass_host_port :: path -> - ( if String.equal proto "http:" - then Ok ("http", Mimic.add http_scheme "http" ctx) - else if String.equal proto "https:" - then Ok ("https", Mimic.add http_scheme "https" ctx) - else Error (`Msg "Couldn't decode user and password") ) >>= fun (scheme, ctx) -> - let decode_user_pass up = match String.split_on_char ':' up with - | [ user; pass; ] -> Ok (user, pass) - | _ -> Error (`Msg "Couldn't decode user and password") in - ( match String.split_on_char '@' user_pass_host_port with - | [ host_port ] -> Ok (None, host_port) - | [ user_pass; host_port ] -> - decode_user_pass user_pass >>= fun up -> - Ok (Some up, host_port) - | _ -> Error (`Msg "Couldn't decode URI") ) >>= fun (user_pass, host_port) -> - ( match String.split_on_char ':' host_port with - | [] -> Error (`Msg "Empty host & port") - | [ hostname ] -> Ok (hostname, Mimic.add http_hostname hostname ctx) - | hd :: tl -> - let port, hostname = match List.rev (hd :: tl) with - | hd :: tl -> hd, String.concat ":" (List.rev tl) - | _ -> assert false in - ( try Ok (hostname, Mimic.add http_hostname hostname (Mimic.add http_port (int_of_string port) ctx)) - with Failure _ -> Error (`Msg "Couldn't decode port") ) ) >>= fun (hostname, ctx) -> - Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path) - | _ -> Error (`Msg "Couldn't decode URI on top") - -let ( >>? ) = Lwt_result.bind - -let alpn_protocol_of_string = function - | "http/1.1" -> Some `HTTP_1_1 - | "h2" -> Some `H2 - | _ -> None - -let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri = - Lwt.return (decode_uri ~ctx uri) >>? fun (ctx, scheme, host, user_pass, path) -> - let ctx = match Lazy.force cfg with - | Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx - | Ok (`Default cfg) -> - ( match Result.bind (Domain_name.of_string host) Domain_name.host with - | Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx - | Error _ -> Mimic.add tls_config cfg ctx ) - | Error _ -> ctx in - Mimic.resolve ctx >>? fun flow -> - (match Option.bind (alpn_protocol flow) alpn_protocol_of_string, config with - | (Some `HTTP_1_1 | None), Some (`HTTP_1_1 config) -> - single_http_1_1_request ~config flow user_pass host meth path headers body - | (Some `HTTP_1_1 | None), None -> - single_http_1_1_request flow user_pass host meth path headers body - | (Some `H2 | None), Some (`H2 config) -> - single_h2_request ~config ~scheme flow user_pass host meth path headers body - | Some `H2, None -> - single_h2_request ~scheme flow user_pass host meth path headers body - | Some `H2, (Some (`HTTP_1_1 _)) -> - single_h2_request ~scheme flow user_pass host meth path headers body - | Some `HTTP_1_1, Some (`H2 _) -> - single_http_1_1_request flow user_pass host meth path headers body) >>= fun r -> - Mimic.close flow >|= fun () -> - r - -let tls_config ?tls_config ?config authenticator = - lazy ( match tls_config with - | Some cfg -> Ok (`Custom cfg) - | None -> - let alpn_protocols = match config with - | None -> [ "h2"; "http/1.1" ] - | Some (`H2 _) -> [ "h2" ] - | Some (`HTTP_1_1 _) -> [ "http/1.1" ] in - Result.map (fun authenticator -> `Default (Tls.Config.client ~alpn_protocols ~authenticator ())) authenticator ) - -let resolve_location ~uri ~location = - match String.split_on_char '/' location with - | "http:" :: "" :: _ -> Ok location - | "https:" :: "" :: _ -> Ok location - | "" :: "" :: _ -> - let schema = String.sub uri 0 (String.index uri '/') in - Ok (schema ^ location) - | "" :: _ -> - (match String.split_on_char '/' uri with - | schema :: "" :: user_pass_host_port :: _ -> - Ok (String.concat "/" [schema ; "" ; user_pass_host_port ^ location]) - | _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri))) - | _ -> Error (`Msg ("unknown location (relative path): " ^ location)) - -let one_request - ?config - ?tls_config:cfg - ~ctx - ~alpn_protocol - ~authenticator - ?(meth= `GET) - ?(headers= []) - ?body - ?(max_redirect= 5) - ?(follow_redirect= true) uri = - let tls_config = tls_config ?tls_config:cfg ?config authenticator in - if not follow_redirect - then single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri - else - let rec follow_redirect count uri = - if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded") - else - single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri - >>? fun (resp, body) -> - if Status.is_redirection resp.status then - ( match Headers.get resp.headers "location" with - | Some location -> - Lwt.return (resolve_location ~uri ~location) >>? fun uri -> - follow_redirect (pred count) uri - | None -> - Lwt.return_ok (resp, body) ) - else - Lwt.return_ok (resp, body) in - follow_redirect max_redirect uri diff --git a/mirage/http_mirage_client.mli b/mirage/http_mirage_client.mli deleted file mode 100644 index eaa7878..0000000 --- a/mirage/http_mirage_client.mli +++ /dev/null @@ -1,35 +0,0 @@ -module type S = sig - val connect : Mimic.ctx -> Mimic.ctx Lwt.t - val alpn_protocol : Mimic.flow -> string option - val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result -end - -module Make - (Time : Mirage_time.S) - (Pclock : Mirage_clock.PCLOCK) - (TCP : Tcpip.Tcp.S) - (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S - -module Version = Httpaf.Version -module Status = H2.Status -module Headers = H2.Headers - -type response = - { version : Version.t - ; status : Status.t - ; reason : string - ; headers : Headers.t } - -val one_request : - ?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] -> - ?tls_config:Tls.Config.client -> - ctx:Mimic.ctx -> - alpn_protocol:(Mimic.flow -> string option) -> - authenticator:(X509.Authenticator.t, [> `Msg of string ]) result -> - ?meth:Httpaf.Method.t -> - ?headers:(string * string) list -> - ?body:string -> - ?max_redirect:int -> - ?follow_redirect:bool -> - string -> - (response * string option, [> Mimic.error ]) result Lwt.t diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml index f5e4d00..69c15c4 100644 --- a/mirage/unikernel.ml +++ b/mirage/unikernel.ml @@ -13,6 +13,7 @@ module Make module Part = Mirage_block_partition.Make(BLOCK) module KV = Tar_mirage.Make_KV_RW(Part) module Cache = OneFFS.Make(Part) + module Store = Git_kv.Make (Pclock) module SM = Map.Make(String) module SSet = Set.Make(String) @@ -53,17 +54,17 @@ module Make module Git = struct let find_contents store = let rec go store path acc = - Git_kv.list store path >>= function + Store.list store path >>= function | Error e -> Logs.err (fun m -> m "error %a while listing %a" - Git_kv.pp_error e Mirage_kv.Key.pp path); + Store.pp_error e Mirage_kv.Key.pp path); Lwt.return acc | Ok steps -> Lwt_list.fold_left_s (fun acc (step, _) -> let full_path = Mirage_kv.Key.add path step in - Git_kv.exists store full_path >>= function + Store.exists store full_path >>= function | Error e -> - Logs.err (fun m -> m "error %a for exists %a" Git_kv.pp_error e + Logs.err (fun m -> m "error %a for exists %a" Store.pp_error e Mirage_kv.Key.pp full_path); Lwt.return acc | Ok None -> @@ -168,7 +169,7 @@ module Make List.filter (fun p -> Mirage_kv.Key.basename p = "opam") paths in Lwt_list.fold_left_s (fun acc path -> - Git_kv.get store path >|= function + Store.get store path >|= function | Ok data -> (* TODO report parser errors *) (try @@ -194,7 +195,7 @@ module Make with _ -> Logs.warn (fun m -> m "some error in %a, ignoring" Mirage_kv.Key.pp path); acc) - | Error e -> Logs.warn (fun m -> m "Git_kv.get: %a" Git_kv.pp_error e); acc) + | Error e -> Logs.warn (fun m -> m "Store.get: %a" Store.pp_error e); acc) SM.empty opam_paths end @@ -487,7 +488,7 @@ module Make in Git.find_contents store >>= fun paths -> Lwt_list.iter_s (fun path -> - Git_kv.get store path >|= function + Store.get store path >|= function | Ok data -> let data = if Mirage_kv.Key.(equal path (v "repo")) then repo else data @@ -505,7 +506,7 @@ module Make let o = ref false in let stream () = if !o then None else (o := true; Some data) in Tar_Gz.write_block ~level:Tar.Header.Ustar hdr gz_out stream - | Error e -> Logs.warn (fun m -> m "Git_kv error: %a" Git_kv.pp_error e)) + | Error e -> Logs.warn (fun m -> m "Store error: %a" Store.pp_error e)) paths >|= fun () -> Tar_Gz.write_end gz_out; Buffer.contents out_channel @@ -525,7 +526,7 @@ module Make Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT" weekday d m' y hh mm ss let commit_id git_kv = - Git_kv.digest git_kv Mirage_kv.Key.empty >|= fun r -> + Store.digest git_kv Mirage_kv.Key.empty >|= fun r -> Result.get_ok r let repo commit = @@ -538,7 +539,7 @@ stamp: %S |} upstream commit commit let modified git_kv = - Git_kv.last_modified git_kv Mirage_kv.Key.empty >|= fun r -> + Store.last_modified git_kv Mirage_kv.Key.empty >|= fun r -> let v = Result.fold ~ok:Fun.id ~error:(fun _ -> Pclock.now_d_ps ()) r in ptime_to_http_date (Ptime.v v) @@ -717,7 +718,7 @@ stamp: %S let bad_archives = SSet.of_list Bad.archives - let download_archives disk http_ctx store = + let download_archives disk http_client store = Git.find_urls store >>= fun urls -> let urls = SM.filter (fun k _ -> not (SSet.mem k bad_archives)) urls in let pool = Lwt_pool.create (Key_gen.parallel_downloads ()) (Fun.const Lwt.return_unit) in @@ -736,10 +737,7 @@ stamp: %S incr idx; if !idx mod 10 = 0 then Gc.full_major () ; Logs.info (fun m -> m "downloading %s" url); - Http_mirage_client.one_request - ~alpn_protocol:HTTP.alpn_protocol - ~authenticator:HTTP.authenticator - ~ctx:http_ctx url >>= function + Http_mirage_client.one_request http_client url >>= function | Ok (resp, Some str) -> if resp.status = `OK then begin Logs.info (fun m -> m "downloaded %s" url);