Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 232 lines (199 sloc) 7.716 kb
fccc685 Initial open-source release
MLstate authored
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
a12b805 Norman Scaife [feature] appruntime: Added read_more4, same as read_more2 but for Buf ...
nrs135 authored
112 let read_more4 conn buf =
113 let nread, _ = read_aux conn read_buff read_buff_length in
114 let () = Buf.add_substring buf read_buff 0 nread in
115 nread, buf
116
fccc685 Initial open-source release
MLstate authored
117 let read_from conn =
118 let nread, addr = read_aux conn read_buff read_buff_length in
119 let get_peer = lazy (Unix.getpeername (NA.get_fd conn)) in
120 let from = Option.default_lazy get_peer addr in
121 nread, from, (String.sub read_buff 0 nread)
122
123 let read conn =
124 let nread, _ = read_aux conn read_buff read_buff_length in
125 nread, (String.sub read_buff 0 nread)
126
127 let _ =
128 MP.on_windows Iocp.async_init;
129
130 exception PermissionDenied
131 exception UnixError
132
133 (* Private function *)
134 let make_socket ?(socket_flags=([] : Unix.socket_bool_option list)) socket_type =
135 let sock =
136 match socket_type with
137 | TCP ->
138 MP.platform_dependent
139 ~unix: (fun()-> Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0)
140 ~windows:(fun()-> Iocp.socket())
141 () ()
142 | UDP ->
143 MP.platform_dependent
144 ~unix: (fun()-> Unix.socket Unix.PF_INET Unix.SOCK_DGRAM 0)
145 ~windows:(fun()-> assert false)
146 () ()
147 in
148 Unix.set_nonblock sock;
149 List.iter (fun opt -> Unix.setsockopt sock opt true) socket_flags;
150 sock
151
152 let accept sock =
153 try
154 let (sd, sa) = Unix.accept sock in
155 match sa with
156 | Unix.ADDR_INET (host, _) ->
157 Unix.set_nonblock sd;
158 sd, host
159 | _ ->
160 Logger.error "Connection refused (unknown client)";
161 (try Unix.close sd with Unix.Unix_error _ -> ()); raise Error
162 with
163 Unix.Unix_error _ as e ->
164 Logger.error "Impossible to accept connection: (%s)" (Printexc.to_string e);
165 raise Error
166
167 let connect ?(socket_type = TCP) ?socket_flags addr =
168 let sock = make_socket ?socket_flags socket_type in
169 try
170 begin
171 try Unix.connect sock addr
172 (* Use epoll to be warned when connect is finished *)
173 with Unix.Unix_error (Unix.EINPROGRESS, _, _) -> ()
174 end;
175 sock
176 with
177 | Unix.Unix_error(e, fct, arg) as exn ->
178 Logger.error "Unix error opening connection: %s for %s %s" (Unix.error_message e) fct arg;
179 raise exn
180 | e ->
181 Logger.error "Fatal error opening connection. Closing socket...";
182 Unix.close sock ;
183 raise e
184
185 let listen ?(socket_type = TCP) ?socket_flags addr =
186 let sock = make_socket ?socket_flags socket_type in
187 MP.on_unixes (fun()->Unix.set_close_on_exec sock);
188 Unix.setsockopt sock Unix.SO_REUSEADDR true;
189 let _ = try Unix.bind sock addr;
190 with
191 | Unix.Unix_error(Unix.EACCES, _fct, _arg) ->
192 Logger.critical "Error binding to [%s]: Permission denied" (NA.string_of_sockaddr addr);
193 (match addr with Unix.ADDR_INET (_addr,port) when port < 1024 ->
194 Logger.critical "Hint: you probably need to be root to run servers on ports < 1024"
195 | _ -> ());
196 exit 20
197 | Unix.Unix_error(Unix.EADDRINUSE, _fct, _arg) ->
198 Logger.critical "Error binding to [%s]: Address already in use" (NA.string_of_sockaddr addr);
199 let port = match addr with Unix.ADDR_INET (_addr,port) -> port | _ -> assert false in
200 Logger.critical "Hint: a server seems to be running already on port %d, either close it or use a different port number" port;
201 exit 21
202 | Unix.Unix_error(e, fct, arg) ->
203 Logger.critical "Error binding on [%s]: %s for %s %s" (NA.string_of_sockaddr addr) (Unix.error_message e) fct arg;
204 raise UnixError
205 in
206 begin match socket_type with
207 | TCP -> Unix.listen sock Const.unix_max_pending_requests
208 | UDP -> () (* we don't call listen for UDP, binding the socket is enough *)
209 end;
210 sock
211
212 (* ============================== *)
213 (* Misc *)
214 (* ============================== *)
215
216 let close descr =
217 let fd = NA.get_fd descr in
218 (try Unix.close fd
219 with e -> Logger.error "unix close error: %s " (Printexc.to_string e);
220 );
221 (try match NA.get_type_and_fd descr with
222 | `Ssl s ->
223 Ssl.shutdown s; Unix.shutdown fd Unix.SHUTDOWN_SEND
224 | `Tcp fd -> Unix.shutdown fd Unix.SHUTDOWN_SEND
225 | `Udp _ -> () (* UDP does not require a shutdown *)
226 | `File fd -> Unix.close fd
227 with Unix.Unix_error _ -> ())
228
229 let name_of_addr addr =
230 try (Unix.gethostbyaddr addr).Unix.h_name
231 with Not_found -> Unix.string_of_inet_addr addr
Something went wrong with that request. Please try again.