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
module Formats = Dream_pure.Formats
module Message = Dream_pure.Message
let log =
Log.sub_log "dream.form"
let sort form =
List.stable_sort (fun (key, _) (key', _) -> String.compare key key') form
type 'a form_result = [
| `Ok of 'a
| `Expired of 'a * float
| `Wrong_session of 'a
| `Invalid_token of 'a
| `Missing_token of 'a
| `Many_tokens of 'a
| `Wrong_content_type
]
let sort_and_check_form ~now to_value form request =
let csrf_token, form =
List.partition (fun (name, _) -> name = Csrf.field_name) form in
let form = sort form in
match csrf_token with
| [_, value] ->
begin match%lwt Csrf.verify_csrf_token ~now request (to_value value) with
| `Ok ->
Lwt.return (`Ok form)
| `Expired time ->
Lwt.return (`Expired (form, time))
| `Wrong_session ->
Lwt.return (`Wrong_session form)
| `Invalid ->
Lwt.return (`Invalid_token form)
end
| [] ->
log.warning (fun log -> log ~request "CSRF token missing");
Lwt.return (`Missing_token form)
| _::_::_ ->
log.warning (fun log -> log ~request "CSRF token duplicated");
Lwt.return (`Many_tokens form)
let wrong_content_type request =
log.warning (fun log -> log ~request
"Content-Type not 'application/x-www-form-urlencoded'");
Lwt.return `Wrong_content_type
let form ?(csrf = true) ~now request =
match Message.header request "Content-Type" with
| None ->
wrong_content_type request
| Some content_type ->
match String.split_on_char ';' content_type with
| "application/x-www-form-urlencoded"::_ ->
let%lwt body = Message.body request in
let form = Formats.from_form_urlencoded body in
if csrf then
sort_and_check_form ~now (fun string -> string) form request
else
Lwt.return (`Ok (sort form))
| _ ->
wrong_content_type request