diff --git a/example/b-flash-message/dune b/example/b-flash-message/dune new file mode 100644 index 00000000..14e691df --- /dev/null +++ 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 new file mode 100644 index 00000000..929c696e --- /dev/null +++ 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 new file mode 100644 index 00000000..92b5c379 --- /dev/null +++ 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 new file mode 100644 index 00000000..7fb544f6 --- /dev/null +++ b/example/b-flash-message/flash_message.eml.ml @@ -0,0 +1,55 @@ +let input_form request = + + + Enter some text: + <%s! Dream.form_tag ~action:"/" request %> + + + + + + +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 index cfaee59c..f96b38f3 100644 --- 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 index 1f26a920..cb915f4c 100644 --- 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 new file mode 100644 index 00000000..34a0169d --- /dev/null +++ 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