← Back to branch summary

~ubuntu-branches/ubuntu/wily/marionnet/wily

« back to all changes in this revision

Viewing changes to marionnet-daemon.ml

  • Committer: Package Import Robot
  • Author(s): Lucas Nussbaum
  • Date: 2014-04-02 16:59:06 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: package-import@ubuntu.com-20140402165906-w6nrmczff6l0cyc3
Tags: 0.90.6+bzr448-1
New upstream snapshot.

Show diffs side-by-side

added added

removed removed

Lines of Context:
marionnet-daemon.ml
71
71
 
72
72
(** Actaully make a tap at the OS level: *)
73
73
let make_system_tap (tap_name : tap_name) uid ip_address =
74
 
  Log.printf "Making the tap %s...\n" tap_name;
 
74
  Log.printf1 "Making the tap %s...\n" tap_name;
75
75
  let command_line =
76
76
    Printf.sprintf
77
77
      "{ tunctl -u %i -t %s && ifconfig %s 172.23.0.254 netmask 255.255.255.255 up; route add %s %s; }"
78
78
      uid tap_name tap_name ip_address tap_name in
79
79
  Log.system_or_fail command_line;
80
 
  Log.printf "The tap %s was created with success\n" tap_name
 
80
  Log.printf1 "The tap %s was created with success\n" tap_name
81
81
  ;;
82
82
 
83
83
(** Actually make a tap at the OS level for the bridge socket component: *)
84
84
let make_system_tap_for_socket (tap_name : tap_name) uid bridge_name =
85
 
  Log.printf "Making the tap %s...\n" tap_name;
 
85
  Log.printf1 "Making the tap %s...\n" tap_name;
86
86
  let command_line =
87
87
    Printf.sprintf
88
88
      "{ tunctl -u %i -t %s && ifconfig %s 0.0.0.0 promisc up && brctl addif %s %s; }"
92
92
      bridge_name tap_name in
93
93
  let on_error = Printf.sprintf "tunctl -d %s" tap_name in
94
94
  Log.system_or_fail ~on_error command_line;
95
 
  Log.printf "The tap %s was created with success\n" tap_name
 
95
  Log.printf1 "The tap %s was created with success\n" tap_name
96
96
  ;;
97
97
 
98
98
(** Actually destroy a tap at the OS level: *)
99
99
let destroy_system_tap (tap_name : tap_name) =
100
 
  Log.printf "Destroying the tap %s...\n" tap_name;
 
100
  Log.printf1 "Destroying the tap %s...\n" tap_name;
101
101
  let redirection = Global_options.Debug_level.redirection () in
102
102
  let command_line =
103
103
    Printf.sprintf
104
104
      "while ! (ifconfig %s down && tunctl -d %s %s); do echo 'I can not destroy %s yet %s...'; sleep 1; done&"
105
105
      tap_name tap_name redirection tap_name redirection  in
106
106
  Log.system_or_fail ~hide_output:false ~hide_errors:false command_line;
107
 
  Log.printf "The tap %s was destroyed with success\n" tap_name
 
107
  Log.printf1 "The tap %s was destroyed with success\n" tap_name
108
108
  ;;
109
109
 
110
110
(** Actually destroy a tap at the OS level for the socket component: *)
111
111
let destroy_system_tap_for_socket (tap_name : tap_name) uid bridge_name =
112
 
  Log.printf "Destroying the tap %s...\n" tap_name;
 
112
  Log.printf1 "Destroying the tap %s...\n" tap_name;
113
113
  let command_line =
114
114
    (* This is currently disabled. We have to decide what to do about this: *)
115
115
    Printf.sprintf
116
116
      "{ ifconfig %s down && brctl delif %s %s && tunctl -d %s; }"
117
117
      tap_name bridge_name tap_name tap_name in
118
118
  Log.system_or_fail command_line;
119
 
  Log.printf "The tap %s was destroyed with success\n" tap_name;
 
119
  Log.printf1 "The tap %s was destroyed with success\n" tap_name;
120
120
  ;;
121
121
 
