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
open Functoria.DSL
let dhcp_ipv4 tap e a = Ip.ipv4_of_dhcp tap e a
let qubes_ipv4 ?(qubesdb = Qubesdb.default_qubesdb) e a =
Ip.ipv4_qubes qubesdb e a
(** dual stack *)
type stackv4v6 = STACKV4V6
let stackv4v6 = typ STACKV4V6
let stackv4v6_direct_conf () =
let packages_v = Ip.right_tcpip_library ~sublibs:[ "stack-direct" ] "tcpip" in
let connect _i modname = function
| [ interface; ethif; arp; ipv4v6; icmpv4; udp; tcp ] ->
code ~pos:__POS__ "%s.connect %s %s %s %s %s %s %s" modname interface
ethif arp ipv4v6 icmpv4 udp tcp
| _ -> Misc.connect_err "direct stack" 7
in
impl ~packages_v ~connect "Tcpip_stack_direct.MakeV4V6"
(Network.network
@-> Ethernet.ethernet
@-> Arp.arpv4
@-> Ip.ipv4v6
@-> Icmp.icmpv4
@-> Udp.udp
@-> Tcp.tcp
@-> stackv4v6)
let direct_stackv4v6 ?group ?tcp network eth arp ipv4 ipv6 =
let ipv4_only = Runtime_arg.ipv4_only ?group ()
and ipv6_only = Runtime_arg.ipv6_only ?group () in
let ip = Ip.keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 in
stackv4v6_direct_conf ()
$ network
$ eth
$ arp
$ ip
$ Icmp.direct_icmpv4 ipv4
$ Udp.direct_udp ip
$ match tcp with None -> Tcp.direct_tcp ip | Some tcp -> tcp
let keyed_direct_stackv4v6 ?tcp ~ipv4_only ~ipv6_only network eth arp ipv4 ipv6
=
let ip = Ip.keyed_ipv4v6 ~ipv4_only ~ipv6_only ipv4 ipv6 in
stackv4v6_direct_conf ()
$ network
$ eth
$ arp
$ ip
$ Icmp.direct_icmpv4 ipv4
$ Udp.direct_udp ip
$ match tcp with None -> Tcp.direct_tcp ip | Some tcp -> tcp
let generic_ipv4v6_stack p ?group ?ipv4_network ?ipv4_gateway ?ipv6_network
?ipv6_gateway ?(arp = Arp.arp) ?tcp tap =
let ipv4_only = Runtime_arg.ipv4_only ?group ()
and ipv6_only = Runtime_arg.ipv6_only ?group () in
let e = Ethernet.ethif tap in
let a = arp e in
let i4 =
match_impl p
[ (`Qubes, qubes_ipv4 e a); (`Dhcp, dhcp_ipv4 tap e a) ]
~default:
(Ip.keyed_create_ipv4 ?group ?network:ipv4_network ?gateway:ipv4_gateway
~no_init:ipv6_only e a)
in
let i6 =
Ip.keyed_create_ipv6 ?group ?network:ipv6_network ?gateway:ipv6_gateway
~no_init:ipv4_only tap e
in
keyed_direct_stackv4v6 ~ipv4_only ~ipv6_only ?tcp tap e a i4 i6
let socket_stackv4v6 ?(group = "") () =
let v4key = Runtime_arg.V4.network ~group Ipaddr.V4.Prefix.global in
let v6key = Runtime_arg.V6.network ~group None in
let ipv4_only = Runtime_arg.ipv4_only ~group () in
let ipv6_only = Runtime_arg.ipv6_only ~group () in
let packages_v = Ip.right_tcpip_library ~sublibs:[ "stack-socket" ] "tcpip" in
let =
[
dep (Udp.udpv4v6_socket_conf ~ipv4_only ~ipv6_only v4key v6key);
dep (Tcp.tcpv4v6_socket_conf ~ipv4_only ~ipv6_only v4key v6key);
]
in
let connect _i modname = function
| [ udp; tcp ] -> code ~pos:__POS__ "%s.connect %s %s" modname udp tcp
| _ -> Misc.connect_err "socket_stackv4v6" 2
in
impl ~packages_v ~extra_deps ~connect "Tcpip_stack_socket.V4V6" stackv4v6
(** Generic stack *)
let generic_stackv4v6 ?group ?(dhcp_key = Key.value @@ Key.dhcp ?group ())
?(net_key = Key.value @@ Key.net ?group ()) ?ipv4_network ?ipv4_gateway
?ipv6_network ?ipv6_gateway ?tcp (tap : Network.network impl) :
stackv4v6 impl =
let choose target net dhcp =
match (target, net, dhcp) with
| `Qubes, _, _ -> `Qubes
| _, Some `Host, _ -> `Socket
| _, _, true -> `Dhcp
| (`Unix | `MacOSX), None, false -> `Socket
| _, _, _ -> `Static
in
let p = Key.(pure choose $ Key.(value target) $ net_key $ dhcp_key) in
match_impl p
[ (`Socket, socket_stackv4v6 ?group ()) ]
~default:
(generic_ipv4v6_stack p ?group ?ipv4_network ?ipv4_gateway ?ipv6_network
?ipv6_gateway ?tcp tap)