diff --git a/bin/template.ml b/bin/template.ml index 966e23c..2330ad2 100644 --- a/bin/template.ml +++ b/bin/template.ml @@ -30,12 +30,12 @@ let overview notes authenticated_as users = and users = String.concat "" ("

Users

" ]) in page "" (String.concat "" (notes @ [authenticated_as;links;users])) @@ -92,7 +92,7 @@ let register_view origin user = let headers = {'Content-type': "application/json; charset=utf-8"}; - let request = new Request('/register_finish/'+username, { method: 'POST', body: body, headers: headers } ); + let request = new Request('/register_finish/'+challengeData.user.id, { method: 'POST', body: body, headers: headers } ); fetch(request) .then(function (response) { if (!response.ok && response.status != 403) { @@ -106,6 +106,7 @@ let register_view origin user = }); }).catch(function (err) { alert("exception: " + err); + window.location = "/"; }); }); } @@ -177,6 +178,7 @@ let authenticate_view challenge credentials user = }); }).catch(function (err) { alert("exception: " + err); + window.location = "/"; }); |} challenge (Yojson.to_string (`List diff --git a/bin/webauthn_demo.ml b/bin/webauthn_demo.ml index f9a5d7b..249d936 100644 --- a/bin/webauthn_demo.ml +++ b/bin/webauthn_demo.ml @@ -1,6 +1,11 @@ open Lwt.Infix -let users : (string, (Mirage_crypto_ec.P256.Dsa.pub * string * X509.Certificate.t option) list) Hashtbl.t = Hashtbl.create 7 +let users : (string, string * (Mirage_crypto_ec.P256.Dsa.pub * string * X509.Certificate.t option) list) Hashtbl.t = Hashtbl.create 7 + +let find_username username = + Hashtbl.fold (fun id v r -> + if String.equal (fst v) username then Some (id, v) else r) + users None module KhPubHashtbl = Hashtbl.Make(struct type t = Webauthn.key_handle * Mirage_crypto_ec.P256.Dsa.pub @@ -22,9 +27,29 @@ let check_counter kh_pub counter = then KhPubHashtbl.replace counters kh_pub counter; r -let registration_challenges : (string, string) Hashtbl.t = Hashtbl.create 7 +let registration_challenges : (string, string * string list) Hashtbl.t = Hashtbl.create 7 -let authentication_challenges : (string, string) Hashtbl.t = Hashtbl.create 7 +let remove_registration_challenge userid challenge = + match Hashtbl.find_opt registration_challenges userid with + | None -> () + | Some (username, challenges) -> + let challenges = List.filter (fun c -> not (String.equal c challenge)) challenges in + if challenges = [] then + Hashtbl.remove registration_challenges userid + else + Hashtbl.replace registration_challenges userid (username, challenges) + +let authentication_challenges : (string, string list) Hashtbl.t = Hashtbl.create 7 + +let remove_authentication_challenge userid challenge = + match Hashtbl.find_opt authentication_challenges userid with + | None -> () + | Some challenges -> + let challenges = List.filter (fun c -> not (String.equal c challenge)) challenges in + if challenges = [] then + Hashtbl.remove authentication_challenges userid + else + Hashtbl.replace authentication_challenges userid challenges let to_string err = Format.asprintf "%a" Webauthn.pp_error err @@ -50,14 +75,16 @@ let add_routes t = let registration_challenge req = let user = Dream.param "user" req in - let challenge = Cstruct.to_string (Mirage_crypto_rng.generate 16) - (* [userid] should be a random value *) - and userid = Base64.encode_string ~pad:false ~alphabet:Base64.uri_safe_alphabet user in - Hashtbl.replace registration_challenges user challenge; - let credentials = match Hashtbl.find_opt users user with - | None -> [] - | Some credentials -> List.map (fun (_, cid, _) -> cid) credentials + let challenge = Cstruct.to_string (Mirage_crypto_rng.generate 16) in + let userid, credentials = match find_username user with + | None -> gen_data ~alphabet:Base64.uri_safe_alphabet 8, [] + | Some (userid, (_, credentials)) -> userid, List.map (fun (_, cid, _) -> cid) credentials in + let challenges = + Option.map snd (Hashtbl.find_opt registration_challenges userid) |> + Option.value ~default:[] + in + Hashtbl.replace registration_challenges userid (user, challenge :: challenges); let challenge_b64 = (Base64.encode_string challenge) in let json = `Assoc [ "challenge", `String challenge_b64 ; @@ -74,94 +101,106 @@ let add_routes t = in let register_finish req = - let user = Dream.param "user" req in + let userid = Dream.param "userid" req in Dream.body req >>= fun body -> - Logs.info (fun m -> m "received body: %s" body); - match Hashtbl.find_opt registration_challenges user with + Logs.debug (fun m -> m "received body: %s" body); + match Hashtbl.find_opt registration_challenges userid with | None -> Logs.warn (fun m -> m "no challenge found"); Dream.respond ~status:`Bad_Request "Bad request." - | Some challenge -> - Hashtbl.remove registration_challenges user; - match Webauthn.register_response t challenge body with + | Some (username, challenges) -> + match Webauthn.register_response t body with | Error e -> Logs.warn (fun m -> m "error %a" Webauthn.pp_error e); let err = to_string e in Flash_message.put_flash "" ("Registration failed " ^ err) req; Dream.json "false" - | Ok (_aaguid, credential_id, pubkey, _client_extensions, user_present, + | Ok (challenge, _aaguid, credential_id, pubkey, _client_extensions, user_present, user_verified, sig_count, _authenticator_extensions, attestation_cert) -> - ignore (check_counter (credential_id, pubkey) sig_count); - Logs.info (fun m -> m "user present %B user verified %B" user_present user_verified); - Logs.app (fun m -> m "challenge for user %S" user); - match Dream.session "authenticated_as" req, Hashtbl.find_opt users user with - | _, None -> - Logs.app (fun m -> m "registered %s: %S" user credential_id); - Hashtbl.replace users user [ (pubkey, credential_id, attestation_cert) ]; - Dream.invalidate_session req >>= fun () -> - Flash_message.put_flash "" - (Printf.sprintf "Successfully registered as %s! [authenticate]" user user) - req; - Dream.json "true" - | Some session_user, Some keys -> - Logs.app (fun m -> m "user %S session_user %S" user session_user); - if String.equal user session_user then begin - Logs.app (fun m -> m "registered %s: %S" user credential_id); - Hashtbl.replace users user ((pubkey, credential_id, attestation_cert) :: keys) ; + if not (List.mem challenge challenges) then begin + Logs.warn (fun m -> m "challenge invalid"); + Flash_message.put_flash "" "Registration failed: invalid challenge" req; + Dream.json "false" + end else begin + remove_registration_challenge userid challenge; + ignore (check_counter (credential_id, pubkey) sig_count); + Logs.info (fun m -> m "user present %B user verified %B" user_present user_verified); + Logs.app (fun m -> m "challenge for user %S" username); + match Dream.session "authenticated_as" req, Hashtbl.find_opt users userid with + | _, None -> + Logs.app (fun m -> m "registered %s: %S" username credential_id); + Hashtbl.replace users userid (username, [ (pubkey, credential_id, attestation_cert) ]); Dream.invalidate_session req >>= fun () -> Flash_message.put_flash "" - (Printf.sprintf "Successfully registered as %s! [authenticate]" user user) + (Printf.sprintf "Successfully registered as %s! [authenticate]" username userid) req; Dream.json "true" - end else - (Logs.info (fun m -> m "session_user %s, user %s" session_user user); - Dream.json ~status:`Forbidden "false") - | None, Some _keys -> - Logs.app (fun m -> m "no session user"); - Dream.json ~status:`Forbidden "false" + | Some session_user, Some (username', keys) -> + Logs.app (fun m -> m "user %S session_user %S" username session_user); + if String.equal username session_user && String.equal username username' then begin + Logs.app (fun m -> m "registered %s: %S" username credential_id); + Hashtbl.replace users userid (username, ((pubkey, credential_id, attestation_cert) :: keys)) ; + Dream.invalidate_session req >>= fun () -> + Flash_message.put_flash "" + (Printf.sprintf "Successfully registered as %s! [authenticate]" username userid) + req; + Dream.json "true" + end else + (Logs.info (fun m -> m "session_user %s, user %s (user in users table %s)" session_user username username'); + Dream.json ~status:`Forbidden "false") + | None, Some _keys -> + Logs.app (fun m -> m "no session user"); + Dream.json ~status:`Forbidden "false" + end in let authenticate req = - let user = Dream.param "user" req in - match Hashtbl.find_opt users user with + let userid = Dream.param "userid" req in + match Hashtbl.find_opt users userid with | None -> Logs.warn (fun m -> m "no user found"); Dream.respond ~status:`Bad_Request "Bad request." - | Some keys -> + | Some (username, keys) -> let credentials = List.map (fun (_, c, _) -> Base64.encode_string c) keys in let challenge = Cstruct.to_string (Mirage_crypto_rng.generate 16) in - Hashtbl.replace authentication_challenges user challenge; - Dream.html (Template.authenticate_view (Base64.encode_string challenge) credentials user) + let challenges = Option.value ~default:[] (Hashtbl.find_opt authentication_challenges userid) in + Hashtbl.replace authentication_challenges userid (challenge :: challenges); + Dream.html (Template.authenticate_view (Base64.encode_string challenge) credentials username) in let authenticate_finish req = - let user = Dream.param "user" req in + let userid = Dream.param "userid" req in Dream.body req >>= fun body -> - Logs.info (fun m -> m "received body: %s" body); - match Hashtbl.find_opt authentication_challenges user with + Logs.debug (fun m -> m "received body: %s" body); + match Hashtbl.find_opt authentication_challenges userid with | None -> Dream.respond ~status:`Internal_Server_Error "Internal server error." - | Some challenge -> - Hashtbl.remove authentication_challenges user; - match Hashtbl.find_opt users user with + | Some challenges -> + match Hashtbl.find_opt users userid with | None -> - Logs.warn (fun m -> m "no user found, using empty"); + Logs.warn (fun m -> m "no user found with id %s" userid); Dream.respond ~status:`Bad_Request "Bad request." - | Some keys -> + | Some (username, keys) -> let cid_keys = List.map (fun (key, credential_id, _) -> credential_id, key) keys in - match Webauthn.authentication_response t cid_keys challenge body with - | Ok (credential, _client_extensions, _user_present, _user_verified, counter, _authenticator_extensions) -> - if check_counter credential counter - then begin - Flash_message.put_flash "" "Successfully authenticated" req; - Dream.put_session "user" user req >>= fun () -> - Dream.put_session "authenticated_as" user req >>= fun () -> - Dream.json "true" - end else begin - Logs.warn (fun m -> m "credential %S for user %S: counter not strictly increasing! \ - Got %ld, expected >%ld. webauthn device compromised?" - (fst credential) user counter (KhPubHashtbl.find counters credential)); - Flash_message.put_flash "" "Authentication failure: key compromised?" req; + match Webauthn.authentication_response t cid_keys body with + | Ok (challenge, credential, _client_extensions, _user_present, _user_verified, counter, _authenticator_extensions) -> + if not (List.mem challenge challenges) then begin + Logs.warn (fun m -> m "invalid challenge"); + Flash_message.put_flash "" "Authentication failure: invalid challenge" req; Dream.json "false" + end else begin + remove_authentication_challenge userid challenge; + if check_counter credential counter + then begin + Flash_message.put_flash "" "Successfully authenticated" req; + Dream.put_session "authenticated_as" username req >>= fun () -> + Dream.json "true" + end else begin + Logs.warn (fun m -> m "credential %S for user %S: counter not strictly increasing! \ + Got %ld, expected >%ld. webauthn device compromised?" + (fst credential) username counter (KhPubHashtbl.find counters credential)); + Flash_message.put_flash "" "Authentication failure: key compromised?" req; + Dream.json "false" + end end | Error e -> Logs.warn (fun m -> m "error %a" Webauthn.pp_error e); @@ -184,9 +223,9 @@ let add_routes t = Dream.get "/" main; Dream.get "/register" register; Dream.get "/registration-challenge/:user" registration_challenge; - Dream.post "/register_finish/:user" register_finish; - Dream.get "/authenticate/:user" authenticate; - Dream.post "/authenticate_finish/:user" authenticate_finish; + Dream.post "/register_finish/:userid" register_finish; + Dream.get "/authenticate/:userid" authenticate; + Dream.post "/authenticate_finish/:userid" authenticate_finish; Dream.post "/logout" logout; Dream.get "/static/base64.js" base64; ] diff --git a/src/webauthn.ml b/src/webauthn.ml index 6284bd7..5e280a7 100644 --- a/src/webauthn.ml +++ b/src/webauthn.ml @@ -3,7 +3,6 @@ type key_handle = string type error = [ | `Json_decoding of string * string * string | `Base64_decoding of string * string * string - | `Challenge_mismatch of string * string | `Client_data_type_mismatch of string | `Origin_mismatch of string * string | `Attestation_object of string @@ -17,8 +16,6 @@ let pp_error ppf = function Fmt.pf ppf "json decoding error in %s: %s (json: %s)" ctx msg json | `Base64_decoding (ctx, msg, json) -> Fmt.pf ppf "base64 decoding error in %s: %s (json: %s)" ctx msg json - | `Challenge_mismatch (should, is) -> - Fmt.pf ppf "challenge mismatch: expected %s, received %s" should is | `Client_data_type_mismatch is -> Fmt.pf ppf "client data type mismatch: received %s" is | `Origin_mismatch (should, is) -> @@ -36,8 +33,6 @@ type t = { type challenge = string -let reynir = {|{"id":"dpI-yUZhgjMkU3jOmFMkwKx1nDRRruT8W647kk5FY-UO3qmlCsctLqtn7D369ovpj1Ki-0bFcfWY0xJTb0ZV3Q","rawId":"dpI-yUZhgjMkU3jOmFMkwKx1nDRRruT8W647kk5FY-UO3qmlCsctLqtn7D369ovpj1Ki-0bFcfWY0xJTb0ZV3Q","type":"public-key","response":{"attestationObject":"o2NmbXRkbm9uZWdhdHRTdG10oGhhdXRoRGF0YVjEVKwkUFODts743j3E4-Pod_krx_x1yPj5MkxzdU0D1ABBAAAAAAAAAAAAAAAAAAAAAAAAAAAAQHaSPslGYYIzJFN4zphTJMCsdZw0Ua7k_FuuO5JORWPlDt6ppQrHLS6rZ-w9-vaL6Y9SovtGxXH1mNMSU29GVd2lAQIDJiABIVgg9W7_s-sr8SP-S6rTbCAtCSeocIY2SYqAFB-WE2S5OnUiWCBWteq4vgVJYTyplxTWiGZePPPREadDxNuYOn5kZFawVQ","clientDataJSON":"eyJjaGFsbGVuZ2UiOiJPaEhCZldGN2RLcjN0VVBfTmZSUzRnIiwiY2xpZW50RXh0ZW5zaW9ucyI6e30sImhhc2hBbGdvcml0aG0iOiJTSEEtMjU2Iiwib3JpZ2luIjoiaHR0cHM6Ly93ZWJhdXRobi1kZW1vLnJvYnVyLmNvb3AiLCJ0eXBlIjoid2ViYXV0aG4uY3JlYXRlIn0"}}|} - let b64_enc = Base64.(encode_string ~pad:false ~alphabet:uri_safe_alphabet) let lift_err f = function Ok _ as a -> a | Error x -> Error (f x) @@ -231,7 +226,7 @@ let rpid t = | [ _protocol ; "" ; host ] -> host | _ -> assert false -let register_response t challenge data = +let register_response t data = of_json "response" public_key_credential_raw_of_yojson data >>= fun credential -> (* XXX: credential.getClientExtensionResults() *) let response = credential.response in @@ -245,10 +240,8 @@ let register_response t challenge data = (function | "webauthn.create" -> Ok () | wrong_typ -> Error (`Client_data_type_mismatch wrong_typ)) >>= fun () -> - json_get "challenge" client_data >>= json_string "challenge" >>= fun challenge' -> - b64_dec "response.ClientDataJSON.challenge" challenge' >>= fun challenge' -> - guard (String.equal challenge challenge') - (`Challenge_mismatch (challenge, challenge')) >>= fun () -> + json_get "challenge" client_data >>= json_string "challenge" >>= fun challenge -> + b64_dec "response.ClientDataJSON.challenge" challenge >>= fun challenge -> json_get "origin" client_data >>= json_string "origin" >>= fun origin -> guard (String.equal t.origin origin) (`Origin_mismatch (t.origin, origin)) >>= fun () -> @@ -276,7 +269,7 @@ let register_response t challenge data = end >>= fun cert -> (* check attestation cert, maybe *) (* check auth_data.attested_credential_data.credential_id is not registered ? *) - Ok (aaguid, Cstruct.to_string credential_id, pubkey, client_extensions, auth_data.user_present, auth_data.user_verified, auth_data.sign_count, auth_data.extension_data, cert) + Ok (challenge, aaguid, Cstruct.to_string credential_id, pubkey, client_extensions, auth_data.user_present, auth_data.user_verified, auth_data.sign_count, auth_data.extension_data, cert) type auth_response_raw = { authenticator_data : base64url_string [@key "authenticatorData"]; @@ -292,7 +285,7 @@ type auth_assertion_raw = { response : auth_response_raw; } [@@deriving of_yojson] -let authentication_response t cid_keys challenge data = +let authentication_response t cid_keys data = of_json "response" auth_assertion_raw_of_yojson data >>= fun assertion -> let response = assertion.response in let client_data_hash = Mirage_crypto.Hash.SHA256.digest @@ -305,10 +298,8 @@ let authentication_response t cid_keys challenge data = (function | "webauthn.get" -> Ok () | wrong_typ -> Error (`Client_data_type_mismatch wrong_typ)) >>= fun () -> - json_get "challenge" client_data >>= json_string "challenge" >>= fun challenge' -> - b64_dec "response.ClientDataJSON.challenge" challenge' >>= fun challenge' -> - guard (String.equal challenge challenge') - (`Challenge_mismatch (challenge, challenge')) >>= fun () -> + json_get "challenge" client_data >>= json_string "challenge" >>= fun challenge -> + b64_dec "response.ClientDataJSON.challenge" challenge >>= fun challenge -> json_get "origin" client_data >>= json_string "origin" >>= fun origin -> guard (String.equal t.origin origin) (`Origin_mismatch (t.origin, origin)) >>= fun () -> @@ -324,4 +315,4 @@ let authentication_response t cid_keys challenge data = and signature = Cstruct.of_string response.signature in X509.Public_key.verify `SHA256 ~signature (`P256 pubkey) (`Message sigdata) >>= fun () -> - Ok ((assertion.raw_id, pubkey), client_extensions, auth_data.user_present, auth_data.user_verified, auth_data.sign_count, auth_data.extension_data) + Ok (challenge, (assertion.raw_id, pubkey), client_extensions, auth_data.user_present, auth_data.user_verified, auth_data.sign_count, auth_data.extension_data)