Skip to content
Newer
Older
100644 140 lines (114 sloc) 4.49 KB
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
1 (*
2aee925 @cedricss [enhance] runtime: Error on unknown options
cedricss authored Feb 24, 2012
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
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 (**
20 Runtime layer to merge and start a set of RuntimeSig.COMPONENT on the same scheduler.
21 @author Cedric Soulas
22 *)
23
24 module P = RuntimeType.Ports
25 module D = RuntimeType.Description
2aee925 @cedricss [enhance] runtime: Error on unknown options
cedricss authored Feb 24, 2012
26 module SA = ServerArg
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
27
28 let make_application (type options) name opt comp =
29 let module Comp = (val comp : RuntimeSig.COMPONENT with type options = options) in
30 let module App =
31 struct
32 type options = Comp.options
33 type t = Comp.t
34
35 let full_name =
36 if name <> "" then
37 Printf.sprintf "%s %s (%s)" Comp.name Comp.version name
38 else
39 Printf.sprintf "%s %s" Comp.name Comp.version
40
41 let names = [full_name]
42 let versions = StringMap.singleton Comp.name Comp.version
43
44 let make opt sched =
45 let comp = Comp.make name opt sched in
46 let ports = Comp.get_ports comp sched in
47 let description = Comp.get_description comp sched in
48 P.add sched ports;
49 D.add name description;
50 comp
51
52 let get_options () =
2aee925 @cedricss [enhance] runtime: Error on unknown options
cedricss authored Feb 24, 2012
53 let parse = SA.make_parser full_name (Comp.spec_args name) in
54 SA.filter (opt:Comp.options) parse
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
55
56 let run = Comp.run
57 let close = Comp.close
58 end
59 in
60 (module App : RuntimeSig.APPLICATION)
61
62 let merge_applications app1 app2 =
63 let module App1 = (val app1 : RuntimeSig.APPLICATION) in
64 let module App2 = (val app2 : RuntimeSig.APPLICATION) in
65 let module App =
66 struct
67 type options = App1.options * App2.options
68 type t = App1.t * App2.t
69
70 let merge_maps map1 map2 =
71 StringMap.fold
72 (fun k v map -> StringMap.add k v map) map2 map1
73
74 let names = App1.names @ App2.names
75 let versions = merge_maps App1.versions App2.versions
76 let get_options () = App1.get_options (), App2.get_options ()
77
78 let make (opt1, opt2) sch =
79 let app1 = App1.make opt1 sch in
80 let app2 = App2.make opt2 sch in
81 (app1, app2)
82
83 let run (app1, app2) sch =
84 let app1 = App1.run app1 sch in
85 let app2 = App2.run app2 sch in
86 (app1, app2)
87
88 let close (app1, app2) sch =
89 App1.close app1 sch;
90 App2.close app2 sch
91 end
92 in
93 (module App : RuntimeSig.APPLICATION)
94
95 let app = ref None
96
97 let add_component comp name opt =
98 match !app with
99 | Some a ->
100 app := Some (merge_applications a (make_application name opt comp))
101 | None ->
102 app := Some (make_application name opt comp)
103
104 let add_httpServer = add_component (module HttpServer : RuntimeSig.COMPONENT with type options = HttpServer.options)
105 let add_httpDialog = add_component (module HttpDialog : RuntimeSig.COMPONENT with type options = HttpDialog.options)
106
107 let add_ftpServer = add_component (module FtpServer : RuntimeSig.COMPONENT with type options = FtpServer.options)
108
109 let add_smtpServer = add_component (module SmtpServer : RuntimeSig.COMPONENT with type options = SmtpServer.options)
110
111 let add_watchdog = add_component (module Watchdog : RuntimeSig.COMPONENT with type options = Watchdog.options)
112
113 let start () =
114 let sched = Scheduler.default in
2aee925 @cedricss [enhance] runtime: Error on unknown options
cedricss authored Feb 24, 2012
115 let get_fun =
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
116 match !app with
2aee925 @cedricss [enhance] runtime: Error on unknown options
cedricss authored Feb 24, 2012
117 | None -> fun () -> (fun _ -> ()), (fun _ -> ())
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
118 | Some a ->
119 let module App = (val a : RuntimeSig.APPLICATION) in
120 let options = App.get_options () in
2aee925 @cedricss [enhance] runtime: Error on unknown options
cedricss authored Feb 24, 2012
121 fun () ->
122 begin
123 let app = App.make options sched in
124 RuntimeType.Ports.init sched;
125 (fun () -> let _ = App.run app sched in ()),
126 (fun () -> App.close app sched)
127 end
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
128 in
2aee925 @cedricss [enhance] runtime: Error on unknown options
cedricss authored Feb 24, 2012
129 let args = (SA.get_argv ()) in
130 if List.mem "--help" (SA.to_list args) then exit 0;
131 if not (SA.is_empty args) then begin
132 Printf.eprintf "Unknown option `%s'." (SA.argv_to_string ());
133 Printf.eprintf "Try `--help' for more information.";
134 exit 1;
135 end;
136 let run, close = get_fun () in
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
137 run ();
138 Scheduler.run sched;
139 close ()
Something went wrong with that request. Please try again.