1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
module Message = Dream_pure.Message
let log =
Log.sub_log "dream.flash"
let five_minutes =
5. *. 60.
let storage_field =
Message.new_field ~name:"dream.flash" ()
let flash_cookie =
"dream.flash"
let content_byte_size_limit =
3072
let (|>?) =
Option.bind
let 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 =
Cookie.cookie request flash_cookie
|>? 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 request category message =
let outbox =
match Message.field request storage_field 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
let flash_messages inner_handler request =
log.debug (fun log ->
let current =
flash request
|> List.map (fun (p,q) -> p ^ ": " ^ q)
|> String.concat ", " in
if String.length current > 0 then
log ~request "Flash messages: %s" current
else
log ~request "%s" "No flash messages.");
let outbox = ref [] in
Message.set_field request storage_field outbox;
let existing = Cookie.cookie request flash_cookie in
let%lwt response = inner_handler request in
let entries = List.rev !outbox in
let () =
match existing, entries with
| None, [] -> ()
| Some _, [] ->
Cookie.set_cookie response request flash_cookie "" ~expires:0.
| _, _ ->
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 () =
if String.length value >= content_byte_size_limit then
log.warning (fun log ->
log ~request
"Flash messages exceed soft size limit (%d bytes)"
content_byte_size_limit)
else
()
in
Cookie.set_cookie
response request flash_cookie value ~max_age:five_minutes
in
Lwt.return response