From 452267534114bedb69f70a8b77d36a96ea9b3c86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Wed, 18 Sep 2024 19:09:35 +0200 Subject: [PATCH 1/6] Refactor authentication, delay to effectful layer Userauth is now an event. This means the effectful layer can do e.g. database lookups or LDAP requests when authenticating a user. As an added bonus an effectful layer that implements trust on first use (TOFU) user authentication is now possible. --- lib/auth.ml | 9 +++----- lib/server.ml | 51 ++++++++++++++++++++++++++++++++++--------- mirage/awa_mirage.ml | 30 +++++++++++++++++++++++-- mirage/awa_mirage.mli | 2 +- 4 files changed, 73 insertions(+), 19 deletions(-) diff --git a/lib/auth.ml b/lib/auth.ml index 52ba35e..d6776c9 100644 --- a/lib/auth.ml +++ b/lib/auth.ml @@ -71,9 +71,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 by_pubkey 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..b4be396 100644 --- a/lib/server.ml +++ b/lib/server.ml @@ -19,12 +19,30 @@ open Util let src = Logs.Src.create "awa.server" ~doc:"AWA server" module Log = (val Logs.src_log src : Logs.LOG) +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.by_pubkey 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 +54,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 @@ -170,7 +190,6 @@ let make_disconnect t code s = let rec 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" @@ -186,13 +205,9 @@ let rec input_userauth_request t username service auth_method = 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 @@ -224,7 +239,7 @@ let rec input_userauth_request t username service auth_method = (* 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 (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" @@ -241,15 +256,15 @@ let rec input_userauth_request t username service auth_method = 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) + 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 in (* See if we can actually authenticate *) match t.auth_state with - | Done -> discard 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 + | Auth.Done -> discard t (* RFC tells us we must discard requests if already authenticated *) + | Auth.Preauth -> (* Recurse, but now Inprogress *) + let t = { t with auth_state = Auth.Inprogress (username, service, 0) } in input_userauth_request t username service auth_method | Inprogress (prev_username, prev_service, nfailed) -> if service <> "ssh-connection" then @@ -266,6 +281,22 @@ let rec input_userauth_request t username service auth_method = else handle_auth t +let reject_userauth t _userauth = + match t.auth_state with + | Auth.Inprogress (u, s, nfailed) -> + let t = { t with auth_state = Auth.Inprogress (u, s, succ nfailed) } in + Ok (t, Ssh.Msg_userauth_failure ([ "publickey"; "password" ], false)) + | Auth.Done | Auth.Preauth -> + Error "userauth in unexpected state" + +let accept_userauth t _userauth = + match t.auth_state with + | Auth.Inprogress _ -> + let t = { t with auth_state = Auth.Done; expect = None } in + Ok (t, Ssh.Msg_userauth_success) + | Auth.Done | Auth.Preauth -> + Error "userauth in unexpected state" + let input_channel_open t send_channel init_win_size max_pkt_size data = let open Ssh in let fail t code s = diff --git a/mirage/awa_mirage.ml b/mirage/awa_mirage.ml index b5e44b5..0d449f4 100644 --- a/mirage/awa_mirage.ml +++ b/mirage/awa_mirage.ml @@ -254,6 +254,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 : Awa.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 +359,30 @@ 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 = + match Awa.Auth.lookup_user user t.user_db with + | None -> + false + | Some u -> + match userauth with + | Password password -> + u.password = Some password + | Pubkey pubkeyauth -> + Awa.Server.verify_pubkeyauth ~user pubkeyauth && + (* XXX: polymorphic compare *) + List.mem (Awa.Server.pubkey_of_pubkeyauth pubkeyauth) u.keys + 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 +430,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..3fa0565 100644 --- a/mirage/awa_mirage.mli +++ b/mirage/awa_mirage.mli @@ -40,7 +40,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 -> Awa.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 From 85fb6eb65f32b67207a928c3f339104c930c6e5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Wed, 18 Sep 2024 20:23:58 +0200 Subject: [PATCH 2/6] Remove user_db from Awa.Server --- lib/server.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lib/server.ml b/lib/server.ml index b4be396..b22cf3f 100644 --- a/lib/server.ml +++ b/lib/server.ml @@ -78,7 +78,6 @@ type t = { 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 *) 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) *) @@ -98,7 +97,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 @@ -122,7 +121,6 @@ let make host_key user_db = key_eol = None; expect = Some MSG_VERSION; auth_state = Auth.Preauth; - user_db; channels = Channel.empty_db; ignore_next_packet = false; dh_group = None; From d1b1b059b135f0ff95fc08b1e6581cceb8262691 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Wed, 18 Sep 2024 20:40:02 +0200 Subject: [PATCH 3/6] Update tests to new Awa.Server --- test/awa_test_server.ml | 46 +++++++++++++++++++++++++++-------------- test/test.ml | 4 ++-- 2 files changed, 33 insertions(+), 17 deletions(-) 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 From 26691728c491dc27bd42f94ac9029f9d2a4c2d76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Thu, 19 Sep 2024 10:14:52 +0200 Subject: [PATCH 4/6] Refactor Auth.db related code --- lib/auth.ml | 52 +++++++++++++++++++++++++++----------------- lib/server.ml | 9 ++++---- mirage/awa_mirage.ml | 14 +----------- 3 files changed, 37 insertions(+), 38 deletions(-) diff --git a/lib/auth.ml b/lib/auth.ml index d6776c9..d938b50 100644 --- a/lib/auth.ml +++ b/lib/auth.ml @@ -27,6 +27,20 @@ type state = | 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 + +type userauth = + | Password of string + | Pubkey of pubkeyauth + let make_user name ?password keys = if password = None && keys = [] then invalid_arg "password must be Some, and/or keys must not be empty"; @@ -35,25 +49,6 @@ let make_user 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,6 +66,23 @@ 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 = +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 + +let verify_pubkeyauth ~user { pubkey; session_id; service ; sig_alg ; signed } = + verify_signature user sig_alg pubkey session_id service signed + +let verify db user userauth = + match lookup_user user db, userauth with + | None, Pubkey pubkeyauth -> + verify_pubkeyauth ~user pubkeyauth && false + | (None | Some { password = None; _ }), Password _ -> false + | Some u, Pubkey pubkeyauth -> + (* XXX: polymorphic comparison *) + verify_pubkeyauth ~user pubkeyauth && List.mem pubkeyauth.pubkey u.keys + | Some { password = Some password; _ }, Password password' -> + let open Digestif.SHA256 in + let a = digest_string password + and b = digest_string password' in + Digestif.SHA256.equal a b diff --git a/lib/server.ml b/lib/server.ml index b22cf3f..87d76e9 100644 --- a/lib/server.ml +++ b/lib/server.ml @@ -19,7 +19,7 @@ open Util let src = Logs.Src.create "awa.server" ~doc:"AWA server" module Log = (val Logs.src_log src : Logs.LOG) -type pubkeyauth = { +type pubkeyauth = Auth.pubkeyauth = { pubkey : Hostkey.pub ; session_id : string ; service : string ; @@ -27,12 +27,11 @@ type pubkeyauth = { signed : string ; } -let pubkey_of_pubkeyauth { pubkey; _ } = pubkey +let pubkey_of_pubkeyauth = Auth.pubkey_of_pubkeyauth -let verify_pubkeyauth ~user { pubkey; session_id; service ; sig_alg ; signed } = - Auth.by_pubkey user sig_alg pubkey session_id service signed +let verify_pubkeyauth = Auth.verify_pubkeyauth -type userauth = +type userauth = Auth.userauth = | Password of string | Pubkey of pubkeyauth diff --git a/mirage/awa_mirage.ml b/mirage/awa_mirage.ml index 0d449f4..068a2f3 100644 --- a/mirage/awa_mirage.ml +++ b/mirage/awa_mirage.ml @@ -360,19 +360,7 @@ module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) = 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 = - match Awa.Auth.lookup_user user t.user_db with - | None -> - false - | Some u -> - match userauth with - | Password password -> - u.password = Some password - | Pubkey pubkeyauth -> - Awa.Server.verify_pubkeyauth ~user pubkeyauth && - (* XXX: polymorphic compare *) - List.mem (Awa.Server.pubkey_of_pubkeyauth pubkeyauth) u.keys - in + let accept = Awa.Auth.verify t.user_db user userauth in (* FIXME: Result.get_ok *) let server, reply = Result.get_ok From 82a6aa715703502892e66e811fa03aae63ed562b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Thu, 19 Sep 2024 10:16:33 +0200 Subject: [PATCH 5/6] Remove a polymorphic compare --- lib/auth.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/auth.ml b/lib/auth.ml index d938b50..dd1506a 100644 --- a/lib/auth.ml +++ b/lib/auth.ml @@ -79,8 +79,8 @@ let verify db user userauth = verify_pubkeyauth ~user pubkeyauth && false | (None | Some { password = None; _ }), Password _ -> false | Some u, Pubkey pubkeyauth -> - (* XXX: polymorphic comparison *) - verify_pubkeyauth ~user pubkeyauth && List.mem pubkeyauth.pubkey u.keys + verify_pubkeyauth ~user pubkeyauth && + List.exists (fun pubkey -> Hostkey.pub_eq pubkey pubkeyauth.pubkey) u.keys | Some { password = Some password; _ }, Password password' -> let open Digestif.SHA256 in let a = digest_string password From 08aa3b952a2ecb1dd32e9cfed52b677c1833b896 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Mon, 23 Sep 2024 19:19:28 +0200 Subject: [PATCH 6/6] Refactor Auth, Server Move bits of Auth into Server and Awa_mirage. --- lib/auth.ml | 52 --------------- lib/server.ml | 147 ++++++++++++++++++++++-------------------- mirage/awa_mirage.ml | 36 ++++++++++- mirage/awa_mirage.mli | 9 ++- 4 files changed, 120 insertions(+), 124 deletions(-) diff --git a/lib/auth.ml b/lib/auth.ml index dd1506a..d02c736 100644 --- a/lib/auth.ml +++ b/lib/auth.ml @@ -14,41 +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 - -type pubkeyauth = { - pubkey : Hostkey.pub ; - session_id : string ; - service : string ; - sig_alg : Hostkey.alg ; - signed : string ; -} - -let pubkey_of_pubkeyauth { pubkey; _ } = pubkey - -type userauth = - | Password of string - | Pubkey of pubkeyauth - -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 to_hash name alg pubkey session_id service = let open Wire in put_string session_id (Dbuf.create ()) |> @@ -69,20 +34,3 @@ let sign name alg key session_id service = 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 - -let verify_pubkeyauth ~user { pubkey; session_id; service ; sig_alg ; signed } = - verify_signature user sig_alg pubkey session_id service signed - -let verify db user userauth = - match lookup_user user db, userauth with - | None, Pubkey pubkeyauth -> - verify_pubkeyauth ~user pubkeyauth && false - | (None | Some { password = None; _ }), Password _ -> false - | Some u, Pubkey pubkeyauth -> - verify_pubkeyauth ~user pubkeyauth && - List.exists (fun pubkey -> Hostkey.pub_eq pubkey pubkeyauth.pubkey) u.keys - | Some { password = Some password; _ }, Password password' -> - let open Digestif.SHA256 in - let a = digest_string password - and b = digest_string password' in - Digestif.SHA256.equal a b diff --git a/lib/server.ml b/lib/server.ml index 87d76e9..634547b 100644 --- a/lib/server.ml +++ b/lib/server.ml @@ -19,7 +19,12 @@ open Util let src = Logs.Src.create "awa.server" ~doc:"AWA server" module Log = (val Logs.src_log src : Logs.LOG) -type pubkeyauth = Auth.pubkeyauth = { +type auth_state = + | Preauth + | Inprogress of (string * string * int) + | Done + +type pubkeyauth = { pubkey : Hostkey.pub ; session_id : string ; service : string ; @@ -27,11 +32,12 @@ type pubkeyauth = Auth.pubkeyauth = { signed : string ; } -let pubkey_of_pubkeyauth = Auth.pubkey_of_pubkeyauth +let pubkey_of_pubkeyauth { pubkey; _ } = pubkey -let verify_pubkeyauth = Auth.verify_pubkeyauth +let verify_pubkeyauth ~user { pubkey; session_id; service ; sig_alg ; signed } = + Auth.verify_signature user sig_alg pubkey session_id service signed -type userauth = Auth.userauth = +type userauth = | Password of string | Pubkey of pubkeyauth @@ -76,7 +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 *) + 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) *) @@ -119,7 +125,7 @@ let make host_key = keying = true; key_eol = None; expect = Some MSG_VERSION; - auth_state = Auth.Preauth; + auth_state = Preauth; channels = Channel.empty_db; ignore_next_packet = false; dh_group = None; @@ -185,7 +191,7 @@ 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 inc_nfailed t = match t.auth_state with @@ -201,69 +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 try_probe t pubkey = make_reply t (Msg_userauth_pk_ok pubkey) 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 - 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) - 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 - 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 - | Auth.Done -> discard t (* RFC tells us we must discard requests if already authenticated *) - | Auth.Preauth -> (* Recurse, but now Inprogress *) - let t = { t with auth_state = Auth.Inprogress (username, service, 0) } in + | 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) @@ -276,22 +285,22 @@ 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 - | Auth.Inprogress (u, s, nfailed) -> - let t = { t with auth_state = Auth.Inprogress (u, s, succ nfailed) } in + | 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)) - | Auth.Done | Auth.Preauth -> + | Done | Preauth -> Error "userauth in unexpected state" let accept_userauth t _userauth = match t.auth_state with - | Auth.Inprogress _ -> - let t = { t with auth_state = Auth.Done; expect = None } in + | Inprogress _ -> + let t = { t with auth_state = Done; expect = None } in Ok (t, Ssh.Msg_userauth_success) - | Auth.Done | Auth.Preauth -> + | Done | Preauth -> Error "userauth in unexpected state" let input_channel_open t send_channel init_win_size max_pkt_size data = diff --git a/mirage/awa_mirage.ml b/mirage/awa_mirage.ml index 068a2f3..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,7 +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 : Awa.Auth.db; + 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 *) @@ -360,7 +392,7 @@ module Make (F : Mirage_flow.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) = 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 = Awa.Auth.verify t.user_db user userauth in + let accept = Auth.verify t.user_db user userauth in (* FIXME: Result.get_ok *) let server, reply = Result.get_ok diff --git a/mirage/awa_mirage.mli b/mirage/awa_mirage.mli index 3fa0565..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.Auth.db -> 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