aantron · aantron · Jun 7, 2021 · May 24, 2021 · May 26, 2021 · May 27, 2021
diff --git a/example/b-flash-message/dune b/example/b-flash-message/dune
@@ -0,0 +1,11 @@
+(executable
+ (name flash_message)
+ (libraries dream tyxml)
+ (preprocess (pps lwt_ppx)))
+
+(rule
+ (targets flash_message.ml)
+ (deps flash_message.eml.ml)
+ (action (run dream_eml %{deps} --workspace %{workspace_root})))
+
+(data_only_dirs _esy esy.lock)
diff --git a/example/b-flash-message/dune-project b/example/b-flash-message/dune-project
@@ -0,0 +1 @@
+(lang dune 2.0)
diff --git a/example/b-flash-message/esy.json b/example/b-flash-message/esy.json
@@ -0,0 +1,13 @@
+{
+  "dependencies": {
+    "@opam/dream": "1.0.0~alpha2",
+    "@opam/dune": "^2.0",
+    "ocaml": "4.12.x"
+  },
+  "resolutions": {
+    "@opam/conf-libev": "esy-packages/libev:package.json#0b5eb6685b688649045aceac55dc559f6f21b829"
+  },
+  "scripts": {
+    "start": "dune exec --root . ./flash_message.exe"
+  }
+}
diff --git a/example/b-flash-message/flash_message.eml.ml b/example/b-flash-message/flash_message.eml.ml
@@ -0,0 +1,55 @@
+let input_form request =
+  <html>
+    <body>
+      Enter some text:
+      <%s! Dream.form_tag ~action:"/" request %>
+        <input name="text" autofocus>
+      </form>
+    </body>
+  </html>
+
+
+let results_page messages text =
+  let open Tyxml.Html in
+  let to_p (category, msg) = p [txt (category ^ " : " ^ msg)] in
+  html ( head (title (txt "Flash Messages Demo")) [] )
+    ( body @@
+        List.map to_p messages @
+        [p [txt @@ Option.value text ~default:""]]
+    )
+
+
+let html_to_string html =
+  Format.asprintf "%a" (Tyxml.Html.pp ()) html
+
+
+let () =
+  Dream.run
+  @@ Dream.logger
+  @@ Dream.memory_sessions
+  @@ Dream.flash_messages
+  @@ Dream.router [
+    Dream.get  "/"
+      (fun request ->
+         Dream.html (input_form request));
+
+    Dream.post "/"
+      (fun request ->
+        match%lwt Dream.form request with
+        | `Ok ["text", text] ->
+          let () = Dream.put_flash "Info" "Message 1" request in
+          let () = Dream.put_flash "Info" "Message 2" request in
+          let () = Dream.put_flash "Debug" "Message 3" request in
+          let%lwt () = Dream.put_session "text" text request in
+          Dream.redirect request "/results"
+        | _ ->
+          Dream.redirect request "/"
+      );
+
+    Dream.get "/results"
+      (fun request ->
+         let messages = Dream.get_flash request in
+         let text = Dream.session "text" request in
+         Dream.html @@ html_to_string @@ results_page messages text);
+  ]
+  @@ Dream.not_found
diff --git a/src/dream.ml b/src/dream.ml
@@ -37,6 +37,8 @@ include Dream__middleware.Static
 include Dream__middleware.Session
 let sql_sessions = Dream__sql.Session.middleware
 
+include Dream__middleware.Flash_message
+
 include Dream__middleware.Origin_referer_check
 include Dream__middleware.Form
 include Dream__middleware.Upload

diff --git a/src/dream.mli b/src/dream.mli
@@ -1387,7 +1387,11 @@ val session_label : request -> string
 val session_expires_at : request -> float
 (** Time at which the session will expire. *)
 
+(** {1 Flash Messages} *)
 
+val flash_messages : middleware
+val put_flash : string -> string -> request -> unit
+val get_flash : request -> (string * string) list
 
 (** {1 WebSockets} *)
 

diff --git a/src/middleware/flash_message.ml b/src/middleware/flash_message.ml
@@ -0,0 +1,56 @@
+module Dream = Dream__pure.Inmost
+
+
+let log =
+  Log.sub_log "dream.flash_message"
+
+
+let five_minutes = 5. *. 60.
+
+
+let storage = Dream.new_local ~name:"dream.flash_message" ()
+
+
+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
+  let%lwt 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
+  )
+
+
+let (|>?) =
+  Option.bind
+
+
+let get_flash request =
+  let rec group x = match x with
+    | x1::x2::rest -> (x1, x2) :: group rest
+    | _ -> []
+  in
+  let unpack u = match u with
+      | `String x -> x
+      | _ -> failwith "Bad flash message content" in
+  let x = Dream.cookie flash_cookie request
+          |>? fun value ->
+          match Yojson.Basic.from_string value with
+          | `List y -> Some (group @@ List.map unpack y)
+          | _ -> None
+  in Option.value x ~default:[]
+
+
+let put_flash category message request =
+  let outbox = match Dream.local storage request with
+  | Some outbox -> outbox
+  | None ->
+    let message = "Missing flash message middleware" in
+    log.error (fun log -> log ~request "%s" message);
+    failwith message in
+  outbox := (category, message) :: !outbox