Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 285 lines (246 sloc) 12.297 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 FIXME: remove these open
20 *)
21 let eprintf fmt = Format.kfprintf (fun _ -> Format.pp_print_flush Format.err_formatter ()) Format.err_formatter fmt
22 let fprintf = Printf.fprintf
23
24 module List = Base.List
25 module Array = Base.Array
26 module String = Base.String
27 module Char = Base.Char
28
29 let ug = String.unsafe_get
30 let us = String.unsafe_sub
31
32 let allhdrs =
33 ["Accept"; "Accept-Charset"; "Accept-Encoding"; "Accept-Language";
34 "Accept-Ranges"; "Age"; "Allow"; "Authorization"; "CONNECT";
35 "Cache-Control"; "Connection"; "Content-Disposition"; "Content-Encoding";
36 "Content-Language"; "Content-Length"; "Content-Location"; "Content-MD5";
37 "Content-Range"; "Content-Type"; "Cookie"; "Cookie2"; "DELETE"; "Date";
38 "ETag"; "Expect"; "Expires"; "From"; "GET"; "HEAD"; "Host"; "If-Match";
39 "If-Modified-Since"; "If-None-Match"; "If-Range"; "If-Unmodified-Since";
40 "Keep-Alive"; "Last-Modified"; "Location"; "Max-Forwards"; "MyCookie";
41 "Origin"; "POST"; "PUT"; "Pragma"; "Proxy-Authenticate";
42 "Proxy-Authorization"; "Referer"; "ReqRange"; "Retry-After"; "Server";
43 "Set-Cookie"; "Set-Cookie2"; "TE"; "TRACE"; "Trailer"; "Transfer-Encoding";
44 "Upgrade"; "User-Agent"; "Vary"; "Via"; "WWW-Authenticate"; "Warning"]
45
46 let mnmx ci b mn mx =
47 if ci
48 then (min (Char.uppercase b) mn),(max (Char.lowercase b) mx)
49 else (min b mn),(max b mx)
50
51 let mktab aname failfn mms =
52 let rec mkatab0 mms =
53 match mms with
54 | [] -> ""
55 | (mn,mx)::[] -> Printf.sprintf "Array.make %d %s" (Char.code mx - Char.code mn + 1) failfn
56 | (mn,mx)::rest -> Printf.sprintf "Array.init %d (fun _ -> %s)" (Char.code mx - Char.code mn + 1) (mkatab0 rest) in
57 "let "^aname^" = "^mkatab0 mms
58
59 let rplcpn str s = Str.global_replace (Str.regexp_string "%n") s str
60
61 let afilt p a l =
62 let cnt = ref 0 in
63 for i = 0 to l - 1 do
64 if p i a.(i) then incr cnt;
65 done;
66 if (!cnt) = 0
67 then None
68 else
69 let b = Array.make (!cnt) a.(0) in
70 cnt := 0;
71 for i = 0 to l - 1 do
72 if p i a.(i) then begin
73 b.(!cnt) <- a.(i); incr cnt
74 end
75 done;
76 Some b
77
78 let saminmax sa = Array.fold_left (fun (a1,a2) b -> let l = String.length b in ((min a1 l),(max a2 l))) (max_int,min_int) sa
79
80 let minmax ci sa n = Array.fold_left (fun (a1,a2) b -> (mnmx ci b.[n] a1 a2)) ('\xff','\x00') sa
81
82 let saconcat sep a = String.concat sep (Array.to_list a)
83
84 let rec ipow x y = match y with | 0 -> 1 | 1 -> x | y -> x * (ipow x (y-1))
85
86 let cics cnt cs =
87 Array.init (ipow 2 cnt)
88 (fun i -> Array.init cnt (fun j ->
89 if i land (ipow 2 j) <> 0
90 then Char.lowercase cs.(j)
91 else Char.uppercase cs.(j)))
92
93 let mkatab ci cnt cs mms =
94 (Array.map (fun cs -> saconcat "." (Array.init cnt (fun i -> Printf.sprintf "(%d)" (Char.code cs.(i) - Char.code (fst (mms.(i)))))))
95 (if ci then cics cnt cs else [|cs|]),
96 saconcat "" (Array.map (fun ch -> (* (String.make 1) ch *) (Printf.sprintf "%02x" (Char.code ch))) cs))
97
98 let mkaccess cnt mms =
99 saconcat "." (Array.init cnt (fun i -> Printf.sprintf "((Char.code c%d)-%d)" i (Char.code (fst (mms.(i))))))
100
101 let mkchk from_n mms cnt inname error =
102 let get_n i = if from_n then Printf.sprintf "(n+%d)" i else Printf.sprintf "%d" i in
103 (saconcat "\n" (Array.init cnt (fun i -> Printf.sprintf " let c%d = String.unsafe_get %s %s in" i inname (get_n i))))^"\n"^
104 (saconcat "\n" (Array.init cnt (fun i -> Printf.sprintf " if c%d < '%s' || c%d > '%s' then %s;"
105 i (Char.escaped (fst (mms.(i)))) i (Char.escaped (snd (mms.(i)))) error)))
106
461365b [cleanup] Base.String: changed String.split to a much simpler String.…
Louis Gesbert authored
107 let mkus args = String.concat " " (List.map (fun s -> "_"^s) (String.slice ' ' args))
fccc685 Initial open-source release
MLstate authored
108
109 let mkerrargs errordef argtys =
110 String.concat " " (List.map (fun (a,t) -> "("^(if List.mem_assoc a errordef then "" else "_")^a^":"^t^")") argtys)
111
112 let mkargs def = String.concat " " (List.map fst def)
113
114 let mktype def = String.concat " * " (List.map snd def)
115
116 let mkfntype def = String.concat " -> " (List.map snd def)
117
118 let mktuple = function [] -> "" | [(a,_)] -> a | def -> "("^String.concat "," (List.map fst def)^")"
119
120 let runtime prefix cnt _ci =
121 Printf.sprintf "let %s_scmp_ ug s1 s2 m n =\n\
122 let p = ref m in\n\
123 let q = ref %d in\n\
124 while !p < n && ug s1 (!p) = ug s2 (!q) do incr p; incr q done;\n\
125 !p = n\n\
126 let %s_scmp = %s_scmp_ String.unsafe_get\n\
127 let %s_scmp_ci = %s_scmp_ (fun str n -> Char.lowercase (String.unsafe_get str n))\n\
128 " prefix cnt
129 (*(if ci then "Char.lowercase (" else "") (if ci then ")" else "")
130 (if ci then "Char.lowercase (" else "") (if ci then ")" else "")*)
131 prefix prefix prefix prefix
132
133 let index_of str a = Array.fold_left_i (fun ii b i -> if b = str then i else ii) (-1) a
134
135 let iter_norpt f a = ignore (Array.fold_left (fun dn x -> if List.mem x dn then dn else (f x; x::dn) ) [] a)
136
137 let rec mktab1 ?(header="")
138 ?(prefix="is")
139 ?(failfn_opt=None)
140 ?(ci = false)
141 ?(from_n=false)
142 ?(str_to_arg=(fun s -> "%n","",s))
143 ?(fn_array=false)
144 ?(argtys=[("str","string");("strlen","int");("nxt","int")])
145 ?(errordef=[("nxt","int")])
146 ?(intype="unit")
147 ?(restype="unit")
148 filename ushdrs cnt n =
149 let hdrs = Array.copy ushdrs in
150 Array.sort String.compare hdrs; (* <--- essential! *)
151 let (samin,_samax) = saminmax hdrs in
152 if samin < cnt then begin eprintf "mkrp: minimum string length is less than dimension\n"; exit 1 end;
153 let oc = if filename = "stdout" then stdout else open_out filename in
154 let aname = prefix^"_tab" in
155 let failfn = Option.default (prefix^"_fail") failfn_opt in
156 let inname = fst (List.hd argtys) in
157 let args = mkargs argtys in
158 let fntype = mkfntype (argtys@[("","int")]@[("",intype)]@[("",restype)]) in
159 let fn = if from_n then "n " else "" in
160 let ffn = if from_n then "(_n:int) " else "" in
161 let error,exntype =
162 if errordef = []
163 then Printf.sprintf "raise ParseFail_%s" prefix,""
164 else Printf.sprintf "raise (ParseFail_%s %s)" prefix (mktuple errordef),Printf.sprintf " of %s" (mktype errordef) in
165 Array.sort String.compare hdrs;
166 let hlen = Array.length hdrs in
167 let mms = Array.init cnt (minmax ci hdrs) in
168 (*let _attlens = Array.map String.length hdrs in*)
169 let lcs = Array.create cnt '\000' in
170 fprintf oc "(* Generated by mkrp.ml - %s *)\n%s\n" (Date.rfc1123 (Unix.gmtime (Unix.gettimeofday()))) header;
171 fprintf oc "exception ParseFail_%s%s\n\n" prefix exntype;
172 fprintf oc "%s\n" (runtime prefix cnt ci);
173 if Option.is_none failfn_opt
174 then fprintf oc "let %s (_:%s%s%s) %s %s= %s\n\n"
175 failfn (if fn_array then "(" else "") fntype (if fn_array then ") array" else "")
176 (mkerrargs errordef argtys) ffn error;
177 fprintf oc "%s\n" (mktab aname failfn (Array.to_list mms));
178 for i = 0 to hlen - 1 do
179 let cs = Array.init cnt (fun j -> ug hdrs.(i) (n+j)) in
180 let inds,ss = mkatab ci cnt cs mms in
181 let ffn j _c = Array.init cnt (fun k -> hdrs.(j).[n+k]) = cs in
182 if cs <> lcs then begin
183 match afilt ffn hdrs hlen with
184 Some subhdrs ->
185 Array.sort (fun s1 s2 -> Pervasives.compare (String.length s2) (String.length s1)) subhdrs;
186 fprintf oc "\nlet %s%s rpfn %s %s=\n" prefix ss args fn;
187 let fst = ref true in
188 for k = 0 to Array.length subhdrs - 1 do
189 let shlen = String.length subhdrs.(k) in
190 if not (!fst) then fprintf oc " else " else fprintf oc " ";
191 let cntn = if from_n then "n" else Printf.sprintf "%d" cnt in
192 let shlenn =
193 if from_n then if shlen = cnt then "n" else Printf.sprintf "(n+%d)" (shlen-cnt) else Printf.sprintf "%d" shlen in
194 let tst =
195 if cnt = shlen
196 then "true"
197 else Printf.sprintf "%s_scmp%s %s \"%s\" %s %s" prefix (if ci then "_ci" else "") inname subhdrs.(k) cntn shlenn in
198 let idx = index_of subhdrs.(k) ushdrs in
199 let n, lts, v = str_to_arg subhdrs.(k) in
200 let n = rplcpn n shlenn in
201 let lts = rplcpn lts shlenn in
202 let v = rplcpn v shlenn in
203 let fnidx = if fn_array then Printf.sprintf ".(%d)" idx else "" in
204 fprintf oc "if %s\n" tst;
205 fprintf oc " then%s rpfn%s %s %s %s\n" lts fnidx args n v;
206 fst := false
207 done;
208 fprintf oc " else %s\n" error;
209 iter_norpt (fun ind -> fprintf oc "let _ = %s.%s <- %s%s\n" aname ind prefix ss) inds;
210 | None -> ();
211 end;
212 Array.blit cs 0 lcs 0 cnt
213 done;
214 fprintf oc "\nlet %s_mms = [|%s|]\n\n"
215 prefix (saconcat ";" (Array.map (fun (mn,mx) -> Printf.sprintf "('%s','%s')" (Char.escaped mn) (Char.escaped mx)) mms));
216 fprintf oc "let %s_call rpfn %s %s=\n try\n%s\n %s.%s rpfn %s%s\n with _ -> %s\n"
217 prefix args fn (mkchk from_n mms cnt inname error) aname (mkaccess cnt mms) args
218 (if from_n then Printf.sprintf " (n+%d)" cnt else "") error;
219 if filename <> "stdout" then close_out oc
220
221 (*
222 let rhtype = "[`string of string | `value of (string * string option) list] RequestHeader.t"
223
224 let cwd = Unix.getcwd()
225
226 let reqhdrs =
227 [| "Cache-Control"; "Connection"; "Date"; "Pragma"; "Trailer"; "Transfer-Encoding"; "Upgrade"; "Via"; "Warning";
228 "Allow"; "Content-Encoding"; "Content-Language"; "Content-Length"; "Content-Location"; "Content-MD5"; "Content-Range";
229 "Content-Type"; "Content-Disposition"; "Expires"; "Last-Modified"; "Accept"; "Accept-Charset"; "Accept-Encoding";
230 "Accept-Language"; "Authorization"; "Expect"; "From"; "Host"; "If-Match"; "If-Modified-Since"; "If-None-Match";
231 "If-Range"; "If-Unmodified-Since"; "Max-Forwards"; "Proxy-Authorization"; "ReqRange"; "Referer"; "TE"; "User-Agent";
232 "Cookie"; "NewCookie"; |]
233
234 let minus_to_under str = String.map (function '-' -> '_' | c -> c) str
235
236 let _ =
237 let file = "libnet/http/rp_hdr.ml" in
238 printf "mkrp: Generating %s/%s\n" cwd file;
239 mktab1
240 ~str_to_arg:(fun s -> "%n","","`"^minus_to_under s)
241 ~prefix:"hdr"
242 ~ci:true
243 ~header:"open Requestdef\nopen RequestType\n"
244 ~argtys:[("hdr","string");("hdrlen","int");("nxt","int");("rh",rhtype)]
245 ~intype:"request_header"
246 ~restype:rhtype
247 ~errordef:[("nxt","int")]
248 file reqhdrs 2 0
249
250 let typhdrs = [| "CONNECT"; "DELETE"; "GET"; "HEAD"; "OPTIONS"; "POST"; "PUT"; "TRACE" |]
251
252 let _ =
253 let file = "libnet/http/rp_typ.ml" in
254 printf "mkrp: Generating %s/%s\n" cwd file;
255 mktab1
256 ~str_to_arg:(fun s -> "%n","",String.capitalize (String.lowercase s))
257 ~prefix:"typ"
258 ~ci:true
259 ~header:"open Requestdef\nopen RequestType\n"
260 ~argtys:[("typ","string");("typlen","int");("nxt","int");("req","string");("reqlen","int")]
261 ~intype:"_method"
262 ~restype:"int * parse_request"
263 ~errordef:[("nxt","int")]
264 file typhdrs 1 0
265
266 let browhdrs = [| "Mozilla"; "Nokia"; "Opera"; "Microsoft"; "MOT"; "HTC"; "w3m"; "Seamonkey"; "Dillo"; "PSP";
267 "Wget"; "lwp-trivial"; "Lynx"; "Links"; "amaya";
268 "Googlebot"; "msnbot"; "MSNBOT"; "Yahoo! Slurp"; "YahooSeeker"; |]
269
270 let _ =
271 let file = "libnet/http/rp_brow.ml" in
272 printf "mkrp: Generating %s/%s\n" cwd file;
273 mktab1
274 ~str_to_arg:(fun s -> "%n","","\""^s^"\"")
275 ~fn_array:true
276 ~prefix:"brow"
277 ~ci:false
278 ~header:"open UserCompatType"
279 ~argtys:[("brow","string");("browlen","int")(*;("nxt","int")*)]
280 ~intype:"string"
281 ~restype:"UserCompatType.renderer_engine"
282 ~errordef:[(*("nxt","int")*)]
283 file browhdrs 2 0
284 *)
Something went wrong with that request. Please try again.