From e5238b2d2b4a7a75ae17b0e3779b771df97d6c0f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 22 Jun 2019 22:58:20 +0200 Subject: [PATCH] add ssh client support --- conduit-mirage.opam | 1 + lib/conduit.ml | 1 + lib/conduit.mli | 1 + lwt-unix/conduit_lwt_unix.ml | 2 + mirage/conduit_mirage.ml | 72 ++++++++++++++++++++++++++++++++---- mirage/conduit_mirage.mli | 12 ++++-- mirage/dune | 2 +- mirage/resolver_mirage.ml | 7 +++- 8 files changed, 86 insertions(+), 12 deletions(-) diff --git a/conduit-mirage.opam b/conduit-mirage.opam index b4200b12..033b2c4f 100644 --- a/conduit-mirage.opam +++ b/conduit-mirage.opam @@ -25,6 +25,7 @@ depends: [ "tls-mirage" {>= "0.11.0"} "ipaddr" {>= "3.0.0"} "ipaddr-sexp" + "awa-mirage" ] conflicts: [ "mirage-conduit" diff --git a/lib/conduit.ml b/lib/conduit.ml index 0a602618..1a3496b4 100644 --- a/lib/conduit.ml +++ b/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] diff --git a/lib/conduit.mli b/lib/conduit.mli index 37456a45..b38760ad 100644 --- a/lib/conduit.mli +++ b/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] diff --git a/lwt-unix/conduit_lwt_unix.ml b/lwt-unix/conduit_lwt_unix.ml index 8dade88d..1d3836f7 100644 --- a/lwt-unix/conduit_lwt_unix.ml +++ b/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 diff --git a/mirage/conduit_mirage.ml b/mirage/conduit_mirage.ml index b9db6b34..31f2e474 100644 --- a/mirage/conduit_mirage.ml +++ b/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 diff --git a/mirage/conduit_mirage.mli b/mirage/conduit_mirage.mli index 1774eb86..928c2ee2 100644 --- a/mirage/conduit_mirage.mli +++ b/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. *) diff --git a/mirage/dune b/mirage/dune index 82cb38c9..da2007a9 100644 --- a/mirage/dune +++ b/mirage/dune @@ -6,4 +6,4 @@ (wrapped false) (libraries conduit conduit-lwt mirage-stack mirage-clock mirage-random mirage-time 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)) diff --git a/mirage/resolver_mirage.ml b/mirage/resolver_mirage.ml index e95ca2f3..7c6dd528 100644 --- a/mirage/resolver_mirage.ml +++ b/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