Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

WIP: Add support for flash messages. #62

Merged
merged 9 commits into from
Jun 7, 2021
Merged

WIP: Add support for flash messages. #62

Show file tree
Hide file tree
Changes from 6 commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
3b3b130
Add a crude first version of flash messages.
jsthomas May 24, 2021
34cd57d
Get more organized.
jsthomas May 26, 2021
73887c3
Build a simple example to illustrate usage.
jsthomas May 27, 2021
d75cd43
Merge branch 'master' of github.com:jsthomas/dream into flash-messages
jsthomas May 27, 2021
9c58ee5
Correct esy file.
jsthomas May 27, 2021
a95e91a
Revisions from review.
jsthomas May 28, 2021
f6e9822
Revise to use a bare-cookie approach, revert sessions to master.
jsthomas May 31, 2021
99552c5
Further simplifications based on feedback.
jsthomas Jun 2, 2021
1e664be
Refactor to support multiple messages of the same category.
jsthomas Jun 5, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
11 changes: 11 additions & 0 deletions example/b-flash-message/dune
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,11 @@
(executable
(name flash_message)
(libraries dream)
(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)
1 change: 1 addition & 0 deletions example/b-flash-message/dune-project
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
(lang dune 2.0)
13 changes: 13 additions & 0 deletions example/b-flash-message/esy.json
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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"
}
}
49 changes: 49 additions & 0 deletions example/b-flash-message/flash_message.eml.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,49 @@
let input_form request =
<html>
<body>
Enter some text:
<%s! Dream.form_tag ~action:"/" request %>
<input name="text" autofocus>
</form>

</body>
</html>


Copy link
Contributor Author

@jsthomas jsthomas Jun 5, 2021 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is mixing Tyxml (in results_page) and templates (in input_form) like this idiomatic? I couldn't figure out how to implement results_page using templates.

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'll edit this example to not use TyXML after the merge, and ping.

let results_page info text =
<html>
<body>
<p><%s Option.value info ~default:"" %></p>
<p><%s Option.value text ~default:"" %></p>
</body>
</html>


let () =
Dream.run
@@ Dream.logger
@@ Dream.memory_sessions
@@ 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%lwt () = Dream.put_flash Info "Text received!" request in
let%lwt () = Dream.put_session "text" text request in
Dream.redirect request "/results"
| _ ->
Dream.redirect request "/"
);

Dream.get "/results"
(fun request ->
let%lwt info = Dream.get_flash Info request in
let text = Dream.session "text" request in
Dream.html (results_page info text));
]
@@ Dream.not_found
5 changes: 5 additions & 0 deletions src/dream.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1387,7 +1387,12 @@ val session_label : request -> string
val session_expires_at : request -> float
(** Time at which the session will expire. *)

(** {1 Flash Messages} *)

type level = Debug | Info | Success | Warning | Error
jsthomas marked this conversation as resolved.
Show resolved Hide resolved
jsthomas marked this conversation as resolved.
Show resolved Hide resolved
val clear_flash : level -> request -> unit promise
val put_flash : level -> string -> request -> unit promise
val get_flash : level -> request -> string option promise

(** {1 WebSockets} *)

Expand Down
43 changes: 43 additions & 0 deletions src/middleware/session.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -63,6 +63,7 @@ type session = {

type operations = {
put : string -> string -> unit Lwt.t;
remove: string -> unit Lwt.t;
invalidate : unit -> unit Lwt.t;
mutable dirty : bool;
}
Expand Down Expand Up @@ -133,6 +134,12 @@ struct
|> fun dictionary -> session.payload <- dictionary;
Lwt.return_unit

let remove session name =
session.payload
|> List.remove_assoc name
|> fun dictionary -> session.payload <- dictionary;
Lwt.return_unit

let invalidate hash_table lifetime operations session =
Hashtbl.remove hash_table !session.id;
session := create hash_table (Unix.gettimeofday () +. lifetime);
Expand All @@ -143,6 +150,8 @@ struct
let rec operations = {
put =
(fun name value -> put !session name value);
remove =
(fun name -> remove !session name);
invalidate =
(fun () -> invalidate hash_table lifetime operations session);
dirty;
Expand Down Expand Up @@ -223,6 +232,13 @@ struct
operations.dirty <- true;
Lwt.return_unit

let remove operations session name =
session.payload
|> List.remove_assoc name
|> fun dictionary -> session.payload <- dictionary;
operations.dirty <- true;
Lwt.return_unit

let invalidate lifetime operations session =
session := create (Unix.gettimeofday () +. lifetime);
operations.dirty <- true;
Expand All @@ -231,6 +247,7 @@ struct
let operations lifetime session dirty =
let rec operations = {
put = (fun name value -> put operations !session name value);
remove = (fun name -> remove operations !session name);
invalidate = (fun () -> invalidate lifetime operations session);
dirty;
} in
Expand Down Expand Up @@ -355,3 +372,29 @@ let session_label request =

let session_expires_at request =
!(snd (getter request)).expires_at


type level = Debug | Info | Success | Warning | Error

let key_of_level l =
let suffix = match l with
| Debug -> "DEBUG"
| Info -> "INFO"
| Success -> "SUCCESS"
| Warning -> "WARNING"
| Error -> "ERROR" in
"FLASH_MESSAGE_" ^ suffix

let clear_flash level request =
let k = key_of_level level in
(fst (getter request)).remove k
jsthomas marked this conversation as resolved.
Show resolved Hide resolved

let get_flash level request =
let k = key_of_level level in
let message = session k request in
let%lwt () = clear_flash level request in
Lwt.return message

let put_flash level message request =
let k = key_of_level level in
put_session k message request
9 changes: 9 additions & 0 deletions src/sql/session.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -120,6 +120,14 @@ let put request (session : Session.session) name value =
|> fun dictionary -> session.payload <- dictionary;
Sql.sql request (fun db -> update db session)


let remove_key request (session : Session.session) name =
session.payload
|> List.remove_assoc name
|> fun dictionary -> session.payload <- dictionary;
Sql.sql request (fun db -> update db session)


let invalidate request lifetime operations (session : Session.session ref) =
Sql.sql request begin fun db ->
let%lwt () = remove db !session.id in
Expand All @@ -133,6 +141,7 @@ let operations request lifetime (session : Session.session ref) dirty =
let rec operations = {
Session.put = (fun name value -> put request !session name value);
invalidate = (fun () -> invalidate request lifetime operations session);
remove = (fun name -> remove_key request !session name);
dirty;
} in
operations
Expand Down