add ssh client support

conduit-mirage.opam

@@ -24,6 +24,7 @@ depends: [
   "tls-mirage" {>= "0.11.0"}
   "ipaddr" {>= "3.0.0"}
   "ipaddr-sexp"
+  "awa-mirage"
 ]
 conflicts: [
   "mirage-conduit"

lib/conduit.ml

@@ -25,6 +25,7 @@ type endp = [
   | `Vchan_direct of int * string        (** domain id, port *)
   | `Vchan_domain_socket of string * string
   | `TLS of string * endp         (** wrap in a TLS channel, [hostname,endp] *)
+  | `SSH of Ipaddr_sexp.t * int * string option
   | `Unknown of string            (** failed resolution *)
 ] [@@deriving sexp]
 

lib/conduit.mli

@@ -55,6 +55,7 @@ type endp = [
   | `Vchan_direct of int * string  (** domain id, port *)
   | `Vchan_domain_socket of string * string (** Vchan Xen domain socket *)
   | `TLS of string * endp          (** Wrap in a TLS channel, [hostname,endp] *)
+  | `SSH of Ipaddr.t * int * string option
   | `Unknown of string             (** Failed resolution *)
 ] [@@deriving sexp]
 

lwt-unix/conduit_lwt_unix.ml

@@ -401,6 +401,7 @@ let endp_to_client ~ctx:_ (endp:Conduit.endp) : client Lwt.t =
                        host (Sexplib.Sexp.to_string_hum (Conduit.sexp_of_endp endp)))
     end
   | `Unknown err -> Lwt.fail_with ("resolution failed: " ^ err)
+  | _ -> assert false
 
 let endp_to_server ~ctx (endp:Conduit.endp) =
   match endp with
@@ -417,3 +418,4 @@ let endp_to_server ~ctx (endp:Conduit.endp) =
   | `Vchan_domain_socket _ as mode -> Lwt.return mode
   | `TLS (_host, _) -> Lwt.fail_with "TLS to non-TCP currently unsupported"
   | `Unknown err -> Lwt.fail_with ("resolution failed: " ^ err)
+  | _ -> assert false

mirage/conduit_mirage.ml

@@ -24,6 +24,7 @@ let (>|=) = Lwt.(>|=)
 let fail fmt = Fmt.kstrf (fun s -> Lwt.fail (Failure s)) fmt
 let err_tcp_not_supported = fail "%s: TCP is not supported"
 let err_tls_not_supported = fail "%s: TLS is not supported"
+let err_ssh_not_supported = fail "%s: SSH is not supported"
 let err_domain_sockets_not_supported =
   fail "%s: Unix domain sockets are not supported inside Unikernels"
 let err_vchan_not_supported = fail "%s: VCHAN is not supported"
@@ -97,8 +98,11 @@ let xs x = x
 type 'a tls_client = [ `TLS of Tls.Config.client * 'a ] [@@deriving sexp]
 type 'a tls_server = [ `TLS of Tls.Config.server * 'a ] [@@deriving sexp]
 
-type client = [ tcp_client | vchan_client | client tls_client ] [@@deriving sexp]
-type server = [ tcp_server | vchan_server | server tls_server ] [@@deriving sexp]
+type ssh_client = [ `SSH of Ipaddr_sexp.t * int * string * string ] [@@deriving sexp]
+type ssh_server = [ `SSH of unit ] [@@deriving sexp]
+
+type client = [ tcp_client | vchan_client | client tls_client | ssh_client ] [@@deriving sexp]
+type server = [ tcp_server | vchan_server | server tls_server | ssh_server  ] [@@deriving sexp]
 
 type tls_client' = client tls_client [@@deriving sexp]
 type tls_server' = server tls_server [@@deriving sexp]
