package mirage

  1. Overview
  2. Docs
The MirageOS library operating system

Install 

dune-project
 Dependency

github.com Edit opam file Versions (14)

Authors

  1. T
    Thomas Gazagnaire
  2. A
    Anil Madhavapeddy
  3. Gabriel Radanne
  4. M
    Mindy Preston
  5. T
    Thomas Leonard
  6. N
    Nicolas Ojeda Bar
  7. D
    Dave Scott
  8. D
    David Kaloper
  9. H
    Hannes Mehnert
  10. R
    Richard Mortier

Maintainers

  1. A
    anil@recoil.org
  2. T
    thomas@gazagnaire.org

Sources

mirage-4.11.2.tbz
sha256=2cbd7924f82d85ad8ed6bab2f8dc95e6bd15a723532193b56af01813ab20b1a7
sha512=995dd413d02cf279d4de4178d0fda61fdcbad9518f2b114eb76d0c16cd4eeb602fbd44a8916e29b62b307fca9a5f374f7c3d104287f4f7ee9c89e706876a9895

doc/src/mirage.devices/stack.ml.html

Source file stack.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
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
open Functoria.DSL

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 = [ Ip.right_tcpip_library [ "stack-direct" ] ] 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 ~connect "Tcpip_stack_direct.MakeV4V6"
    (Network.network
    @-> Ethernet.ethernet
    @-> Arp.arpv4
    @-> Ip.ipv4v6
    @-> Icmp.icmpv4
    @-> Udp.udp
    @-> Tcp.tcp
    @-> stackv4v6)

let direct_stackv4v6 ?group 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
  $ Tcp.direct_tcp ?group ip

let keyed_direct_stackv4v6 ~ipv4_only ~ipv6_only ?group 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
  $ Tcp.direct_tcp ?group ip

let generic_ipv4v6_stack p ?group ?dhcp_requests ?ipv4_network ?ipv4_gateway
    ?ipv6_network ?ipv6_gateway ?(arp = Arp.arp) 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 dhcp_ipv4 = Ip.ipv4_of_dhcp ?group ?dhcp_requests tap e a in
  let tap =
    match_impl p [ (`Dhcp, Ip.dhcp_proj_net $ dhcp_ipv4) ] ~default:tap
  in
  let i4 =
    match_impl p
      [ (`Qubes, qubes_ipv4 e a); (`Dhcp, Ip.dhcp_proj_ipv4 $ dhcp_ipv4) ]
      ~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
  let lease =
    match_impl p
      [ (`Dhcp, Ip.dhcp_proj_lease $ dhcp_ipv4) ]
      ~default:Ip.no_lease
  in
  (keyed_direct_stackv4v6 ~ipv4_only ~ipv6_only ?group tap e a i4 i6, lease)

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 = [ Ip.right_tcpip_library [ "stack-socket" ] ] in
  let extra_deps =
    [
      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 ~extra_deps ~connect "Tcpip_stack_socket.V4V6" stackv4v6

(** Generic stack *)
let generic_stackv4v6_with_lease ?group ?dhcp_requests ?ipv4_network
    ?ipv4_gateway ?ipv6_network ?ipv6_gateway (tap : Network.network impl) :
    stackv4v6 impl * Ip.lease impl =
  let no_dhcp_key = Key.value @@ Key.no_dhcp ?group () in
  let net_key = Key.value @@ Key.net ?group () in
  let choose target net no_dhcp =
    match (target, net, no_dhcp) with
    | `Qubes, _, _ -> `Qubes
    | _, Some `Host, _ -> `Socket
    | _, _, false -> `Dhcp
    | (`Unix | `MacOSX), None, true -> `Socket
    | _, _, _ -> `Static
  in
  let p = Key.(pure choose $ Key.(value target) $ net_key $ no_dhcp_key) in
  let generic_ipv4v6_stack =
    generic_ipv4v6_stack p ?group ?dhcp_requests ?ipv4_network ?ipv4_gateway
      ?ipv6_network ?ipv6_gateway tap
  in
  ( match_impl p
      [ (`Socket, socket_stackv4v6 ?group ()) ]
      ~default:(fst generic_ipv4v6_stack),
    match_impl p [ (`Socket, Ip.no_lease) ] ~default:(snd generic_ipv4v6_stack)
  )

let generic_stackv4v6 ?group ?ipv4_network ?ipv4_gateway ?ipv6_network
    ?ipv6_gateway tap =
  generic_stackv4v6_with_lease ?group ?dhcp_requests:None ?ipv4_network
    ?ipv4_gateway ?ipv6_network ?ipv6_gateway tap
  |> fst