Skip to content
Newer
Older
100644 404 lines (379 sloc) 19.8 KB
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
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 module List = Base.List
20 module O = Ocaml
21 module Cons = O.Cons
22 module G = Grammar
23
24 let (<|) f a = f a
25 let (|>) a f = f a
26 let ( @* ) g f x = g(f(x))
27
28 let msgtype_of_defs lst =
29 let typeconstr_of_def = function
30 | G.Define (G.Constr (name, []), _) -> name, None
31 | G.Define (G.Constr (name, lst), _) ->
32 name, Some (O.TypeTuple (List.map (snd @* Tools.tuple_of_var) lst))
33 | _ -> assert false
34 in O.Type [[], "msg", O.TypeConstructor (List.map typeconstr_of_def lst)]
35
36 let gettype_of_defs lst =
37 let gettype_of_def = function
38 | G.Define (G.Constr (name, []), _) ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored Jun 28, 2011
39 O.Val (Ident.source (Printf.sprintf "get_%s" name),
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
40 O.TypeArrow (O.TypeName ([O.TypeVerbatim "msg"],["list"]), O.TypeVerbatim "msg option"))
41 | G.Define (G.Constr (name, lst), _) ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored Jun 28, 2011
42 O.Val (Ident.source (Printf.sprintf "get_%s" name),
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
43 O.TypeArrow (O.TypeName ([O.TypeVerbatim "msg"],["list"]),
44 O.TypeName ([(O.TypeTuple (List.map (snd @* Tools.tuple_of_var) lst))],["option"])))
45 | _ -> assert false
46 in List.map gettype_of_def lst
47
48 let rec ol2l = function [] -> [] | (Some x)::rest -> x::ol2l rest | None::rest -> (O.TypeConst O.TypeString)::ol2l rest
49
50 let msgtype_of_raws lst =
51 let typeconstr_of_raw = function
52 | G.Raw (name, _, []) -> name, None
53 | G.Raw (name, _, lst) -> name, Some (O.TypeTuple (ol2l (List.map (fun (_,b,_,_) -> b) lst)))
54 | _ -> assert false
55 in O.Type [[], "rawmsg", O.TypeConstructor (List.map typeconstr_of_raw lst)]
56
57 let gettype_of_raws lst =
58 let gettype_of_raw = function
a9f8d34 [cleanup] Base: remove sprintf
Raja authored Jun 28, 2011
59 | G.Raw (name, _, []) -> O.Val (Ident.source (Printf.sprintf "get_%s" name),
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
60 O.TypeArrow (O.TypeName ([O.TypeVerbatim "rawmsg"],["list"]), O.TypeVerbatim "rawmsg option"))
a9f8d34 [cleanup] Base: remove sprintf
Raja authored Jun 28, 2011
61 | G.Raw (name, _, lst) -> O.Val (Ident.source (Printf.sprintf "get_%s" name),
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
62 O.TypeArrow (O.TypeName ([O.TypeVerbatim "rawmsg"],["list"]),
63 O.TypeName ([(O.TypeTuple (ol2l (List.map (fun (_,b,_,_) -> b) lst)))],["option"])))
64 | _ -> assert false
65 in List.map gettype_of_raw lst
66
67 let str_of_type_expr te = let b = Buffer.create 1024 in (OcamlPrint.Buf.type_expr b te; Buffer.contents b)
68
69 let make_runtime_type = function
70 | G.Startfun (name, lst, _) ->
71 let param_types =
72 str_of_type_expr (match lst with [] -> O.TypeConst O.TypeUnit | _ -> (O.TypeTuple (List.map (snd @* Tools.tuple_of_var) lst))) in
73 "\
74 type proto_exn = exn * string * (string option)\n\
75 \n\
76 type ec = proto_exn -> runtime -> Scheduler.t -> Scheduler.connection_info -> Buffer.t * int ref -> unit\n\
77 \n\
78 type ecsa = proto_exn -> runtime -> Scheduler.t -> Scheduler.connection_info -> Buffer.t * int ref -> ec -> unit\n\
79 \n\
80 type t =\n \
81 {\n \
82 runtime : runtime;\n \
83 err_cont : ecsa option;\n \
84 extra_params : "^param_types^";\n \
85 }\n\n"
86 | _ -> assert false
87
88 let make_launch_server parserprefix = function
89 | G.Startfun (name, lst, _) ->
90 let params = String.concat " " <| List.map (fst @* Tools.tuple_of_var) lst in
91 let paramst = "("^(String.concat "," <| List.map (fst @* Tools.tuple_of_var) lst)^")" in
92 let modname = String.capitalize parserprefix in
93 "\n(* == Future design on Runtime layer == *)\n\
94 (* Two steps (privileged and unprivileged) *)\n\
95 exception PermissionDenied\n\
96 exception UnixError\n\
97 \n\
98 let proto_"^name^"_start "^params^" runtime sched conn (_err_cont:ec) =\n \
99 (* Per-connection initialisation here... *)\n \
100 incr number_of_connections;\n \
101 proto_"^name^" "^params^" runtime sched conn (new_mailbox runtime) _err_cont\n\
102 \n\
103 let get_ports (t:t) (sched:Scheduler.t) =\n \
104 [ t.runtime.rt_proto.rt_name, `Connection\n \
105 { Network.\n \
106 conn_incoming =\n \
107 (fun _params conn ->\n \
108 let "^paramst^" = t.extra_params in\n \
109 let _err_cont = Option.default default_err_cont (Option.map ecsa2ec t.err_cont) in\n \
110 proto_"^name^"_start "^params^" t.runtime sched conn _err_cont\n \
111 );\n \
112 conn_terminating = (fun () -> Logger.log \""^modname^" terminated\");\n \
113 secure_mode = t.runtime.rt_proto.rt_secure_mode;\n \
114 port_spec = Network.make_port_spec ~protocol (Unix.inet_addr_of_string t.runtime.rt_proto.rt_addr) t.runtime.rt_proto.rt_port\n \
115 };\n \
116 ]\n\n"
117 | _ -> assert false
118
119
120 let make_launch_client = function
121 | G.Startfun (name, lst, _) ->
122 let params = String.concat " " <| List.map (fst @* Tools.tuple_of_var) lst in
123 let paramst = "("^(String.concat "," <| List.map (fst @* Tools.tuple_of_var) lst)^")" in
124 "\n\
125 let proto_"^name^"_start "^params^" (runtime:runtime) (sched:Scheduler.t) (conn:Scheduler.connection_info) ?_err_cont () =\n \
126 (* Per-connection initialisation here... *)\n \
127 incr number_of_connections;\n \
128 let _err_cont = Option.default default_err_cont (Option.map ecsa2ec _err_cont) in\n \
129 proto_"^name^" "^params^" runtime sched conn (new_mailbox runtime) _err_cont\n\
130 \n\
131 let connect (t:t) ?(secure_mode=Network.Unsecured) (sched:Scheduler.t) (addr:string) (port:int) =\n \
132 let port_spec = Network.make_port_spec ~protocol (Network.inet_addr_of_name addr) port in\n \
133 let "^paramst^" = t.extra_params in\n \
134 Network.connect sched port_spec secure_mode\n \
135 (fun conn -> proto_"^name^"_start "^params^" t.runtime sched conn ?_err_cont:t.err_cont ())\n\
136 \n\
137 let run_client (sched:Scheduler.t) =\n \
138 Scheduler.run sched\n\
139 \n\
140 let launch_client (t:t) (addr:string) (port:int) =\n \
141 let sched = Scheduler.default in\n \
142 connect t sched addr port;\n \
143 run_client sched\n\n"
144 | _ -> assert false
145
146
147 let gen_functor_sign has_raw arg lst =
148 let ilst, stuff = List.partition (function G.Import _ -> true | _ -> false) lst in
149 let sign = List.map Tools.val_of_import ilst
150 and startfun =
151 try
152 List.find (function G.Startfun _ -> true | _ -> false) lst
153 with Not_found -> failwith "Fatal Error: No entry node defined"
154 in
155 let fsign =
156 match startfun with
157 | G.Startfun (_, lst, _) ->
158 let funame = match arg with | "server" -> "launch_server" | _ -> "launch_client" in
159 (match arg with
160 | "client" ->
161 [ O.Val (Ident.source "number_of_connections", O.TypeVerbatim "int ref");
162 O.Val (Ident.source "connect",
163 O.TypeVerbatim ("t -> ?secure_mode:Network.secure_mode -> Scheduler.t -> string -> int -> unit"));
164 O.Val (Ident.source "run_client", O.TypeVerbatim ("Scheduler.t -> unit"));
165 O.Val (Ident.source funame, O.TypeVerbatim ("t -> string -> int -> unit"));
166 O.Val (Ident.source "protocol", O.TypeVerbatim "NetAddr.protocol");
167 O.Val (Ident.source "string_of_msg", O.TypeVar("msg -> string")) ;
168 ]
169 | _ ->
170 [ O.Exception ("PermissionDenied",None);
171 O.Exception ("UnixError",None);
172 O.Val (Ident.source "number_of_connections", O.TypeVerbatim "int ref");
173 O.Val (Ident.source "string_of_msg", O.TypeVar("msg -> string")) ;
174 if has_raw then O.Val (Ident.source "string_of_rawmsg", O.TypeVar("rawmsg -> string")) else O.Verbatim "";
175 O.Val (Ident.source "compare_msg", O.TypeVar("msg * msg -> bool")) ;
176 O.Val (Ident.source "get_msg_name", O.TypeVar("msg -> string")) ;
177 O.Val (Ident.source "get_ports",
178 O.TypeVerbatim("t -> Scheduler.t -> (string * [> `Connection of Network.port ]) list"));
179 O.Val (Ident.source "protocol", O.TypeVerbatim "NetAddr.protocol");
180 ])
181 | _ -> assert false
182 in
183 if List.length sign > 0 then
184 [O.DeclareFunctor (
185 "Make",
186 [ ("Required", Some (O.Signature (O.Inlined sign))) ],
187 Some (O.Signature (O.Inlined fsign)),
188 O.Structure []
189 )]
190 else fsign
191
192 let read_fun pp pn = O.Verbatim ("\n\
193 (*let raw_oc_opt = Some (open_out (Sys.getenv(\"HOME\")^\"/output.txt\"))*)\n\
194 \n\
195 let write_errcont runtime sched conn ?block_size ?timeout buf ?err_cont finalize =\n \
196 let default_errcont = function\n \
197 | Scheduler.Timeout ->\n \
198 (Logger.error \"write_errcont: Timeout\";\n \
199 Scheduler.remove_connection sched conn)\n \
200 | Scheduler.Connection_closed ->\n \
201 (Logger.error \"write_errcont: Connection_closed\";\n \
202 Scheduler.remove_connection sched conn)\n \
203 | exn ->\n \
204 (Logger.error \"Caught write exception: %s\" (Printexc.to_string exn);\n \
205 if runtime.rt_proto.rt_backtrace then Logger.debug \"%s\" (Printexc.get_backtrace());\n \
206 Scheduler.remove_connection sched conn)\n \
207 in\n \
208 let err_cont = Option.default default_errcont err_cont in\n \
209 let timeout = Option.default (runtime.rt_proto.rt_server_write_timeout) timeout in \n \
210 (*#<If$minlevel 10>match raw_oc_opt with\n \
211 | Some oc -> (output_string oc buf; Pervasives.flush oc)\n \
212 | None -> ()#<End>;*)\n \
213 Scheduler.write sched conn ?block_size ~timeout buf ~err_cont finalize\n\
214 \n\
215 let new_mailbox runtime = (HttpTools.get_buf ~hint:runtime.rt_proto.rt_block_size (), ref 0)\n\
216 \n\
217 let number_of_connections = ref 0\n\
218 \n\
219 let close_conn sched conn mailbox =\n \
220 (* Connection close code here... *)\n \
221 HttpTools.free_buf (fst mailbox);\n \
222 HttpTools.collect_bufs 2 (*(!number_of_connections)*);\n \
223 decr number_of_connections;\n \
224 #<If$minlevel 2>Logger.debug \"close_conn: %d\" !number_of_connections#<End>;\n \
225 Scheduler.remove_connection sched conn\n\
226 \n\
227 let (default_err_cont:ec) = fun (exn,name,bt_opt) _runtime sched conn mailbox ->\n \
228 Logger.error \""^(String.lowercase pp)^"(%s): Uncaught exception %s%!\" name (Printexc.to_string exn);\n \
229 Option.iter (fun bt -> Logger.debug \"%s\" bt) bt_opt;\n \
230 close_conn sched conn mailbox\n\
231 \n\
232 let ec2ecsa (ec:ec) = ((fun exn_name _runtime sched conn mailbox _ec -> ec exn_name _runtime sched conn mailbox):ecsa)\n\
233 \n\
234 let ecsa2ec (ecsa:ecsa) = ((fun exn_name _runtime sched conn mailbox -> ecsa exn_name _runtime sched conn mailbox default_err_cont):ec)\n\
235 \n\
236 let receive _runtime sched conn mailbox ?err_cont ?timeout cont =\n \
237 let parse_msg (buf,start,len) =\n \
238 let str = Buffer.sub buf start len in\n \
239 #<If$minlevel 2>Logger.debug \"receive: str='%s'\" (String.escaped str)#<End>;\n \
240 let (_pos,msg) = parse_"^(String.lowercase pn)^"_msg1 str in\n \
241 #<If$minlevel 1>Logger.debug \"receive: msg1=%s\" (String.escaped (string_of_msg msg))#<End>;\n \
242 cont msg\n \
243 in\n \
244 try\n \
245 HttpTools.upto_mark_stream_cps2 ~inclusive:true sched conn mailbox \"\\r\\n\" _runtime.rt_proto.rt_payload ?err_cont ?timeout parse_msg\n \
246 with exn -> match err_cont with Some err_cont -> err_cont exn | None -> raise exn\n\
247 ")
248
249 let gen_functor ~protocol parserprefix parsername arg lst types startfun =
250 let dlst, temp = List.partition (function G.Define _ -> true | _ -> false) lst in
251 let rlst, temp2 = List.partition (function G.Raw _ -> true |_ -> false) temp in
252 let slst, rest = List.partition (function G.Set _ -> true | _ -> false) temp2 in
253 (*let opens, stuff = List.partition (function G.MOpen _ -> true | _ -> false) rest in*)
254 let ilst, stuff2 = List.partition (function G.Import _ -> true | _ -> false) rest in
255 let ocam, stuff3 = List.partition (function G.OcamlTop _ -> true | G.Ocaml _ -> true | G.GVerbatim _ -> true | _ -> false) stuff2 in
256 let dbgvars, stuff4 = List.partition (function G.Debugvar _ -> true | _ -> false) stuff3 in
257 let funs, _ = List.partition (function G.Startfun _ -> true | G.Fun _ -> true | _ -> false) stuff4 in
258 let fs = Rewrite_funs.gen_funs funs in
259 let code = List.fold_left (fun el gl ->
260 match gl with
261 | G.OcamlTop sl -> sl@el
262 | G.Ocaml (dbg,l,ew,en,e) -> (Rewrite_funs.dbgexpr (dbg,l,ew,en,e))::el
263 | G.GVerbatim (dbg,l,ew,en,s) -> (O.Verbatim (Rewrite_funs.verbstr (dbg,l,ew,en,s)))::el
264 | _ -> assert false) [] ocam in
265 let sign = List.map Tools.val_of_import ilst in
266 let launch =
267 match arg with
268 | "server" -> make_launch_server parserprefix startfun
269 | _ -> make_launch_client startfun
270 in
271 let stru =
272 O.Verbatim (Printf.sprintf "let protocol = NetAddr.mk_protocol \"%s\"" protocol)
273 :: (if List.length sign > 0 then O.Open [Ident.source "Required"] else O.Verbatim "")
274 :: (if not (List.is_empty dlst) then Gen_printer.do_it dlst else O.Verbatim "")
275 :: (if not (List.is_empty dlst) then Gen_compare.gen_get_compare_msg dlst else O.Verbatim "")
276 :: (if not (List.is_empty dlst) then Gen_compare.gen_get_msg_name dlst else O.Verbatim "")
277 :: (if not (List.is_empty dlst) then Gen_compare.gen_get_msg_value dlst else O.Verbatim "")
278 :: (if not (List.is_empty rlst) then Gen_raw_printer.do_it rlst else O.Verbatim "")
279 :: (if not (List.is_empty rlst) then Gen_compare.gen_get_compare_rawmsg rlst else O.Verbatim "")
280 :: (if not (List.is_empty rlst) then Gen_compare.gen_get_rawmsg_name rlst else O.Verbatim "")
281 :: (if not (List.is_empty rlst) then Gen_compare.gen_get_rawmsg_value rlst else O.Verbatim "")
282 :: read_fun parserprefix parsername
283 :: List.map Tools.let_of_set slst
284 @ code
285 @ fs
286 @ [O.Verbatim launch]
287 in
288 O.Open [Ident.source "Base"]
289 :: O.Open [Ident.source "Scheduler"]
290 :: O.Open [Ident.source (String.capitalize parsername)]
291 (*:: List.map (function MOpen s -> O.Open [Ident.source s] | _ -> assert false) opens*)
292 :: List.map (function G.Debugvar s -> O.Verbatim ("#<Debugvar:"^s^">") | _ -> assert false) dbgvars
293 @ types
294 @ (if List.length sign > 0 then
295 [O.DeclareFunctor (
296 "Make",
297 [ ("Required", Some (O.Signature (O.Inlined sign))) ],
298 None,
299 O.Structure stru
300 )]
301 else stru)
302
303 let rec resolve_includes lst =
304 List.fold_right (fun expr lst ->
305 match expr with
306 | G.Include name ->
307 (*Printf.eprintf "resolve_includes: name=%s\n%!" name;*)
308 let str = File.content name in
309 let pos,partial = G.parse_grammar_prog str in
310 if pos < String.length str then
a9f8d34 [cleanup] Base: remove sprintf
Raja authored Jun 28, 2011
311 failwith <| Printf.sprintf "Parse error at char: %d in file %s" pos name
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
312 else
313 let lst2 = resolve_includes (partial) in
314 lst2@lst
315 | expr -> expr::lst) lst []
316
317 let () =
318 if Array.length Sys.argv <> 5 then
319 failwith "Not the right number of arguments."
320 else
321 let src = Sys.argv.(1) in
322 let dst_dir = Sys.argv.(2) ^ "/" in
323 let dst = dst_dir ^ Sys.argv.(3) ^ ".ml" in
324 let mlidst = dst_dir ^ Sys.argv.(3) ^ ".mli" in
325 let parserprefix = Sys.argv.(3) in
326 let parsername = Sys.argv.(4) in
327 let trx = dst_dir ^ parsername ^ ".trx" in
328 let rp = dst_dir ^ parsername ^ "_rp.ml" in
329 let str = File.content src in
330
331 let pos, partial = G.parse_grammar_prog str in
332 if pos < String.length str then
a9f8d34 [cleanup] Base: remove sprintf
Raja authored Jun 28, 2011
333 failwith <| Printf.sprintf "Parse error at char: %d in file %s" pos src
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
334 else
335 let complete = resolve_includes partial in
336
337 let tmpl = List.filter (function
338 | G.Generate _ -> false
339 | _ -> true) complete in
340 let olst, lst3 = List.partition (function G.MOpen _ -> true | _ -> false) tmpl in
341 let malst, lst4 = List.partition (function G.MAlias _ -> true | _ -> false) lst3 in
342 let tlst, lst2 = List.partition (function G.MType _ -> true | _ -> false) lst4 in
343 let vlst, lst = List.partition (function G.MVal _ -> true | _ -> false) lst2 in
344 let defs = List.filter (function G.Define _ -> true |_ -> false) lst in
345 let raws = List.filter (function G.Raw _ -> true |_ -> false) lst in
346 let has_raw = List.length raws > 0 in
347 let mtype = msgtype_of_defs defs::[] in
348 let mvals = gettype_of_defs defs in
349 let rtype = if has_raw then msgtype_of_raws raws::[] else [] in
350 let rvals = if has_raw then gettype_of_raws raws else [] in
351 let opens = List.map (function G.MOpen s -> O.Open [Ident.source s] | _ -> assert false) olst in
352 let modaliases = List.map (function G.MAlias (a,m) -> O.Module (a,Some (O.Verbatim m),[],None) | _ -> assert false) malst in
353 let startfun =
354 try List.find (function G.Startfun _ -> true | _ -> false) lst
355 with Not_found -> failwith "Fatal Error: No entry node defined" in
356 let protocol =
357 match List.find_map (function G.Protocol ct -> Some ct | _ -> None) lst with
358 | Some ct -> ct
359 | None -> failwith "Fatal error: No protocol type specification; please add '-protocol XXX' in the protocol file"
360 in
361 let runtime_type = make_runtime_type startfun in
362 let types = (Tools.types_of_tdefs parsername (G.MType ("msg", O.TypeVar "msg") :: tlst))@[O.Verbatim runtime_type] in
363 let vals = Tools.types_of_tdefs parsername vlst in
364 if not (List.is_empty raws)
365 then
366 Gen_rp.do_it rtype parsername raws rp;
367 if not (List.is_empty defs) then let output_gra = open_out trx in (
368 try
369 Gen_trx.do_it mtype defs |> OcamlPrint.Output.code output_gra;
370 let output_mod = open_out dst in (
371 try
372 let serv_or_client =
373 (try
374 (function G.Generate s -> s |_ -> assert false)
375 <| List.find (function G.Generate _ -> true | _ -> false) complete
376 with
377 | Not_found -> failwith "Fatal error: No generate specification;\
378 please add -generate client (or server) in protocol file")
379 in opens @ modaliases @ rtype @ gen_functor ~protocol parserprefix parsername serv_or_client lst types startfun
380 |> OcamlPrint.Output.code output_mod
381 ; let output_mli = open_out mlidst in (
382 try
383 opens @ modaliases @ types @ mvals @ rtype @ rvals @ vals @ gen_functor_sign has_raw serv_or_client lst
384 |> OcamlPrint.Output.code output_mli
385 with
386 | Failure s -> prerr_endline s
387 | e -> prerr_endline
a9f8d34 [cleanup] Base: remove sprintf
Raja authored Jun 28, 2011
388 <| Printf.sprintf "Fatal error while generating the signature file:"
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
389 ^ Printexc.to_string e
390 ) ; close_out output_mli
391 with
392 | Failure s -> prerr_endline s
393 | Not_found -> prerr_endline "Error, you didn't precise if you wanted a server or a client.\nRemember to add a « -generate » rule in your proto source code."
394 | e -> prerr_endline
395 <| "Fatal error while generating the ocaml source code:\n"
396 ^ Printexc.to_string e
397 ) ; close_out output_mod
398 with
399 | Failure s -> prerr_endline s
400 | e -> prerr_endline
401 <| "Fatal error while generating the trx grammar:\n"
402 ^ Printexc.to_string e
403 ) ; close_out output_gra
Something went wrong with that request. Please try again.