Welcome %s.
@@ -102,39 +103,58 @@ let register_view user challenge userid = in page script body -let authenticate_view data user = +let authenticate_view challenge credentials user = let script = Printf.sprintf {| -var request = JSON.parse('%s'); -setTimeout(function() { - u2f.sign( - request.appId, - request.challenge, - request.registeredKeys, - function(data) { - if(data.errorCode) { - switch (data.errorCode) { - case 4: - alert("This device is not registered for this account."); - break; - default: - alert("U2F failed with error code: " + data.errorCode); - } - return; - } else { - document.getElementById('token').value = JSON.stringify(data); - document.getElementById('form').submit(); - } + var request_options = { + challenge: Uint8Array.from(window.atob("%s"), c=>c.charCodeAt(0)), + allowCredentials: %s.map(x => { x.id = Uint8Array.from(window.atob(x.id), c=>c.charCodeAt(0)); return x }), + }; + navigator.credentials.get({ publicKey: request_options }) + .then(function (assertion) { + console.log(assertion); + let response = assertion.response; + let rawId = new Uint8Array(assertion.rawId); + let authenticatorData = new Uint8Array(assertion.response.authenticatorData); + let clientDataJSON = new Uint8Array(assertion.response.clientDataJSON); + let signature = new Uint8Array(assertion.response.signature); + let userHandle = assertion.response.userHandle ? new Uint8Array(assertion.response.userHandle) : null; + + var body = + JSON.stringify({ + id: assertion.id, + rawId: bufferEncode(rawId), + type: assertion.type, + response: { + authenticatorData: bufferEncode(authenticatorData), + clientDataJSON: bufferEncode(clientDataJSON), + signature: bufferEncode(signature), + userHandle: userHandle ? bufferEncode(userHandle) : null, } - ); -}, 1000); -|} data + }); + console.log(body); + + let headers = {'Content-type': "application/json; charset=utf-8"}; + + let request = new Request('/authenticate_finish', { method: 'POST', body: body, headers: headers } ); + fetch(request) + .then(function (response) { + console.log(response); + if (!response.ok) { + console.log("bad response: " + response.status); + }; + }); + }).catch(function (err) { + console.error(err); + }); + |} challenge + (Yojson.to_string (`List + (List.map (fun credential_id -> + (`Assoc ["id", `String credential_id; "type", `String "public-key"])) + credentials))) and body = Printf.sprintf {| -Touch your U2F token to authenticate as %S.
- +Touch your token to authenticate as %S.
|} user in page script body diff --git a/bin/webauthn_demo.ml b/bin/webauthn_demo.ml index 5288bcb..0a0ccf7 100644 --- a/bin/webauthn_demo.ml +++ b/bin/webauthn_demo.ml @@ -1,6 +1,6 @@ open Lwt.Infix -let users = Hashtbl.create 7 +let users : (string, (Mirage_crypto_ec.P256.Dsa.pub * string * X509.Certificate.t option) list) Hashtbl.t = Hashtbl.create 7 module KhPubHashtbl = Hashtbl.Make(struct type t = Webauthn.key_handle * Mirage_crypto_ec.P256.Dsa.pub @@ -22,17 +22,13 @@ let check_counter kh_pub counter = then KhPubHashtbl.replace counters kh_pub counter; r -let retrieve_form request = - Dream.body request >|= fun body -> - let form = Dream__pure.Formats.from_form_urlencoded body in - List.stable_sort (fun (key, _) (key', _) -> String.compare key key') form +let challenges : (string, string) Hashtbl.t = Hashtbl.create 7 let to_string err = Format.asprintf "%a" Webauthn.pp_error err let gen_data ?(pad = false) ?alphabet length = Base64.encode_string ~pad ?alphabet (Cstruct.to_string (Mirage_crypto_rng.generate length)) - let add_routes t = let main req = @@ -43,62 +39,69 @@ let add_routes t = let register req = let user = - match Dream.session "authenticated_as" req with - | None -> gen_data ~alphabet:Base64.uri_safe_alphabet 8 - | Some username -> username + (* match Dream.session "authenticated_as" req with + | None -> *) gen_data ~alphabet:Base64.uri_safe_alphabet 8 + (* | Some username -> username *) in let _key_handles = match Hashtbl.find_opt users user with | None -> [] | Some keys -> List.map (fun (_, kh, _) -> kh) keys in - (* let challenge, rr = Webauthn.register_request ~key_handles t in *) - let challenge = gen_data ~pad:true 16 - and userid = gen_data ~pad:true 16 + let challenge = Cstruct.to_string (Mirage_crypto_rng.generate 16) + and userid = Base64.encode_string user in + Hashtbl.replace challenges challenge user; Dream.put_session "challenge" challenge req >>= fun () -> - Dream.html (Template.register_view user challenge userid) + Dream.html (Template.register_view (Webauthn.rpid t) user (Base64.encode_string challenge) userid) in let register_finish req = Dream.body req >>= fun body -> Logs.info (fun m -> m "received body: %s" body); -(* let token = List.assoc "token" data in - let user = List.assoc "username" data in *) - let token = "a" and user = "b" in match Dream.session "challenge" req with | None -> Logs.warn (fun m -> m "no challenge found"); Dream.respond ~status:`Bad_Request "Bad request." | Some challenge -> - match Webauthn.register_response t challenge token with + match Webauthn.register_response t challenge 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.redirect req "/" - | Ok (key, kh, cert) -> - match Dream.session "authenticated_as" req, Hashtbl.find_opt users user with - | _, None -> - Logs.app (fun m -> m "registered %s" user); - Hashtbl.replace users user [ (key, kh, cert) ]; - Dream.invalidate_session req >>= fun () -> - Flash_message.put_flash "" - (Printf.sprintf "Successfully registered as %s! [authenticate]" user user) - req; - Dream.redirect req "/" - | Some session_user, Some keys -> - if String.equal user session_user then begin + | Ok (_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); + match Hashtbl.find_opt challenges challenge with + | None -> + Logs.warn (fun m -> m "challenge not registered"); + Dream.respond ~status:`Internal_Server_Error + "Internal server error: couldn't find user for challenge" + | Some user -> + Hashtbl.remove challenges challenge; + match Dream.session "authenticated_as" req, Hashtbl.find_opt users user with + | _, None -> Logs.app (fun m -> m "registered %s" user); - Hashtbl.replace users user ((key, kh, cert) :: keys) ; + 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.redirect req "/" - end else + | Some session_user, Some keys -> + if String.equal user session_user then begin + Logs.app (fun m -> m "registered %s" user); + Hashtbl.replace users user ((pubkey, credential_id, attestation_cert) :: keys) ; + Dream.invalidate_session req >>= fun () -> + Flash_message.put_flash "" + (Printf.sprintf "Successfully registered as %s! [authenticate]" user user) + req; + Dream.redirect req "/" + end else + Dream.respond ~status:`Forbidden "Forbidden." + | None, Some _keys -> Dream.respond ~status:`Forbidden "Forbidden." - | None, Some _keys -> - Dream.respond ~status:`Forbidden "Forbidden." in let authenticate req = @@ -108,15 +111,16 @@ let add_routes t = Logs.warn (fun m -> m "no user found"); Dream.respond ~status:`Bad_Request "Bad request." | Some keys -> - let khs = List.map (fun (_, kh, _) -> kh) keys in - let challenge, ar = Webauthn.authentication_request t khs in + let credentials = List.map (fun (_, c, _) -> Base64.encode_string c) keys in + let challenge = Cstruct.to_string (Mirage_crypto_rng.generate 16) in Dream.put_session "challenge" challenge req >>= fun () -> Dream.put_session "challenge_user" user req >>= fun () -> - Dream.html (Template.authenticate_view ar user) + Dream.html (Template.authenticate_view (Base64.encode_string challenge) credentials user) in let authenticate_finish req = - retrieve_form req >>= fun data -> + Dream.body req >>= fun body -> + Logs.info (fun m -> m "received body: %s" body); match Dream.session "challenge_user" req with | None -> Dream.respond ~status:`Internal_Server_Error "Internal server error." | Some user -> @@ -130,20 +134,19 @@ let add_routes t = Logs.warn (fun m -> m "no user found, using empty"); Dream.respond ~status:`Bad_Request "Bad request." | Some keys -> - let kh_keys = List.map (fun (key, kh, _) -> kh, key) keys in - let token = List.assoc "token" data in - match Webauthn.authentication_response t kh_keys challenge token with - | Ok (key_handle_pubkey, _user_present, counter) -> - if check_counter key_handle_pubkey counter + 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.redirect req "/" end else begin - Logs.warn (fun m -> m "key handle %S for user %S: counter not strictly increasing! \ + Logs.warn (fun m -> m "credential %S for user %S: counter not strictly increasing! \ Got %ld, expected >%ld. webauthn device compromised?" - (fst key_handle_pubkey) user counter (KhPubHashtbl.find counters key_handle_pubkey)); + (fst credential) user counter (KhPubHashtbl.find counters credential)); Flash_message.put_flash "" "Authentication failure: key compromised?" req; Dream.redirect req "/" end diff --git a/cbor/CBOR.ml b/cbor/CBOR.ml new file mode 100644 index 0000000..d57402f --- /dev/null +++ b/cbor/CBOR.ml @@ -0,0 +1,228 @@ +(** CBOR encoder/decoder, RFC 7049 *) + +open Printf +module BE = EndianBytes.BigEndian_unsafe +module SE = EndianString.BigEndian_unsafe + +exception Error of string + +let (@@) f x = f x +let (|>) x f = f x +let list_iteri f l = let i = ref 0 in List.iter (fun x -> f !i x; incr i) l +let fail fmt = ksprintf (fun s -> raise (Error s)) fmt + +module Encode = struct + +let start () = Buffer.create 10 + +let init b ~maj add = + assert (maj >= 0 && maj < 8); + assert (add >= 0 && add < 32); + Buffer.add_char b @@ char_of_int @@ (maj lsl 5) lor add + +let put_n b n f x = + let s = Bytes.create n in + f s 0 x; + Buffer.add_string b (Bytes.unsafe_to_string s) + +let max_uint32 = + match Sys.word_size with + | 32 -> max_int (* max signed int, but on 32-bit this is enough *) + | _ -> int_of_string "0xFF_FF_FF_FF" (* so that it compiles on 32-bit *) + +let put b ~maj n = + assert (n >= 0); + if n < 24 then + init b ~maj n + else if n < 256 then + begin init b ~maj 24; Buffer.add_char b @@ char_of_int n end + else if n < 65536 then + begin init b ~maj 25; put_n b 2 BE.set_int16 n end + else if n <= max_uint32 then + begin init b ~maj 26; put_n b 4 BE.set_int32 @@ Int32.of_int n end + else + begin init b ~maj 27; put_n b 8 BE.set_int64 @@ Int64.of_int n end + +let int b n = + let (maj,n) = if n < 0 then 1, -1 - n else 0, n in + put b ~maj n + +let hex_char x = + assert (x >= 0 && x < 16); + if x <= 9 then Char.chr @@ Char.code '0' + x + else Char.chr @@ Char.code 'a' + x - 10 + +let to_hex s = + let r = Bytes.create (String.length s * 2) in + for i = 0 to String.length s - 1 do + Bytes.set r (i*2) @@ hex_char @@ Char.code s.[i] lsr 4; + Bytes.set r (i*2+1) @@ hex_char @@ Char.code s.[i] land 0b1111; + done; + Bytes.to_string r + +end + +module Simple = struct + +type t = +[ `Null +| `Undefined +| `Simple of int +| `Bool of bool +| `Int of int +| `Float of float +| `Bytes of string +| `Text of string +| `Array of t list +| `Map of (t * t) list +] + +let encode item = + let open Encode in + let b = start () in + let rec write = function + | `Null -> put b ~maj:7 22; + | `Undefined -> put b ~maj:7 23; + | `Bool false -> put b ~maj:7 20; + | `Bool true -> put b ~maj:7 21; + | `Simple n when (n >= 0 && n <= 23) || (n >= 32 && n <= 255) -> put b ~maj:7 n + | `Simple n -> fail "encode: simple(%d)" n + | `Int n -> int b n + | `Float f -> init b ~maj:7 27; put_n b 8 BE.set_double f + | `Bytes s -> put b ~maj:2 (String.length s); Buffer.add_string b s + | `Text s -> put b ~maj:3 (String.length s); Buffer.add_string b s + | `Array l -> put b ~maj:4 (List.length l); List.iter write l + | `Map m -> put b ~maj:5 (List.length m); List.iter (fun (a,b) -> write a; write b) m + in + write item; + Buffer.contents b + +let need (s,i) n = + if n > String.length s || !i + n > String.length s then + fail "truncated: len %d pos %d need %d" (String.length s) !i n; + let j = !i in + i := !i + n; + j + +let get_byte (s,_ as r) = int_of_char @@ s.[need r 1] +let get_n (s,_ as r) n f = f s @@ need r n +let get_s (s,_ as r) n = String.sub s (need r n) n + +let get_additional byte1 = byte1 land 0b11111 +let is_indefinite byte1 = get_additional byte1 = 31 + +let int64_max_int = Int64.of_int max_int +let two_min_int32 = 2 * Int32.to_int Int32.min_int + +let extract_number byte1 r = + match get_additional byte1 with + | n when n < 24 -> n + | 24 -> get_byte r + | 25 -> get_n r 2 SE.get_uint16 + | 26 -> + let n = Int32.to_int @@ get_n r 4 SE.get_int32 in + if n < 0 then n - two_min_int32 else n + | 27 -> + let n = get_n r 8 SE.get_int64 in + if n > int64_max_int || n < 0L then fail "extract_number: %Lu" n; + Int64.to_int n + | n -> fail "bad additional %d" n + +let get_float16 s i = + let half = Char.code s.[i] lsl 8 + Char.code s.[i+1] in + let mant = half land 0x3ff in + let value = + match (half lsr 10) land 0x1f with (* exp *) + | 31 when mant = 0 -> infinity + | 31 -> nan + | 0 -> ldexp (float mant) ~-24 + | exp -> ldexp (float @@ mant + 1024) (exp - 25) + in + if half land 0x8000 = 0 then value else ~-. value + +exception Break + +let extract_list byte1 r f = + if is_indefinite byte1 then + let l = ref [] in + try while true do l := f r :: !l done; assert false with Break -> List.rev !l + else + let n = extract_number byte1 r in Array.to_list @@ Array.init n (fun _ -> f r) + +let rec extract_pair r = + let a = extract r in + let b = try extract r with Break -> fail "extract_pair: unexpected break" in + a,b +and extract_string byte1 r f = + if is_indefinite byte1 then + let b = Buffer.create 10 in + try while true do Buffer.add_string b (f @@ extract r) done; assert false with Break -> Buffer.contents b + else + let n = extract_number byte1 r in get_s r n +and extract r = + let byte1 = get_byte r in + match byte1 lsr 5 with + | 0 -> `Int (extract_number byte1 r) + | 1 -> `Int (-1 - extract_number byte1 r) + | 2 -> `Bytes (extract_string byte1 r (function `Bytes s -> s | _ -> fail "extract: not a bytes chunk")) + | 3 -> `Text (extract_string byte1 r (function `Text s -> s | _ -> fail "extract: not a text chunk")) + | 4 -> `Array (extract_list byte1 r extract) + | 5 -> `Map (extract_list byte1 r extract_pair) + | 6 -> let _tag = extract_number byte1 r in extract r + | 7 -> + begin match get_additional byte1 with + | n when n < 20 -> `Simple n + | 20 -> `Bool false + | 21 -> `Bool true + | 22 -> `Null + | 23 -> `Undefined + | 24 -> `Simple (get_byte r) + | 25 -> `Float (get_n r 2 get_float16) + | 26 -> `Float (get_n r 4 SE.get_float) + | 27 -> `Float (get_n r 8 SE.get_double) + | 31 -> raise Break + | a -> fail "extract: (7,%d)" a + end + | _ -> assert false + +let decode_partial s = + let i = ref 0 in + let x = try extract (s,i) with Break -> fail "decode: unexpected break" in + x, String.sub s !i (String.length s - !i) + +let decode s : t = + let x, rest = decode_partial s in + if rest = "" then x + else fail "decode: extra data: len %d pos %d" (String.length s) (String.length s - String.length rest) + +let to_diagnostic item = + let b = Buffer.create 10 in + let put = Buffer.add_string b in + let rec write = function + | `Null -> put "null" + | `Bool false -> put "false" + | `Bool true -> put "true" + | `Simple n -> bprintf b "simple(%d)" n + | `Undefined -> put "undefined" + | `Int n -> bprintf b "%d" n + | `Float f -> + begin match classify_float f with + | FP_nan -> put "NaN" + | FP_infinite -> put (if f < 0. then "-Infinity" else "Infinity") + | FP_zero | FP_normal | FP_subnormal -> bprintf b "%g" f + end + | `Bytes s -> bprintf b "h'%s'" (Encode.to_hex s) + | `Text s -> bprintf b "\"%s\"" s + | `Array l -> + put "["; + l |> list_iteri (fun i x -> if i <> 0 then put ", "; write x); + put "]" + | `Map m -> + put "{"; + m |> list_iteri (fun i (k,v) -> if i <> 0 then put ", "; write k; put ": "; write v); + put "}" + in + write item; + Buffer.contents b + +end (* Simple *) diff --git a/cbor/CBOR.mli b/cbor/CBOR.mli new file mode 100644 index 0000000..4e8f789 --- /dev/null +++ b/cbor/CBOR.mli @@ -0,0 +1,26 @@ +(** CBOR encoder/decoder, RFC 7049 *) + +exception Error of string + +module Simple : sig + +type t = +[ `Null +| `Undefined +| `Simple of int +| `Bool of bool +| `Int of int +| `Float of float +| `Bytes of string +| `Text of string +| `Array of t list +| `Map of (t * t) list +] + +val encode : t -> string +val decode : string -> t +val decode_partial : string -> t * string + +val to_diagnostic : t -> string + +end diff --git a/cbor/dune b/cbor/dune new file mode 100644 index 0000000..e16f80f --- /dev/null +++ b/cbor/dune @@ -0,0 +1,5 @@ +(library + (name cbor) + (public_name webauthn.cbor) + (wrapped false) + (libraries ocplib-endian)) diff --git a/src/dune b/src/dune index ab6bf5c..4efe4a7 100644 --- a/src/dune +++ b/src/dune @@ -3,4 +3,4 @@ (public_name webauthn) (preprocess (pps ppx_deriving_yojson)) - (libraries mirage-crypto-rng yojson mirage-crypto-ec x509 base64)) + (libraries mirage-crypto-rng yojson mirage-crypto-ec x509 base64 webauthn.cbor)) diff --git a/src/webauthn.ml b/src/webauthn.ml index d0db745..4875566 100644 --- a/src/webauthn.ml +++ b/src/webauthn.ml @@ -1,29 +1,44 @@ type key_handle = string type error = [ - `None + | `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 + | `Rpid_hash_mismatch of Cstruct.t * Cstruct.t + | `Missing_credential_data + | `Msg of string + | `None ] -let pp_error _ppf _e = () +let pp_error ppf = function + | `Json_decoding (ctx, msg, json) -> + 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) -> + Fmt.pf ppf "origin mismatch: expected %s, received %s" should is + | `Attestation_object msg -> + Fmt.pf ppf "attestation object error %s" msg + | `Rpid_hash_mismatch (should, is) -> + Fmt.pf ppf "rpid hash mismatch: expected %a received %a" Cstruct.hexdump_pp should Cstruct.hexdump_pp is + | `Missing_credential_data -> Fmt.string ppf "missing credential data" + | `Msg msg -> Fmt.pf ppf "error %s" msg + | `None -> Fmt.string ppf "error none" -type t = unit +type t = { + origin : string; +} type challenge = string -type typ = Public_key [@name "public-key"] -[@@deriving yojson] - -type response_raw = { - attestation_object : string [@key "attestationObject"]; - client_data_json : string [@key "clientDataJSON"]; -} [@@deriving of_yojson] - -type attestation_raw = { - id : string; - raw_id : string [@key "rawId"]; - typ : typ [@key "type"]; - response : response_raw; -} [@@deriving of_yojson] +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) @@ -34,15 +49,280 @@ let b64_dec thing s = (function `Msg m -> `Base64_decoding (thing, m, s)) Base64.(decode ~pad:false ~alphabet:uri_safe_alphabet s) -let _ = ignore b64_enc; ignore b64_dec +let guard p e = if p then Ok () else Error e -let create _app = () +let (>>=) v f = match v with Ok v -> f v | Error _ as e -> e -let register_request ?key_handles:_ _t = "foo", "bar" +type base64url_string = string +let base64url_string_of_yojson = function + | `String b64 -> + Base64.(decode ~pad:false ~alphabet:uri_safe_alphabet b64) + |> Result.map_error (function `Msg m -> m) + | _ -> Error "base64url_string" +let base64url_string_to_yojson s = + `String Base64.(encode_string ~pad:false ~alphabet:uri_safe_alphabet s) -let register_response _t _challenge _data = Error `None +type typ = Public_key -let authentication_request _t _handles = "foo", "bar" +let typ_of_yojson = function + | `String "public-key" -> Ok Public_key + | _ -> Error "typ" -let authentication_response _t _handles _challenges _data = - Error `None +let typ_to_yojson Public_key = `String "public-key" + +let extract_k_i map k : (_, string) result = + Option.to_result ~none:"key not present" + (Option.map snd + (List.find_opt (fun (l, _) -> match l with `Int i -> i = k | _ -> false) map)) + +let extract_k_str map k = + Option.to_result ~none:"key not present" + (Option.map snd + (List.find_opt (fun (l, _) -> match l with `Text s -> s = k | _ -> false) map)) + +let extract_int = function + | `Int i -> Ok i + | _ -> Error "not an integer" + +let extract_bytes = function + | `Bytes b -> Ok b + | _ -> Error "not a bytes" + +let extract_map = function + | `Map b -> Ok b + | _ -> Error "not a map" + +let extract_array = function + | `Array b -> Ok b + | _ -> Error "not an array" + +let extract_text = function + | `Text s -> Ok s + | _ -> Error "not a text" + +let cose_pubkey cbor_data = + extract_map cbor_data >>= fun kv -> + extract_k_i kv 1 >>= extract_int >>= fun kty -> + guard (kty = 2) "unknown key type" >>= fun () -> + extract_k_i kv 3 >>= extract_int >>= fun alg -> + guard (alg = -7) "unknown algorithm" >>= fun () -> + extract_k_i kv (-1) >>= extract_int >>= fun crv -> + guard (crv = 1) "unknown elliptic curve" >>= fun () -> + extract_k_i kv (-2) >>= extract_bytes >>= fun x -> + extract_k_i kv (-3) >>= extract_bytes >>= fun y -> + let four = Cstruct.create 1 in Cstruct.set_uint8 four 0 4; + let cs = Cstruct.concat [ four ; Cstruct.of_string x ; Cstruct.of_string y ] in + Result.map_error (Fmt.to_to_string Mirage_crypto_ec.pp_error) + (Mirage_crypto_ec.P256.Dsa.pub_of_cstruct cs) + +let parse_attested_credential_data data = + guard (Cstruct.length data >= 18) "too short" >>= fun () -> + let aaguid = Cstruct.sub data 0 16 in + let cid_len = Cstruct.BE.get_uint16 data 16 in + let rest = Cstruct.shift data 18 in + guard (Cstruct.length rest >= cid_len) "too short" >>= fun () -> + let cid, pubkey = Cstruct.split rest cid_len in + (try Ok (CBOR.Simple.decode_partial (Cstruct.to_string pubkey)) + with CBOR.Error m -> Error m) >>= fun (pubkey, rest) -> + cose_pubkey pubkey >>= fun pubkey -> + Ok ((aaguid, cid, pubkey), Cstruct.of_string rest) + +let parse_extension_data data = + (try Ok (CBOR.Simple.decode_partial (Cstruct.to_string data)) + with CBOR.Error m -> Error m) >>= fun (data, rest) -> + extract_map data >>= fun kv -> + Ok (kv, Cstruct.of_string rest) + +type auth_data = { + rpid_hash : Cstruct.t ; + user_present : bool ; + user_verified : bool ; + sign_count : Int32.t ; + attested_credential_data : (Cstruct.t * Cstruct.t * Mirage_crypto_ec.P256.Dsa.pub) option ; + extension_data : (CBOR.Simple.t * CBOR.Simple.t) list option ; +} + +let flags byte = + let b i = byte land (1 lsl i) <> 0 in + b 0, b 2, b 6, b 7 + +let parse_auth_data data = + let data = Cstruct.of_string data in + guard (Cstruct.length data >= 37) "too short" >>= fun () -> + let rpid_hash = Cstruct.sub data 0 32 in + let user_present, user_verified, attested_data_included, extension_data_included = + flags (Cstruct.get_uint8 data 32) + in + let sign_count = Cstruct.BE.get_uint32 data 33 in + let rest = Cstruct.shift data 37 in + (if attested_data_included then + Result.map (fun (d, r) -> Some d, r) (parse_attested_credential_data rest) + else Ok (None, rest)) >>= fun (attested_credential_data, rest) -> + (if extension_data_included then + Result.map (fun (d, r) -> Some d, r) (parse_extension_data rest) + else Ok (None, rest)) >>= fun (extension_data, rest) -> + guard (Cstruct.length rest = 0) "too long" >>= fun () -> + Ok { rpid_hash ; user_present ; user_verified ; sign_count ; attested_credential_data ; extension_data } + +let parse_attestation_statement fmt data = + match fmt with + | "none" -> if data = [] then Ok None else Error "bad attestation data (format = none, map must be empty)" + | "fido-u2f" -> + extract_k_str data "x5c" >>= extract_array >>= fun cert -> + extract_k_str data "sig" >>= extract_bytes >>= fun signature -> + begin match cert with + | [ c ] -> + extract_bytes c >>= fun c -> + Result.map_error (fun (`Msg m) -> m) (X509.Certificate.decode_der (Cstruct.of_string c)) + | _ -> Error "expected single certificate" + end >>= fun cert -> + Ok (Some (cert, signature)) + | _ -> Error "bad attestation format" + +let parse_attestation_object data = + match CBOR.Simple.decode data with + | `Map kv -> + extract_k_str kv "fmt" >>= extract_text >>= fun fmt -> + guard (fmt = "none" || fmt = "fido-u2f") "unsupported format" >>= fun () -> + extract_k_str kv "authData" >>= extract_bytes >>= fun auth_data -> + extract_k_str kv "attStmt" >>= extract_map >>= fun attestation_statement -> + parse_auth_data auth_data >>= fun auth_data -> + parse_attestation_statement fmt attestation_statement >>= fun attestation_statement -> + Ok (auth_data, attestation_statement) + | _ -> Error "bad attestationObject CBOR" + | exception CBOR.Error m -> Error m + +type response_raw = { + attestation_object : base64url_string [@key "attestationObject"]; + client_data_json : base64url_string [@key "clientDataJSON"]; +} [@@deriving of_yojson] + +type public_key_credential_raw = { + id : string; + raw_id : base64url_string [@key "rawId"]; + typ : typ [@key "type"]; + response : response_raw; +} [@@deriving of_yojson] + +let of_json_or_err thing p json = + lift_err + (fun msg -> `Json_decoding (thing, msg, Yojson.Safe.to_string json)) + (p json) + +let of_json thing p s = + (try Ok (Yojson.Safe.from_string s) + with Yojson.Json_error msg -> + Error (`Json_decoding (thing, msg, s))) >>= + of_json_or_err thing p + +let json_get member = function + | `Assoc kv as json -> + List.assoc_opt member kv + |> Option.to_result ~none:(`Json_decoding (member, "missing key", Yojson.Safe.to_string json)) + | json -> Error (`Json_decoding (member, "non-object", Yojson.Safe.to_string json)) + +let json_string thing : Yojson.Safe.t -> (string, _) result = function + | `String s -> Ok s + | json -> Error (`Json_decoding (thing, "non-string", Yojson.Safe.to_string json)) + +let create origin = { origin } + +let rpid t = + match String.split_on_char '/' t.origin with + | [ _protocol ; "" ; host ] -> host + | _ -> assert false + +let register_response t challenge data = + of_json "response" public_key_credential_raw_of_yojson data >>= fun credential -> + (* XXX: credential.getClientExtensionResults() *) + let response = credential.response in + let client_data_hash = Mirage_crypto.Hash.SHA256.digest + (Cstruct.of_string response.client_data_json) in + begin try Ok (Yojson.Safe.from_string response.client_data_json) + with Yojson.Json_error msg -> + Error (`Json_decoding ("clientDataJSON", msg, response.client_data_json)) + end >>= fun client_data -> + json_get "type" client_data >>= json_string "type" >>= + (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 "origin" client_data >>= json_string "origin" >>= fun origin -> + guard (String.equal t.origin origin) + (`Origin_mismatch (t.origin, origin)) >>= fun () -> + json_get "clientExtensions" client_data >>= fun client_extensions -> + Result.map_error (fun m -> `Attestation_object m) + (parse_attestation_object response.attestation_object) >>= fun (auth_data, attestation_statement) -> + let rpid_hash = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string (rpid t)) in + guard (Cstruct.equal auth_data.rpid_hash rpid_hash) + (`Rpid_hash_mismatch (rpid_hash, auth_data.rpid_hash)) >>= fun () -> + (* verify user present, user verified flags in auth_data.flags *) + Option.to_result ~none:`Missing_credential_data + auth_data.attested_credential_data >>= fun (aaguid, credential_id, pubkey) -> + begin match attestation_statement with + | None -> Ok None + | Some (cert, signature) -> + let pub_cs = Mirage_crypto_ec.P256.Dsa.pub_to_cstruct pubkey in + let sigdata = Cstruct.concat [ + Cstruct.create 1 ; rpid_hash ; client_data_hash ; credential_id ; pub_cs + ] in + let pk = X509.Certificate.public_key cert + and signature = Cstruct.of_string signature + in + X509.Public_key.verify `SHA256 ~signature pk (`Message sigdata) >>= fun () -> + Ok (Some cert) + 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) + +type auth_response_raw = { + authenticator_data : base64url_string [@key "authenticatorData"]; + client_data_json : base64url_string [@key "clientDataJSON"]; + signature : base64url_string ; + userHandle : base64url_string option ; +} [@@deriving of_yojson] + +type auth_assertion_raw = { + id : string; + raw_id : base64url_string [@key "rawId"]; + typ : typ [@key "type"]; + response : auth_response_raw; +} [@@deriving of_yojson] + +let authentication_response t cid_keys challenge 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 + (Cstruct.of_string response.client_data_json) in + begin try Ok (Yojson.Safe.from_string response.client_data_json) + with Yojson.Json_error msg -> + Error (`Json_decoding ("clientDataJSON", msg, response.client_data_json)) + end >>= fun client_data -> + json_get "type" client_data >>= json_string "type" >>= + (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 "origin" client_data >>= json_string "origin" >>= fun origin -> + guard (String.equal t.origin origin) + (`Origin_mismatch (t.origin, origin)) >>= fun () -> + json_get "clientExtensions" client_data >>= fun client_extensions -> + Result.map_error (fun m -> `Msg m) + (parse_auth_data response.authenticator_data) >>= fun auth_data -> + let rpid_hash = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string (rpid t)) in + guard (Cstruct.equal auth_data.rpid_hash rpid_hash) + (`Rpid_hash_mismatch (rpid_hash, auth_data.rpid_hash)) >>= fun () -> + Option.to_result ~none:(`Msg "no key found") + (List.assoc_opt assertion.raw_id cid_keys) >>= fun pubkey -> + let sigdata = Cstruct.concat [ Cstruct.of_string response.authenticator_data ; client_data_hash ] + 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) diff --git a/src/webauthn.mli b/src/webauthn.mli deleted file mode 100644 index 1f84ed1..0000000 --- a/src/webauthn.mli +++ /dev/null @@ -1,26 +0,0 @@ -type key_handle = string - -type error - -val pp_error : Format.formatter -> error -> unit - -type t - -val create : string -> t - -type challenge = string - -val register_request : ?key_handles:key_handle list -> t -> challenge * string - -val register_response : t -> challenge -> string -> - (Mirage_crypto_ec.P256.Dsa.pub * key_handle * X509.Certificate.t, - error) result - -val authentication_request : t -> key_handle list -> - challenge * string - -val authentication_response : t -> - (key_handle * Mirage_crypto_ec.P256.Dsa.pub) list -> - challenge -> string -> - ((key_handle * Mirage_crypto_ec.P256.Dsa.pub) * bool * int32, error) result -