FastCGI implementation in OCaml
anil.recoil.org
1
2(** {1 Error Handling Helpers} *)
3
4(** Helper functions for consistent error handling *)
5let invalid_version version =
6 invalid_arg (Printf.sprintf "Unsupported FastCGI version: %d" version)
7
8let unknown_record_type n =
9 invalid_arg (Printf.sprintf "Unknown FastCGI record type: %d" n)
10
11let buffer_underflow msg =
12 failwith (Printf.sprintf "Unexpected end of buffer while %s" msg)
13
14let check_bounds buf pos len context =
15 if pos + len > String.length buf then
16 buffer_underflow context
17
18type version = int
19
20type record =
21 | Begin_request
22 | Abort_request
23 | End_request
24 | Params
25 | Stdin
26 | Stdout
27 | Stderr
28 | Data
29 | Get_values
30 | Get_values_result
31 | Unknown_type
32
33let record_to_int = function
34 | Begin_request -> 1
35 | Abort_request -> 2
36 | End_request -> 3
37 | Params -> 4
38 | Stdin -> 5
39 | Stdout -> 6
40 | Stderr -> 7
41 | Data -> 8
42 | Get_values -> 9
43 | Get_values_result -> 10
44 | Unknown_type -> 11
45
46let record_of_int = function
47 | 1 -> Begin_request
48 | 2 -> Abort_request
49 | 3 -> End_request
50 | 4 -> Params
51 | 5 -> Stdin
52 | 6 -> Stdout
53 | 7 -> Stderr
54 | 8 -> Data
55 | 9 -> Get_values
56 | 10 -> Get_values_result
57 | 11 -> Unknown_type
58 | n -> unknown_record_type n
59
60let pp_record ppf = function
61 | Begin_request -> Format.pp_print_string ppf "Begin_request"
62 | Abort_request -> Format.pp_print_string ppf "Abort_request"
63 | End_request -> Format.pp_print_string ppf "End_request"
64 | Params -> Format.pp_print_string ppf "Params"
65 | Stdin -> Format.pp_print_string ppf "Stdin"
66 | Stdout -> Format.pp_print_string ppf "Stdout"
67 | Stderr -> Format.pp_print_string ppf "Stderr"
68 | Data -> Format.pp_print_string ppf "Data"
69 | Get_values -> Format.pp_print_string ppf "Get_values"
70 | Get_values_result -> Format.pp_print_string ppf "Get_values_result"
71 | Unknown_type -> Format.pp_print_string ppf "Unknown_type"
72
73type request_id = int
74
75type t = {
76 version : version;
77 record_type : record;
78 request_id : request_id;
79 content : string;
80 offset : int;
81 length : int;
82}
83
84let pp ?(max_content_len=100) ppf record =
85 let actual_content = String.sub record.content record.offset record.length in
86 let truncated_content =
87 let len = String.length actual_content in
88 if len <= max_content_len then actual_content
89 else String.sub actual_content 0 max_content_len ^ "..." ^ Printf.sprintf " (%d more bytes)" (len - max_content_len)
90 in
91 Format.fprintf ppf
92 "@[<2>{ version = %d;@ record_type = %a;@ request_id = %d;@ content = %S;@ offset = %d;@ length = %d }@]"
93 record.version
94 pp_record record.record_type
95 record.request_id
96 truncated_content
97 record.offset
98 record.length
99
100(* FastCGI constants *)
101let fcgi_version_1 = 1
102let fcgi_header_len = 8
103
104let read buf_read =
105 Printf.eprintf "[DEBUG] Fastcgi_record.read: Starting to read record\n%!";
106 (* Read the 8-byte header *)
107 Printf.eprintf "[DEBUG] Fastcgi_record.read: Reading %d-byte header\n%!" fcgi_header_len;
108 let header = Eio.Buf_read.take fcgi_header_len buf_read in
109
110 (* Parse header fields *)
111 let version = Char.code header.[0] in
112 let record_type_int = Char.code header.[1] in
113 let request_id = (Char.code header.[2] lsl 8) lor (Char.code header.[3]) in
114 let content_length = (Char.code header.[4] lsl 8) lor (Char.code header.[5]) in
115 let padding_length = Char.code header.[6] in
116 let _reserved = Char.code header.[7] in
117
118 Printf.eprintf "[DEBUG] Fastcgi_record.read: Header parsed - version=%d, type=%d, id=%d, content_len=%d, padding=%d\n%!"
119 version record_type_int request_id content_length padding_length;
120
121 (* Validate version *)
122 if version <> fcgi_version_1 then invalid_version version;
123
124 (* Convert record type *)
125 let record_type = record_of_int record_type_int in
126 Printf.eprintf "[DEBUG] Fastcgi_record.read: Record type = %s\n%!"
127 (Format.asprintf "%a" pp_record record_type);
128
129 (* Read content *)
130 let content =
131 if content_length = 0 then (
132 Printf.eprintf "[DEBUG] Fastcgi_record.read: No content to read (length=0)\n%!";
133 ""
134 ) else (
135 Printf.eprintf "[DEBUG] Fastcgi_record.read: Reading %d bytes of content\n%!" content_length;
136 let c = Eio.Buf_read.take content_length buf_read in
137 Printf.eprintf "[DEBUG] Fastcgi_record.read: Successfully read %d bytes\n%!" (String.length c);
138 c
139 )
140 in
141
142 (* Skip padding *)
143 if padding_length > 0 then (
144 Printf.eprintf "[DEBUG] Fastcgi_record.read: Skipping %d bytes of padding\n%!" padding_length;
145 ignore (Eio.Buf_read.take padding_length buf_read)
146 );
147
148 let record = { version; record_type; request_id; content; offset = 0; length = String.length content } in
149 Printf.eprintf "[DEBUG] Fastcgi_record.read: Complete record = %s\n%!"
150 (Format.asprintf "%a" (pp ~max_content_len:50) record);
151 record
152
153let write buf_write record =
154 let total_content_length = String.length record.content in
155 let content_offset = record.offset in
156 let content_length = record.length in
157
158 (* Validate bounds *)
159 if content_offset < 0 || content_offset > total_content_length then
160 invalid_arg "Fastcgi_record.write: offset out of bounds";
161 if content_length < 0 || content_offset + content_length > total_content_length then
162 invalid_arg "Fastcgi_record.write: length out of bounds";
163
164 (* Calculate padding for 8-byte alignment *)
165 let padding_length = (8 - (content_length land 7)) land 7 in
166
167 (* Create and write header *)
168 let header = Bytes.create fcgi_header_len in
169 Bytes.set_uint8 header 0 record.version;
170 Bytes.set_uint8 header 1 (record_to_int record.record_type);
171 Bytes.set_uint16_be header 2 record.request_id;
172 Bytes.set_uint16_be header 4 content_length;
173 Bytes.set_uint8 header 6 padding_length;
174 Bytes.set_uint8 header 7 0; (* reserved *)
175
176 Eio.Buf_write.string buf_write (Bytes.to_string header);
177
178 (* Write content with offset and length *)
179 if content_length > 0 then
180 Eio.Buf_write.string buf_write record.content ~off:content_offset ~len:content_length;
181
182 (* Write padding *)
183 if padding_length > 0 then
184 Eio.Buf_write.string buf_write (String.make padding_length '\000')
185
186let create ?(version=1) ~record ~request_id ~content ?(offset=0) ?length () =
187 let content_length = match length with
188 | None -> String.length content - offset
189 | Some l -> l
190 in
191 { version; record_type = record; request_id; content; offset; length = content_length }
192
193module KV = struct
194 type t = (string * string) list
195
196 let empty = []
197
198 let add key value kvs = (key, value) :: kvs
199
200 let remove key kvs = List.filter (fun (k, _) -> k <> key) kvs
201
202 let cardinal kvs = List.length kvs
203
204 let find key kvs =
205 try List.assoc key kvs
206 with Not_found -> raise Not_found
207
208 let find_opt key kvs =
209 try Some (List.assoc key kvs)
210 with Not_found -> None
211
212 let to_seq kvs = List.to_seq kvs
213
214 let of_seq seq = List.of_seq seq
215
216 (** Helper functions for length encoding/decoding *)
217 let is_long_length first_byte = first_byte land 0x80 <> 0
218
219 let decode_short_length first_byte = first_byte
220
221 let decode_long_length buf pos =
222 check_bounds buf pos 4 "reading 4-byte length";
223 let first_byte = Char.code buf.[pos] in
224 ((first_byte land 0x7f) lsl 24) lor
225 ((Char.code buf.[pos + 1]) lsl 16) lor
226 ((Char.code buf.[pos + 2]) lsl 8) lor
227 (Char.code buf.[pos + 3])
228
229 let encode_length len =
230 if len <= 127 then
231 String.make 1 (Char.chr len)
232 else
233 let b = Bytes.create 4 in
234 Bytes.set_int32_be b 0 (Int32.logor (Int32.of_int len) 0x80000000l);
235 Bytes.to_string b
236
237 let decode_length buf pos =
238 check_bounds buf pos 1 "reading length";
239 let first_byte = Char.code buf.[pos] in
240 if is_long_length first_byte then
241 (* Four byte length *)
242 let len = decode_long_length buf pos in
243 (len, pos + 4)
244 else
245 (* Single byte length *)
246 (decode_short_length first_byte, pos + 1)
247
248 let encode kvs =
249 let buf = Buffer.create 256 in
250 List.iter (fun (key, value) ->
251 let key_len = String.length key in
252 let value_len = String.length value in
253 Buffer.add_string buf (encode_length key_len);
254 Buffer.add_string buf (encode_length value_len);
255 Buffer.add_string buf key;
256 Buffer.add_string buf value
257 ) kvs;
258 Buffer.contents buf
259
260 (** Extract key-value pair from buffer at given position *)
261 let extract_kv_pair content pos name_len value_len =
262 check_bounds content pos (name_len + value_len) "reading key-value data";
263 let name = String.sub content pos name_len in
264 let value = String.sub content (pos + name_len) value_len in
265 (name, value)
266
267 let decode content =
268 let len = String.length content in
269 let rec loop pos acc =
270 if pos >= len then
271 List.rev acc
272 else
273 (* Read name length *)
274 let name_len, pos = decode_length content pos in
275 (* Read value length *)
276 let value_len, pos = decode_length content pos in
277
278 (* Extract name and value *)
279 let name, value = extract_kv_pair content pos name_len value_len in
280
281 loop (pos + name_len + value_len) ((name, value) :: acc)
282 in
283 loop 0 []
284
285 let read buf_read =
286 (* For reading from a stream, we need to determine how much data to read.
287 Since we're in a record context, we should read all available data
288 until we hit the end of the record content. *)
289 let content = Eio.Buf_read.take_all buf_read in
290 decode content
291
292 let write buf_write kvs =
293 let encoded = encode kvs in
294 Eio.Buf_write.string buf_write encoded
295
296 let pp ppf kvs =
297 Format.fprintf ppf "@[<2>[@[";
298 let first = ref true in
299 List.iter (fun (key, value) ->
300 if not !first then Format.fprintf ppf ";@ ";
301 first := false;
302 Format.fprintf ppf "(%S, %S)" key value
303 ) kvs;
304 Format.fprintf ppf "@]]@]"
305end