Skip to content

Commit 9fb835b

Browse files
hannesmhannesm
authored
Merge pull request #74 from reynir/banawa
Refactor authentication, delay to effectful layer
2 parents 422f7d6 + 268be2d commit 9fb835b

File tree

6 files changed

+194
-131
lines changed

6 files changed

+194
-131
lines changed

‎lib/auth.ml

+3-46
Original file line numberDiff line numberDiff line change
@@ -14,46 +14,6 @@
1414
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
1515
*)
1616

17-
type user = {
18-
name : string;
19-
password : string option;
20-
keys : Hostkey.pub list;
21-
}
22-
23-
type db = user list
24-
25-
type state =
26-
| Preauth
27-
| Inprogress of (string * string * int)
28-
| Done
29-
30-
let make_user name ?password keys =
31-
if password = None && keys = [] then
32-
invalid_arg "password must be Some, and/or keys must not be empty";
33-
{ name; password; keys }
34-
35-
let lookup_user name db =
36-
List.find_opt (fun user -> user.name = name) db
37-
38-
let lookup_key user key =
39-
List.find_opt (fun key2 -> key = key2 ) user.keys
40-
41-
let lookup_user_key user key db =
42-
match lookup_user user db with
43-
| None -> None
44-
| Some user -> lookup_key user key
45-
46-
let by_password name password db =
47-
match lookup_user name db with
48-
| None -> false
49-
| Some user -> match user.password with
50-
| Some password' ->
51-
let open Digestif.SHA256 in
52-
let a = to_raw_string (digest_string password')
53-
and b = to_raw_string (digest_string password) in
54-
Eqaf.equal a b
55-
| None -> false
56-
5717
let to_hash name alg pubkey session_id service =
5818
let open Wire in
5919
put_string session_id (Dbuf.create ()) |>
@@ -71,9 +31,6 @@ let sign name alg key session_id service =
7131
let data = to_hash name alg (Hostkey.pub_of_priv key) session_id service in
7232
Hostkey.sign alg key data
7333

74-
let by_pubkey name alg pubkey session_id service signed db =
75-
match lookup_user_key name pubkey db with
76-
| None -> false
77-
| Some pubkey ->
78-
let unsigned = to_hash name alg pubkey session_id service in
79-
Hostkey.verify alg pubkey ~unsigned ~signed
34+
let verify_signature name alg pubkey session_id service signed =
35+
let unsigned = to_hash name alg pubkey session_id service in
36+
Hostkey.verify alg pubkey ~unsigned ~signed

‎lib/server.ml

+102-65
Original file line numberDiff line numberDiff line change
@@ -19,12 +19,35 @@ open Util
1919
let src = Logs.Src.create "awa.server" ~doc:"AWA server"
2020
module Log = (val Logs.src_log src : Logs.LOG)
2121

22+
type auth_state =
23+
| Preauth
24+
| Inprogress of (string * string * int)
25+
| Done
26+
27+
type pubkeyauth = {
28+
pubkey : Hostkey.pub ;
29+
session_id : string ;
30+
service : string ;
31+
sig_alg : Hostkey.alg ;
32+
signed : string ;
33+
}
34+
35+
let pubkey_of_pubkeyauth { pubkey; _ } = pubkey
36+
37+
let verify_pubkeyauth ~user { pubkey; session_id; service ; sig_alg ; signed } =
38+
Auth.verify_signature user sig_alg pubkey session_id service signed
39+
40+
type userauth =
41+
| Password of string
42+
| Pubkey of pubkeyauth
43+
2244
type event =
2345
| Channel_exec of (int32 * string)
2446
| Channel_subsystem of (int32 * string)
2547
| Channel_data of (int32 * Cstruct.t)
2648
| Channel_eof of int32
2749
| Disconnected of string
50+
| Userauth of string * userauth
2851
| Pty of (string * int32 * int32 * int32 * int32 * string)
2952
| Pty_set of (int32 * int32 * int32 * int32)
3053
| Set_env of (string * string)
@@ -36,6 +59,8 @@ let pp_event ppf = function
3659
| Channel_data (c, data) -> Fmt.pf ppf "channel data %lu: %d bytes" c (Cstruct.length data)
3760
| Channel_eof c -> Fmt.pf ppf "channel end-of-file %lu" c
3861
| Disconnected s -> Fmt.pf ppf "disconnected with messsage %S" s
62+
| Userauth (user, Password _) -> Fmt.pf ppf "userauth password for %S" user
63+
| Userauth (user, Pubkey _) -> Fmt.pf ppf "userauth pubkey for %S" user
3964
| Pty _ -> Fmt.pf ppf "pty"
4065
| Pty_set _ -> Fmt.pf ppf "pty set"
4166
| Set_env (k, v) -> Fmt.pf ppf "Set env %S=%S" k v
@@ -57,8 +82,7 @@ type t = {
5782
keying : bool; (* keying = sent KEXINIT *)
5883
key_eol : Mtime.t option; (* Keys end of life, in ns *)
5984
expect : Ssh.message_id option; (* Messages to expect, None if any *)
60-
auth_state : Auth.state; (* username * service in progress *)
61-
user_db : Auth.db; (* username database *)
85+
auth_state : auth_state; (* username * service in progress *)
6286
channels : Channel.db; (* Ssh channels *)
6387
ignore_next_packet : bool; (* Ignore the next packet from the wire *)
6488
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 =
78102
let host_key_algs key =
79103
List.filter Hostkey.(alg_matches (priv_to_typ key)) Hostkey.preferred_algs
80104

81-
let make host_key user_db =
105+
let make host_key =
82106
let open Ssh in
83107
let server_kexinit =
84108
let algs = host_key_algs host_key in
@@ -101,8 +125,7 @@ let make host_key user_db =
101125
keying = true;
102126
key_eol = None;
103127
expect = Some MSG_VERSION;
104-
auth_state = Auth.Preauth;
105-
user_db;
128+
auth_state = Preauth;
106129
channels = Channel.empty_db;
107130
ignore_next_packet = false;
108131
dh_group = None;
@@ -168,9 +191,8 @@ let make_reply_with_event t msg e = Ok (t, [ msg ], Some e)
168191
let make_disconnect t code s =
169192
Ok (t, [ Ssh.disconnect_msg code s ], Some (Disconnected s))
170193

171-
let rec input_userauth_request t username service auth_method =
194+
let input_userauth_request t username service auth_method =
172195
let open Ssh in
173-
let open Auth in
174196
let inc_nfailed t =
175197
match t.auth_state with
176198
| Preauth | Done -> Error "Unexpected auth_state"
@@ -185,73 +207,72 @@ let rec input_userauth_request t username service auth_method =
185207
let* t = inc_nfailed t in
186208
make_reply t (Msg_userauth_failure ([ "publickey"; "password" ], false))
187209
in
188-
let discard t = make_noreply t in
189-
let success t =
190-
make_reply { t with auth_state = Done; expect = None } Msg_userauth_success
191-
in
192210
let try_probe t pubkey =
193211
make_reply t (Msg_userauth_pk_ok pubkey)
194212
in
195-
let try_auth t b = if b then success t else failure t in
196-
let handle_auth t =
197-
(* XXX verify all fail cases, what should we do and so on *)
198-
let* session_id = guard_some t.session_id "No session_id" in
199-
let* () = guard (service = "ssh-connection") "Bad service" in
200-
match auth_method with
201-
| Pubkey (pkalg, pubkey_raw, None) -> (* Public key probing *)
202-
begin match Wire.pubkey_of_blob pubkey_raw with
203-
| Ok pubkey when Hostkey.comptible_alg pubkey pkalg ->
204-
try_probe t pubkey
205-
| Ok _ ->
213+
(* XXX verify all fail cases, what should we do and so on *)
214+
let* session_id = guard_some t.session_id "No session_id" in
215+
let* () = guard (service = "ssh-connection") "Bad service" in
216+
match auth_method with
217+
| Pubkey (pkalg, pubkey_raw, None) -> (* Public key probing *)
218+
begin match Wire.pubkey_of_blob pubkey_raw with
219+
| Ok pubkey when Hostkey.comptible_alg pubkey pkalg ->
220+
try_probe t pubkey
221+
| Ok _ ->
222+
Log.debug (fun m -> m "Client offered unsupported or incompatible signature algorithm %s"
223+
pkalg);
224+
failure t
225+
| Error `Unsupported keytype ->
226+
Log.debug (fun m -> m "Client offered unsupported key type %s" keytype);
227+
failure t
228+
| Error `Msg s ->
229+
Log.warn (fun m -> m "Failed to decode public key (while client offered a key): %s" s);
230+
disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed"
231+
end
232+
| Pubkey (pkalg, pubkey_raw, Some (sig_alg, signed)) -> (* Public key authentication *)
233+
begin match Wire.pubkey_of_blob pubkey_raw with
234+
| Ok pubkey when Hostkey.comptible_alg pubkey pkalg &&
235+
String.equal pkalg sig_alg ->
236+
(* NOTE: for backwards compatibility with older OpenSSH clients we
237+
should be more lenient if the sig_alg is "ssh-rsa-cert-v01" (if we
238+
ever implement that). See
239+
https://github.com/openssh/openssh-portable/blob/master/ssh-rsa.c#L504-L507 *)
240+
(* XXX: this should be fine due to the previous [Hostkey.comptible_alg] *)
241+
(* TODO: avoid Result.get_ok :/ *)
242+
let sig_alg = Result.get_ok (Hostkey.alg_of_string sig_alg) in
243+
Ok (t, [], Some (Userauth (username, Pubkey { pubkey; session_id; service; sig_alg; signed })))
244+
| Ok pubkey ->
245+
if Hostkey.comptible_alg pubkey pkalg then
206246
Log.debug (fun m -> m "Client offered unsupported or incompatible signature algorithm %s"
207-
pkalg);
208-
failure t
209-
| Error `Unsupported keytype ->
210-
Log.debug (fun m -> m "Client offered unsupported key type %s" keytype);
211-
failure t
212-
| Error `Msg s ->
213-
Log.warn (fun m -> m "Failed to decode public key (while client offered a key): %s" s);
214-
disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed"
215-
end
216-
| Pubkey (pkalg, pubkey_raw, Some (sig_alg, signed)) -> (* Public key authentication *)
217-
begin match Wire.pubkey_of_blob pubkey_raw with
218-
| Ok pubkey when Hostkey.comptible_alg pubkey pkalg &&
219-
String.equal pkalg sig_alg ->
220-
(* NOTE: for backwards compatibility with older OpenSSH clients we
221-
should be more lenient if the sig_alg is "ssh-rsa-cert-v01" (if we
222-
ever implement that). See
223-
https://github.com/openssh/openssh-portable/blob/master/ssh-rsa.c#L504-L507 *)
224-
(* XXX: this should be fine due to the previous [Hostkey.comptible_alg] *)
225-
(* TODO: avoid Result.get_ok :/ *)
226-
let sig_alg = Result.get_ok (Hostkey.alg_of_string sig_alg) in
227-
try_auth t (by_pubkey username sig_alg pubkey session_id service signed t.user_db)
228-
| Ok pubkey ->
229-
if Hostkey.comptible_alg pubkey pkalg then
230-
Log.debug (fun m -> m "Client offered unsupported or incompatible signature algorithm %s"
231-
pkalg)
232-
else
233-
Log.debug (fun m -> m "Client offered signature using algorithm different from advertised: %s vs %s"
234-
sig_alg pkalg);
235-
failure t
236-
| Error `Unsupported keytype ->
237-
Log.debug (fun m -> m "Client attempted authentication with unsupported key type %s" keytype);
238-
failure t
239-
| Error `Msg s ->
240-
Log.warn (fun m -> m "Failed to decode public key (while authenticating): %s" s);
241-
disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed"
242-
end
243-
| Password (password, None) -> (* Password authentication *)
244-
try_auth t (by_password username password t.user_db)
245-
(* Change of password, or keyboard_interactive, or Authnone won't be supported *)
246-
| Password (_, Some _) | Keyboard_interactive _ | Authnone -> failure t
247-
in
247+
pkalg)
248+
else
249+
Log.debug (fun m -> m "Client offered signature using algorithm different from advertised: %s vs %s"
250+
sig_alg pkalg);
251+
failure t
252+
| Error `Unsupported keytype ->
253+
Log.debug (fun m -> m "Client attempted authentication with unsupported key type %s" keytype);
254+
failure t
255+
| Error `Msg s ->
256+
Log.warn (fun m -> m "Failed to decode public key (while authenticating): %s" s);
257+
disconnect t DISCONNECT_PROTOCOL_ERROR "public key decoding failed"
258+
end
259+
| Password (password, None) -> (* Password authentication *)
260+
Ok (t, [], Some (Userauth (username, Password password)))
261+
(* Change of password, or keyboard_interactive, or Authnone won't be supported *)
262+
| Password (_, Some _) | Keyboard_interactive _ | Authnone -> failure t
263+
264+
let input_userauth_request t username service auth_method =
248265
(* See if we can actually authenticate *)
249266
match t.auth_state with
250-
| Done -> discard t (* RFC tells us we must discard requests if already authenticated *)
267+
| Done -> make_noreply t (* RFC tells us we must discard requests if already authenticated *)
251268
| Preauth -> (* Recurse, but now Inprogress *)
252269
let t = { t with auth_state = Inprogress (username, service, 0) } in
253270
input_userauth_request t username service auth_method
254271
| Inprogress (prev_username, prev_service, nfailed) ->
272+
let disconnect t code s =
273+
let t = { t with auth_state = Inprogress (prev_username, prev_service, succ nfailed) } in
274+
make_disconnect t code s
275+
in
255276
if service <> "ssh-connection" then
256277
disconnect t DISCONNECT_SERVICE_NOT_AVAILABLE
257278
(sprintf "Don't know service `%s`" service)
@@ -264,7 +285,23 @@ let rec input_userauth_request t username service auth_method =
264285
else if nfailed > 10 then
265286
Error "Maximum authentication attempts reached, already sent disconnect"
266287
else
267-
handle_auth t
288+
input_userauth_request t username service auth_method
289+
290+
let reject_userauth t _userauth =
291+
match t.auth_state with
292+
| Inprogress (u, s, nfailed) ->
293+
let t = { t with auth_state = Inprogress (u, s, succ nfailed) } in
294+
Ok (t, Ssh.Msg_userauth_failure ([ "publickey"; "password" ], false))
295+
| Done | Preauth ->
296+
Error "userauth in unexpected state"
297+
298+
let accept_userauth t _userauth =
299+
match t.auth_state with
300+
| Inprogress _ ->
301+
let t = { t with auth_state = Done; expect = None } in
302+
Ok (t, Ssh.Msg_userauth_success)
303+
| Done | Preauth ->
304+
Error "userauth in unexpected state"
268305

269306
let input_channel_open t send_channel init_win_size max_pkt_size data =
270307
let open Ssh in

‎mirage/awa_mirage.ml

+48-2
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,38 @@ open Lwt.Infix
33
let src = Logs.Src.create "awa.mirage" ~doc:"Awa mirage"
44
module Log = (val Logs.src_log src : Logs.LOG)
55

6+
module Auth = struct
7+
type user = {
8+
name : string;
9+
password : string option;
10+
keys : Awa.Hostkey.pub list;
11+
}
12+
13+
type db = user list
14+
15+
let make_user name ?password keys =
16+
if password = None && keys = [] then
17+
invalid_arg "password must be Some, and/or keys must not be empty";
18+
{ name; password; keys }
19+
20+
let lookup_user name db =
21+
List.find_opt (fun user -> user.name = name) db
22+
23+
let verify db user userauth =
24+
match lookup_user user db, userauth with
25+
| None, Awa.Server.Pubkey pubkeyauth ->
26+
Awa.Server.verify_pubkeyauth ~user pubkeyauth && false
27+
| (None | Some { password = None; _ }), Awa.Server.Password _ -> false
28+
| Some u, Awa.Server.Pubkey pubkeyauth ->
29+
Awa.Server.verify_pubkeyauth ~user pubkeyauth &&
30+
List.exists (fun pubkey -> Awa.Hostkey.pub_eq pubkey pubkeyauth.pubkey) u.keys
31+
| Some { password = Some password; _ }, Awa.Server.Password password' ->
32+
let open Digestif.SHA256 in
33+
let a = digest_string password
34+
and b = digest_string password' in
35+
Digestif.SHA256.equal a b
36+
end
37+
638
module Make (F : Mirage_flow.S) = struct
739
type error = [ `Msg of string
840
| `Read of F.error
@@ -251,6 +283,7 @@ module Make (F : Mirage_flow.S) = struct
251283
type exec_callback = request -> unit Lwt.t
252284

253285
type t = {
286+
user_db : Auth.db;
254287
exec_callback : exec_callback; (* callback to run on exec *)
255288
channels : channel list; (* Opened channels *)
256289
nexus_mbox : nexus_msg Lwt_mvar.t;(* Nexus mailbox *)
@@ -355,6 +388,18 @@ module Make (F : Mirage_flow.S) = struct
355388
>>= fun server ->
356389
match event with
357390
| None -> nexus t fd server input_buffer (List.append pending_promises [ Lwt_mvar.take t.nexus_mbox ])
391+
| Some Awa.Server.Userauth (user, userauth) ->
392+
let accept = Auth.verify t.user_db user userauth in
393+
(* FIXME: Result.get_ok: Awa.Server.{accept,reject}_userauth should likely raise instead *)
394+
let server, reply =
395+
Result.get_ok
396+
(if accept then
397+
Awa.Server.accept_userauth server userauth
398+
else
399+
Awa.Server.reject_userauth server userauth)
400+
in
401+
send_msg fd server reply >>= fun server ->
402+
nexus t fd server input_buffer pending_promises
358403
| Some Awa.Server.Pty (term, width, height, max_width, max_height, _modes) ->
359404
t.exec_callback (Pty_req { width; height; max_width; max_height; term; }) >>= fun () ->
360405
nexus t fd server input_buffer pending_promises
@@ -402,8 +447,9 @@ module Make (F : Mirage_flow.S) = struct
402447
let t = { t with channels = c :: t.channels } in
403448
nexus t fd server input_buffer (List.append pending_promises [ Lwt_mvar.take t.nexus_mbox ])
404449

405-
let spawn_server ?stop server msgs fd exec_callback =
406-
let t = { exec_callback;
450+
let spawn_server ?stop server user_db msgs fd exec_callback =
451+
let t = { user_db;
452+
exec_callback;
407453
channels = [];
408454
nexus_mbox = Lwt_mvar.create_empty ()
409455
}

‎mirage/awa_mirage.mli

+8-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,12 @@
11
(** Effectful operations using Mirage for pure SSH. *)
22

3+
module Auth : sig
4+
type user
5+
type db = user list
6+
7+
val make_user : string -> ?password:string -> Awa.Hostkey.pub list -> user
8+
end
9+
310
(** SSH module given a flow *)
411
module Make (F : Mirage_flow.S) : sig
512

@@ -40,7 +47,7 @@ module Make (F : Mirage_flow.S) : sig
4047

4148
type exec_callback = request -> unit Lwt.t
4249

43-
val spawn_server : ?stop:Lwt_switch.t -> Awa.Server.t -> Awa.Ssh.message list -> F.flow ->
50+
val spawn_server : ?stop:Lwt_switch.t -> Awa.Server.t -> Auth.db -> Awa.Ssh.message list -> F.flow ->
4451
exec_callback -> t Lwt.t
4552
(** [spawn_server ?stop server msgs flow callback] launches an {i internal}
4653
SSH channels handler which can be stopped by [stop]. This SSH channels

0 commit comments

Comments
 (0)