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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
module Message = Dream_pure.Message
type multipart_state = {
mutable state_init : bool;
mutable name : string option;
mutable filename : string option;
mutable stream : (< > * Multipart_form.Header.t * string Lwt_stream.t) Lwt_stream.t;
}
let initial_multipart_state () = {
state_init = true;
name = None;
filename = None;
stream = Lwt_stream.of_list [];
}
let multipart_state_field : multipart_state Message.field =
Message.new_field
~name:"dream.multipart"
()
let multipart_state request =
match Message.field request multipart_state_field with
| Some state -> state
| None ->
let state = initial_multipart_state () in
Message.set_field request multipart_state_field state;
state
let field_to_string (request : Message.request) field =
let open Multipart_form in
match field with
| Field.Field (field_name, Field.Content_type, v) ->
(field_name :> string), Content_type.to_string v
| Field.Field (field_name, Field.Content_disposition, v) ->
let state = multipart_state request in
state.filename <- Content_disposition.filename v ;
state.name <- Content_disposition.name v ;
(field_name :> string), Content_disposition.to_string v
| Field.Field (field_name, Field.Content_encoding, v) ->
(field_name :> string), Content_encoding.to_string v
| Field.Field (field_name, Field.Field, v) ->
(field_name :> string), Unstrctrd.to_utf_8_string v
let log = Log.sub_log "dream.upload"
let upload_part (request : Message.request) =
let state = multipart_state request in
match%lwt Lwt_stream.peek state.stream with
| None -> Lwt.return_none
| Some (_uid, , stream) ->
match%lwt Lwt_stream.get stream with
| Some _ as v -> Lwt.return v
| None ->
log.debug (fun m -> m "End of the part.") ;
let%lwt () = Lwt_stream.junk state.stream in
Lwt.return_none
let identify _ = object end
type part = string option * string option * ((string * string) list)
let rec state (request : Message.request) =
let state' = multipart_state request in
let stream = state'.stream in
match%lwt Lwt_stream.peek stream with
| None -> let%lwt () = Lwt_stream.junk stream in Lwt.return_none
| Some (_, , _stream) ->
let =
headers
|> Multipart_form.Header.to_list
|> List.map (field_to_string request)
in
let part =
state'.name, state'.filename, headers in
Lwt.return (Some part)
and upload (request : Message.request) =
let state' = multipart_state request in
match state'.state_init with
| false ->
state request
| true ->
let content_type = match Message.header request "Content-Type" with
| Some content_type ->
Result.to_option
(Multipart_form.Content_type.of_string (content_type ^ "\r\n"))
| None ->
None
in
match content_type with
| None ->
let message =
"The request does not have 'Content-Type: multipart/form_data; ...'" in
log.error (fun log -> log "%s" message);
failwith message
| Some content_type ->
let body =
Lwt_stream.from (fun () ->
Message.read (Message.server_stream request)) in
let `Parse th, stream =
Multipart_form_lwt.stream ~identify body content_type in
Lwt.async (fun () -> let%lwt _ = th in Lwt.return_unit);
state'.stream <- stream;
state'.state_init <- false;
state request
type multipart_form =
(string * ((string option * string) list)) list
module Map = Map.Make (String)
let multipart ?(csrf=true) ~now request =
let content_type = match Message.header request "Content-Type" with
| Some content_type ->
Result.to_option (Multipart_form.Content_type.of_string (content_type ^ "\r\n"))
| None -> None in
match content_type with
| None -> Lwt.return `Wrong_content_type
| Some content_type ->
let body =
Lwt_stream.from (fun () ->
Message.read (Message.server_stream request)) in
match%lwt Multipart_form_lwt.of_stream_to_list body content_type with
| Error (`Msg _err) ->
Lwt.return `Wrong_content_type
| Ok (tree, assoc) ->
let open Multipart_form in
let tree = flatten tree in
let fold acc { ; body= uid; } =
let contents = List.assoc uid assoc in
let content_disposition = Header.content_disposition header in
let filename = Option.bind content_disposition Content_disposition.filename in
match Option.bind content_disposition Content_disposition.name with
| None -> acc
| Some name ->
let vs =
match Map.find_opt name acc with
| Some vs -> vs
| None -> []
in
Map.add name ((filename, contents)::vs) acc
in
let parts =
List.fold_left fold Map.empty tree
|> Map.bindings
|> List.map (fun (name, values) ->
match values with
| [Some "", ""] -> name, []
| _ -> name, List.rev values)
in
if csrf then
Form.sort_and_check_form ~now
(function
| [None, value] -> value
| _ -> "")
parts request
else
let form = Form.sort parts in
Lwt.return (`Ok form)