@@ -113,10 +117,11 @@ let tcp_server _ p = Lwt.return (`TCP p)
 type t = {
   tcp  : (tcp_client  , tcp_server  ) handler option;
   tls  : (tls_client' , tls_server' ) handler option;
+  ssh  : (ssh_client  , ssh_server  ) handler option;
   vchan: (vchan_client, vchan_server) handler option;
 }
 
-let empty = { tcp = None; tls = None; vchan = None }
+let empty = { tcp = None; tls = None; ssh = None; vchan = None }
 
 let connect t (c:client) = match c with
   | `TCP _ as x ->
@@ -134,6 +139,11 @@ let connect t (c:client) = match c with
       | None -> err_tls_not_supported "connect"
       | Some (S ((module S), t)) -> S.connect t x
     end
+  | `SSH _ as x ->
+    begin match t.ssh with
+      | None -> err_ssh_not_supported "connect"
+      | Some (S ((module S), t)) -> S.connect t x
+    end
 
 let listen t (s:server) f = match s with
   | `TCP _ as x ->
@@ -151,6 +161,7 @@ let listen t (s:server) f = match s with
       | None -> err_tls_not_supported "listen"
       | Some (S ((module S), t)) -> S.listen t x f
     end
+  | `SSH _ -> err_ssh_not_supported "listen"
 
 (******************************************************************************)
 (*                         Implementation of handlers                         *)
@@ -253,6 +264,50 @@ let mk_vchan (module X: XS) (module V: VCHAN) t =
 
 let with_vchan t x y z = mk_vchan x y z >|= fun x -> { t with vchan = Some x }
 
+(* SSH *)
+
+module SSH (M : Mirage_clock.MCLOCK) = struct
+  module SSH = Awa_mirage.Make(Flow)(M)
+  let err_flow m e = fail "%s: %a" m SSH.pp_error e
+  type client = ssh_client [@@deriving sexp]
+  type server = ssh_server [@@deriving sexp]
+
+  type x = t
+  type t = x
+
+  let listen _ _ = assert false
+
+  let connect (t : t) (`SSH (ip, port, user, cfg) : client) =
+    match Astring.String.cuts ~sep:":" cfg with
+    | cmd :: seed :: rt ->
+      let key = Awa.Keys.of_seed seed
+      and req = Awa.Ssh.Exec cmd
+      and authenticator =
+        let data = Astring.String.concat ~sep:":" rt in
+        match Awa.Keys.authenticator_of_string data with
+        | Ok k -> k
+        | Error str -> invalid_arg ("hostkey " ^ str)
+      in
+      connect t (`TCP (ip, port)) >>= fun flow ->
+      (SSH.client_of_flow ~authenticator ~user key req flow >>= function
+        | Error e -> err_flow "connect" e
+        | Ok flow -> Lwt.return (Flow.create (module SSH) flow))
+    | _  -> Lwt.fail_with "invalid ssh configuration"
+end
+
+
+let mk_ssh (module M: Mirage_clock.MCLOCK) t =
+  let module SSH = SSH(M) in
+  S ((module SSH), t)
+
+let with_ssh t x = let x= mk_ssh x t in Lwt.return { t with ssh = Some x }
+
+let ssh_client ?config i p u =
+  match config, u with
+  | None, _ | _, None -> Lwt.fail_with "no ssh config"
+  | Some cfg, Some u ->
+    Lwt.return (`SSH (i, p, u, cfg))
+
 (* TLS *)
 
 let client_of_bytes _ =
@@ -262,7 +317,7 @@ let client_of_bytes _ =
 
 let server_of_bytes str = Tls.Config.server_of_sexp (Sexplib.Sexp.of_string str)
 
