Update to dream.1.0.0~alpha4 and cmdliner>=1.1.0

This commit is contained in:
Reynir Björnsson 2023-02-17 09:45:27 +01:00
parent 18e5babfde
commit 2c2a7a9038
3 changed files with 18 additions and 21 deletions

View file

@ -74,7 +74,7 @@ let add_routes t =
in in
let registration_challenge req = let registration_challenge req =
let user = Dream.param "user" req in let user = Dream.param req "user" in
let challenge, challenge_b64 = Webauthn.generate_challenge () in let challenge, challenge_b64 = Webauthn.generate_challenge () in
let userid, credentials = match find_username user with let userid, credentials = match find_username user with
| None -> gen_data ~alphabet:Base64.uri_safe_alphabet 8, [] | None -> gen_data ~alphabet:Base64.uri_safe_alphabet 8, []
@ -100,7 +100,7 @@ let add_routes t =
in in
let register_finish req = let register_finish req =
let userid = Dream.param "userid" req in let userid = Dream.param req "userid" in
Dream.body req >>= fun body -> Dream.body req >>= fun body ->
Logs.debug (fun m -> m "received body: %s" body); Logs.debug (fun m -> m "received body: %s" body);
match Hashtbl.find_opt registration_challenges userid with match Hashtbl.find_opt registration_challenges userid with
@ -168,7 +168,7 @@ let add_routes t =
in in
let authenticate req = let authenticate req =
let userid = Dream.param "userid" req in let userid = Dream.param req "userid" in
match Hashtbl.find_opt users userid with match Hashtbl.find_opt users userid with
| None -> | None ->
Logs.warn (fun m -> m "no user found"); Logs.warn (fun m -> m "no user found");
@ -182,8 +182,8 @@ let add_routes t =
in in
let authenticate_finish req = let authenticate_finish req =
let userid = Dream.param "userid" req let userid = Dream.param req "userid"
and b64_credential_id = Dream.param "credential_id" req and b64_credential_id = Dream.param req "credential_id"
in in
match Base64.decode ~alphabet:Base64.uri_safe_alphabet ~pad:false b64_credential_id with match Base64.decode ~alphabet:Base64.uri_safe_alphabet ~pad:false b64_credential_id with
| Error `Msg err -> | Error `Msg err ->
@ -262,18 +262,17 @@ let add_routes t =
] ]
let setup_app level port host origin https = let setup_app level port host origin tls =
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 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.initialize_log ?level ();
match Webauthn.create origin with match Webauthn.create origin with
| Error e -> Logs.err (fun m -> m "failed to create webauthn: %s" e); exit 1 | Error e -> Logs.err (fun m -> m "failed to create webauthn: %s" e); exit 1
| Ok webauthn -> | Ok webauthn ->
Dream.run ~port ~interface:host ~https Dream.run ~port ~interface:host ~tls
@@ Dream.logger @@ Dream.logger
@@ Dream.memory_sessions @@ Dream.memory_sessions
@@ Flash_message.flash_messages @@ Flash_message.flash_messages
@@ add_routes webauthn @@ add_routes webauthn
@@ Dream.not_found
open Cmdliner open Cmdliner
@ -294,9 +293,6 @@ let tls =
Arg.(value & flag & info [ "tls" ] ~doc) Arg.(value & flag & info [ "tls" ] ~doc)
let () = let () =
let term = Term.(pure setup_app $ Logs_cli.level () $ port $ host $ origin $ tls) in let term = Term.(const setup_app $ Logs_cli.level () $ port $ host $ origin $ tls) in
let info = Term.info "Webauthn app" ~doc:"Webauthn app" ~man:[] in let info = Cmd.info "Webauthn app" ~doc:"Webauthn app" ~man:[] in
match Term.eval (term, info) with exit (Cmd.eval (Cmd.v info term))
| `Ok () -> exit 0
| `Error _ -> exit 1
| _ -> exit 0

View file

@ -3,7 +3,7 @@ open Lwt.Syntax
let five_minutes = 5. *. 60. let five_minutes = 5. *. 60.
let storage = Dream.new_local ~name:"dream.flash_message" () let storage = Dream.new_field ~name:"dream.flash_message" ()
let flash_cookie = "dream.flash_message" let flash_cookie = "dream.flash_message"
@ -11,13 +11,14 @@ let flash_cookie = "dream.flash_message"
let flash_messages inner_handler request = let flash_messages inner_handler request =
let outbox = ref [] in let outbox = ref [] in
let request = Dream.with_local storage outbox request in Dream.set_field request storage outbox;
let* response = inner_handler request in let* response = inner_handler request in
Lwt.return( Lwt.return(
let entries = List.rev !outbox in let entries = List.rev !outbox in
let content = List.fold_right (fun (x,y) a -> `String x :: `String y :: a) entries [] in let content = List.fold_right (fun (x,y) a -> `String x :: `String y :: a) entries [] in
let value = `List content |> Yojson.Basic.to_string in let value = `List content |> Yojson.Basic.to_string in
Dream.set_cookie flash_cookie value request response ~max_age:five_minutes Dream.set_cookie response request flash_cookie value ~max_age:five_minutes;
response
) )
@ -33,7 +34,7 @@ let get_flash request =
let unpack u = match u with let unpack u = match u with
| `String x -> x | `String x -> x
| _ -> failwith "Bad flash message content" in | _ -> failwith "Bad flash message content" in
let x = Dream.cookie flash_cookie request let x = Dream.cookie request flash_cookie
|>? fun value -> |>? fun value ->
match Yojson.Basic.from_string value with match Yojson.Basic.from_string value with
| `List y -> Some (group @@ List.map unpack y) | `List y -> Some (group @@ List.map unpack y)
@ -42,7 +43,7 @@ let get_flash request =
let put_flash category message request = let put_flash category message request =
let outbox = match Dream.local storage request with let outbox = match Dream.field request storage with
| Some outbox -> outbox | Some outbox -> outbox
| None -> | None ->
let message = "Missing flash message middleware" in let message = "Missing flash message middleware" in

View file

@ -16,9 +16,9 @@ build: [
depends: [ depends: [
"ocaml" {>= "4.08.0"} "ocaml" {>= "4.08.0"}
"dune" {>= "2.7"} "dune" {>= "2.7"}
"dream" {dev & >= "1.0.0~alpha2"} "dream" {dev & >= "1.0.0~alpha4"}
"ppx_blob" {dev} "ppx_blob" {dev}
"cmdliner" {dev} "cmdliner" {dev & >= "1.1.0"}
"logs" {dev} "logs" {dev}
"lwt" {dev} "lwt" {dev}
"yojson" "yojson"