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.

Sign up for GitHub

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

Jump to bottom

Refactor authentication, delay to effectful layer #74

Open
wants to merge 6 commits into
base: main
Choose a base branch
from
Open

Refactor authentication, delay to effectful layer #74

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
4522675
Refactor authentication, delay to effectful layer
reynir Sep 18, 2024
85fb6eb
Remove user_db from Awa.Server
reynir Sep 18, 2024
d1b1b05
Update tests to new Awa.Server
reynir Sep 18, 2024
2669172
Refactor Auth.db related code
reynir Sep 19, 2024
82a6aa7
Remove a polymorphic compare
reynir Sep 19, 2024
08aa3b9
Refactor Auth, Server
reynir Sep 23, 2024
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
49 changes: 3 additions & 46 deletions lib/auth.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()) |>
Expand All @@ -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
167 changes: 102 additions & 65 deletions lib/server.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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) *)
Expand All @@ -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
Expand All @@ -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;
Expand Down Expand Up @@ -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"
Expand All @@ -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)
Expand All @@ -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 =
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The reason for the unused userauth argument is that in a .mli we can better ensure proper protocol flow as you can only call it if you've got a userauth in your hand - which, if made opaque, you can only get from a Userauth _ event.

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"
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't know if we should raise invalid argument here instead?!


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
Expand Down
50 changes: 48 additions & 2 deletions mirage/awa_mirage.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 *)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 ()
}
Expand Down
9 changes: 8 additions & 1 deletion mirage/awa_mirage.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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

Expand Down Expand Up @@ -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
Expand Down
Loading