Merge pull request #459 from mirage/improve-mirage-and-mimic

Improve the way to play with mimic/endpoint and mirage/functoria

src/git-mirage/dune

@@ -18,9 +18,3 @@
  (public_name git-mirage.dns)
  (libraries mimic git.nss.git domain-name lwt ipaddr mirage-random
    mirage-time mirage-clock mirage-protocols mirage-stack dns-client.mirage))
-
-(library
- (name git_mirage)
- (modules git_mirage)
- (public_name git-mirage)
- (libraries mimic git.nss.git ipaddr mirage-stack mirage-protocols lwt))

src/git-mirage/git_mirage_dns.ml

@@ -3,35 +3,29 @@ module Make
     (Mclock : Mirage_clock.MCLOCK)
     (Time : Mirage_time.S)
     (Stack : Mirage_stack.V4) (TCP : sig
-      val tcp_stack : Stack.t Mimic.value
       val tcp_ipaddr : Ipaddr.V4.t Mimic.value
     end) =
 struct
+  open Lwt.Infix
   include Dns_client_mirage.Make (Random) (Time) (Mclock) (Stack)
 
-  let dns_domain_name = Mimic.make ~name:"domain-name"
-  let with_domain_name v ctx = Mimic.add dns_domain_name v ctx
+  let dns = Mimic.make ~name:"dns"
 
-  let with_resolv ctx =
-    let open Lwt.Infix in
-    let k stack domain_name =
-      let dns = create stack in
-      gethostbyname dns domain_name >>= function
-      | Ok ipv4 -> Lwt.return_some ipv4
-      | _ -> Lwt.return_none
-    in
-    Mimic.(
-      fold TCP.tcp_ipaddr Fun.[ req TCP.tcp_stack; req dns_domain_name ] ~k ctx)
-
-  let ctx = with_resolv Mimic.empty
+  let with_dns ?size ?nameserver ?timeout stack ctx =
+    let v = create ?size ?nameserver ?timeout stack in
+    Mimic.add dns v ctx
 
