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
module Dream = Dream__pure.Inmost
let field_to_string (request : Dream.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) ->
request.specific.upload.filename <- Content_disposition.filename v ;
request.specific.upload.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 : Dream.request) =
match%lwt Lwt_stream.peek request.specific.upload.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 request.specific.upload.stream in
Lwt.return_none
let identify _ = object end
type part = string option * string option * ((string * string) list)
let rec state (request : Dream.request) =
let stream = request.specific.upload.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 =
request.specific.upload.name, request.specific.upload.filename, headers in
Lwt.return (Some part)
and upload (request : Dream.request) =
match request.specific.upload.state_init with
| false ->
state request
| true ->
let content_type = match Dream.header "content-type" request 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 () -> Dream.read 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);
request.specific.upload.stream <- stream;
request.specific.upload.state_init <- false;
state request
type multipart_form =
(string * ((string option * string) list)) list
module Map = Map.Make (String)
let multipart request =
let content_type = match Dream.header "content-type" request 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 () -> Dream.read 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
Form.sort_and_check_form
(function
| [None, value] -> value
| _ -> "")
parts request