Skip to content
Newer
Older
100644 131 lines (105 sloc) 4.25 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 (**
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
26
27 let make_application (type options) name opt comp =
28 let module Comp = (val comp : RuntimeSig.COMPONENT with type options = options) in
29 let module App =
30 struct
31 type options = Comp.options
32 type t = Comp.t
33
34 let full_name =
35 if name <> "" then
36 Printf.sprintf "%s %s (%s)" Comp.name Comp.version name
37 else
38 Printf.sprintf "%s %s" Comp.name Comp.version
39
40 let names = [full_name]
41 let versions = StringMap.singleton Comp.name Comp.version
42
43 let make opt sched =
44 let comp = Comp.make name opt sched in
45 let ports = Comp.get_ports comp sched in
46 let description = Comp.get_description comp sched in
47 P.add sched ports;
48 D.add name description;
49 comp
50
51 let get_options () =
52 let parse = ServerArg.make_parser full_name (Comp.spec_args name) in
53 ServerArg.filter (opt:Comp.options) parse
54
55 let run = Comp.run
56 let close = Comp.close
57 end
58 in
59 (module App : RuntimeSig.APPLICATION)
60
61 let merge_applications app1 app2 =
62 let module App1 = (val app1 : RuntimeSig.APPLICATION) in
63 let module App2 = (val app2 : RuntimeSig.APPLICATION) in
64 let module App =
65 struct
66 type options = App1.options * App2.options
67 type t = App1.t * App2.t
68
69 let merge_maps map1 map2 =
70 StringMap.fold
71 (fun k v map -> StringMap.add k v map) map2 map1
72
73 let names = App1.names @ App2.names
74 let versions = merge_maps App1.versions App2.versions
75 let get_options () = App1.get_options (), App2.get_options ()
76
77 let make (opt1, opt2) sch =
78 let app1 = App1.make opt1 sch in
79 let app2 = App2.make opt2 sch in
80 (app1, app2)
81
82 let run (app1, app2) sch =
83 let app1 = App1.run app1 sch in
84 let app2 = App2.run app2 sch in
85 (app1, app2)
86
87 let close (app1, app2) sch =
88 App1.close app1 sch;
89 App2.close app2 sch
90 end
91 in
92 (module App : RuntimeSig.APPLICATION)
93
94 let app = ref None
95
96 let add_component comp name opt =
97 match !app with
98 | Some a ->
99 app := Some (merge_applications a (make_application name opt comp))
100 | None ->
101 app := Some (make_application name opt comp)
102
103 let add_httpServer = add_component (module HttpServer : RuntimeSig.COMPONENT with type options = HttpServer.options)
104 let add_httpDialog = add_component (module HttpDialog : RuntimeSig.COMPONENT with type options = HttpDialog.options)
105
106 let add_ftpServer = add_component (module FtpServer : RuntimeSig.COMPONENT with type options = FtpServer.options)
107
108 let add_smtpServer = add_component (module SmtpServer : RuntimeSig.COMPONENT with type options = SmtpServer.options)
109
110 let add_watchdog = add_component (module Watchdog : RuntimeSig.COMPONENT with type options = Watchdog.options)
111
112 let start () =
113 let sched = Scheduler.default in
114 let run, close =
115 match !app with
116 | None -> (fun _ -> ()), (fun _ -> ())
117 | Some a ->
118 let module App = (val a : RuntimeSig.APPLICATION) in
119 let options = App.get_options () in
120 let args = (ServerArg.get_argv ()) in
121 if List.mem "--help" (ServerArg.to_list args) then exit 0;
122 let app = App.make options sched in
123 RuntimeType.Ports.init sched;
124 let run () = let _ = App.run app sched in () in
125 let close () = App.close app sched in
126 run, close
127 in
128 run ();
129 Scheduler.run sched;
130 close ()
Something went wrong with that request. Please try again.