-  let with_smart_git_endpoint edn ctx =
-    match Smart_git.Endpoint.of_string edn with
-    | Ok { Smart_git.Endpoint.host = `Domain host; _ } ->
-        with_domain_name host ctx
-    | Ok { Smart_git.Endpoint.host = `Addr (Ipaddr.V4 v); _ } ->
-        Mimic.add TCP.tcp_ipaddr v ctx
-    | Ok { Smart_git.Endpoint.host = `Addr (Ipaddr.V6 _); _ } ->
-        assert false (* TODO *)
-    | _ -> ctx
+  let ctx =
+    let k dns hostname =
+      match dns, hostname with
+      | _, `Addr (Ipaddr.V4 ipv4) -> Lwt.return_some ipv4
+      | _, `Addr (Ipaddr.V6 _) -> Lwt.return_none (* TODO *)
+      | None, `Domain _ -> Lwt.return_none
+      | Some dns, `Domain domain_name -> (
+          gethostbyname dns domain_name >>= function
+          | Ok ipv4 -> Lwt.return_some ipv4
+          | _ -> Lwt.return_none)
+    in
+    let open Mimic in
+    fold TCP.tcp_ipaddr Fun.[ opt dns; req Smart_git.git_host ] ~k Mimic.empty
 end

src/git-mirage/git_mirage_dns.mli

@@ -3,12 +3,15 @@ module Make
     (Mclock : Mirage_clock.MCLOCK)
     (Time : Mirage_time.S)
     (Stack : Mirage_stack.V4) (TCP : sig
-      val tcp_stack : Stack.t Mimic.value
       val tcp_ipaddr : Ipaddr.V4.t Mimic.value
     end) : sig
-  val dns_domain_name : [ `host ] Domain_name.t Mimic.value
-  val with_domain_name : [ `host ] Domain_name.t -> Mimic.ctx -> Mimic.ctx
-  val with_resolv : Mimic.ctx -> Mimic.ctx
+  val with_dns :
+    ?size:int ->
+    ?nameserver:[ `TCP | `UDP ] * (Ipaddr.V4.t * int) ->
+    ?timeout:int64 ->
+    Stack.t ->
+    Mimic.ctx ->
+    Mimic.ctx
+
   val ctx : Mimic.ctx
-  val with_smart_git_endpoint : string -> Mimic.ctx -> Mimic.ctx
 end

src/git-mirage/git_mirage_ssh.ml

@@ -16,7 +16,6 @@ module Make
       val tcp_endpoint : (Stack.t * Ipaddr.V4.t * int) Mimic.value
       val tcp_stack : Stack.t Mimic.value
       val tcp_ipaddr : Ipaddr.V4.t Mimic.value
-      val tcp_port : int Mimic.value
     end)
     (Mclock : Mirage_clock.MCLOCK) =
 struct
@@ -68,9 +67,7 @@ struct
     Mimic.register ~name:"mirage-ssh" (module SSH)
 
   let ssh_authenticator = Mimic.make ~name:"ssh-authenticator"
-  let ssh_user = Mimic.make ~name:"ssh-user"
   let ssh_key = Mimic.make ~name:"ssh-key"
-  let with_user v ctx = Mimic.add ssh_user v ctx
 
   let with_authenticator v ctx =
     match Awa.Keys.authenticator_of_string v with
@@ -85,8 +82,8 @@ struct
     let v = Awa.Keys.of_seed `Ed25519 v in
     Mimic.add ssh_key v ctx
 
-  let with_resolv ctx =
-    let k scheme (stack, ipaddr, port) ssh_authenticator ssh_user ssh_key
+  let ctx =
+    let k0 scheme (stack, ipaddr, port) ssh_authenticator ssh_user ssh_key
         git_path git_capabilities =
       match scheme with
       | `SSH ->
@@ -103,36 +100,24 @@ struct
             }
       | _ -> Lwt.return_none
     in
-    let ctx =
-      Mimic.(
-        fold ssh_endpoint
-          Fun.
-            [
-              req Smart_git.git_scheme; req TCP.tcp_endpoint;
-              opt ssh_authenticator; req ssh_user; req ssh_key;
-              req Smart_git.git_path; req Smart_git.git_capabilities;
-            ]
-          ~k ctx)
-    in
-    let k scheme stack ipaddr port = k scheme (stack, ipaddr, port) in
-    let ctx =
-      Mimic.(
-        fold ssh_endpoint
-          Fun.
-            [
-              req Smart_git.git_scheme; req TCP.tcp_stack; req TCP.tcp_ipaddr;
-              dft TCP.tcp_port 22; opt ssh_authenticator; req ssh_user;
-              req ssh_key; req Smart_git.git_path;
-              req Smart_git.git_capabilities;
-            ]
-          ~k ctx)
-    in
-    ctx
-
-  let ctx = with_resolv Mimic.empty
-
-  let with_smart_git_endpoint edn ctx =
-    match Smart_git.Endpoint.of_string edn with
-    | Ok { Smart_git.Endpoint.scheme = `SSH user; _ } -> with_user user ctx
-    | _ -> ctx
+    let k1 scheme stack ipaddr port = k0 scheme (stack, ipaddr, port) in
+    let open Mimic in
+    Mimic.empty
+    |> fold ssh_endpoint
+         Fun.
+           [
+             req Smart_git.git_scheme; req TCP.tcp_endpoint;
+             opt ssh_authenticator; req Smart_git.git_ssh_user; req ssh_key;
+             req Smart_git.git_path; req Smart_git.git_capabilities;
+           ]
+         ~k:k0
+    |> fold ssh_endpoint
+         Fun.
+           [
+             req Smart_git.git_scheme; req TCP.tcp_stack; req TCP.tcp_ipaddr;
+             dft Smart_git.git_port 22; opt ssh_authenticator;
+             req Smart_git.git_ssh_user; req ssh_key; req Smart_git.git_path;
+             req Smart_git.git_capabilities;
+           ]
+         ~k:k1
 end

src/git-mirage/git_mirage_ssh.mli

@@ -14,7 +14,6 @@ module Make
       val tcp_endpoint : (Stack.t * Ipaddr.V4.t * int) Mimic.value
       val tcp_stack : Stack.t Mimic.value
       val tcp_ipaddr : Ipaddr.V4.t Mimic.value
