Skip to content
Newer
Older
100644 227 lines (195 sloc) 7.38 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 This module deals with file descriptors and synchronous operations over them.
21
22 @author Henri Binsztok
23 @author Laurent Le Brun
24 @author Frederic Ye
25 @author Cedric Soulas
26 *)
27
28 module MP = Mlstate_platform
29 module NA = NetAddr
30
31 let (|>) = InfixOperator.(|>)
32
33 module Const =
34 struct
35 let unix_max_pending_requests = 1024
36 end
37
38 type socket_type = TCP | UDP
39
40 (* ============================== *)
41 (* In / Out Operations *)
42 (* ============================== *)
43
44 exception Busy
45 exception Error
46
47 (* Private function *)
48 let nonblocking_try f zero =
49 try f () with
50 | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _)
51 | Ssl.Write_error (Ssl.Error_want_read | Ssl.Error_want_write)
52 | Ssl.Read_error (Ssl.Error_want_read | Ssl.Error_want_write) -> raise Busy
53 | Ssl.Read_error _
54 | Ssl.Write_error _ -> zero
55 | Unix.Unix_error((Unix.EPIPE | Unix.ECONNRESET), _, _) -> zero
56 | Unix.Unix_error(err, ctx1, ctx2) as e -> Logger.error "Unix error: %s, %s, %s\n" (Unix.error_message err) ctx1 ctx2; raise e
57 | e -> raise e
58
59 (* FIXME: use FBuffers for large inputs ? *)
60 let write conn ?(pos=0) buf len =
61 nonblocking_try (
62 fun () ->
63 match NA.get_type_and_fd conn with
64 | `File fd -> Unix.write fd buf pos len
65 | `Tcp fd -> Unix.send fd buf pos len []
66 | `Udp fd -> Unix.sendto fd buf pos len [] (Unix.getpeername fd)
67 | `Ssl s -> Ssl.write s buf pos len
68 ) 0
69
70 (* FIXME, should that really only work for UDP sockets? *)
71 let write_to conn addr ?(pos=0) buf len =
72 nonblocking_try (
73 fun () ->
74 match NA.get_type_and_fd conn with
75 | `Udp fd -> Unix.sendto fd buf pos len [] addr
76 | _ -> failwith "[Connection] write_to used on a non-UDP socket"
77 ) 0
78
79 let read_aux conn tmp to_read : int * Unix.sockaddr option =
80 let no_addr res = res, None in
81 nonblocking_try (
82 fun () ->
83 match NA.get_type_and_fd conn with
84 | `File fd -> Unix.read fd tmp 0 to_read |> no_addr
85 | `Tcp fd -> Unix.recv fd tmp 0 to_read [] |> no_addr
86 | `Udp fd ->
87 let len, addr = Unix.recvfrom fd tmp 0 to_read [] in
88 len, Some addr
89 | `Ssl s -> Ssl.read s tmp 0 to_read |> no_addr
90 ) (no_addr 0)
91
92 let read_more conn buf to_read =
93 let tmp = String.create to_read in
94 let nread, _ = read_aux conn tmp to_read in
95 let buf = FBuffer.add_substring buf tmp 0 nread in
96 nread, buf
97
98 let read_content conn content to_read =
99 let tmp = String.create to_read in
100 let nread, _ = read_aux conn tmp to_read in
101 let content = Rcontent.content_add (String.sub tmp 0 nread) content in
102 nread, content
103
104 let read_buff_length = 32768
105 let read_buff = String.create read_buff_length
106
107 let read_more2 conn buf =
108 let nread, _ = read_aux conn read_buff read_buff_length in
109 let () = Buffer.add_substring buf read_buff 0 nread in
110 nread, buf
111
112 let read_from conn =
113 let nread, addr = read_aux conn read_buff read_buff_length in
114 let get_peer = lazy (Unix.getpeername (NA.get_fd conn)) in
115 let from = Option.default_lazy get_peer addr in
116 nread, from, (String.sub read_buff 0 nread)
117
118 let read conn =
119 let nread, _ = read_aux conn read_buff read_buff_length in
120 nread, (String.sub read_buff 0 nread)
121
122 let _ =
123 MP.on_windows Iocp.async_init;
124
125 exception PermissionDenied
126 exception UnixError
127
128 (* Private function *)
129 let make_socket ?(socket_flags=([] : Unix.socket_bool_option list)) socket_type =
130 let sock =
131 match socket_type with
132 | TCP ->
133 MP.platform_dependent
134 ~unix: (fun()-> Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0)
135 ~windows:(fun()-> Iocp.socket())
136 () ()
137 | UDP ->
138 MP.platform_dependent
139 ~unix: (fun()-> Unix.socket Unix.PF_INET Unix.SOCK_DGRAM 0)
140 ~windows:(fun()-> assert false)
141 () ()
142 in
143 Unix.set_nonblock sock;
144 List.iter (fun opt -> Unix.setsockopt sock opt true) socket_flags;
145 sock
146
147 let accept sock =
148 try
149 let (sd, sa) = Unix.accept sock in
150 match sa with
151 | Unix.ADDR_INET (host, _) ->
152 Unix.set_nonblock sd;
153 sd, host
154 | _ ->
155 Logger.error "Connection refused (unknown client)";
156 (try Unix.close sd with Unix.Unix_error _ -> ()); raise Error
157 with
158 Unix.Unix_error _ as e ->
159 Logger.error "Impossible to accept connection: (%s)" (Printexc.to_string e);
160 raise Error
161
162 let connect ?(socket_type = TCP) ?socket_flags addr =
163 let sock = make_socket ?socket_flags socket_type in
164 try
165 begin
166 try Unix.connect sock addr
167 (* Use epoll to be warned when connect is finished *)
168 with Unix.Unix_error (Unix.EINPROGRESS, _, _) -> ()
169 end;
170 sock
171 with
172 | Unix.Unix_error(e, fct, arg) as exn ->
173 Logger.error "Unix error opening connection: %s for %s %s" (Unix.error_message e) fct arg;
174 raise exn
175 | e ->
176 Logger.error "Fatal error opening connection. Closing socket...";
177 Unix.close sock ;
178 raise e
179
180 let listen ?(socket_type = TCP) ?socket_flags addr =
181 let sock = make_socket ?socket_flags socket_type in
182 MP.on_unixes (fun()->Unix.set_close_on_exec sock);
183 Unix.setsockopt sock Unix.SO_REUSEADDR true;
184 let _ = try Unix.bind sock addr;
185 with
186 | Unix.Unix_error(Unix.EACCES, _fct, _arg) ->
187 Logger.critical "Error binding to [%s]: Permission denied" (NA.string_of_sockaddr addr);
188 (match addr with Unix.ADDR_INET (_addr,port) when port < 1024 ->
189 Logger.critical "Hint: you probably need to be root to run servers on ports < 1024"
190 | _ -> ());
191 exit 20
192 | Unix.Unix_error(Unix.EADDRINUSE, _fct, _arg) ->
193 Logger.critical "Error binding to [%s]: Address already in use" (NA.string_of_sockaddr addr);
194 let port = match addr with Unix.ADDR_INET (_addr,port) -> port | _ -> assert false in
195 Logger.critical "Hint: a server seems to be running already on port %d, either close it or use a different port number" port;
196 exit 21
197 | Unix.Unix_error(e, fct, arg) ->
198 Logger.critical "Error binding on [%s]: %s for %s %s" (NA.string_of_sockaddr addr) (Unix.error_message e) fct arg;
199 raise UnixError
200 in
201 begin match socket_type with
202 | TCP -> Unix.listen sock Const.unix_max_pending_requests
203 | UDP -> () (* we don't call listen for UDP, binding the socket is enough *)
204 end;
205 sock
206
207 (* ============================== *)
208 (* Misc *)
209 (* ============================== *)
210
211 let close descr =
212 let fd = NA.get_fd descr in
213 (try Unix.close fd
214 with e -> Logger.error "unix close error: %s " (Printexc.to_string e);
215 );
216 (try match NA.get_type_and_fd descr with
217 | `Ssl s ->
218 Ssl.shutdown s; Unix.shutdown fd Unix.SHUTDOWN_SEND
219 | `Tcp fd -> Unix.shutdown fd Unix.SHUTDOWN_SEND
220 | `Udp _ -> () (* UDP does not require a shutdown *)
221 | `File fd -> Unix.close fd
222 with Unix.Unix_error _ -> ())
223
224 let name_of_addr addr =
225 try (Unix.gethostbyaddr addr).Unix.h_name
226 with Not_found -> Unix.string_of_inet_addr addr
Something went wrong with that request. Please try again.