Merge pull request 'Upgrade opam-mirror with last release of git and new version of git-kv' (#23) from upgrade into main
Reviewed-on: https://git.robur.io/robur/opam-mirror/pulls/23
This commit is contained in:
commit
0e048549a1
4 changed files with 25 additions and 399 deletions
|
|
@ -66,14 +66,15 @@ 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 "hex" ;
|
||||
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" ;
|
||||
package ~min:"2.2.0" ~sublibs:[ "gz" ] "tar" ;
|
||||
package ~min:"2.2.0" "tar-mirage" ;
|
||||
package "mirage-block-partition" ;
|
||||
package "oneffs" ;
|
||||
]
|
||||
|
|
@ -86,12 +87,14 @@ 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 ] ->
|
||||
| [ _pclock; _tcpv4v6; ctx ] ->
|
||||
Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx
|
||||
| _ -> assert false in
|
||||
impl ~connect "Http_mirage_client.Make"
|
||||
(time @-> pclock @-> tcpv4v6 @-> git_client @-> http_client)
|
||||
impl ~packages ~connect "Http_mirage_client.Make"
|
||||
(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]
|
||||
and provide an [http_client] instead of a [git_client] but that mostly means that
|
||||
|
|
@ -102,7 +105,7 @@ let git_client, http_client =
|
|||
let happy_eyeballs = git_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) in
|
||||
merge_git_clients (git_tcp tcp happy_eyeballs)
|
||||
(git_http ~authenticator:tls_authenticator tcp happy_eyeballs),
|
||||
http_client $ default_time $ default_posix_clock $ tcp $ happy_eyeballs
|
||||
http_client $ default_posix_clock $ tcp $ happy_eyeballs
|
||||
|
||||
let program_block_size =
|
||||
let doc = Key.Arg.info [ "program-block-size" ] in
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -11,8 +11,9 @@ module Make
|
|||
(HTTP : Http_mirage_client.S) = struct
|
||||
|
||||
module Part = Mirage_block_partition.Make(BLOCK)
|
||||
module KV = Tar_mirage.Make_KV_RW(Part)
|
||||
module KV = Tar_mirage.Make_KV_RW(Pclock)(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);
|
||||
|
|
|
|||
Loading…
Reference in a new issue