Merge pull request 'Update to dream.1.0.0~alpha4 and cmdliner>=1.1.0' (#5) from update-example into main

Reviewed-on: https://git.robur.io/robur/webauthn/pulls/5

bin/webauthn_demo.ml

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

flash_message/flash_message.ml

@@ -3,7 +3,7 @@ open Lwt.Syntax
 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"
@@ -11,13 +11,14 @@ let flash_cookie = "dream.flash_message"
 
 let flash_messages inner_handler request =
   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
   Lwt.return(
     let entries = List.rev !outbox 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
-    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
       | `String x -> x
       | _ -> failwith "Bad flash message content" in
-  let x = Dream.cookie flash_cookie request
+  let x = Dream.cookie request flash_cookie
           |>? fun value ->
           match Yojson.Basic.from_string value with
           | `List y -> Some (group @@ List.map unpack y)
@@ -42,7 +43,7 @@ let get_flash 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
   | None ->
     let message = "Missing flash message middleware" in

webauthn.opam

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