diff --git a/lib/auth.ml b/lib/auth.ml index 52ba35e..d02c736 100644 --- a/lib/auth.ml +++ b/lib/auth.ml @@ -14,46 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type user = { - name : string; - password : string option; - keys : Hostkey.pub list; -} - -type db = user list - -type state = - | Preauth - | Inprogress of (string * string * int) - | Done - -let make_user name ?password keys = - if password = None && keys = [] then - invalid_arg "password must be Some, and/or keys must not be empty"; - { name; password; keys } - -let lookup_user name db = - List.find_opt (fun user -> user.name = name) db - -let lookup_key user key = - List.find_opt (fun key2 -> key = key2 ) user.keys - -let lookup_user_key user key db = - match lookup_user user db with - | None -> None - | Some user -> lookup_key user key - -let by_password name password db = - match lookup_user name db with - | None -> false - | Some user -> match user.password with - | Some password' -> - let open Digestif.SHA256 in - let a = to_raw_string (digest_string password') - and b = to_raw_string (digest_string password) in - Eqaf.equal a b - | None -> false - let to_hash name alg pubkey session_id service = let open Wire in put_string session_id (Dbuf.create ()) |> @@ -71,9 +31,6 @@ let sign name alg key session_id service = let data = to_hash name alg (Hostkey.pub_of_priv key) session_id service in Hostkey.sign alg key data -let by_pubkey name alg pubkey session_id service signed db = - match lookup_user_key name pubkey db with - | None -> false - | Some pubkey -> - let unsigned = to_hash name alg pubkey session_id service in - Hostkey.verify alg pubkey ~unsigned ~signed +let verify_signature name alg pubkey session_id service signed = + let unsigned = to_hash name alg pubkey session_id service in + Hostkey.verify alg pubkey ~unsigned ~signed diff --git a/lib/server.ml b/lib/server.ml index 0eda600..634547b 100644 --- a/lib/server.ml +++ b/lib/server.ml @@ -19,12 +19,35 @@ open Util let src = Logs.Src.create "awa.server" ~doc:"AWA server" module Log = (val Logs.src_log src : Logs.LOG) +type auth_state = + | Preauth + | Inprogress of (string * string * int) + | Done + +type pubkeyauth = { + pubkey : Hostkey.pub ; + session_id : string ; + service : string ; + sig_alg : Hostkey.alg ; + signed : string ; +} + +let pubkey_of_pubkeyauth { pubkey; _ } = pubkey + +let verify_pubkeyauth ~user { pubkey; session_id; service ; sig_alg ; signed } = + Auth.verify_signature user sig_alg pubkey session_id service signed + +type userauth = + | Password of string + | Pubkey of pubkeyauth + type event = | Channel_exec of (int32 * string) | Channel_subsystem of (int32 * string) | Channel_data of (int32 * Cstruct.t) | Channel_eof of int32 | Disconnected of string + | Userauth of string * userauth | Pty of (string * int32 * int32 * int32 * int32 * string) | Pty_set of (int32 * int32 * int32 * int32) | Set_env of (string * string) @@ -36,6 +59,8 @@ let pp_event ppf = function | Channel_data (c, data) -> Fmt.pf ppf "channel data %lu: %d bytes" c (Cstruct.length data) | Channel_eof c -> Fmt.pf ppf "channel end-of-file %lu" c | Disconnected s -> Fmt.pf ppf "disconnected with messsage %S" s + | Userauth (user, Password _) -> Fmt.pf ppf "userauth password for %S" user + | Userauth (user, Pubkey _) -> Fmt.pf ppf "userauth pubkey for %S" user | Pty _ -> Fmt.pf ppf "pty" | Pty_set _ -> Fmt.pf ppf "pty set" | Set_env (k, v) -> Fmt.pf ppf "Set env %S=%S" k v @@ -57,8 +82,7 @@ type t = { keying : bool; (* keying = sent KEXINIT *) key_eol : Mtime.t option; (* Keys end of life, in ns *) expect : Ssh.message_id option; (* Messages to expect, None if any *) - auth_state : Auth.state; (* username * service in progress *) - user_db : Auth.db; (* username database *) + auth_state : auth_state; (* username * service in progress *) channels : Channel.db; (* Ssh channels *) ignore_next_packet : bool; (* Ignore the next packet from the wire *) dh_group : (Mirage_crypto_pk.Dh.group * int32 * int32 * int32) option; (* used for GEX (RFC 4419) *) @@ -78,7 +102,7 @@ let guard_msg t msg = let host_key_algs key = List.filter Hostkey.(alg_matches (priv_to_typ key)) Hostkey.preferred_algs -let make host_key user_db = +let make host_key = let open Ssh in let server_kexinit = let algs = host_key_algs host_key in @@ -101,8 +125,7 @@ let make host_key user_db = keying = true; key_eol = None; expect = Some MSG_VERSION; - auth_state = Auth.Preauth; - user_db; + auth_state = Preauth; channels = Channel.empty_db; ignore_next_packet = false; dh_group = None; @@ -168,9 +191,8 @@ let make_reply_with_event t msg e = Ok (t, [ msg ], Some e) let make_disconnect t code s = Ok (t, [ Ssh.disconnect_msg code s ], Some (Disconnected s)) -let rec input_userauth_request t username service auth_method = +let input_userauth_request t username service auth_method = let open Ssh in - let open Auth in let inc_nfailed t = match t.auth_state with | Preauth | Done -> Error "Unexpected auth_state" @@ -185,73 +207,72 @@ let rec input_userauth_request t username service auth_method = let* t = inc_nfailed t in make_reply t (Msg_userauth_failure ([ "publickey"; "password" ], false)) in - let discard t = make_noreply t in - let success t = - make_reply { t with auth_state = Done; expect = None } Msg_userauth_success - in let try_probe t pubkey = make_reply t (Msg_userauth_pk_ok pubkey) in - let try_auth t b = if b then success t else failure t in - let handle_auth t = - (* XXX verify all fail cases, what should we do and so on *) - let* session_id = guard_some t.session_id "No session_id" in - let* () = guard (service = "ssh-connection") "Bad service" in - match auth_method with - | Pubkey (pkalg, pubkey_raw, None) -> (* Public key probing *) - begin match Wire.pubkey_of_blob pubkey_raw with - | Ok pubkey when Hostkey.comptible_alg pubkey pkalg -> - try_probe t pubkey - | Ok _ -> + (* XXX verify all fail cases, what should we do and so on *) + let* session_id = guard_some t.session_id "No session_id" in + let* () = guard (service = "ssh-connection") "Bad service" in + match auth_method with + | Pubkey (pkalg, pubkey_raw, None) -> (* Public key probing *) + begin match Wire.pubkey_of_blob pubkey_raw with + | Ok pubkey when Hostkey.comptible_alg pubkey pkalg -> + try_probe t pubkey + | Ok _ -> + Log.debug (fun m -> m "Client offered unsupported or incompatible signature algorithm %s" + pkalg); + failure t + | Error `Unsupported keytype -> + Log.debug (fun m -> m "Client offered unsupported key type %s" keytype); + failure t + | Error `Msg s -> + Log.warn (fun m -> m "Failed to decode public key (while client offered a key): %s" s); + disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed" + end + | Pubkey (pkalg, pubkey_raw, Some (sig_alg, signed)) -> (* Public key authentication *) + begin match Wire.pubkey_of_blob pubkey_raw with + | Ok pubkey when Hostkey.comptible_alg pubkey pkalg && + String.equal pkalg sig_alg -> + (* NOTE: for backwards compatibility with older OpenSSH clients we + should be more lenient if the sig_alg is "ssh-rsa-cert-v01" (if we + ever implement that). See + https://github.com/openssh/openssh-portable/blob/master/ssh-rsa.c#L504-L507 *) + (* XXX: this should be fine due to the previous [Hostkey.comptible_alg] *) + (* TODO: avoid Result.get_ok :/ *) + let sig_alg = Result.get_ok (Hostkey.alg_of_string sig_alg) in + Ok (t, [], Some (Userauth (username, Pubkey { pubkey; session_id; service; sig_alg; signed }))) + | Ok pubkey -> + if Hostkey.comptible_alg pubkey pkalg then Log.debug (fun m -> m "Client offered unsupported or incompatible signature algorithm %s" - pkalg); - failure t - | Error `Unsupported keytype -> - Log.debug (fun m -> m "Client offered unsupported key type %s" keytype); - failure t - | Error `Msg s -> - Log.warn (fun m -> m "Failed to decode public key (while client offered a key): %s" s); - disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed" - end - | Pubkey (pkalg, pubkey_raw, Some (sig_alg, signed)) -> (* Public key authentication *) - begin match Wire.pubkey_of_blob pubkey_raw with - | Ok pubkey when Hostkey.comptible_alg pubkey pkalg && - String.equal pkalg sig_alg -> - (* NOTE: for backwards compatibility with older OpenSSH clients we - should be more lenient if the sig_alg is "ssh-rsa-cert-v01" (if we - ever implement that). See - https://github.com/openssh/openssh-portable/blob/master/ssh-rsa.c#L504-L507 *) - (* XXX: this should be fine due to the previous [Hostkey.comptible_alg] *) - (* TODO: avoid Result.get_ok :/ *) - let sig_alg = Result.get_ok (Hostkey.alg_of_string sig_alg) in - try_auth t (by_pubkey username sig_alg pubkey session_id service signed t.user_db) - | Ok pubkey -> - if Hostkey.comptible_alg pubkey pkalg then - Log.debug (fun m -> m "Client offered unsupported or incompatible signature algorithm %s" - pkalg) - else - Log.debug (fun m -> m "Client offered signature using algorithm different from advertised: %s vs %s" - sig_alg pkalg); - failure t - | Error `Unsupported keytype -> - Log.debug (fun m -> m "Client attempted authentication with unsupported key type %s" keytype); - failure t - | Error `Msg s -> - Log.warn (fun m -> m "Failed to decode public key (while authenticating): %s" s); - disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed" - end - | Password (password, None) -> (* Password authentication *) - try_auth t (by_password username password t.user_db) - (* Change of password, or keyboard_interactive, or Authnone won't be supported *) - | Password (_, Some _) | Keyboard_interactive _ | Authnone -> failure t - in + pkalg) + else + Log.debug (fun m -> m "Client offered signature using algorithm different from advertised: %s vs %s" + sig_alg pkalg); + failure t + | Error `Unsupported keytype -> + Log.debug (fun m -> m "Client attempted authentication with unsupported key type %s" keytype); + failure t + | Error `Msg s -> + Log.warn (fun m -> m "Failed to decode public key (while authenticating): %s" s); + disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed" + end + | Password (password, None) -> (* Password authentication *) + Ok (t, [], Some (Userauth (username, Password password))) + (* Change of password, or keyboard_interactive, or Authnone won't be supported *) + | Password (_, Some _) | Keyboard_interactive _ | Authnone -> failure t + +let input_userauth_request t username service auth_method = (* See if we can actually authenticate *) match t.auth_state with - | Done -> discard t (* RFC tells us we must discard requests if already authenticated *) + | Done -> make_noreply t (* RFC tells us we must discard requests if already authenticated *) | Preauth -> (* Recurse, but now Inprogress *) let t = { t with auth_state = Inprogress (username, service, 0) } in input_userauth_request t username service auth_method | Inprogress (prev_username, prev_service, nfailed) -> + let disconnect t code s = + let t = { t with auth_state = Inprogress (prev_username, prev_service, succ nfailed) } in + make_disconnect t code s + in if service <> "ssh-connection" then disconnect t DISCONNECT_SERVICE_NOT_AVAILABLE (sprintf "Don't know service `%s`" service) @@ -264,7 +285,23 @@ let rec input_userauth_request t username service auth_method = else if nfailed > 10 then Error "Maximum authentication attempts reached, already sent disconnect" else - handle_auth t + input_userauth_request t username service auth_method + +let reject_userauth t _userauth = + match t.auth_state with + | Inprogress (u, s, nfailed) -> + let t = { t with auth_state = Inprogress (u, s, succ nfailed) } in + Ok (t, Ssh.Msg_userauth_failure ([ "publickey"; "password" ], false)) + | Done | Preauth -> + Error "userauth in unexpected state" + +let accept_userauth t _userauth = + match t.auth_state with + | Inprogress _ -> + let t = { t with auth_state = Done; expect = None } in + Ok (t, Ssh.Msg_userauth_success) + | Done | Preauth -> + Error "userauth in unexpected state" let input_channel_open t send_channel init_win_size max_pkt_size data = let open Ssh in diff --git a/mirage/awa_mirage.ml b/mirage/awa_mirage.ml index b5e44b5..01e82f5 100644 --- a/mirage/awa_mirage.ml +++ b/mirage/awa_mirage.ml @@ -3,6 +3,38 @@ open Lwt.Infix let src = Logs.Src.create "awa.mirage" ~doc:"Awa mirage" module Log = (val Logs.src_log src : Logs.LOG) +module Auth = struct + type user = { + name : string; + password : string option; + keys : Awa.Hostkey.pub list; + } + + type db = user list + + let make_user name ?password keys = + if password = None && keys = [] then + invalid_arg "password must be Some, and/or keys must not be empty"; + { name; password; keys } + + let lookup_user name db = + List.find_opt (fun user -> user.name = name) db + + let verify db user userauth = + match lookup_user user db, userauth with + | None, Awa.Server.Pubkey pubkeyauth -> + Awa.Server.verify_pubkeyauth ~user pubkeyauth && false + | (None | Some { password = None; _ }), Awa.Server.Password _ -> false + | Some u, Awa.Server.Pubkey pubkeyauth -> + Awa.Server.verify_pubkeyauth ~user pubkeyauth && + List.exists (fun pubkey -> Awa.Hostkey.pub_eq pubkey pubkeyauth.pubkey) u.keys + | Some { password = Some password; _ }, Awa.Server.Password password' -> + let open Digestif.SHA256 in + let a = digest_string password + and b = digest_string password' in + Digestif.SHA256.equal a b +end + module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) = struct module MCLOCK = M @@ -254,6 +286,7 @@ module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) = type exec_callback = request -> unit Lwt.t type t = { + user_db : Auth.db; exec_callback : exec_callback; (* callback to run on exec *) channels : channel list; (* Opened channels *) nexus_mbox : nexus_msg Lwt_mvar.t;(* Nexus mailbox *) @@ -358,6 +391,18 @@ module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) = >>= fun server -> match event with | None -> nexus t fd server input_buffer (List.append pending_promises [ Lwt_mvar.take t.nexus_mbox ]) + | Some Awa.Server.Userauth (user, userauth) -> + let accept = Auth.verify t.user_db user userauth in + (* FIXME: Result.get_ok *) + let server, reply = + Result.get_ok + (if accept then + Awa.Server.accept_userauth server userauth + else + Awa.Server.reject_userauth server userauth) + in + send_msg fd server reply >>= fun server -> + nexus t fd server input_buffer pending_promises | Some Awa.Server.Pty (term, width, height, max_width, max_height, _modes) -> t.exec_callback (Pty_req { width; height; max_width; max_height; term; }) >>= fun () -> nexus t fd server input_buffer pending_promises @@ -405,8 +450,9 @@ module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) = let t = { t with channels = c :: t.channels } in nexus t fd server input_buffer (List.append pending_promises [ Lwt_mvar.take t.nexus_mbox ]) - let spawn_server ?stop server msgs fd exec_callback = - let t = { exec_callback; + let spawn_server ?stop server user_db msgs fd exec_callback = + let t = { user_db; + exec_callback; channels = []; nexus_mbox = Lwt_mvar.create_empty () } diff --git a/mirage/awa_mirage.mli b/mirage/awa_mirage.mli index 51aef1d..1fd34b2 100644 --- a/mirage/awa_mirage.mli +++ b/mirage/awa_mirage.mli @@ -1,5 +1,12 @@ (** Effectful operations using Mirage for pure SSH. *) +module Auth : sig + type user + type db = user list + + val make_user : string -> ?password:string -> Awa.Hostkey.pub list -> user +end + (** SSH module given a flow *) module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) : sig @@ -40,7 +47,7 @@ module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) : type exec_callback = request -> unit Lwt.t - val spawn_server : ?stop:Lwt_switch.t -> Awa.Server.t -> Awa.Ssh.message list -> F.flow -> + val spawn_server : ?stop:Lwt_switch.t -> Awa.Server.t -> Auth.db -> Awa.Ssh.message list -> F.flow -> exec_callback -> t Lwt.t (** [spawn_server ?stop server msgs flow callback] launches an {i internal} SSH channels handler which can be stopped by [stop]. This SSH channels diff --git a/test/awa_test_server.ml b/test/awa_test_server.ml index d962a02..d2c42d1 100644 --- a/test/awa_test_server.ml +++ b/test/awa_test_server.ml @@ -79,6 +79,15 @@ module Driver = struct | None -> poll t | Some event -> Ok (t, event) + let user_auth t userauth success = + let* server, reply = + if success then + Awa.Server.accept_userauth t.server userauth + else + Awa.Server.reject_userauth t.server userauth + in + send_msg { t with server } reply + let send_channel_data t id data = let* server, msgs = Server.output_channel_data t.server id data in send_msgs { t with server } msgs @@ -133,10 +142,13 @@ let bc t id data = in Driver.send_channel_data t id (Cstruct.of_string reply) -let rec serve t cmd = +let rec serve t user_auth cmd = let open Server in let* t, poll_result = Driver.poll t in match poll_result with + | Userauth (username, userauth) -> + let* t = Driver.user_auth t userauth (user_auth username userauth) in + serve t user_auth cmd | Disconnected s -> Logs.info (fun m -> m "Disconnected: %s" s); Ok () @@ -146,17 +158,17 @@ let rec serve t cmd = | Channel_data (id, data) -> Logs.info (fun m -> m "channel data %d" (Cstruct.length data)); (match cmd with - | None -> serve t cmd + | None -> serve t user_auth cmd | Some "echo" -> if (Cstruct.to_string data) = "rekey\n" then let* t = Driver.rekey t in - serve t cmd + serve t user_auth cmd else let* t = echo t id data in - serve t cmd + serve t user_auth cmd | Some "bc" -> let* t = bc t id data in - serve t cmd + serve t user_auth cmd | _ -> Error "Unexpected cmd") | Channel_subsystem (id, exec) (* same as exec *) | Channel_exec (id, exec) -> @@ -170,16 +182,16 @@ let rec serve t cmd = let* _ = Driver.disconnect t in Logs.info (fun m -> m "sent pong"); Ok () - | "echo" | "bc" as c -> serve t (Some c) + | "echo" | "bc" as c -> serve t user_auth (Some c) | _ -> let msg = Printf.sprintf "Unknown command %s" exec in let* t = Driver.send_channel_data t id (Cstruct.of_string msg) in Logs.info (fun m -> m "%s" msg); let* t = Driver.disconnect t in - serve t cmd end + serve t user_auth cmd end | Set_env (k, v) -> Logs.info (fun m -> m "Ignoring Set_env (%S, %S)" k v); - serve t cmd + serve t user_auth cmd | Pty _ | Pty_set _ -> let msg = Ssh.disconnect_msg Ssh.DISCONNECT_SERVICE_NOT_AVAILABLE @@ -195,29 +207,33 @@ let rec serve t cmd = let* _ = Driver.send_msg t msg in Ok () -let user_db = - (* User foo auths by passoword *) - let foo = Auth.make_user "foo" ~password:"bar" [] in +let user_auth = (* User awa auths by pubkey *) let fd = Unix.(openfile "test/data/awa_test_rsa.pub" [O_RDONLY] 0) in let file_buf = Unix_cstruct.of_fd fd in let key = Result.get_ok (Wire.pubkey_of_openssh file_buf) in Unix.close fd; - let awa = Auth.make_user "awa" [ key ] in - [ foo; awa ] + fun user userauth -> + match user, userauth with + | "foo", Awa.Server.Password "bar" -> + true + | "awa", Awa.Server.Pubkey pubkeyauth -> + Awa.Server.verify_pubkeyauth ~user:"awa" pubkeyauth && + Awa.Server.pubkey_of_pubkeyauth pubkeyauth = key + | _ -> false let rec wait_connection priv_key listen_fd server_port = Logs.info (fun m -> m "Awa server waiting connections on port %d" server_port); let client_fd, _ = Unix.(accept listen_fd) in Logs.info (fun m -> m "Client connected!"); - let server, msgs = Server.make priv_key user_db in + let server, msgs = Server.make priv_key in let* t = Driver.of_server server msgs (write_cstruct client_fd) (read_cstruct client_fd) Mtime_clock.now in - let () = match serve t None with + let () = match serve t user_auth None with | Ok () -> Logs.info (fun m -> m "Client finished") | Error e -> Logs.warn (fun m -> m "error: %s" e) in diff --git a/test/test.ml b/test/test.ml index 56c73f6..88a7bc3 100644 --- a/test/test.ml +++ b/test/test.ml @@ -335,7 +335,7 @@ let t_mpint () = test_ok let t_version () = - let t, _ = Server.make (Hostkey.Rsa_priv (Mirage_crypto_pk.Rsa.generate ~bits:2048 ())) [] in + let t, _ = Server.make (Hostkey.Rsa_priv (Mirage_crypto_pk.Rsa.generate ~bits:2048 ())) in let client_version = "SSH-2.0-OpenSSH_6.9\r\n" in let* t, msg, input_buffer = Server.pop_msg2 t (Cstruct.of_string client_version) @@ -410,7 +410,7 @@ let t_signature () = test_ok let t_ignore_next_packet () = - let t, _ = Server.make (Hostkey.Rsa_priv (Mirage_crypto_pk.Rsa.generate ~bits:2048 ())) [] in + let t, _ = Server.make (Hostkey.Rsa_priv (Mirage_crypto_pk.Rsa.generate ~bits:2048 ())) in let t = Server.{ t with client_version = Some "SSH-2.0-client"; expect = Some(Ssh.MSG_KEXINIT) } in