ocaml http/1, http/2 and websocket client and server library
gdiazlo.tngl.sh
1(** Request helper functions.
2
3 This module provides utility functions for working with HTTP requests,
4 including header access, query parameter parsing, and body handling. *)
5
6let string_contains haystack pattern =
7 let plen = String.length pattern in
8 let hlen = String.length haystack in
9 if plen > hlen then false
10 else
11 let rec check i =
12 if i > hlen - plen then false
13 else if String.sub haystack i plen = pattern then true
14 else check (i + 1)
15 in
16 check 0
17
18type t = H1_server.request
19
20let meth (req : t) = req.meth
21let target (req : t) = req.target
22let headers (req : t) = req.headers
23let body (req : t) = H1_server.read_body req
24let body_reader (req : t) = req.body_reader
25
26let path (req : t) =
27 match String.index_opt req.target '?' with
28 | Some i -> String.sub req.target 0 i
29 | None -> req.target
30
31let query_string (req : t) =
32 match String.index_opt req.target '?' with
33 | Some i ->
34 Some (String.sub req.target (i + 1) (String.length req.target - i - 1))
35 | None -> None
36
37let parse_query_string qs =
38 let pairs = String.split_on_char '&' qs in
39 List.filter_map
40 (fun pair ->
41 match String.index_opt pair '=' with
42 | Some i ->
43 let key = String.sub pair 0 i in
44 let value = String.sub pair (i + 1) (String.length pair - i - 1) in
45 Some (Uri.pct_decode key, Uri.pct_decode value)
46 | None -> Some (Uri.pct_decode pair, ""))
47 pairs
48
49let query_params (req : t) =
50 match query_string req with None -> [] | Some qs -> parse_query_string qs
51
52let query_params_from_target target =
53 match String.index_opt target '?' with
54 | Some i ->
55 let qs = String.sub target (i + 1) (String.length target - i - 1) in
56 parse_query_string qs
57 | None -> []
58
59let query (req : Server.request) key =
60 List.assoc_opt key (query_params_from_target req.target)
61
62let query_or ~default (req : Server.request) key =
63 match query req key with Some v -> v | None -> default
64
65let query_all (req : Server.request) key =
66 List.filter_map
67 (fun (k, v) -> if String.equal k key then Some v else None)
68 (query_params_from_target req.target)
69
70let query_int (req : Server.request) key =
71 match query req key with Some v -> int_of_string_opt v | None -> None
72
73let query_int_or ~default (req : Server.request) key =
74 match query_int req key with Some v -> v | None -> default
75
76let query_bool (req : Server.request) key =
77 match query req key with
78 | Some v -> (
79 match String.lowercase_ascii v with
80 | "true" | "1" | "yes" | "on" -> Some true
81 | "false" | "0" | "no" | "off" -> Some false
82 | _ -> None)
83 | None -> None
84
85let query_bool_or ~default (req : Server.request) key =
86 match query_bool req key with Some v -> v | None -> default
87
88let query_float (req : Server.request) key =
89 match query req key with Some v -> float_of_string_opt v | None -> None
90
91let query_float_or ~default (req : Server.request) key =
92 match query_float req key with Some v -> v | None -> default
93
94let header name (req : t) = H1.Headers.get req.headers name
95let header_all name (req : t) = H1.Headers.get_multi req.headers name
96
97let has_header name (req : t) =
98 match H1.Headers.get req.headers name with Some _ -> true | None -> false
99
100let content_type req = header "content-type" req
101
102let content_length req =
103 match header "content-length" req with
104 | Some s -> Int64.of_string_opt s
105 | None -> None
106
107let is_keep_alive (req : t) =
108 match header "connection" req with
109 | Some v -> String.lowercase_ascii v = "keep-alive"
110 | None -> true
111
112let host req = header "host" req
113let accept req = header "accept" req
114let authorization req = header "authorization" req
115
116let accepts_json req =
117 match accept req with
118 | Some v -> string_contains v "application/json" || string_contains v "*/*"
119 | None -> false
120
121let accepts_html req =
122 match accept req with
123 | Some v -> string_contains v "text/html" || string_contains v "*/*"
124 | None -> false
125
126let is_get (req : t) = req.meth = `GET
127let is_post (req : t) = req.meth = `POST
128let is_put (req : t) = req.meth = `PUT
129let is_delete (req : t) = req.meth = `DELETE
130let is_patch (req : t) = req.meth = `Other "PATCH"
131let is_head (req : t) = req.meth = `HEAD
132let is_options (req : t) = req.meth = `OPTIONS
133
134let is_safe (req : t) =
135 match req.meth with `GET | `HEAD | `OPTIONS -> true | _ -> false
136
137let is_idempotent (req : t) =
138 match req.meth with
139 | `GET | `HEAD | `PUT | `DELETE | `OPTIONS -> true
140 | _ -> false
141
142let body_string (req : t) = body req
143let body_length (req : t) = String.length (body req)
144let has_body (req : t) = String.length (body req) > 0
145
146let form_decode s =
147 let s = String.map (fun c -> if c = '+' then ' ' else c) s in
148 Uri.pct_decode s
149
150let parse_form_body body =
151 if String.length body = 0 then []
152 else
153 let pairs = String.split_on_char '&' body in
154 List.filter_map
155 (fun pair ->
156 match String.index_opt pair '=' with
157 | Some i ->
158 let key = String.sub pair 0 i in
159 let value = String.sub pair (i + 1) (String.length pair - i - 1) in
160 Some (form_decode key, form_decode value)
161 | None -> Some (form_decode pair, ""))
162 pairs
163
164let form_data (req : t) = parse_form_body (body req)
165let form_data_from_body body = parse_form_body body
166
167let form_field (req : Server.request) key =
168 List.assoc_opt key (form_data_from_body req.body)
169
170let form_field_or ~default (req : Server.request) key =
171 match form_field req key with Some v -> v | None -> default
172
173let form_int (req : Server.request) key =
174 match form_field req key with Some v -> int_of_string_opt v | None -> None
175
176let form_int_or ~default (req : Server.request) key =
177 match form_int req key with Some v -> v | None -> default