diff --git a/git-cohttp-mirage.opam b/git-cohttp-mirage.opam index 19181fa21..9e5d233d4 100644 --- a/git-cohttp-mirage.opam +++ b/git-cohttp-mirage.opam @@ -24,9 +24,10 @@ depends: [ ] pin-depends: [ - [ "conduit-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "conduit-mirage.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] - [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] - [ "cohttp-mirage.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-mirage.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] + [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] + [ "cohttp-mirage.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] ] diff --git a/git-cohttp-unix.opam b/git-cohttp-unix.opam index f1d9171a7..ee52befeb 100644 --- a/git-cohttp-unix.opam +++ b/git-cohttp-unix.opam @@ -24,10 +24,11 @@ depends: [ ] pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "conduit-lwt-tls.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] - [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] - [ "cohttp-lwt-unix.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-lwt-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] + [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] + [ "cohttp-lwt-unix.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] ] diff --git a/git-mirage.opam b/git-mirage.opam index 5f052ce87..174ba410e 100644 --- a/git-mirage.opam +++ b/git-mirage.opam @@ -23,8 +23,9 @@ depends: [ ] pin-depends: [ - [ "conduit-mirage.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#11dc50bf1ee6e3df831e76ebcc25a5c9f3abc280" ] - [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#11dc50bf1ee6e3df831e76ebcc25a5c9f3abc280" ] - [ "cohttp-mirage.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#11dc50bf1ee6e3df831e76ebcc25a5c9f3abc280" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-mirage.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] + [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] + [ "cohttp-mirage.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] ] diff --git a/git-unix.opam b/git-unix.opam index 651a89cd2..e9a73c3b8 100644 --- a/git-unix.opam +++ b/git-unix.opam @@ -43,6 +43,6 @@ depends: [ ] pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] ] diff --git a/git.opam b/git.opam index 7d4dde0de..2d558f78a 100644 --- a/git.opam +++ b/git.opam @@ -48,7 +48,7 @@ depends: [ "ocamlgraph" {>= "1.8.8"} "astring" "fpath" - "encore" + "encore" {>= "0.7"} "alcotest" {with-test & >= "1.1.0"} "alcotest-lwt" {with-test & >= "1.1.0"} "mirage-crypto-rng" {with-test & >= "0.8.0"} @@ -59,6 +59,5 @@ depends: [ ] pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "encore.dev" "git+https://github.com/mirage/encore.git#d376be363e0fb26c0c04d334931a4519a0c30878" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] ] diff --git a/nss.opam b/nss.opam index 775b9cf49..402d9fd58 100644 --- a/nss.opam +++ b/nss.opam @@ -47,6 +47,6 @@ depends: [ ] pin-depends: [ - [ "conduit.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] - [ "conduit-lwt.dev" "git+https://github.com/dinosaure/ocaml-conduit.git#056e94b57e6fc2a08b587e949a7c38d2f1b79e6a" ] + [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] + [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] ] diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index b4f72117b..5de505c63 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -2,7 +2,7 @@ (name smart) (public_name nss.smart) (modules smart filter capability state protocol encoder decoder) - (libraries stdlib-shims result rresult domain-name astring fmt)) + (libraries conduit stdlib-shims result rresult domain-name astring fmt)) (library (name sigs) @@ -26,12 +26,12 @@ (name nss) (public_name nss) (modules nss fetch push) - (libraries fmt result rresult logs domain-name smart sigs neg pck)) + (libraries conduit fmt result rresult logs domain-name smart sigs neg pck)) (library (name smart_git) (public_name nss.git) (modules smart_git) - (libraries decompress.de decompress.zl cstruct logs astring result rresult - bigstringaf fmt emile conduit lwt domain-name uri sigs smart pck nss - digestif carton carton-lwt)) + (libraries ipaddr decompress.de decompress.zl cstruct logs astring result + rresult bigstringaf fmt emile conduit lwt domain-name uri sigs smart pck + nss digestif carton carton-lwt)) diff --git a/src/not-so-smart/fetch.mli b/src/not-so-smart/fetch.mli index 69bbe6ed7..019c8c72f 100644 --- a/src/not-so-smart/fetch.mli +++ b/src/not-so-smart/fetch.mli @@ -17,7 +17,7 @@ module Make capabilities:Smart.Capability.t list -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> ?want:[ `All | `Some of Ref.t list | `None ] -> - host:[ `host ] Domain_name.t -> + host:Conduit.Endpoint.t -> string -> Flow.t -> (Uid.t, Uid.t * int ref * int64, 'g) store -> diff --git a/src/not-so-smart/protocol.ml b/src/not-so-smart/protocol.ml index 05984b102..5c939c87b 100644 --- a/src/not-so-smart/protocol.ml +++ b/src/not-so-smart/protocol.ml @@ -99,7 +99,7 @@ end module Proto_request = struct type t = { path : string; - host : [ `host ] Domain_name.t * int option; + host : Conduit.Endpoint.t * int option; version : int; request_command : [ `Upload_pack | `Receive_pack | `Upload_archive ]; } @@ -119,8 +119,8 @@ module Proto_request = struct | `Upload_archive -> Fmt.pf ppf "git-upload-archive" in let pp_host ppf = function - | host, Some port -> Fmt.pf ppf "%a:%d" Domain_name.pp host port - | host, None -> Fmt.pf ppf "%a" Domain_name.pp host + | host, Some port -> Fmt.pf ppf "%a:%d" Conduit.Endpoint.pp host port + | host, None -> Fmt.pf ppf "%a" Conduit.Endpoint.pp host in Fmt.pf ppf "%a %s %a %a" pp_request_command request_command path Fmt.(prefix (const string " host=") pp_host) @@ -745,10 +745,12 @@ module Encoder = struct in let write_host encoder = function | host, Some port -> - let host = Fmt.strf "host=%s:%d" (Domain_name.to_string host) port in + let host = + Fmt.strf "host=%s:%d" (Conduit.Endpoint.to_string host) port + in write encoder host | host, None -> - let host = Fmt.strf "host=%s" (Domain_name.to_string host) in + let host = Fmt.strf "host=%s" (Conduit.Endpoint.to_string host) in write encoder host in let k encoder = diff --git a/src/not-so-smart/protocol.mli b/src/not-so-smart/protocol.mli index cec91bc11..26957d138 100644 --- a/src/not-so-smart/protocol.mli +++ b/src/not-so-smart/protocol.mli @@ -46,10 +46,10 @@ module Proto_request : sig val pp : t Fmt.t val upload_pack : - host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t + host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t val receive_pack : - host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t + host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t end module Want : sig diff --git a/src/not-so-smart/push.mli b/src/not-so-smart/push.mli index 1ed70fb08..3d3c13bbb 100644 --- a/src/not-so-smart/push.mli +++ b/src/not-so-smart/push.mli @@ -14,7 +14,7 @@ module Make ?prelude:bool -> capabilities:Smart.Capability.t list -> [ `Create of Ref.t | `Delete of Ref.t | `Update of Ref.t * Ref.t ] list -> - host:[ `host ] Domain_name.t -> + host:Conduit.Endpoint.t -> string -> Flow.t -> (Uid.t, Uid.t Pck.t, 'git) store -> diff --git a/src/not-so-smart/smart.mli b/src/not-so-smart/smart.mli index 37a2910ca..f634aa23c 100644 --- a/src/not-so-smart/smart.mli +++ b/src/not-so-smart/smart.mli @@ -54,10 +54,10 @@ module Proto_request : sig val pp : t Fmt.t val upload_pack : - host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t + host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t val receive_pack : - host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t + host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t end module Want : sig diff --git a/src/not-so-smart/smart_git.ml b/src/not-so-smart/smart_git.ml index 2cbba761a..dd3523f71 100644 --- a/src/not-so-smart/smart_git.ml +++ b/src/not-so-smart/smart_git.ml @@ -63,19 +63,19 @@ type endpoint = { | `HTTP of (string * string) list | `HTTPS of (string * string) list ]; path : string; - domain_name : [ `host ] Domain_name.t; + endpoint : Conduit.Endpoint.t; } let pp_endpoint ppf edn = match edn with - | { scheme = `SSH user; path; domain_name } -> - Fmt.pf ppf "%s@%a:%s" user Domain_name.pp domain_name path - | { scheme = `Git; path; domain_name } -> - Fmt.pf ppf "git://%a/%s" Domain_name.pp domain_name path - | { scheme = `HTTP _; path; domain_name } -> - Fmt.pf ppf "http://%a/%s" Domain_name.pp domain_name path - | { scheme = `HTTPS _; path; domain_name } -> - Fmt.pf ppf "https://%a/%s" Domain_name.pp domain_name path + | { scheme = `SSH user; path; endpoint } -> + Fmt.pf ppf "%s@%a:%s" user Conduit.Endpoint.pp endpoint path + | { scheme = `Git; path; endpoint } -> + Fmt.pf ppf "git://%a/%s" Conduit.Endpoint.pp endpoint path + | { scheme = `HTTP _; path; endpoint } -> + Fmt.pf ppf "http://%a/%s" Conduit.Endpoint.pp endpoint path + | { scheme = `HTTPS _; path; endpoint } -> + Fmt.pf ppf "https://%a/%s" Conduit.Endpoint.pp endpoint path let endpoint_of_string str = let open Rresult in @@ -95,24 +95,33 @@ let endpoint_of_string str = m.Emile.local) in ( match fst m.Emile.domain with - | `Domain vs -> Domain_name.of_strings vs >>= Domain_name.host - | `Literal v -> Domain_name.of_string v >>= Domain_name.host - | `Addr _ -> R.error_msg "domain part must be a domain" ) - >>= fun domain_name -> R.ok { scheme = `SSH user; path; domain_name } + | `Domain vs -> + Domain_name.of_strings vs + >>= Domain_name.host + >>| Conduit.Endpoint.domain + | `Literal v -> + Domain_name.of_string v + >>= Domain_name.host + >>| Conduit.Endpoint.domain + | `Addr (Emile.IPv4 ipv4) -> R.ok (Conduit.Endpoint.ip (Ipaddr.V4 ipv4)) + | `Addr (Emile.IPv6 ipv6) -> R.ok (Conduit.Endpoint.ip (Ipaddr.V6 ipv6)) + | `Addr (Emile.Ext (ext, _)) -> + R.error_msgf "Git does not handle domain extension %s." ext ) + >>= fun endpoint -> R.ok { scheme = `SSH user; path; endpoint } | _ -> R.error_msg "invalid pattern" in let parse_uri x = let uri = Uri.of_string x in match Uri.scheme uri, Uri.host uri, Uri.path uri with - | Some "git", Some domain_name, path -> - Domain_name.of_string domain_name >>= Domain_name.host - >>= fun domain_name -> R.ok { scheme = `Git; path; domain_name } - | Some "http", Some domain_name, path -> - Domain_name.of_string domain_name >>= Domain_name.host - >>= fun domain_name -> R.ok { scheme = `HTTP []; path; domain_name } - | Some "https", Some domain_name, path -> - Domain_name.of_string domain_name >>= Domain_name.host - >>= fun domain_name -> R.ok { scheme = `HTTPS []; domain_name; path } + | Some "git", Some host, path -> + Conduit.Endpoint.of_string host >>= fun endpoint -> + R.ok { scheme = `Git; path; endpoint } + | Some "http", Some host, path -> + Conduit.Endpoint.of_string host >>= fun endpoint -> + R.ok { scheme = `HTTP []; path; endpoint } + | Some "https", Some host, path -> + Conduit.Endpoint.of_string host >>= fun endpoint -> + R.ok { scheme = `HTTPS []; path; endpoint } | _ -> R.error_msgf "invalid uri: %a" Uri.pp uri in match parse_ssh str, parse_uri str with @@ -321,13 +330,13 @@ struct module Push = Nss.Push.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref) let fetch_v1 ?prelude ~push_stdout ~push_stderr ~capabilities path ~resolvers - ?deepen ?want domain_name store access fetch_cfg pack = + ?deepen ?want endpoint store access fetch_cfg pack = let open Lwt.Infix in - Conduit.resolve resolvers domain_name >>? fun flow -> + Conduit.resolve resolvers endpoint >>? fun flow -> Lwt.try_bind (fun () -> Fetch.fetch_v1 ?prelude ~push_stdout ~push_stderr ~capabilities ?deepen - ?want ~host:domain_name path flow store access fetch_cfg + ?want ~host:endpoint path flow store access fetch_cfg (fun (payload, off, len) -> let v = String.sub payload off len in pack (Some (v, 0, len)))) @@ -377,7 +386,7 @@ struct module Fetch_http = Nss.Fetch.Make (Scheduler) (Lwt) (Flow_http) (Uid) (Ref) let http_fetch_v1 ~push_stdout ~push_stderr ~capabilities uri ?(headers = []) - domain_name path ~resolvers ?deepen ?want store access fetch_cfg pack = + endpoint path ~resolvers ?deepen ?want store access fetch_cfg pack = let open Rresult in let open Lwt.Infix in let uri0 = Fmt.strf "%a/info/refs?service=git-upload-pack" Uri.pp uri in @@ -398,7 +407,7 @@ struct } in Fetch_http.fetch_v1 ~prelude:false ~push_stdout ~push_stderr ~capabilities - ?deepen ?want ~host:domain_name path flow store access fetch_cfg + ?deepen ?want ~host:endpoint path flow store access fetch_cfg (fun (payload, off, len) -> let v = String.sub payload off len in pack (Some (v, 0, len))) @@ -418,7 +427,7 @@ struct ~idx = let open Rresult in let open Lwt.Infix in - let domain_name = edn.domain_name in + let endpoint = edn.endpoint in let path = edn.path in let stream, pusher = Lwt_stream.create () in let pusher = function @@ -439,7 +448,7 @@ struct let run () = Lwt.both (fetch_v1 ~push_stdout ~push_stderr ~prelude ~capabilities path - ~resolvers ?deepen ~want domain_name store access fetch_cfg + ~resolvers ?deepen ~want endpoint store access fetch_cfg pusher) (run ~light_load ~heavy_load stream t_pck t_idx ~src ~dst ~idx) >>= fun (refs, idx) -> @@ -458,18 +467,19 @@ struct match scheme with | `HTTP headers -> ( Uri.of_string - (Fmt.strf "http://%a%s.git" Domain_name.pp domain_name path), + (Fmt.strf "http://%a%s.git" Conduit.Endpoint.pp endpoint + path), headers ) | `HTTPS headers -> ( Uri.of_string - (Fmt.strf "https://%a%s.git" Domain_name.pp domain_name + (Fmt.strf "https://%a%s.git" Conduit.Endpoint.pp endpoint path), headers ) in let run () = Lwt.both (http_fetch_v1 ~push_stdout ~push_stderr ~capabilities uri - ~headers domain_name path ~resolvers ?deepen ~want store access + ~headers endpoint path ~resolvers ?deepen ~want store access fetch_cfg pusher) (run ~light_load ~heavy_load stream t_pck t_idx ~src ~dst ~idx) >>= fun (refs, idx) -> @@ -577,12 +587,12 @@ struct Lwt.async fiber; stream - let push ?prelude ~resolvers ~capabilities path cmds domain_name store access + let push ?prelude ~resolvers ~capabilities path cmds endpoint store access push_cfg pack = let open Lwt.Infix in - Conduit.resolve resolvers domain_name >>? fun flow -> - Push.push ?prelude ~capabilities cmds ~host:domain_name path flow store - access push_cfg pack + Conduit.resolve resolvers endpoint >>? fun flow -> + Push.push ?prelude ~capabilities cmds ~host:endpoint path flow store access + push_cfg pack >>= fun () -> Conduit.close flow let push ~resolvers (access, light_load, heavy_load) store edn @@ -591,12 +601,12 @@ struct match version, edn.scheme with | `V1, ((`Git | `SSH _) as scheme) -> let prelude = match scheme with `Git -> true | `SSH _ -> false in - let domain_name = edn.domain_name in + let endpoint = edn.endpoint in let path = edn.path in let push_cfg = Nss.Push.configuration () in let run () = - push ~prelude ~resolvers ~capabilities path cmds domain_name store - access push_cfg + push ~prelude ~resolvers ~capabilities path cmds endpoint store access + push_cfg (pack ~light_load ~heavy_load) in Lwt.catch run (function diff --git a/src/not-so-smart/smart_git.mli b/src/not-so-smart/smart_git.mli index 473b9b7ff..970009790 100644 --- a/src/not-so-smart/smart_git.mli +++ b/src/not-so-smart/smart_git.mli @@ -54,7 +54,7 @@ type endpoint = private { | `HTTP of (string * string) list | `HTTPS of (string * string) list ]; path : string; - domain_name : [ `host ] Domain_name.t; + endpoint : Conduit.Endpoint.t; } val pp_endpoint : endpoint Fmt.t diff --git a/test/smart/hTTP.ml b/test/smart/hTTP.ml index 40eb0a2fc..fbe649ff6 100644 --- a/test/smart/hTTP.ml +++ b/test/smart/hTTP.ml @@ -18,7 +18,7 @@ end (* XXX(dinosaure): just pass the given value and * inherits the totality axiom of [conduit]. *) -let localhost = Domain_name.(host_exn (of_string_exn "localhost")) +let localhost = Conduit.Endpoint.v "localhost" let protocol = Conduit_lwt.register ~protocol:(module None) module Protocol = struct include (val Conduit_lwt.repr protocol) end