-
Notifications
You must be signed in to change notification settings - Fork 13
/
pcap_mirage.ml
100 lines (92 loc) · 3.69 KB
/
pcap_mirage.ml
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
(*
* Copyright (c) 2012 Citrix Systems
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
open Lwt
open OS
(*open Net.Ethif *)
open Pcap
open Pcap.LE (* write in little-endian format *)
let capture_limit = 64
(** Buffer this many packets before we start to drop *)
(* We lack a decent file abstraction so we'll experiment with representing
open files as threads which read commands from an mvar. *)
type fd = Cstruct.buf list option Lwt_mvar.t
let open_blkif blkif : fd =
let m : fd = Lwt_mvar.create_empty () in
let page_offset = ref 0L in
let buf_offset = ref 0 in
let closed = ref false in
let buf = Io_page.get () in
let (_: unit Lwt.t) =
while_lwt not(!closed) do
Lwt_mvar.take m >>=
function
| None ->
closed := true;
return ()
| Some (frags: Cstruct.buf list) ->
let single_write frag =
let available_space = 4096 - !buf_offset in
let needed_space = Cstruct.len frag in
if needed_space >= available_space then begin
Cstruct.blit_buffer frag 0 buf !buf_offset available_space;
lwt () = blkif#write_page !page_offset buf in
page_offset := Int64.add !page_offset 4096L;
buf_offset := 0;
return available_space
end else begin
Cstruct.blit_buffer frag 0 buf !buf_offset needed_space;
buf_offset := !buf_offset + needed_space;
return needed_space
end in
let write frag =
let remaining = ref frag in
while_lwt Cstruct.len !remaining > 0 do
lwt written = single_write !remaining in
remaining := Cstruct.shift !remaining written;
return ()
done in
Lwt_list.iter_s write frags
done in
m
let capture input fd =
let buf = OS.Io_page.get () in
set_pcap_header_magic_number buf magic_number;
set_pcap_header_version_major buf major_version;
set_pcap_header_version_minor buf minor_version;
set_pcap_header_thiszone buf 0l;
set_pcap_header_sigfigs buf 0l;
set_pcap_header_snaplen buf 4096l;
set_pcap_header_network buf (Network.(to_int32 Ethernet));
lwt () = Lwt_mvar.put fd (Some [Cstruct.sub buf 0 sizeof_pcap_header] ) in
set_capture_limit capture_limit input;
OS.Console.log (Printf.sprintf "pcap: set capture limit to %d" capture_limit);
let stream = get_captured_packets input in
try_lwt
while_lwt true do
lwt packets = Lwt_bounded_stream.nget 1 stream in
Lwt_list.iter_s
(fun (time, frags) ->
let len = List.fold_left (+) 0 (List.map Cstruct.len frags) in
let buf = OS.Io_page.get () in
set_pcap_packet_ts_sec buf (Int32.(of_float time));
set_pcap_packet_ts_usec buf (Int32.rem (Int32.of_float ( time *. 1000000.)) 1000000l);
set_pcap_packet_incl_len buf (Int32.of_int len);
set_pcap_packet_orig_len buf (Int32.of_int len);
Lwt_mvar.put fd (Some (Cstruct.sub buf 0 sizeof_pcap_packet :: frags))
) packets
done
with Lwt_stream.Closed ->
return ()