anil.recoil.org
An OCaml webserver, but the allocating version (vs httpz which doesnt)
1(* date.ml - HTTP-date parsing and formatting per RFC 7231 Section 7.1.1.1 *)
2
3open Base
4
5type status =
6 | Valid
7 | Invalid
8
9(* Day and month names for parsing and formatting *)
10let day_names = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
11let month_names = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]
12
13(* Parse 2-digit number at position, returns (value, valid) *)
14let parse_2digit buf pos =
15 let c0 = Base_bigstring.unsafe_get buf pos in
16 let c1 = Base_bigstring.unsafe_get buf (pos + 1) in
17 if Char.is_digit c0 && Char.is_digit c1 then
18 ((Char.to_int c0 - 48) * 10 + (Char.to_int c1 - 48), true)
19 else
20 (0, false)
21;;
22
23(* Parse 4-digit year at position, returns (value, valid) *)
24let parse_4digit buf pos =
25 let c0 = Base_bigstring.unsafe_get buf pos in
26 let c1 = Base_bigstring.unsafe_get buf (pos + 1) in
27 let c2 = Base_bigstring.unsafe_get buf (pos + 2) in
28 let c3 = Base_bigstring.unsafe_get buf (pos + 3) in
29 if Char.is_digit c0 && Char.is_digit c1 && Char.is_digit c2 && Char.is_digit c3 then
30 ((Char.to_int c0 - 48) * 1000 + (Char.to_int c1 - 48) * 100 +
31 (Char.to_int c2 - 48) * 10 + (Char.to_int c3 - 48), true)
32 else
33 (0, false)
34;;
35
36(* Parse 1 or 2 digit day, returns (day, next_pos, valid) *)
37let parse_day buf pos len =
38 if pos >= len then (0, pos, false)
39 else
40 let c0 = Base_bigstring.unsafe_get buf pos in
41 if Char.equal c0 ' ' && pos + 1 < len then
42 (* Space-padded single digit *)
43 let c1 = Base_bigstring.unsafe_get buf (pos + 1) in
44 if Char.is_digit c1 then (Char.to_int c1 - 48, pos + 2, true)
45 else (0, pos, false)
46 else if Char.is_digit c0 && pos + 1 < len then
47 let c1 = Base_bigstring.unsafe_get buf (pos + 1) in
48 if Char.is_digit c1 then
49 ((Char.to_int c0 - 48) * 10 + (Char.to_int c1 - 48), pos + 2, true)
50 else
51 (Char.to_int c0 - 48, pos + 1, true)
52 else
53 (0, pos, false)
54;;
55
56(* Parse 3-letter month abbreviation, returns 0-11 or -1 *)
57let parse_month buf pos =
58 let c0 = Base_bigstring.unsafe_get buf pos in
59 let c1 = Base_bigstring.unsafe_get buf (pos + 1) in
60 let c2 = Base_bigstring.unsafe_get buf (pos + 2) in
61 match (c0, c1, c2) with
62 | ('J', 'a', 'n') -> 0
63 | ('F', 'e', 'b') -> 1
64 | ('M', 'a', 'r') -> 2
65 | ('A', 'p', 'r') -> 3
66 | ('M', 'a', 'y') -> 4
67 | ('J', 'u', 'n') -> 5
68 | ('J', 'u', 'l') -> 6
69 | ('A', 'u', 'g') -> 7
70 | ('S', 'e', 'p') -> 8
71 | ('O', 'c', 't') -> 9
72 | ('N', 'o', 'v') -> 10
73 | ('D', 'e', 'c') -> 11
74 | _ -> -1
75;;
76
77(* Parse time HH:MM:SS at position, returns (hour, minute, second, valid) *)
78let parse_time buf pos =
79 let (hour, h_valid) = parse_2digit buf pos in
80 if not h_valid then (0, 0, 0, false)
81 else if not (Char.equal (Base_bigstring.unsafe_get buf (pos + 2)) ':') then (0, 0, 0, false)
82 else
83 let (minute, m_valid) = parse_2digit buf (pos + 3) in
84 if not m_valid then (0, 0, 0, false)
85 else if not (Char.equal (Base_bigstring.unsafe_get buf (pos + 5)) ':') then (0, 0, 0, false)
86 else
87 let (second, s_valid) = parse_2digit buf (pos + 6) in
88 if not s_valid then (0, 0, 0, false)
89 else if hour > 23 || minute > 59 || second > 60 then (0, 0, 0, false) (* 60 for leap second *)
90 else (hour, minute, second, true)
91;;
92
93(* Days in each month (non-leap year) *)
94let days_in_month = [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |]
95
96(* Check if year is leap year *)
97let is_leap_year year =
98 (year % 4 = 0 && year % 100 <> 0) || (year % 400 = 0)
99;;
100
101(* Convert date components to Unix timestamp, returns (timestamp, valid) *)
102let to_timestamp ~year ~month ~day ~hour ~minute ~second =
103 (* Validate ranges *)
104 if year < 1970 || month < 0 || month > 11 then (0.0, false)
105 else
106 let max_day =
107 if month = 1 && is_leap_year year then 29
108 else days_in_month.(month)
109 in
110 if day < 1 || day > max_day then (0.0, false)
111 else
112 (* Calculate days since epoch *)
113 let days = ref 0 in
114 (* Add days for complete years *)
115 for y = 1970 to year - 1 do
116 days := !days + (if is_leap_year y then 366 else 365)
117 done;
118 (* Add days for complete months in current year *)
119 for m = 0 to month - 1 do
120 days := !days + days_in_month.(m);
121 if m = 1 && is_leap_year year then days := !days + 1
122 done;
123 (* Add days in current month *)
124 days := !days + (day - 1);
125 (* Convert to seconds and add time *)
126 let timestamp =
127 Float.of_int !days *. 86400.0 +.
128 Float.of_int hour *. 3600.0 +.
129 Float.of_int minute *. 60.0 +.
130 Float.of_int second
131 in
132 (timestamp, true)
133;;
134
135let invalid_result = (0.0, false)
136
137(* Parse IMF-fixdate: Sun, 06 Nov 1994 08:49:37 GMT *)
138let parse_imf_fixdate buf off len =
139 (* Minimum length: "Sun, 06 Nov 1994 08:49:37 GMT" = 29 chars *)
140 if len < 29 then invalid_result
141 else
142 (* Skip day name - find comma *)
143 let comma_pos = ref off in
144 while !comma_pos < off + 4 && not (Char.equal (Base_bigstring.unsafe_get buf !comma_pos) ',') do
145 Int.incr comma_pos
146 done;
147 if !comma_pos >= off + len || not (Char.equal (Base_bigstring.unsafe_get buf !comma_pos) ',') then invalid_result
148 else if not (Char.equal (Base_bigstring.unsafe_get buf (!comma_pos + 1)) ' ') then invalid_result
149 else
150 let day_pos = !comma_pos + 2 in
151 let (day, day_valid) = parse_2digit buf day_pos in
152 if not day_valid then invalid_result
153 else if not (Char.equal (Base_bigstring.unsafe_get buf (day_pos + 2)) ' ') then invalid_result
154 else
155 let month = parse_month buf (day_pos + 3) in
156 if month < 0 then invalid_result
157 else if not (Char.equal (Base_bigstring.unsafe_get buf (day_pos + 6)) ' ') then invalid_result
158 else
159 let (year, year_valid) = parse_4digit buf (day_pos + 7) in
160 if not year_valid then invalid_result
161 else if not (Char.equal (Base_bigstring.unsafe_get buf (day_pos + 11)) ' ') then invalid_result
162 else
163 let (hour, minute, second, time_valid) = parse_time buf (day_pos + 12) in
164 if not time_valid then invalid_result
165 else
166 (* Check for " GMT" at end *)
167 let gmt_pos = day_pos + 20 in
168 if gmt_pos + 4 > off + len then invalid_result
169 else if not (Char.equal (Base_bigstring.unsafe_get buf gmt_pos) ' ') then invalid_result
170 else if not (Char.equal (Base_bigstring.unsafe_get buf (gmt_pos + 1)) 'G') then invalid_result
171 else if not (Char.equal (Base_bigstring.unsafe_get buf (gmt_pos + 2)) 'M') then invalid_result
172 else if not (Char.equal (Base_bigstring.unsafe_get buf (gmt_pos + 3)) 'T') then invalid_result
173 else to_timestamp ~year ~month ~day ~hour ~minute ~second
174;;
175
176(* Parse RFC 850 date: Sunday, 06-Nov-94 08:49:37 GMT *)
177let parse_rfc850 buf off len =
178 (* Find comma after full day name *)
179 let comma_pos = ref off in
180 while !comma_pos < off + 10 && not (Char.equal (Base_bigstring.unsafe_get buf !comma_pos) ',') do
181 Int.incr comma_pos
182 done;
183 if !comma_pos >= off + len || not (Char.equal (Base_bigstring.unsafe_get buf !comma_pos) ',') then invalid_result
184 else if not (Char.equal (Base_bigstring.unsafe_get buf (!comma_pos + 1)) ' ') then invalid_result
185 else
186 let pos = !comma_pos + 2 in
187 let (day, day_valid) = parse_2digit buf pos in
188 if not day_valid then invalid_result
189 else if not (Char.equal (Base_bigstring.unsafe_get buf (pos + 2)) '-') then invalid_result
190 else
191 let month = parse_month buf (pos + 3) in
192 if month < 0 then invalid_result
193 else if not (Char.equal (Base_bigstring.unsafe_get buf (pos + 6)) '-') then invalid_result
194 else
195 let (year2, year2_valid) = parse_2digit buf (pos + 7) in
196 if not year2_valid then invalid_result
197 else
198 (* RFC 850 uses 2-digit year. Interpret 00-99 as 2000-2099 for dates >= 70,
199 and 1970-1999 for dates < 70. Modern interpretation varies. *)
200 let year = if year2 >= 70 then 1900 + year2 else 2000 + year2 in
201 if not (Char.equal (Base_bigstring.unsafe_get buf (pos + 9)) ' ') then invalid_result
202 else
203 let (hour, minute, second, time_valid) = parse_time buf (pos + 10) in
204 if not time_valid then invalid_result
205 else
206 (* Check for " GMT" *)
207 let gmt_pos = pos + 18 in
208 if gmt_pos + 4 > off + len then invalid_result
209 else if not (Char.equal (Base_bigstring.unsafe_get buf gmt_pos) ' ') then invalid_result
210 else if not (Char.equal (Base_bigstring.unsafe_get buf (gmt_pos + 1)) 'G') then invalid_result
211 else if not (Char.equal (Base_bigstring.unsafe_get buf (gmt_pos + 2)) 'M') then invalid_result
212 else if not (Char.equal (Base_bigstring.unsafe_get buf (gmt_pos + 3)) 'T') then invalid_result
213 else to_timestamp ~year ~month ~day ~hour ~minute ~second
214;;
215
216(* Parse asctime format: Sun Nov 6 08:49:37 1994 *)
217let parse_asctime buf off len =
218 (* Minimum length: "Sun Nov 6 08:49:37 1994" = 24 chars *)
219 if len < 24 then invalid_result
220 (* Skip 3-char day name and space *)
221 else if not (Char.equal (Base_bigstring.unsafe_get buf (off + 3)) ' ') then invalid_result
222 else
223 let month = parse_month buf (off + 4) in
224 if month < 0 then invalid_result
225 else if not (Char.equal (Base_bigstring.unsafe_get buf (off + 7)) ' ') then invalid_result
226 else
227 let (day, next_pos, day_valid) = parse_day buf (off + 8) len in
228 if not day_valid then invalid_result
229 else if not (Char.equal (Base_bigstring.unsafe_get buf next_pos) ' ') then invalid_result
230 else
231 let (hour, minute, second, time_valid) = parse_time buf (next_pos + 1) in
232 if not time_valid then invalid_result
233 else
234 let year_pos = next_pos + 9 in
235 if not (Char.equal (Base_bigstring.unsafe_get buf year_pos) ' ') then invalid_result
236 else
237 let (year, year_valid) = parse_4digit buf (year_pos + 1) in
238 if not year_valid then invalid_result
239 else to_timestamp ~year ~month ~day ~hour ~minute ~second
240;;
241
242(* Main parse function - tries all three formats *)
243let parse buf (sp : Span.t) =
244 let off = Span.off sp in
245 let len = Span.len sp in
246 if len < 24 then (Invalid, 0.0)
247 else
248 (* Check for comma to distinguish IMF-fixdate/RFC850 from asctime *)
249 let c4 = Base_bigstring.unsafe_get buf (off + 3) in
250 let (ts, valid) =
251 if Char.equal c4 ',' then
252 (* IMF-fixdate: short day name + comma *)
253 parse_imf_fixdate buf off len
254 else if Char.equal c4 ' ' then
255 (* asctime: short day name + space *)
256 parse_asctime buf off len
257 else
258 (* RFC 850: full day name, look for comma *)
259 parse_rfc850 buf off len
260 in
261 if valid then (Valid, ts) else (Invalid, 0.0)
262;;
263
264(* Format timestamp as IMF-fixdate *)
265let format timestamp =
266 (* Use Unix module to break down timestamp *)
267 let tm = Unix.gmtime timestamp in
268 Stdlib.Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT"
269 day_names.(tm.Unix.tm_wday)
270 tm.Unix.tm_mday
271 month_names.(tm.Unix.tm_mon)
272 (tm.Unix.tm_year + 1900)
273 tm.Unix.tm_hour
274 tm.Unix.tm_min
275 tm.Unix.tm_sec
276;;
277
278(* Write HTTP-date at offset without header name *)
279let write_http_date dst ~off timestamp =
280 let tm = Unix.gmtime timestamp in
281 let off = Buf_write.string dst ~off day_names.(tm.Unix.tm_wday) in
282 let off = Buf_write.string dst ~off ", " in
283 let off = Buf_write.digit2 dst ~off tm.Unix.tm_mday in
284 let off = Buf_write.char dst ~off ' ' in
285 let off = Buf_write.string dst ~off month_names.(tm.Unix.tm_mon) in
286 let off = Buf_write.char dst ~off ' ' in
287 let off = Buf_write.digit4 dst ~off (tm.Unix.tm_year + 1900) in
288 let off = Buf_write.char dst ~off ' ' in
289 let off = Buf_write.digit2 dst ~off tm.Unix.tm_hour in
290 let off = Buf_write.char dst ~off ':' in
291 let off = Buf_write.digit2 dst ~off tm.Unix.tm_min in
292 let off = Buf_write.char dst ~off ':' in
293 let off = Buf_write.digit2 dst ~off tm.Unix.tm_sec in
294 Buf_write.string dst ~off " GMT"
295;;
296
297let write_date_header dst ~off timestamp =
298 let off = Buf_write.string dst ~off "Date: " in
299 let off = write_http_date dst ~off timestamp in
300 Buf_write.crlf dst ~off
301;;
302
303let write_last_modified dst ~off timestamp =
304 let off = Buf_write.string dst ~off "Last-Modified: " in
305 let off = write_http_date dst ~off timestamp in
306 Buf_write.crlf dst ~off
307;;
308
309let write_expires dst ~off timestamp =
310 let off = Buf_write.string dst ~off "Expires: " in
311 let off = write_http_date dst ~off timestamp in
312 Buf_write.crlf dst ~off
313;;
314
315(* Comparison helpers *)
316let is_modified_since ~last_modified ~if_modified_since =
317 (* Resource is modified if last_modified > if_modified_since
318 Note: HTTP dates have 1-second resolution, so we use > not >= *)
319 Float.(last_modified > if_modified_since)
320;;
321
322let is_unmodified_since ~last_modified ~if_unmodified_since =
323 (* Resource is unmodified if last_modified <= if_unmodified_since *)
324 Float.(last_modified <= if_unmodified_since)
325;;