File: marionnet-daemon.ml

package info (click to toggle)
marionnet 0.90.6+bzr508-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 9,532 kB
  • sloc: ml: 18,130; sh: 5,384; xml: 1,152; makefile: 1,003; ansic: 275
file content (595 lines) | stat: -rw-r--r-- 24,808 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
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
(* This file is part of Marionnet, a virtual network laboratory
   Copyright (C) 2008, 2010  Jean-Vincent Loddo
   Copyright (C) 2008  Luca Saiu
   Copyright (C) 2008, 2010  Université Paris 13

   This program 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, see <http://www.gnu.org/licenses/>. *)

(* Activate log: *)   
let () = Log.Tuning.Set.debug_level (fun () -> 1)

(* Convenient aliases: *)
module Parameters      = Daemon_parameters
module Language        = Daemon_language
module Recursive_mutex = MutexExtra.Recursive
(* --- *)

let socket_name      = Parameters.socket_name
let timeout_interval = Parameters.timeout_interval
let debug_interval   = Parameters.debug_interval
let select_timeout   = Parameters.select_timeout

(** Client identifiers are simply automatically-generated sequential integers: *)
type client = int

(** Pretty-print a client identifier: *)
let string_of_client client =
  Printf.sprintf "<client #%i>" client

(** The mutex used to protect the resource map from concurrent access: *)
let the_daemon_mutex =
  Recursive_mutex.create ()

(* ----------------------------------------------------------------------- 
                          CLIENT INFORMATIONS
                        and related structures
   ----------------------------------------------------------------------- *)

(** An associative structure mapping each client to its resources: *)
let resource_map : (client, Language.resource) Hashmmap.hashmultimap =
  new Hashmmap.hashmultimap ()

let ownership (client: client) (resource : Language.resource) : bool =
  resource_map#mem client resource

(** An associative structure mapping each client to the time of the death
    of its resources (unless they send messages, of course): *)
let client_death_time_map : (client, float) Hashmap.hashmap =
  new Hashmap.hashmap ()

(** An associative structure mapping each client to its socket: *)
let socket_map : (client, Unix.file_descr) Hashmap.hashmap =
  new Hashmap.hashmap ()

(** An associative structure mapping each client to its declared uid: *)
let uid_map : (client, Language.uid) Hashmmap.hashmultimap =
  new Hashmmap.hashmultimap ()

(* Add the binding (client, uid) if the requested resource contains this information: *)
let uid_map_add (client: client) = function
| Language.SocketTap (_tap_name, uid, _bridge_name) -> 
    (* Note that the following test is implicitely performed by the method #add with ocamlbricks revno >= 452 *)
    if uid_map#mem (client) (uid) 
      then () 
      else uid_map#add (client) (uid)
| _ -> () (* Nothing to do *)

(** Useful to check the consistency before destroying a resource: *)  
let uid_consistency (client: client) (uid : Language.uid) : bool =
  let () = Log.printf2 "Looking for client-uid consistency: (#%d, %d)... \n" client uid in 
  match (uid_map#lookup client) with
  | [uid'] when uid = uid'  -> true
  | [uid'] when uid <> uid' ->
      let () = Log.printf1 "Error: the client %d has previously declared another uid!\n" client in 
      false
  | [] ->
      let () = Log.printf1 "Error: the client %d has not a declared uid!\n" client in 
      false
  | _ -> 
      let () = Log.printf1 "Error: the client %d has too many declared uid!\n" client in 
      false

(* ----------------------------------------------- END of CLIENT STRUCTURES *)

(** Seed the random number generator: *)
let () = Random.self_init ()

(** Generate a random name, very probably unique, with the given prefix: *)
let make_fresh_name prefix =
  let random_number = Random.int 1000000 in
  Printf.sprintf "%s%i" prefix random_number

(** Generate a random name, very probably unique, for a new tap: *)
let make_fresh_tap_name () =
   make_fresh_name "tap"

(** Generate a random name, very probably unique, for a new tap
    for the socket component: *)
let make_fresh_tap_name_for_world_bridge () =
  make_fresh_name "wbtap"

(** Accepted tap prefixes for destructions: *)  
let accepted_tap_prefixes = 
  ["tap"; "wbtap"]

(** Actually make a tap at the OS level: *)
let make_system_tap (tap_name : Language.tap_name) uid ip_address =
  Log.printf1 "Making the tap %s...\n" tap_name;
  let command_line =
    Printf.sprintf
      "{ tunctl -u %i -t %s && ifconfig %s 172.23.0.254 netmask 255.255.255.255 up; route add %s %s; }"
      (uid) (tap_name) (tap_name) (ip_address) (tap_name) 
  in begin
  Log.system_or_fail command_line;
  Log.printf1 "The tap %s was created with success\n" tap_name
  end

(** Actually make a tap at the OS level for the world bridge component: *)
let make_system_tap_for_world_bridge (tap_name : Language.tap_name) uid bridge_name =
  Log.printf1 "Making the tap %s...\n" tap_name;
  let command_line =
    Printf.sprintf
      "{ tunctl -u %i -t %s && ifconfig %s 0.0.0.0 promisc up && brctl addif %s %s; }"
      (uid) (tap_name) (tap_name) (bridge_name) (tap_name) 
  in begin
  let on_error = Printf.sprintf "tunctl -d %s" tap_name in
  Log.system_or_fail ~on_error command_line;
  Log.printf1 "The tap %s was created with success\n" tap_name
  end

let destroy_system_tap_OLD (tap_name : Language.tap_name) =
  Log.printf1 "Destroying the tap %s...\n" tap_name;
  let redirection = Global_options.Debug_level.redirection () in
  let command_line =
    Printf.sprintf
      "while ! (ifconfig %s down && tunctl -d %s %s); do echo 'I can not destroy %s yet...' %s ; sleep 1; done&"
      (tap_name) (tap_name) (redirection) (tap_name) (redirection) 
  in begin
  Log.system_or_fail ~hide_output:false ~hide_errors:false command_line;
  Log.printf1 "Launched command to destroy tap %s in background. It's probably destroyed now.\n" tap_name
  end
  
let repeat_obstinately 
  ?(delay=1.) 
  ?(delay_increasing=(fun x -> x +. 1.)) 
  ?(max_attempts=100) (* with increasing \x.x+1 => max waiting time = 100*101/2=5000 seconds > 1 day *)
  (thunk:unit->bool) : unit -> unit =    
  let rec loop (delay) (attempts) =
    if attempts > max_attempts then () else (* continue: *)
    if thunk () then () else (* continue: *)
    let () = Thread.delay (delay) in
    loop (delay_increasing delay) (attempts+1)
  in
  fun () -> loop delay 0
  
let remove_tuntap ~(command:string) (tap_name : Language.tap_name) : bool =
  (* --- *)
  let () = Log.printf1 "Destroying the TUN/TAP interface %s...\n" tap_name in
  (* Try to remove the tuntap with the provided shell command: *)
  let () = ignore (Unix.system command) in
  (* Now test if the tap exists: *)
  let ifconfig_tap = Printf.sprintf "ifconfig %s 2>/dev/null 1>/dev/null" (tap_name) in
  match (Unix.system ifconfig_tap) with
  (* --- *)  
  | Unix.WEXITED 0 (* Damn, the tap still exists! *) ->
      let () = Log.printf1 "Failed to destroy the TUN/TAP interface %s\n" tap_name in
      false
  (* --- *)  
  | _ -> (* The tap doesn't exist. It's fine: *)
     let () = Log.printf1 "The TUN/TAP interface %s was destroyed with success\n" tap_name in
     true 
     
(** Actually destroy a tap at the OS level for the socket component: *)
let destroy_system_tap_for_world_bridge (tap_name : Language.tap_name) (uid (*unused*))  (bridge_name) =
  let command =
    Printf.sprintf "ifconfig %s down && brctl delif %s %s && tunctl -d %s"
      (tap_name)  (bridge_name) (tap_name)  (tap_name) 
  in
  let thunk () : bool = remove_tuntap ~command (tap_name) in
  let _ = Thread.create (repeat_obstinately thunk) () in
  ()

(** Actually destroy a tap at the OS level: *)
let destroy_system_tap (tap_name : Language.tap_name) =
  let command = Printf.sprintf "ifconfig %s down && tunctl -d %s" (tap_name) (tap_name) in
  let thunk () : bool = remove_tuntap ~command (tap_name) in
  let _ = Thread.create (repeat_obstinately thunk) () in
  ()
  
(** Instantiate the given pattern, actually create the system object, and return
    the instantiated resource: *)
let make_system_resource resource_pattern : Language.resource =
  match resource_pattern with
  (* --- *)    
  | Language.AnyTap(uid, ip_address) ->
      let tap_name = make_fresh_tap_name () in
      make_system_tap tap_name uid ip_address;
      Language.Tap tap_name
  (* --- *)    
  | Language.AnySocketTap(uid, bridge_name) ->
      let tap_name = make_fresh_tap_name_for_world_bridge () in
      make_system_tap_for_world_bridge tap_name uid bridge_name;
      Language.SocketTap(tap_name, uid, bridge_name)

(** Actually destroyed the system object named by the given resource: *)
let destroy_system_resource resource =
  match resource with
  | Language.Tap tap_name ->
      destroy_system_tap tap_name
  | Language.SocketTap(tap_name, uid, bridge_name) ->
      destroy_system_tap_for_world_bridge tap_name uid bridge_name

(** Create a suitable resource matching the given pattern, and return it.
    Synchronization is performed inside this function, hence the caller doesn't need
    to worry about it: *)
let make_resource client resource_pattern =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      try
        (* Create a resource satisfying the given specification, and return it: *)
        Log.printf2
          "Making %s for %s\n"
          (Language.string_of_daemon_resource_pattern resource_pattern)
          (string_of_client client);
        let resource = make_system_resource resource_pattern in
        Log.printf2 "Adding %s for %s\n" (Language.string_of_daemon_resource resource) (string_of_client client);
        resource_map#add client resource;
        uid_map_add client resource;
        resource
      with e -> begin
        Log.printf3 "Failed (%s) when making the resource %s for %s; bailing out.\n"
          (Printexc.to_string e)
          (Language.string_of_daemon_resource_pattern resource_pattern)
          (string_of_client client);
        raise e;
      end)

(** Destroy the given resource. Synchronization is performed inside this function,
    hence the caller doesn't need to worry about it: *)
let destroy_resource (client) (resource) =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      try
        Log.printf2 "Removing %s %s\n" (string_of_client client) (Language.string_of_daemon_resource resource);
        Log.printf1 "** resource_map has %i bindings\n" (List.length resource_map#to_list);
        resource_map#remove_key_value_or_fail client resource;
        (* resource_map#remove_key_value client resource; *)
        Log.printf1 "** resource_map has %i bindings\n" (List.length resource_map#to_list);
        destroy_system_resource resource;
      with e -> begin
        Log.printf3 "WARNING: failed (%s) when destroying %s for %s.\n"
          (Printexc.to_string e)
          (Language.string_of_daemon_resource resource)
          (string_of_client client);
        raise e;
      end)

let destroy_all_client_resources client =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      try
        Log.printf1 "Removing all %s's resources:\n" (string_of_client client);
        (* --- *)  
        List.iter
          (fun resource -> destroy_resource client resource)
          (resource_map#lookup client);
        (* --- *)  
        let () =  uid_map#remove ~all:true client in
        (* --- *)  
        Log.printf1 "All %s's resources were removed with success.\n" (string_of_client client);
      with e -> begin
        Log.printf2 "Failed (%s) when removing %s's resources; continuing anyway.\n"
          (Printexc.to_string e)
          (string_of_client client);
      end)

let destroy_all_resources () =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
       List.iter
         (fun (client, _) ->
            try
              destroy_all_client_resources client
            with e -> begin
              Log.printf2 "Failed (%s) when removing %s's resources (while removing *all* resources); continuing anyway.\n"
                (Printexc.to_string e)
                (string_of_client client);
            end)
         client_death_time_map#to_list)

let keep_alive_client client =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      try
        (* Immediately raise an exception if the client is not alive: *)
        let _ = client_death_time_map#lookup client in
        let current_time = Unix.time () in
        let death_time = current_time +. timeout_interval in
        client_death_time_map#add client death_time;
        Log.printf3
          "I will not kill %s until %f (it's now %f)\n"
          (string_of_client client)
          death_time
          current_time;
        flush_all ();
      with Not_found -> begin
        Log.printf1
          "keep_client_alive failed because the client %s is not alive.\n"
          (string_of_client client);
        failwith ("keep_alive_client: " ^ (string_of_client client) ^ " is not alive.");
      end);;

(** Some resources [well, none as of now] are global, i.e. shared by all
    clients whenever there is at least one. We use a reference-counter to keep
    track of the number of currently existing clients; global resources are
    created when the counter raises from 0 to 1, and destroyed when it drops
    from 1 to 0. *)
let client_no = ref 0;;
let the_resources_if_any = ref None;;
let global_resources () =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      match !the_resources_if_any with
      | None ->
          failwith "the global resources do not exist; this should never happen"
      | Some resources ->
          resources);;

let make_global_resources_unlocked_ () =
  let () = assert(!the_resources_if_any = None) in
  (* To do: actually create something, if needed. *)
  the_resources_if_any := Some ()

let destroy_global_resources_unlocked_ () =
  match !the_resources_if_any with
  | None -> assert false
  | Some resources -> begin
      (* To do: actually destroy something, if needed. *)
      the_resources_if_any := None;
      flush_all ();
      end

let increment_client_no () =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      (if !client_no = 0 then begin
        Log.printf "There is at least one client now. Creating global resources...\n";
        make_global_resources_unlocked_ ();
        Log.printf "Global resources were created with success.\n";
      end);
      client_no := !client_no + 1)

let decrement_client_no () =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      client_no := !client_no - 1;
      (if !client_no = 0 then begin
        Log.printf "There are no more clients now. Destroying global resources...\n";
        destroy_global_resources_unlocked_ ();
        Log.printf "Global resources were destroyed with success.\n";
      end))

(** Create a new client on which we're going to interact with the given socket,
    and return its identifier: *)
let make_client =
  let next_client_no = ref 1 in
  fun socket ->
    Recursive_mutex.with_mutex (the_daemon_mutex)
      (fun () ->
        (* Generate a new unique identifier: *)
        let result = !next_client_no in
        next_client_no := !next_client_no + 1;
        (* First add any number to the data structure, then call keep_alive_client to make
           the death time correct: *)
        Log.printf1 "Creating %s.\n" (string_of_client result);
        client_death_time_map#add result 42.42;
        socket_map#add result socket;
        keep_alive_client result;
        increment_client_no ();
        Log.printf1 "Created %s.\n" (string_of_client result);
        result)

let destroy_client client =
  Recursive_mutex.with_mutex (the_daemon_mutex)
    (fun () ->
      Log.printf1 "Killing %s.\n" (string_of_client client);
      (try client_death_time_map#remove client with _ -> ());
      (try destroy_all_client_resources client with _ -> ());
      decrement_client_no ();
      (try
        Unix.close (socket_map#lookup client);
        Log.printf1 "The socket serving the client %i was closed with success.\n" client;
      with e -> begin
        Log.printf2
          "Closing the socket serving the client %i failed (%s).\n"
          client (Printexc.to_string e);
      end);
      (try socket_map#remove client with _ -> ());
      Log.printf1 "%s was killed.\n" (string_of_client client))

let debugging_thread_thunk () =
  while true do
    Thread.delay debug_interval;
    Recursive_mutex.with_mutex (the_daemon_mutex)
      (fun () ->
        Log.printf "--------------------------------------------\nCurrently existing non-global resources are:\n";
        List.iter
          (fun (client, resource) ->
            Log.printf2 "* %s (owned by %s)\n" (Language.string_of_daemon_resource resource) (string_of_client client))
          (resource_map#to_list);
        Log.printf "--------------------------------------------\n";
        );
  done

(** The 'timeout thread' wakes up every timeout_interval seconds and kills
    all clients whose death time is past. *)
let timeout_thread_thunk () =
  while true do
    (* Sleep: *)
    Thread.delay timeout_interval;

    (* Some variables are shared, so we have to synchronize this block; it's not
       a problem as this should be very quick: *)
    Recursive_mutex.with_mutex (the_daemon_mutex)
      (fun () ->
        (* Get up-to-date death time information for all clients: *)
        let current_time = Unix.time () in
        let client_death_times = client_death_time_map#to_list in
        (* Kill all clients whose death time is past: *)
        List.iter
          (fun (client, death_time) ->
            if current_time >= death_time then begin
              Log.printf1 "Client %s didn't send enough keep-alive's.\n" (string_of_client client);
              destroy_client client;
            end)
          client_death_times);
  done

(** Serve the given single request from the given client, and return the
    response. This does not include the keep-alive. *)
let serve_request request client =
  match request with
  | Language.IAmAlive              -> Language.Success
  | Language.Make resource_pattern -> Language.Created (make_resource client resource_pattern)
  | Language.Destroy resource      -> begin destroy_resource client resource; Language.Success; end
  | Language.DestroyAllMyResources -> begin destroy_all_client_resources client; Language.Success; end


(** This thread serves *one* client whose socket is given and is assumed
    to be open: *)
let connection_server_thread (client, socket) =
  try
    Log.printf1 "This is the connection server thread for client %i.\n" client;
    while true do
      Log.printf "Beginning of the iteration.\n";
      (* We want the message to be initially invalid, at every iteration, to
         avoid the risk of not seeing a receive error. Just to play it extra safe: *)
      let buffer = String.make (Language.message_length) 'x' in
      (* We don't want to block indefinitely on read() because the socket could
         be closed by another thread; so we simply select() with a timeout: *)
      let (ready_for_read, _, failed) =
        try
          Unix.select [socket] [] [socket] select_timeout
        with _ -> begin
          Log.printf "!!!!FAILED IN select (connection_server_thread)!!!!\n";
          failwith "select() failed";
          (* ([], [], []); *)
        end
      in
      (* --- *)
      (* Unix.select [socket] [] [socket] select_timeout in *)
      if (List.length failed) > 0 then
        failwith "select() reported failure with the socket"
      else if (List.length ready_for_read) > 0 then begin
        let received_byte_no =
          Unix.read socket buffer 0 Language.message_length in
        if received_byte_no < Language.message_length then
          failwith "recv() failed, or the message is ill-formed"
        else begin
          (* --- *)
          let request : Language.secure_daemon_request = 
            Language.parse_request 
              ~ownership:(ownership client)
              ~uid_consistency:(uid_consistency client)
              ~accepted_address_prefix:"172.23."   (* tap adresses are in this range *)
              ~accepted_tap_prefixes buffer        (* defined above: ["tap"; "wbtap"] *)
          in
          keep_alive_client client;
          (* --- *)
          let response =
            match request with
            | Either.Right error_msg -> 
                let () = Log.printf1 "Invalid request: %s\n" error_msg in
                Language.Error (error_msg)
            (* --- *)
            | Either.Left request -> 
                let () = Log.printf1 "The request is\n  %s\n" (Language.string_of_daemon_request request) in
                (try
                   serve_request request client
                 with e ->
                   Language.Error (Printexc.to_string e))
          in
          (* --- *)
          Log.printf1 "My response is\n  %s\n" (Language.string_of_daemon_response response);
          let sent_byte_no = Unix.send socket (Language.print_response response) 0 Language.message_length [] in
          (if not (sent_byte_no == sent_byte_no) then failwith "send() failed");
          (* --- *)
        end; (* inner else *)
      end else begin
        (* If we arrived here select() returned due to the timeout, and we
           didn't receive anything: loop again. *)
      end;
    done;
  with e -> begin
    Log.printf2
      "Failed in connection_server_thread (%s) for client %i.\nBailing out.\n"
      (Printexc.to_string e)
      client;
    destroy_client client; (* This also closes the socket *)
    Log.printf1 "Exiting from the thread which was serving client %i\n" client;
  end

(** Remove an old socket file, remained from an old instance or from ours
    (when we're about to exit). Do nothing if there is no such file: *)
let remove_socket_file_if_any () =
  try
    Unix.unlink socket_name;
    Log.printf1 "[Removed the old socket file %s]\n" socket_name;
  with _ ->
    Log.printf1 "[There was no need to remove the socket file %s]\n" socket_name

(** Destroy all resources, destroy the socket and exit on either SIGINT and SIGTERM: *)
let signal_handler signal = begin
  Log.printf1 "=========================\nI received the signal %i!\n=========================\nDestroying all resources...\n" signal;
  destroy_all_resources ();
  Log.printf "Ok, all resources were destroyed.\nRemoving the socket file...\n";
  remove_socket_file_if_any ();
  Log.printf "Ok, the socket file was removed.\n";
  raise Exit
  end

(** Strangely, without calling this the program is uninterruptable from the
    console: *)
Sys.catch_break false;;
Sys.set_signal Sys.sigint (Sys.Signal_handle signal_handler);;
Sys.set_signal Sys.sigterm (Sys.Signal_handle signal_handler);;

let check_that_we_are_root () =
  if (Unix.getuid ()) != 0 then begin
    Log.printf "\n*********************************************\n";
    Log.printf "* The Marionnet daemon must be run as root. *\n";
    Log.printf "* Bailing out.                              *\n";
    Log.printf "*********************************************\n\n";
    raise Exit;
  end

let the_server_main_thread = begin
  check_that_we_are_root ();
  ignore (Thread.create timeout_thread_thunk ());
  ignore (Thread.create debugging_thread_thunk ());
  let connection_no_limit = 10 in
  let accepting_socket = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
  let sock_addr = Unix.ADDR_UNIX socket_name in
  (* Remove the socket file, if it already exists: *)
  remove_socket_file_if_any ();
  (* Bind the file to the socket; this creates the file, or fails if there
     are permission or disk space problems: *)
  Unix.bind accepting_socket sock_addr;
  (* Everybody must be able to send messages to us: *)
  Unix.chmod socket_name 438 (* a+rw *);
  Log.printf1 "I am waiting on %s.\n" socket_name;
  Unix.listen accepting_socket connection_no_limit;
  while true do
    try
      Log.printf "Waiting for the next connection...\n";
      let (socket_to_client, socket_to_client_address) = Unix.accept accepting_socket in
      let client_id = make_client socket_to_client in
      Log.printf1 "A new connection was accepted; the new client id is %i\n" client_id;
      ignore (Thread.create connection_server_thread (client_id, socket_to_client));
    with e -> begin
      Log.printf1 "Failed in the main thread (%s). Bailing out.\n" (Printexc.to_string e);
      raise e;
      end;
  done
end (* the_server_main_thread *)