Skip to content
This repository
Newer
Older
100644 203 lines (168 sloc) 6.859 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
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 NA = NetAddr
20 type secure_mode =
21 | Unsecured
22 | Secured of SslAS.secure_type
23
24 type socket_type = TCP | UDP
25
26 type port_spec = {
27 addr : Unix.inet_addr;
28 port : int;
29 prot : NetAddr.protocol;
30 stype : Connection.socket_type
31 }
32
33 type port = {
34 conn_incoming :
35 SslAS.secure_response -> Scheduler.connection_info -> unit;
36 conn_terminating : unit -> unit;
37 secure_mode : secure_mode;
38 port_spec : port_spec
39 }
40
41 type socket = Unix.file_descr
42
43 let _SUSPICIOUS_ mess =
44 Logger.debug "!!!\nSUSPICIOUS %s\n!!!!" mess;
45 ()
46
47 exception Unknown_machine of string
48
49 let inet_addr_of_name machine =
50 try (Unix.gethostbyname machine).Unix.h_addr_list.(0)
51 with Unix.Unix_error _ | Not_found -> try Unix.inet_addr_of_string machine
52 with Unix.Unix_error _ | Failure _ -> raise (Unknown_machine machine)
53
54 let addr_of_ipv4 (ip1, ip2, ip3, ip4) =
a9f8d34c » Raja
2011-06-28 [cleanup] Base: remove sprintf
55 Unix.inet_addr_of_string (Printf.sprintf "%d.%d.%d.%d" ip1 ip2 ip3 ip4)
fccc6851 » MLstate
2011-06-21 Initial open-source release
56
57 let string_of_ipv4 (ip1, ip2, ip3, ip4) =
a9f8d34c » Raja
2011-06-28 [cleanup] Base: remove sprintf
58 Printf.sprintf "%d.%d.%d.%d" ip1 ip2 ip3 ip4
fccc6851 » MLstate
2011-06-21 Initial open-source release
59
60 let name_of_addr addr =
61 try (Unix.gethostbyaddr addr).Unix.h_name
62 with Not_found -> Unix.string_of_inet_addr addr
63
64 let make_port_spec ?(socket_type = TCP) ~protocol addr port =
65 let stype =
66 match socket_type with
67 | TCP -> Connection.TCP
68 | UDP -> Connection.UDP
69 in
70 { addr = addr
71 ; port = port
72 ; prot = protocol
73 ; stype = stype
74 }
75
76 let get_port p = p.port
77
78 let get_addr p = p.addr
79
80 let get_socket_type p =
81 match p.stype with
82 | Connection.TCP -> TCP
83 | Connection.UDP -> UDP
84
85
86 (* == LISTEN == *)
87
88 let listen_port port_spec = Connection.listen ~socket_type:port_spec.stype (Unix.ADDR_INET (port_spec.addr, port_spec.port))
89
90 (* Only used by a normal connection (listen_normal),
91 but listen_ssl uses listen_normal *)
92 let new_client_UNIX sched _conn (server_fun: Scheduler.connection_info -> unit) conn () =
93 try
94 let sock = Scheduler.get_connection_fd conn in
95 let client_sock, host = Connection.accept sock in
96 let addr = NA.mk_tcp
97 ~protocol:(NA.get_protocol conn.Scheduler.addr)
98 ~fd:client_sock ~addr:host
99 in
100 let conn = Scheduler.make_connection sched addr in
101 server_fun conn
102 with Connection.Error -> ()
103
104 (* let rec new_client_WINDOWS sched _unused_conn (server_fun: Scheduler.connection_info -> unit) (\*sock*\) conn () = *)
105 (* try *)
106 (* (\* listen for other clients *\) *)
107 (* (\* let _id = Iocp.async_accept sock in *\) *)
108 (* (\* _SUSPICIOUS_ "What is that self#new_clien callback IN the new_client method ????" ; *\) *)
109 (* let callback () = () *)
110 (* (\* new_client_WINDOWS conn server_fun sock () *\) *)
111 (* in *)
112 (* ignore(Scheduler.listen sched conn (\* TODO ~async_id:id *\) callback); *)
113 (* let sd = Iocp.get_socket() in *)
114 (* let host = Unix.inet_addr_loopback in (\*FIXME*\) *)
115 (* let conn = Scheduler.make_connection sched (Scheduler.Normal (sd, host)) in *)
116 (* server_fun conn *)
117 (* with Connection.Error -> () *)
118 (* (\* Unix.Unix_error _ as e -> *\) *)
119 (* (\* Logger.warning "Net.server: can't accept connection (%s)" (Printexc.to_string e) *\) *)
120
121
122 let new_client_WINDOWS sched _conn (server_fun: Scheduler.connection_info -> unit) conn () =
123 try
124 let sock = Scheduler.get_connection_fd conn in
125 let client_sock, host = Connection.accept sock in
126 let addr = NA.mk_tcp
127 ~protocol:(NA.get_protocol conn.Scheduler.addr)
128 ~fd:client_sock ~addr:host
129 in
130 let conn = Scheduler.make_connection sched addr in
131 server_fun conn
132 with Connection.Error -> ()
133
134 let new_client = Mlstate_platform.platform_dependent ~unix:new_client_UNIX ~windows:new_client_WINDOWS ()
135
136 let listen_normal sched conn server_fun =
137 Scheduler.listen sched conn (new_client sched conn server_fun conn)
138 (* platform_dependent *)
139 (* ~unix:(fun ()-> Scheduler.listen sched conn (new_client sched conn server_fun conn)) *)
140 (* ~windows:(fun ()-> *)
141 (* let _id = Iocp.async_accept sock in *)
142 (* Scheduler.listen (\* TODO ~async_id:id *\) sched conn (new_client sched conn server_fun conn)) () () *)
143
144
145 (* == Public functions == *)
146
147 let listen sched port_spec secure_mode ?socket_flags server_fun =
148 let socket = Connection.listen ~socket_type:port_spec.stype ?socket_flags (Unix.ADDR_INET (port_spec.addr, port_spec.port)) in
149 let addr = NA.mk_tcp ~protocol:port_spec.prot
150 ~fd:socket ~addr:Unix.inet_addr_loopback
151 in
152 let conn = Scheduler.make_connection sched addr in
153 let listen_key =
154 match secure_mode with
155 | Unsecured ->
156 listen_normal sched conn (server_fun SslAS.UnsecuredRes)
157 | Secured params ->
158 listen_normal sched conn (SslAS.get_listen_callback sched params server_fun)
159 in
160 (fun () ->
161 Scheduler.abort sched listen_key;
162 Scheduler.remove_connection sched conn
163 )
164
165 let connect sched port_spec secure_mode ?socket_flags ?err_cont cont =
166 let sockaddr = Unix.ADDR_INET (port_spec.addr, port_spec.port) in
167 let sock = Connection.connect ?socket_flags sockaddr in
168 let addr = NA.mk_tcp ~protocol:port_spec.prot
169 ~fd:sock ~addr:port_spec.addr
170 in
171 let conn = Scheduler.make_connection sched addr in
172 let err_cont e =
173 Scheduler.remove_connection sched conn;
174 match err_cont with
175 | Some f -> f e
176 | None -> ()
177 in
178 match secure_mode with
179 | Unsecured -> Scheduler.connect sched conn (fun () -> cont conn) ~err_cont
180 | Secured ssl_params ->
181 let normal_cont () = SslAS.connect sched conn ssl_params ~err_cont cont in
182 (* Wait for normal connect to be done *)
183 Scheduler.connect sched conn normal_cont ~err_cont
184
185 let secure_mode_from_params certificate verify_params =
186 match certificate, verify_params with
187 | Some _, _
188 | _, Some _ -> Secured (certificate, verify_params)
189 | _ -> Unsecured
190
191
192 let loop sched =
193 (* Printexc.record_backtrace true; (\* for get_backtrace below *\) *)
194 Sys.catch_break true; (* turn on handlig of Ctrl-c in async *)
195 let loop = ref true in
196 while !loop do
197 try
198 loop := Scheduler.wait sched ~block:true
199 with
200 | Sys.Break -> loop := false
201 | Failure "Interrupted system call" -> loop := false
202 | e -> Logger.log_error "%s" (Printexc.to_string e)
203 done
Something went wrong with that request. Please try again.