-let tls_client c x = Lwt.return (`TLS (client_of_bytes c, x))
+let tls_client ?config _host x = Lwt.return (`TLS (client_of_bytes config, x))
 let tls_server s x = Lwt.return (`TLS (server_of_bytes s, x))
 
 module TLS = struct
@@ -305,17 +360,19 @@ module type S = sig
   end
   val with_tcp: t -> 'a stackv4 -> 'a -> t Lwt.t
   val with_tls: t -> t Lwt.t
+  val with_ssh: t -> (module Mirage_clock.MCLOCK) -> t Lwt.t
   val with_vchan: t -> xs -> vchan -> string -> t Lwt.t
   val connect: t -> client -> Flow.flow Lwt.t
   val listen: t -> server -> callback -> unit Lwt.t
 end
 
-let rec client (e:Conduit.endp): client Lwt.t = match e with
+let rec client ?config (e:Conduit.endp): client Lwt.t = match e with
   | `TCP (x, y) -> tcp_client x y
   | `Unix_domain_socket _ -> err_domain_sockets_not_supported "client"
   | `Vchan_direct _
   | `Vchan_domain_socket _ as x -> vchan_client x
-  | `TLS (x, y) -> client y >>= fun c -> tls_client x c
+  | `TLS (x, y) -> client y >>= fun c -> tls_client ?config x c
+  | `SSH (x, y, z) -> ssh_client ?config x y z
   | `Unknown s -> err_unknown s
 
 let rec server (e:Conduit.endp): server Lwt.t = match e with
@@ -324,10 +381,10 @@ let rec server (e:Conduit.endp): server Lwt.t = match e with
   | `Vchan_direct _
   | `Vchan_domain_socket _ as x -> vchan_server x
   | `TLS (x, y) -> server y >>= fun s -> tls_server x s
+  | `SSH _ -> err_unknown "ssh server"
   | `Unknown s -> err_unknown s
 
 module Context (R: Mirage_random.S) (T : Mirage_time.S) (C: Mirage_clock.MCLOCK) (S: Mirage_stack.V4) = struct
-
   type t = Resolver_lwt.t * conduit
 
   module RES = Resolver_mirage.Make_with_stack(R)(T)(C)(S)
@@ -339,6 +396,7 @@ module Context (R: Mirage_random.S) (T : Mirage_time.S) (C: Mirage_clock.MCLOCK)
     let res = Resolver_lwt.init () in
     RES.R.register ~stack res;
     with_tcp conduit stackv4 stack >>= fun conduit ->
+    with_ssh conduit (module C : Mirage_clock.MCLOCK) >>= fun conduit ->
     if tls then
       with_tls conduit >|= fun conduit ->
       res, conduit

mirage/conduit_mirage.mli

@@ -79,18 +79,21 @@ type xs
 val vchan: (module VCHAN) -> vchan
 val xs: (module XS) -> xs
 
+type ssh_client = [ `SSH of Ipaddr_sexp.t * int * string * string ]
+type ssh_server = [ `SSH of unit ]
+
 (** {2 TLS} *)
 
 type 'a tls_client = [ `TLS of Tls.Config.client * 'a ]
 type 'a tls_server = [ `TLS of Tls.Config.server * 'a ]
 
-type client = [ tcp_client | vchan_client | client tls_client ] [@@deriving sexp]
+type client = [ tcp_client | vchan_client | client tls_client | ssh_client ] [@@deriving sexp]
 (** The type for client configuration values. *)
 
-type server = [ tcp_server | vchan_server | server tls_server ] [@@deriving sexp]
+type server = [ tcp_server | vchan_server | server tls_server | ssh_server ] [@@deriving sexp]
 (** The type for server configuration values. *)
 
-val client: Conduit.endp -> client Lwt.t
+val client: ?config:string -> Conduit.endp -> client Lwt.t
 (** Resolve a conduit endpoint into a client configuration. *)
 
 val server: Conduit.endp -> server Lwt.t
@@ -117,6 +120,9 @@ module type S = sig
   val with_tls: t -> t Lwt.t
   (** Extend a conduit with an implementation for TLS. *)
 
+  val with_ssh: t -> (module Mirage_clock.MCLOCK) -> t Lwt.t
+  (** Extend a conduit with an implementation for SSH. *)
+
   val with_vchan: t -> xs -> vchan -> string -> t Lwt.t
   (** Extend a conduit with an implementation for VCHAN. *)
 

mirage/dune

@@ -6,4 +6,4 @@
   (wrapped     false)
   (libraries   conduit conduit-lwt mirage-stack mirage-clock mirage-random
                mirage-flow mirage-flow-combinators dns-client.mirage ipaddr-sexp
-               vchan tls tls-mirage xenstore.client uri.services))
+               vchan tls tls-mirage xenstore.client uri.services awa-mirage))

mirage/resolver_mirage.ml

@@ -100,7 +100,12 @@ module Make_with_stack (R: Mirage_random.S) (T : Mirage_time.S) (C: Mirage_clock
            | Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
            | Ok host -> DNS.gethostbyname dns host) >|= function
       | Error (`Msg err) -> `Unknown ("name resolution failed: " ^ err)
-      | Ok addr -> `TCP (Ipaddr.V4 addr, port)
+      | Ok addr ->
+        match service.Resolver.name with
+        | "ssh" ->
+          let user = Uri.user uri in
+          `SSH (Ipaddr.V4 addr, port, user)
+        | _ -> `TCP (Ipaddr.V4 addr, port)
 
     let register ?ns ?(ns_port = 53) ?stack res =
       begin match stack with