File: eventloop.ml

package info (click to toggle)
sks 1.1.6-14
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 2,296 kB
  • sloc: ml: 15,228; ansic: 1,069; sh: 358; makefile: 347
file content (273 lines) | stat: -rw-r--r-- 9,122 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
(***********************************************************************)
(* eventloop.ml - Basic eventloop for picking up timer and socket      *)
(*                events                                               *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* This file is part of SKS.  SKS is free software; you can            *)
(* redistribute it and/or modify it under the terms of the GNU General *)
(* Public License as published by the Free Software Foundation; either *)
(* version 2 of the License, or (at your option) any later version.    *)
(*                                                                     *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU   *)
(* General Public License for more details.                            *)
(*                                                                     *)
(* You should have received a copy of the GNU General Public License   *)
(* along with this program; if not, write to the Free Software         *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA or see <http://www.gnu.org/licenses/>.                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
open Printf
open Common
open Packet
let unix_socket = Unix.socket
module Unix = UnixLabels
open Unix


(** Timeout code.
  Allows the addition of generic timeouts for actions *)

exception SigAlarm
let waiting_for_alarm = ref false
let sigalarm_handler _ =
  if !waiting_for_alarm
  then raise SigAlarm
  else ()

let _ =
  Sys.set_signal Sys.sigalrm (Sys.Signal_handle sigalarm_handler)

type timed_event =
    Event of float * callback
and timed_callback = { callback: unit -> timed_event list;
                       timeout: int;
                       name: string option;
                     }
and callback = | Callback of (unit -> timed_event list)
               | TimedCallback of timed_callback


type timed_handler =
    { h_callback: sockaddr -> in_channel -> out_channel -> timed_event list;
      h_timeout: int;
      h_name: string option;
    }
type handler =
  | Handler of (sockaddr -> in_channel -> out_channel -> timed_event list)
  | TimedHandler of timed_handler


let unwrap opt = match !opt with
    None -> failwith "unwrap failure"
  | Some x -> x

let make_tc ~name ~timeout ~cb =
  TimedCallback { callback = cb;
                  name = Some name;
                  timeout = timeout;
                }

let make_th ~name ~timeout ~cb =
  TimedHandler { h_callback = cb;
                 h_name = Some name;
                 h_timeout = timeout;
               }

(** reraises an exception if it is a user-initiated break or a SigAlarm *)
let reraise e = match e with
    Sys.Break | SigAlarm -> raise e
  | _ -> ()

(*************************************************************)

(** executes function with timeout enforced using Unix.alarm *)
let do_with_timeout f timeout =
  ignore (Unix.alarm timeout);
  waiting_for_alarm := true;
  protect ~f
    ~finally:(fun () ->
                waiting_for_alarm := false;
                ignore (Unix.alarm 0);)


let cbname cb = match cb.name with
    None -> ""
  | Some s -> sprintf "<%s> " s


(** Does timed callback, including possible recovery action,
  with timeouts enforced by Unix.alarm *)
let do_timed_callback cb =
  try
    do_with_timeout cb.callback cb.timeout
  with
    | Sys.Break as e ->
        perror "%scallback interrupted by break." (cbname cb);
        raise e
    | SigAlarm ->
        perror "%scallback timed out." (cbname cb);
        []
    | e ->
        eplerror 2 e "%serror in callback." (cbname cb);
        []

let do_callback cb = match cb with
  | TimedCallback cb -> do_timed_callback cb
  | Callback cb -> cb ()


(** Socket handling functions *)

let create_sock addr =
  try
    let domain =
      Unix.domain_of_sockaddr addr in
    let sock =
      unix_socket domain SOCK_STREAM 0 in
    setsockopt sock SO_REUSEADDR true;
    if domain = PF_INET6 then
      setsockopt sock IPV6_ONLY true;
    bind sock ~addr;
    listen sock ~max:20;
    sock
  with
    | Unix_error (_,"bind",_) ->
        failwith "Failure while binding socket.  Probably another socket bound to this address"
    | e -> raise e
let add_events heap evlist =
  List.iter ~f:(fun (Event (time, callback)) ->
                  Heap.push heap ~key:time ~data:callback)
    evlist

let maybe_create_sock addr =
  try
    Some (create_sock addr)
  with
    | err ->
        let saddr = match addr with
          | ADDR_UNIX path ->  "\"" ^ path ^ "\""
          | ADDR_INET(ip, port) -> (string_of_inet_addr ip) ^ ":" ^ (string_of_int port)
        in
        perror "Failed to listen on %s: %s" saddr (err_to_string err);
        None

(***************************************************************)
(*  Event Handlers  *******************************************)
(***************************************************************)

let handle_socket handler sock =
  let (s,caller) = accept sock in
  let inchan = in_channel_of_descr s in
  let outchan = out_channel_of_descr s in
  protect ~f:(fun () -> handler caller inchan outchan)
    ~finally:(fun () -> Unix.close s)


let handler_to_callback handler sock =
  match handler with
      Handler handler ->
        Callback (fun () ->
                    let (s,caller) = accept sock in
                    let inchan = in_channel_of_descr s in
                    let outchan = out_channel_of_descr s in
                    protect ~f:(fun () -> handler caller inchan outchan)
                      ~finally:(fun () -> Unix.close s)
                 )
    | TimedHandler handler ->
        TimedCallback
          { callback =
              (fun () ->
                let (s,caller) = accept sock in
                let inchan = in_channel_of_descr s
                and outchan = out_channel_of_descr s in
                protect ~f:(fun () -> handler.h_callback
                              caller inchan outchan)
                  ~finally:(fun () -> Unix.close s)
              );
            timeout = handler.h_timeout;
            name = handler.h_name;
          }

(***************************************************************)
(*  Event Loop  ***********************************************)
(***************************************************************)

let some opt = match opt with
    None -> false
  | Some x -> true

(***************************************************************)

(** Does all events occuring at or before time [now], updating heap
  appropriately.  Returns the time left until the next undone event
  on the heap
*)
let rec do_current_events heap now =
  match (try Some (Heap.top heap)
         with Not_found -> None)
  with
    | Some (time,callback) ->
        let timeout = time -. now in
        if timeout <= 0.0 then (
          ignore (Heap.pop heap);
          add_events heap (do_callback callback);
          do_current_events heap now;
        ) else timeout
    | None -> -1.0

(** function for adding to heap callbacks for handling
  incoming socket connections *)
let add_socket_handlers heap now fdlist sockets =
  List.iter sockets
    ~f:(fun sock ->
          try
            let handler = List.assoc sock fdlist in
            add_events heap
              [ Event (now, handler_to_callback handler sock) ]
          with
              Not_found ->
                plerror 0 "%s" ("BUG: eventloop -- socket without " ^
                                "handler.  Event dropped")
       )
(** Do all available events in FIFO order *)
let do_next_event heap fdlist =
  let now = gettimeofday () in
  let timeout = do_current_events heap now in
  let (fds,_) = List.split fdlist in
  let (rd,_,_) = select ~read:fds ~write:[] ~except:[] ~timeout in
  add_socket_handlers heap now fdlist rd

(***************************************************************)
(***************************************************************)

let heap = Heap.empty (<) 20

let evloop events socklist =
  add_events heap events;
  try
    while true do
      try
        do_next_event heap socklist
      with
        | Sys.Break ->
            eprintf "Ctrl-C.  Exiting eventloop\n";
            flush Pervasives.stderr;
            raise Exit
        | Unix_error (error,func_name,param) ->
            if error <> Unix.EINTR
              (* EINTR just means the alarm interrupted select *)
            then
              plerror 2 "%s" ("eventloop: Unix Error: " ^
                              (Unix.error_message error) ^ ",  " ^
                              func_name ^ ", " ^ param ^ "\n")
        | e -> eplerror 2 e "eventloop"
    done
  with
      Exit -> ()