-      val tcp_port : int Mimic.value
     end)
     (Mclock : Mirage_clock.MCLOCK) : sig
   type nonrec endpoint = Stack.t endpoint
@@ -23,13 +22,9 @@ module Make
   val ssh_endpoint : endpoint Mimic.value
   val ssh_protocol : (endpoint, flow) Mimic.protocol
   val ssh_authenticator : Awa.Keys.authenticator Mimic.value
-  val ssh_user : string Mimic.value
   val ssh_key : Awa.Hostkey.priv Mimic.value
-  val with_user : string -> Mimic.ctx -> Mimic.ctx
   val with_authenticator : string -> Mimic.ctx -> Mimic.ctx
   val with_rsa_key : string -> Mimic.ctx -> Mimic.ctx
   val with_ed25519_key : string -> Mimic.ctx -> Mimic.ctx
-  val with_resolv : Mimic.ctx -> Mimic.ctx
   val ctx : Mimic.ctx
-  val with_smart_git_endpoint : string -> Mimic.ctx -> Mimic.ctx
 end

src/git-mirage/git_mirage_tcp.ml

@@ -36,10 +36,34 @@ module Make (Stack : Mirage_stack.V4) = struct
     Mimic.register ~name:"mirage-tcpip" (module TCP)
 
   let tcp_ipaddr = Mimic.make ~name:"tcp-ipaddr"
-  let tcp_port = Mimic.make ~name:"tcp-port"
   let tcp_stack : Stack.t Mimic.value = Mimic.make ~name:"tcp-stack"
-  let with_port v ctx = Mimic.add tcp_port v ctx
-  let with_ipaddr v ctx = Mimic.add tcp_ipaddr v ctx
-  let with_stack v ctx = Mimic.add tcp_stack v ctx
-  let ctx = Mimic.empty
+  let with_stack stack ctx = Mimic.add tcp_stack stack ctx
+
+  let ctx =
+    let k_git scheme stack ipaddr port =
+      match scheme with
+      | `Git -> Lwt.return_some (stack, ipaddr, port)
+      | _ -> Lwt.return_none
+    in
+    let k_http scheme stack ipaddr port =
+      match scheme with
+      | `HTTP -> Lwt.return_some (stack, ipaddr, port)
+      | _ -> Lwt.return_none
+    in
+    let open Mimic in
+    Mimic.empty
+    |> fold tcp_endpoint
+         Fun.
+           [
+             req Smart_git.git_scheme; req tcp_stack; req tcp_ipaddr;
+             dft Smart_git.git_port 9418;
+           ]
+         ~k:k_git
+    |> fold tcp_endpoint
+         Fun.
+           [
+             req Smart_git.git_scheme; req tcp_stack; req tcp_ipaddr;
+             dft Smart_git.git_port 80;
+           ]
+         ~k:k_http
 end

src/git-mirage/git_mirage_tcp.mli

@@ -5,10 +5,7 @@ module Make (Stack : Mirage_stack.V4) : sig
     (Stack.t * Ipaddr.V4.t * int, Stack.TCPV4.flow) Mimic.protocol
 
   val tcp_ipaddr : Ipaddr.V4.t Mimic.value
-  val tcp_port : int Mimic.value
   val tcp_stack : Stack.t Mimic.value
-  val with_port : int -> Mimic.ctx -> Mimic.ctx
-  val with_ipaddr : Ipaddr.V4.t -> Mimic.ctx -> Mimic.ctx
   val with_stack : Stack.t -> Mimic.ctx -> Mimic.ctx
   val ctx : Mimic.ctx
 end

src/git-unix/ogit-fetch/main.ml

@@ -180,7 +180,7 @@ let of_smart_git_endpoint edn ctx =
     | `Addr v -> Mimic.add ipaddr v ctx
   in
   match edn with
-  | { Smart_git.Endpoint.scheme = `SSH v_user; path = v_path; host } ->
+  | { Smart_git.Endpoint.scheme = `SSH v_user; path = v_path; host; _ } ->
       ctx |> add_host host |> Mimic.add path v_path |> Mimic.add user v_user
   | { Smart_git.Endpoint.path = v_path; host; _ } ->
       ctx |> add_host host |> Mimic.add path v_path