robur/webauthn
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

works as initial version

Browse source
This commit is contained in:
Robur 2021-09-29 14:34:09 +00:00
parent 55bb364b72
commit 9837815a5a
11 changed files with 663 additions and 127 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

0
CHANGES.md Normal file
View file

0
LICENSE.md Normal file
View file

0
README.md Normal file
View file

84
bin/template.ml
View file

@ -37,12 +37,12 @@ let overview notes authenticated_as users =
in
page "" (String.concat "" (notes @ [authenticated_as;links;users]))
let register_view user challenge userid =
let register_view origin user challenge userid =
let script = Printf.sprintf {|
var publicKey = {
challenge: Uint8Array.from(window.atob("%s"), c=>c.charCodeAt(0)),
rp: {
id: "webauthn-demo.robur.coop",
id: "%s",
name: "WebAuthn Demo from robur.coop"
},
user: {
@ -55,7 +55,8 @@ let register_view user challenge userid =
type: "public-key",
alg: -7
}
]
],
attestation: "direct"
};
navigator.credentials.create({ publicKey })
.then(function (credential) {
@ -94,7 +95,7 @@ let register_view user challenge userid =
}).catch(function (err) {
console.error(err);
});
|} challenge userid user user
|} challenge origin userid user user
and body =
Printf.sprintf {|
<p>Welcome %s.</p>
@ -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 {|
<p>Touch your U2F token to authenticate as %S.</p>
<form method="POST" action="/authenticate_finish" id="form">
<input type="hidden" name="token" id="token"/>
</form>
<p>Touch your token to authenticate as %S.</p>
|} user
in
page script body

91
bin/webauthn_demo.ml
View file

@ -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! <a href=\"/authenticate/%s\">[authenticate]</a>" 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! <a href=\"/authenticate/%s\">[authenticate]</a>" 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! <a href=\"/authenticate/%s\">[authenticate]</a>" 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

228
cbor/CBOR.ml Normal file
View file

@ -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 *)

26
cbor/CBOR.mli Normal file
View file

@ -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

5
cbor/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name cbor)
(public_name webauthn.cbor)
(wrapped false)
(libraries ocplib-endian))

2
src/dune
View file

@ -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))

328
src/webauthn.ml
View file

@ -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)

26
src/webauthn.mli
View file

@ -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