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}
81
82let pp ?(max_content_len=100) ppf record =
83 let truncated_content =
84 let content = record.content in
85 let len = String.length content in
86 if len <= max_content_len then content
87 else String.sub content 0 max_content_len ^ "..." ^ Printf.sprintf " (%d more bytes)" (len - max_content_len)
88 in
89 Format.fprintf ppf
90 "@[<2>{ version = %d;@ record_type = %a;@ request_id = %d;@ content = %S }@]"
91 record.version
92 pp_record record.record_type
93 record.request_id
94 truncated_content
95
96(* FastCGI constants *)
97let fcgi_version_1 = 1
98let fcgi_header_len = 8
99
100let read buf_read =
101 Printf.eprintf "[DEBUG] Fastcgi_record.read: Starting to read record\n%!";
102 (* Read the 8-byte header *)
103 Printf.eprintf "[DEBUG] Fastcgi_record.read: Reading %d-byte header\n%!" fcgi_header_len;
104 let header = Eio.Buf_read.take fcgi_header_len buf_read in
105
106 (* Parse header fields *)
107 let version = Char.code header.[0] in
108 let record_type_int = Char.code header.[1] in
109 let request_id = (Char.code header.[2] lsl 8) lor (Char.code header.[3]) in
110 let content_length = (Char.code header.[4] lsl 8) lor (Char.code header.[5]) in
111 let padding_length = Char.code header.[6] in
112 let _reserved = Char.code header.[7] in
113
114 Printf.eprintf "[DEBUG] Fastcgi_record.read: Header parsed - version=%d, type=%d, id=%d, content_len=%d, padding=%d\n%!"
115 version record_type_int request_id content_length padding_length;
116
117 (* Validate version *)
118 if version <> fcgi_version_1 then invalid_version version;
119
120 (* Convert record type *)
121 let record_type = record_of_int record_type_int in
122 Printf.eprintf "[DEBUG] Fastcgi_record.read: Record type = %s\n%!"
123 (Format.asprintf "%a" pp_record record_type);
124
125 (* Read content *)
126 let content =
127 if content_length = 0 then (
128 Printf.eprintf "[DEBUG] Fastcgi_record.read: No content to read (length=0)\n%!";
129 ""
130 ) else (
131 Printf.eprintf "[DEBUG] Fastcgi_record.read: Reading %d bytes of content\n%!" content_length;
132 let c = Eio.Buf_read.take content_length buf_read in
133 Printf.eprintf "[DEBUG] Fastcgi_record.read: Successfully read %d bytes\n%!" (String.length c);
134 c
135 )
136 in
137
138 (* Skip padding *)
139 if padding_length > 0 then (
140 Printf.eprintf "[DEBUG] Fastcgi_record.read: Skipping %d bytes of padding\n%!" padding_length;
141 ignore (Eio.Buf_read.take padding_length buf_read)
142 );
143
144 let record = { version; record_type; request_id; content } in
145 Printf.eprintf "[DEBUG] Fastcgi_record.read: Complete record = %s\n%!"
146 (Format.asprintf "%a" (pp ~max_content_len:50) record);
147 record
148
149let write buf_write record =
150 let content_length = String.length record.content in
151
152 (* Calculate padding for 8-byte alignment *)
153 let padding_length = (8 - (content_length land 7)) land 7 in
154
155 (* Create and write header *)
156 let header = Bytes.create fcgi_header_len in
157 Bytes.set_uint8 header 0 record.version;
158 Bytes.set_uint8 header 1 (record_to_int record.record_type);
159 Bytes.set_uint16_be header 2 record.request_id;
160 Bytes.set_uint16_be header 4 content_length;
161 Bytes.set_uint8 header 6 padding_length;
162 Bytes.set_uint8 header 7 0; (* reserved *)
163
164 Eio.Buf_write.string buf_write (Bytes.to_string header);
165
166 (* Write content *)
167 if content_length > 0 then
168 Eio.Buf_write.string buf_write record.content;
169
170 (* Write padding *)
171 if padding_length > 0 then
172 Eio.Buf_write.string buf_write (String.make padding_length '\000')
173
174let create ~version ~record ~request_id ~content =
175 { version; record_type = record; request_id; content }
176
177module KV = struct
178 type t = (string * string) list
179
180 let empty = []
181
182 let add key value kvs = (key, value) :: kvs
183
184 let remove key kvs = List.filter (fun (k, _) -> k <> key) kvs
185
186 let cardinal kvs = List.length kvs
187
188 let find key kvs =
189 try List.assoc key kvs
190 with Not_found -> raise Not_found
191
192 let find_opt key kvs =
193 try Some (List.assoc key kvs)
194 with Not_found -> None
195
196 let to_seq kvs = List.to_seq kvs
197
198 let of_seq seq = List.of_seq seq
199
200 (** Helper functions for length encoding/decoding *)
201 let is_long_length first_byte = first_byte land 0x80 <> 0
202
203 let decode_short_length first_byte = first_byte
204
205 let decode_long_length buf pos =
206 check_bounds buf pos 4 "reading 4-byte length";
207 let first_byte = Char.code buf.[pos] in
208 ((first_byte land 0x7f) lsl 24) lor
209 ((Char.code buf.[pos + 1]) lsl 16) lor
210 ((Char.code buf.[pos + 2]) lsl 8) lor
211 (Char.code buf.[pos + 3])
212
213 let encode_length len =
214 if len <= 127 then
215 String.make 1 (Char.chr len)
216 else
217 let b = Bytes.create 4 in
218 Bytes.set_int32_be b 0 (Int32.logor (Int32.of_int len) 0x80000000l);
219 Bytes.to_string b
220
221 let decode_length buf pos =
222 check_bounds buf pos 1 "reading length";
223 let first_byte = Char.code buf.[pos] in
224 if is_long_length first_byte then
225 (* Four byte length *)
226 let len = decode_long_length buf pos in
227 (len, pos + 4)
228 else
229 (* Single byte length *)
230 (decode_short_length first_byte, pos + 1)
231
232 let encode kvs =
233 let buf = Buffer.create 256 in
234 List.iter (fun (key, value) ->
235 let key_len = String.length key in
236 let value_len = String.length value in
237 Buffer.add_string buf (encode_length key_len);
238 Buffer.add_string buf (encode_length value_len);
239 Buffer.add_string buf key;
240 Buffer.add_string buf value
241 ) kvs;
242 Buffer.contents buf
243
244 (** Extract key-value pair from buffer at given position *)
245 let extract_kv_pair content pos name_len value_len =
246 check_bounds content pos (name_len + value_len) "reading key-value data";
247 let name = String.sub content pos name_len in
248 let value = String.sub content (pos + name_len) value_len in
249 (name, value)
250
251 let decode content =
252 let len = String.length content in
253 let rec loop pos acc =
254 if pos >= len then
255 List.rev acc
256 else
257 (* Read name length *)
258 let name_len, pos = decode_length content pos in
259 (* Read value length *)
260 let value_len, pos = decode_length content pos in
261
262 (* Extract name and value *)
263 let name, value = extract_kv_pair content pos name_len value_len in
264
265 loop (pos + name_len + value_len) ((name, value) :: acc)
266 in
267 loop 0 []
268
269 let read buf_read =
270 (* For reading from a stream, we need to determine how much data to read.
271 Since we're in a record context, we should read all available data
272 until we hit the end of the record content. *)
273 let content = Eio.Buf_read.take_all buf_read in
274 decode content
275
276 let write buf_write kvs =
277 let encoded = encode kvs in
278 Eio.Buf_write.string buf_write encoded
279
280 let pp ppf kvs =
281 Format.fprintf ppf "@[<2>[@[";
282 let first = ref true in
283 List.iter (fun (key, value) ->
284 if not !first then Format.fprintf ppf ";@ ";
285 first := false;
286 Format.fprintf ppf "(%S, %S)" key value
287 ) kvs;
288 Format.fprintf ppf "@]]@]"
289end