works as initial version

bin/template.ml

@@ -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');
+    var request_options = {
-setTimeout(function() {
+        challenge: Uint8Array.from(window.atob("%s"), c=>c.charCodeAt(0)),
-        u2f.sign(
+        allowCredentials: %s.map(x => { x.id = Uint8Array.from(window.atob(x.id), c=>c.charCodeAt(0)); return x }),
-            request.appId,
+    };
-            request.challenge,
+    navigator.credentials.get({ publicKey: request_options })
-            request.registeredKeys,
+      .then(function (assertion) {
-            function(data) {
+        console.log(assertion);
-                if(data.errorCode) {
+        let response = assertion.response;
-                    switch (data.errorCode) {
+        let rawId = new Uint8Array(assertion.rawId);
-                        case 4:
+        let authenticatorData = new Uint8Array(assertion.response.authenticatorData);
-                            alert("This device is not registered for this account.");
+        let clientDataJSON = new Uint8Array(assertion.response.clientDataJSON);
-                            break;
+        let signature = new Uint8Array(assertion.response.signature);
-                        default:
+        let userHandle = assertion.response.userHandle ? new Uint8Array(assertion.response.userHandle) : null;
-                            alert("U2F failed with error code: " + data.errorCode);
+ 
-                    }
+        var body =
-                    return;
+          JSON.stringify({
-                } else {
+            id: assertion.id,
-                    document.getElementById('token').value = JSON.stringify(data);
+            rawId: bufferEncode(rawId),
-                    document.getElementById('form').submit();
+            type: assertion.type,
-                }
+            response: {
+              authenticatorData: bufferEncode(authenticatorData),
+              clientDataJSON: bufferEncode(clientDataJSON),
+              signature: bufferEncode(signature),
+              userHandle: userHandle ? bufferEncode(userHandle) : null,
             }
-        );
+           });
-}, 1000);
+        console.log(body);
-|} data
+
+        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>
+      <p>Touch your token to authenticate as %S.</p>
-      <form method="POST" action="/authenticate_finish" id="form">
-         <input type="hidden" name="token" id="token"/>
-      </form>
 |} user
   in
   page script body

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 =
+let challenges : (string, string) Hashtbl.t = Hashtbl.create 7
-  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 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
+      (* match Dream.session "authenticated_as" req with
-      | None -> gen_data ~alphabet:Base64.uri_safe_alphabet 8
+      | None -> *) gen_data ~alphabet:Base64.uri_safe_alphabet 8
-      | Some username -> username
+      (* | 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 = Cstruct.to_string (Mirage_crypto_rng.generate 16)
-    let challenge = gen_data ~pad:true 16
+    and userid = Base64.encode_string user
-    and userid = gen_data ~pad:true 16
     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,
-        match Dream.session "authenticated_as" req, Hashtbl.find_opt users user with
+            user_verified, sig_count, _authenticator_extensions, attestation_cert) ->
-        | _, None ->
+        ignore (check_counter (credential_id, pubkey) sig_count);
-          Logs.app (fun m -> m "registered %s" user);
+        Logs.info (fun m -> m "user present %B user verified %B" user_present user_verified);
-          Hashtbl.replace users user [ (key, kh, cert) ];
+        match Hashtbl.find_opt challenges challenge with
-          Dream.invalidate_session req >>= fun () ->
+        | None ->
-          Flash_message.put_flash ""
+          Logs.warn (fun m -> m "challenge not registered");
-            (Printf.sprintf "Successfully registered as %s! <a href=\"/authenticate/%s\">[authenticate]</a>" user user)
+          Dream.respond ~status:`Internal_Server_Error
-            req;
+            "Internal server error: couldn't find user for challenge"
-          Dream.redirect req "/"
+        | Some user ->
-        | Some session_user, Some keys ->
+          Hashtbl.remove challenges challenge;
-          if String.equal user session_user then begin
+          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 credentials = List.map (fun (_, c, _) -> Base64.encode_string c) keys in
-      let challenge, ar = Webauthn.authentication_request t khs 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 cid_keys = List.map (fun (key, credential_id, _) -> credential_id, key) keys in
-          let token = List.assoc "token" data in
+          match Webauthn.authentication_response t cid_keys challenge body with
-          match Webauthn.authentication_response t kh_keys challenge token with
+          | Ok (credential, _client_extensions, _user_present, _user_verified, counter, _authenticator_extensions) ->
-          | Ok (key_handle_pubkey, _user_present, counter) ->
+            if check_counter credential counter
-            if check_counter key_handle_pubkey 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

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

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

cbor/dune

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

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

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"]
+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"}}|}
-[@@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 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 =
+let typ_to_yojson Public_key = `String "public-key"
-  Error `None
+
+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)

src/webauthn.mli

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