works as initial version
This commit is contained in:
parent
55bb364b72
commit
9837815a5a
11 changed files with 663 additions and 127 deletions
0
CHANGES.md
Normal file
0
CHANGES.md
Normal file
0
LICENSE.md
Normal file
0
LICENSE.md
Normal file
0
README.md
Normal file
0
README.md
Normal 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);
|
||||
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,
|
||||
}
|
||||
return;
|
||||
} else {
|
||||
document.getElementById('token').value = JSON.stringify(data);
|
||||
document.getElementById('form').submit();
|
||||
}
|
||||
}
|
||||
);
|
||||
}, 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
|
||||
|
|
|
@ -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,10 +22,7 @@ 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
|
||||
|
||||
|
@ -33,7 +30,6 @@ 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 =
|
||||
let authenticated_as = Dream.session "authenticated_as" req in
|
||||
|
@ -43,44 +39,51 @@ 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) ->
|
||||
| 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) ];
|
||||
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)
|
||||
|
@ -89,7 +92,7 @@ let add_routes t =
|
|||
| 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 ((key, kh, cert) :: keys) ;
|
||||
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)
|
||||
|
@ -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
228
cbor/CBOR.ml
Normal 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
26
cbor/CBOR.mli
Normal 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
5
cbor/dune
Normal file
|
@ -0,0 +1,5 @@
|
|||
(library
|
||||
(name cbor)
|
||||
(public_name webauthn.cbor)
|
||||
(wrapped false)
|
||||
(libraries ocplib-endian))
|
2
src/dune
2
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))
|
||||
|
|
328
src/webauthn.ml
328
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)
|
||||
|
|
|
@ -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
|
||||
|
Loading…
Reference in a new issue