122
122
(** Instantiate the given pattern, actually create the system object, and return
148
148
    (fun () ->
149
149
      try
150
150
        (* Create a resource satisfying the given specification, and return it: *)
151
 
        Log.printf
 
151
        Log.printf2
152
152
          "Making %s for %s\n"
153
153
          (string_of_daemon_resource_pattern resource_pattern)
154
154
          (string_of_client client);
155
155
        let resource = make_system_resource resource_pattern in
156
 
        Log.printf "Adding %s for %s\n" (string_of_daemon_resource resource) (string_of_client client);
 
156
        Log.printf2 "Adding %s for %s\n" (string_of_daemon_resource resource) (string_of_client client);
157
157
        resource_map#add client resource;
158
158
        resource
159
159
      with e -> begin
160
 
        Log.printf "Failed (%s) when making the resource %s for %s; bailing out.\n"
 
160
        Log.printf3 "Failed (%s) when making the resource %s for %s; bailing out.\n"
161
161
          (Printexc.to_string e)
162
162
          (string_of_daemon_resource_pattern resource_pattern)
163
163
          (string_of_client client);
170
170
  Recursive_mutex.with_mutex the_daemon_mutex
171
171
    (fun () ->
172
172
      try
173
 
        Log.printf "Removing %s %s\n" (string_of_client client) (string_of_daemon_resource resource);
174
 
        Log.printf "** resource_map has %i bindings\n" (List.length resource_map#to_list); flush_all ();
 
173
        Log.printf2 "Removing %s %s\n" (string_of_client client) (string_of_daemon_resource resource);
 
174
        Log.printf1 "** resource_map has %i bindings\n" (List.length resource_map#to_list);
175
175
        resource_map#remove_key_value_or_fail client resource;
176
176
        (* resource_map#remove_key_value client resource; *)
177
 
        Log.printf "** resource_map has %i bindings\n" (List.length resource_map#to_list); flush_all ();
 
177
        Log.printf1 "** resource_map has %i bindings\n" (List.length resource_map#to_list);
178
178
        destroy_system_resource resource;
179
179
      with e -> begin
180
 
        Log.printf "WARNING: failed (%s) when destroying %s for %s.\n"
 
180
        Log.printf3 "WARNING: failed (%s) when destroying %s for %s.\n"
181
181
          (Printexc.to_string e)
182
182
          (string_of_daemon_resource resource)
183
183
          (string_of_client client);
188
188
  Recursive_mutex.with_mutex the_daemon_mutex
189
189
    (fun () ->
190
190
      try
191
 
        Log.printf "Removing all %s's resources:\n" (string_of_client client);
 
191
        Log.printf1 "Removing all %s's resources:\n" (string_of_client client);
192
192
        List.iter
193
193
          (fun resource -> destroy_resource client resource)
194
194
          (resource_map#lookup client);
195
 
        Log.printf "All %s's resources were removed with success.\n" (string_of_client client);
196
 
        flush_all ();
 
195
        Log.printf1 "All %s's resources were removed with success.\n" (string_of_client client);
197
196
      with e -> begin
198
 
        Log.printf "Failed (%s) when removing %s's resources; continuing anyway.\n"
 
197
        Log.printf2 "Failed (%s) when removing %s's resources; continuing anyway.\n"
199
198
          (Printexc.to_string e)
200
199
          (string_of_client client);
201
200
      end);;
208
207
          try
209
208
            destroy_all_client_resources client
210
209
          with e -> begin
211
 
            Log.printf "Failed (%s) when removing %s's resources (while removing *all* resources); continuing anyway.\n"
 
210
            Log.printf2 "Failed (%s) when removing %s's resources (while removing *all* resources); continuing anyway.\n"
212
211
              (Printexc.to_string e)
213
212
              (string_of_client client);
214
213
          end))
223
222
        let current_time = Unix.time () in
224
223
        let death_time = current_time +. timeout_interval in
225
224
        client_death_time_map#add client death_time;
226
 
        Log.printf
 
225
        Log.printf3
227
226
          "I will not kill %s until %f (it's now %f)\n"
228
227
          (string_of_client client)
229
228
          death_time
230
229
          current_time;
231
230
        flush_all ();
232
231
      with Not_found -> begin
233
 
        Log.printf
 
232
        Log.printf1
234
233
          "keep_client_alive failed because the client %s is not alive.\n"
235
234
          (string_of_client client);
236
235
        failwith ("keep_alive_client: " ^ (string_of_client client) ^ " is not alive.");
270
269
        Log.printf "There is at least one client now. Creating global resources...\n";
271
270
        make_global_resources_unlocked_ ();
272
271
        Log.printf "Global resources were created with success.\n";
273
 
        flush_all ();
274
272
      end);
275
273
      client_no := !client_no + 1);;
276
274
let decrement_client_no () =
281
279
        Log.printf "There are no more clients now. Destroying global resources...\n";
282
280
        destroy_global_resources_unlocked_ ();
283
281
        Log.printf "Global resources were destroyed with success.\n";
284
 
        flush_all ();
285
282
      end));;
286
283
 
287
284
(** Create a new client on which we're going to interact with the given socket,
296
293
        next_client_no := !next_client_no + 1;
297
294
        (* First add any number to the data structure, then call keep_alive_client to make
298
295
           the death time correct: *)
299
 
        Log.printf "Creating %s.\n" (string_of_client result); flush_all ();
 
296
        Log.printf1 "Creating %s.\n" (string_of_client result);
300
297
        client_death_time_map#add result 42.42;
301
298
        socket_map#add result socket;
302
299
        keep_alive_client result;
303
300
        increment_client_no ();
304
 
        Log.printf "Created %s.\n" (string_of_client result); flush_all ();
 
301
        Log.printf1 "Created %s.\n" (string_of_client result);
305
302
        result);;
306
303
 
307
304
let destroy_client client =
308
305
  Recursive_mutex.with_mutex the_daemon_mutex
309
306
    (fun () ->
310
 
      Log.printf "Killing %s.\n" (string_of_client client); flush_all ();
 
307
      Log.printf1 "Killing %s.\n" (string_of_client client);
311
308
      (try client_death_time_map#remove client with _ -> ());
312
309
      (try destroy_all_client_resources client with _ -> ());
313
310
      decrement_client_no ();
314
311
      (try
315
312
        Unix.close (socket_map#lookup client);
316
 
        Log.printf
317
 
          "The socket serving the client %i was closed with success.\n" client;
318
 
        flush_all ();
 
313
        Log.printf1 "The socket serving the client %i was closed with success.\n" client;
319
314
      with e -> begin
320
 
        Log.printf
 
315
        Log.printf2
321
316
          "Closing the socket serving the client %i failed (%s).\n"
322
317
          client (Printexc.to_string e);
323
 
        flush_all ();
324
318
      end);
325
319
      (try socket_map#remove client with _ -> ());
326
 
      Log.printf "%s was killed.\n" (string_of_client client); flush_all ());;
 
320
      Log.printf1 "%s was killed.\n" (string_of_client client));;
327
321
 
328
322
let debugging_thread_thunk () =
329
323
  while true do
330
324
    Thread.delay debug_interval;
331
325
    Recursive_mutex.with_mutex the_daemon_mutex
332
326
      (fun () ->
333
 
        Log.printf "--------------------------------------------\n";
334
 
        Log.printf "Currently existing non-global resources are:\n";
 
327
        Log.printf "--------------------------------------------\nCurrently existing non-global resources are:\n";
335
328
        List.iter
336
329
          (fun (client, resource) ->
337
 
            Log.printf "* %s (owned by %s)\n" (string_of_daemon_resource resource) (string_of_client client))
 
330
            Log.printf2 "* %s (owned by %s)\n" (string_of_daemon_resource resource) (string_of_client client))
338
331
          (resource_map#to_list);
339
332
        Log.printf "--------------------------------------------\n";
340
 
        flush_all ();
341
333
        );
342
 
    flush_all ();
343
334
  done;;
344
335
 
345
336
(** The 'timeout thread' wakes up every timeout_interval seconds and kills
360
351
        List.iter
361
352
          (fun (client, death_time) ->
362
353
            if current_time >= death_time then begin
363
 
              Log.printf "Client %s didn't send enough keep-alive's.\n" (string_of_client client);
 
354
              Log.printf1 "Client %s didn't send enough keep-alive's.\n" (string_of_client client);
364
355
              destroy_client client;
365
 
              flush_all ();
366
356
            end)
367
 
          client_death_times;
368
 
        flush_all ());
 
357
          client_death_times);
369
358
  done;;
370
359
 
371
360
(** Serve the given single request from the given client, and return the
388
377
    to be open: *)
389
378
let connection_server_thread (client, socket) =
390
379
  try
391
 
    Log.printf "This is the connection server thread for client %i.\n" client;
392
 
    flush_all ();
 
380
    Log.printf1 "This is the connection server thread for client %i.\n" client;
393
381
    while true do
394
 
      Log.printf "Beginning of the iteration.\n"; flush_all ();
 
382
      Log.printf "Beginning of the iteration.\n";
395
383
      (* We want the message to be initially invalid, at every iteration, to
396
384
         avoid the risk of not seeing a receive error. Just to play it extra
397
385
        safe: *)
399
387
      (* We don't want to block indefinitely on read() because the socket could
400
388
         be closed by another thread; so we simply select() with a timeout: *)
401
389
      let (ready_for_read, _, failed) =
402
 
(****)
403
390
        try
404
391
          Unix.select [socket] [] [socket] select_timeout
405
392
        with _ -> begin
406
393
          Log.printf "!!!!FAILED IN select (connection_server_thread)!!!!\n";
407
 
          flush_all ();
408
394
          failwith "select() failed";
409
395
          (* ([], [], []); *)
410
396
        end
411
 
in
412
 
(****)
413
 
        (* Unix.select [socket] [] [socket] select_timeout in *)
 
397
      in
 
398
      (* --- *)
 
399
      (* Unix.select [socket] [] [socket] select_timeout in *)
414
400
      if (List.length failed) > 0 then
415
401
        failwith "select() reported failure with the socket"
416
402
      else if (List.length ready_for_read) > 0 then begin
420
406
          failwith "recv() failed, or the message is ill-formed"
421
407
        else begin
422
408
          let request = parse_request buffer in
423
 
          Log.printf "The request is\n  %s\n" (string_of_daemon_request request); flush_all ();
 
409
          Log.printf1 "The request is\n  %s\n" (string_of_daemon_request request);
424
410
          keep_alive_client client;
425
411
          let response =
426
412
            try
428
414
            with e ->
429
415
              Error (Printexc.to_string e)
430
416
          in
431
 
          Log.printf "My response is\n  %s\n" (string_of_daemon_response response); flush_all ();
 
417
          Log.printf1 "My response is\n  %s\n" (string_of_daemon_response response);
432
418
          let sent_byte_no = Unix.send socket (print_response response) 0 message_length [] in
433
419
          (if not (sent_byte_no == sent_byte_no) then
434
420
            failwith "send() failed");
439
425
      end;
440
426
    done;
441
427
  with e -> begin
442
 
    Log.printf
 
428
    Log.printf2
443
429
      "Failed in connection_server_thread (%s) for client %i.\nBailing out.\n"
444
430
      (Printexc.to_string e)
445
431
      client;
446
432
    destroy_client client; (* This also closes the socket *)
447
 
    Log.printf "Exiting from the thread which was serving client %i\n" client;
448
 
    flush_all ();
 
433
    Log.printf1 "Exiting from the thread which was serving client %i\n" client;
449
434
  end;;
450
435
 
451
436
(** Remove an old socket file, remained from an old instance or from ours
453
438
let remove_socket_file_if_any () =
454
439
  try
455
440
    Unix.unlink socket_name;
456
 
    Log.printf "[Removed the old socket file %s]\n" socket_name;
457
 
    flush_all ();
 
441
    Log.printf1 "[Removed the old socket file %s]\n" socket_name;
458
442
  with _ ->
459
 
    Log.printf "[There was no need to remove the socket file %s]\n" socket_name;;
 
443
    Log.printf1 "[There was no need to remove the socket file %s]\n" socket_name;;
460
444
 
461
445
(** Destroy all resources, destroy the socket and exit on either SIGINT and SIGTERM: *)
462
446
let signal_handler signal =
463
 
  Log.printf "=========================\n";
464
 
  Log.printf "I received the signal %i!\n" signal;
465
 
  Log.printf "=========================\n";
466
 
  Log.printf "Destroying all resources...\n";
 
447
  Log.printf1 "=========================\nI received the signal %i!\n=========================\nDestroying all resources...\n" signal;
467
448
  destroy_all_resources ();
468
 
  Log.printf "Ok, all resources were destroyed.\n";
469
 
  Log.printf "Removing the socket file...\n";
 
449
  Log.printf "Ok, all resources were destroyed.\nRemoving the socket file...\n";
470
450
  remove_socket_file_if_any ();
471
451
  Log.printf "Ok, the socket file was removed.\n";
472
 
  flush_all ();
473
452
  raise Exit;;
474
453
 
475
454
(** Strangely, without calling this the program is uninterruptable from the
501
480
  Unix.bind accepting_socket sock_addr;
502
481
  (* Everybody must be able to send messages to us: *)
503
482
  Unix.chmod socket_name 438 (* a+rw *);
504
 
  Log.printf "I am waiting on %s.\n" socket_name; flush_all ();
 
483
  Log.printf1 "I am waiting on %s.\n" socket_name;
505
484
  Unix.listen accepting_socket connection_no_limit;
506
485
  while true do
507
486
    try
508
 
      Log.printf "Waiting for the next connection...\n"; flush_all ();
 
487
      Log.printf "Waiting for the next connection...\n";
509
488
      let (socket_to_client, socket_to_client_address) = Unix.accept accepting_socket in
510
489
      let client_id = make_client socket_to_client in
511
 
      Log.printf "A new connection was accepted; the new client id is %i\n" client_id; flush_all ();
 
490
      Log.printf1 "A new connection was accepted; the new client id is %i\n" client_id;
512
491
      ignore (Thread.create connection_server_thread (client_id, socket_to_client));
513
492
    with e -> begin
514
 
    Log.printf
515
 
      "Failed in the main thread (%s). Bailing out.\n"
516
 
      (Printexc.to_string e);
517
 
      flush_all ();
 
493
      Log.printf1 "Failed in the main thread (%s). Bailing out.\n" (Printexc.to_string e);
518
494
      raise e;
519
 
    end;
 
495
      end;
520
496
  done;;