214 lines
7.9 KiB
OCaml
214 lines
7.9 KiB
OCaml
|
open Lwt.Infix
|
||
|
|
||
|
let users = Hashtbl.create 7
|
||
|
|
||
|
module KhPubHashtbl = Hashtbl.Make(struct
|
||
|
type t = Webauthn.key_handle * Mirage_crypto_ec.P256.Dsa.pub
|
||
|
let cs_of_pub = Mirage_crypto_ec.P256.Dsa.pub_to_cstruct
|
||
|
let equal (kh, pub) (kh', pub') =
|
||
|
String.equal kh kh' && Cstruct.equal (cs_of_pub pub) (cs_of_pub pub')
|
||
|
let hash (kh, pub) = Hashtbl.hash (kh, Cstruct.to_string (cs_of_pub pub ))
|
||
|
end)
|
||
|
|
||
|
let counters = KhPubHashtbl.create 7
|
||
|
|
||
|
let check_counter kh_pub counter =
|
||
|
let r =
|
||
|
match KhPubHashtbl.find_opt counters kh_pub with
|
||
|
| Some counter' -> Int32.unsigned_compare counter counter' > 0
|
||
|
| None -> true
|
||
|
in
|
||
|
if r
|
||
|
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 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 =
|
||
|
let authenticated_as = Dream.session "authenticated_as" req in
|
||
|
let flash = Flash_message.get_flash req |> List.map snd in
|
||
|
Dream.html (Template.overview flash authenticated_as users)
|
||
|
in
|
||
|
|
||
|
let register req =
|
||
|
let user =
|
||
|
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
|
||
|
in
|
||
|
Dream.put_session "challenge" challenge req >>= fun () ->
|
||
|
Dream.html (Template.register_view user 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
|
||
|
| 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
|
||
|
Logs.app (fun m -> m "registered %s" user);
|
||
|
Hashtbl.replace users user ((key, kh, 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."
|
||
|
in
|
||
|
|
||
|
let authenticate req =
|
||
|
let user = Dream.param "user" req in
|
||
|
match Hashtbl.find_opt users user with
|
||
|
| None ->
|
||
|
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
|
||
|
Dream.put_session "challenge" challenge req >>= fun () ->
|
||
|
Dream.put_session "challenge_user" user req >>= fun () ->
|
||
|
Dream.html (Template.authenticate_view ar user)
|
||
|
in
|
||
|
|
||
|
let authenticate_finish req =
|
||
|
retrieve_form req >>= fun data ->
|
||
|
match Dream.session "challenge_user" req with
|
||
|
| None -> Dream.respond ~status:`Internal_Server_Error "Internal server error."
|
||
|
| Some user ->
|
||
|
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 Hashtbl.find_opt users user with
|
||
|
| None ->
|
||
|
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
|
||
|
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! \
|
||
|
Got %ld, expected >%ld. webauthn device compromised?"
|
||
|
(fst key_handle_pubkey) user counter (KhPubHashtbl.find counters key_handle_pubkey));
|
||
|
Flash_message.put_flash "" "Authentication failure: key compromised?" req;
|
||
|
Dream.redirect req "/"
|
||
|
end
|
||
|
| Error e ->
|
||
|
Logs.warn (fun m -> m "error %a" Webauthn.pp_error e);
|
||
|
let err = to_string e in
|
||
|
Flash_message.put_flash "" ("Authentication failure: " ^ err) req;
|
||
|
Dream.redirect req "/"
|
||
|
in
|
||
|
|
||
|
let logout req =
|
||
|
Dream.invalidate_session req >>= fun () ->
|
||
|
Dream.redirect req "/"
|
||
|
in
|
||
|
|
||
|
let base64 _req =
|
||
|
Dream.respond ~headers:[("Content-type", "application/javascript")]
|
||
|
[%blob "base64.js"]
|
||
|
in
|
||
|
|
||
|
Dream.router [
|
||
|
Dream.get "/" main;
|
||
|
Dream.get "/register" register;
|
||
|
Dream.post "/register_finish" register_finish;
|
||
|
Dream.get "/authenticate/:user" authenticate;
|
||
|
Dream.post "/authenticate_finish" authenticate_finish;
|
||
|
Dream.post "/logout" logout;
|
||
|
Dream.get "/static/base64.js" base64;
|
||
|
]
|
||
|
|
||
|
|
||
|
let setup_app level port host application_id https =
|
||
|
let webauthn = Webauthn.create application_id in
|
||
|
let level = match level with None -> None | Some Logs.Debug -> Some `Debug | Some Info -> Some `Info | Some Warning -> Some `Warning | Some Error -> Some `Error | Some App -> None in
|
||
|
Dream.initialize_log ?level ();
|
||
|
Dream.run ~port ~interface:host ~https
|
||
|
@@ Dream.logger
|
||
|
@@ Dream.memory_sessions
|
||
|
@@ Flash_message.flash_messages
|
||
|
@@ add_routes webauthn
|
||
|
@@ Dream.not_found
|
||
|
|
||
|
open Cmdliner
|
||
|
|
||
|
let port =
|
||
|
let doc = "port" in
|
||
|
Arg.(value & opt int 5000 & info [ "p"; "port" ] ~doc)
|
||
|
|
||
|
let host =
|
||
|
let doc = "host" in
|
||
|
Arg.(value & opt string "0.0.0.0" & info [ "h"; "host" ] ~doc)
|
||
|
|
||
|
let application_id =
|
||
|
let doc = "the webauthn application id - usually protocol://host(:port)" in
|
||
|
Arg.(value & opt string "https://webauthn-demo.robur.coop" & info [ "application-id" ] ~doc)
|
||
|
|
||
|
let tls =
|
||
|
let doc = "tls" in
|
||
|
Arg.(value & flag & info [ "tls" ] ~doc)
|
||
|
|
||
|
let () =
|
||
|
let term = Term.(pure setup_app $ Logs_cli.level () $ port $ host $ application_id $ tls) in
|
||
|
let info = Term.info "Webauthn app" ~doc:"Webauthn app" ~man:[] in
|
||
|
match Term.eval (term, info) with
|
||
|
| `Ok () -> exit 0
|
||
|
| `Error _ -> exit 1
|
||
|
| _ -> exit 0
|