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 5 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
59 changes: 34 additions & 25 deletions lib/auth.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Copy link
Member Author

Choose a reason for hiding this comment

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

Moving this into Auth made sense to me as the related verification code lives there. But it makes it a bit more annoying to make pubkeyauth opaque as we need to construct it in Server.

Of course, we can create a awa.mli and better control what is exposed to library users.

Copy link
Member Author

Choose a reason for hiding this comment

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

After some thought: Maybe this is moved back to Server.ml, and the Auth.user/Auth.db related code is moved into Awa_mirage?

Copy link
Member

Choose a reason for hiding this comment

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

I'd be happy to have a awa.mli :) about code moving, I'm not sure, if you think it is worth, please do it :) though moving purely functional stuff into the effectful mirage layer is something I'd avoid.

Copy link
Member Author

Choose a reason for hiding this comment

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

Another motivation for me of moving that code to Awa_mirage is I may eventually want to get rid of that code tbh. After all, a (static) list of users in memory is maybe not the best fit for all. We may want to use various password hashing algorithms. Or we may accept public keys based on their fingerprint (this may be a very bad idea; I don't know).

let make_user name ?password keys =
if password = None && keys = [] then
invalid_arg "password must be Some, and/or keys must not be empty";
Expand All @@ -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 ()) |>
Expand All @@ -71,9 +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 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

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

Choose a reason for hiding this comment

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

seeing it like this, I was wondering whether we should store the password as a hash or somehow derived in the memory of the server -- but this can obviously be another PR since AFAICT this PR doesn't change it, only makes it more obvious

Digestif.SHA256.equal a b
54 changes: 41 additions & 13 deletions lib/server.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,12 +19,29 @@ 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 = {
pubkey : Hostkey.pub ;
session_id : string ;
service : string ;
sig_alg : Hostkey.alg ;
signed : string ;
}

let pubkey_of_pubkeyauth = Auth.pubkey_of_pubkeyauth

let verify_pubkeyauth = Auth.verify_pubkeyauth

type userauth = Auth.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 +53,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 @@ -58,7 +77,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) *)
Expand All @@ -78,7 +96,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 @@ -102,7 +120,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;
Expand Down Expand Up @@ -170,7 +187,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"
Expand All @@ -186,13 +202,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
Expand Down Expand Up @@ -224,7 +236,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"
Expand All @@ -241,15 +253,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
Expand All @@ -266,6 +278,22 @@ let rec input_userauth_request t username service auth_method =
else
handle_auth t

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
| 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"
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
| 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 =
Expand Down
18 changes: 16 additions & 2 deletions mirage/awa_mirage.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 *)
Expand Down Expand Up @@ -358,6 +359,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 = Awa.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 +418,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
2 changes: 1 addition & 1 deletion mirage/awa_mirage.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
46 changes: 31 additions & 15 deletions test/awa_test_server.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Member

Choose a reason for hiding this comment

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

should this logic be done inside of awa -- i.e. provide a function:

let auth ? success =
      if success then
        Awa.Server.accept_userauth t.server userauth
      else
        Awa.Server.reject_userauth t.server userauth

this way we wouldn't repeat that in both the test and the mirage server!?

Copy link
Member

Choose a reason for hiding this comment

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

or, maybe to reduce the error conditions, we could provide the Userauth event with "yay" and "nay" (which are accept_userauth / reject_userauth - which wouldn't need to check the state - i.e. there shouldn't be the error case).

Copy link
Member Author

Choose a reason for hiding this comment

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

(Sorry I pressed the "resolve conversation" button instead of the "comment" button and at the same time lost my comment...)

This is interesting. I think we then need to make sure that the Server.t doesn't progress through reading and processing incoming packets?

I think it makes sense to combine accept_userauth / reject_userauth to a variant that takes a bool

Copy link
Member

Choose a reason for hiding this comment

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

make sure that the Server.t doesn't progress

being functional and value-passing, isn't it the case that the effectful layer only has that information -- a mutable Server.t -- and from within the core protocol (server.ml) we're not able to verify that "Server.t has not progressed".

Copy link
Member Author

Choose a reason for hiding this comment

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

Right


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
Expand Down Expand Up @@ -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 ()
Expand All @@ -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) ->
Expand All @@ -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
Expand All @@ -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
Comment on lines +216 to +223
Copy link
Member Author

Choose a reason for hiding this comment

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

This shows a different way to do authentication - we could even read the public key on request.


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
Expand Down
4 changes: 2 additions & 2 deletions test/test.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down