Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[WIP] ssh client support in conduit_mirage #296

Closed
wants to merge 1 commit into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions conduit-mirage.opam
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ depends: [
"tls-mirage" {>= "0.11.0"}
"ipaddr" {>= "3.0.0"}
"ipaddr-sexp"
"awa-mirage"
]
conflicts: [
"mirage-conduit"
Expand Down
1 change: 1 addition & 0 deletions lib/conduit.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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]

Expand Down
1 change: 1 addition & 0 deletions lib/conduit.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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]

Expand Down
2 changes: 2 additions & 0 deletions lwt-unix/conduit_lwt_unix.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
72 changes: 65 additions & 7 deletions mirage/conduit_mirage.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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]
Expand All @@ -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 ->
Expand All @@ -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 ->
Expand All @@ -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 *)
Expand Down Expand Up @@ -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 _ =
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand Down
12 changes: 9 additions & 3 deletions mirage/conduit_mirage.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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. *)

Expand Down
2 changes: 1 addition & 1 deletion mirage/dune
Original file line number Diff line number Diff line change
Expand Up @@ -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))
7 changes: 6 additions & 1 deletion mirage/resolver_mirage.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down