├── arp_tester ├── README.md ├── config.ml └── unikernel.ml ├── https-client ├── config.ml └── unikernel.ml ├── irmin-arp-node ├── README.md ├── config.ml ├── mirarp.xl └── unikernel.ml ├── oscon-demo ├── config.ml ├── css.ml ├── names.ml └── unikernel.ml ├── qubes-dhcpd ├── config.ml └── unikernel.ml ├── read_pcap ├── README.md ├── config.ml └── unikernel.ml └── test-multiple-outbound ├── ask_thing.ml └── config.ml /arp_tester/README.md: -------------------------------------------------------------------------------- 1 | This unikernel currently only compiles in Unix mode because of its use of oUnit. However, it uses the Mirage TCP/IP stack without requiring tap configuration. 2 | 3 | Currently, the tests will fail, as they correctly detect deficiencies in the current ARP implementation (as of tcpip 2.3.0). This unikernel is meant for use in developing an adequate patch for these deficiencies. 4 | 5 | This unikernel requires the `mirage-net-pcap` library. To get it, 6 | 7 | ``` 8 | opam pin add mirage-net-pcap https://github.com/yomimono/mirage-net-pcap 9 | ``` 10 | -------------------------------------------------------------------------------- /arp_tester/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = 4 | foreign "Unikernel.Main" (console @-> kv_ro @-> job) 5 | 6 | let disk1 = crunch "pcaps" 7 | 8 | let tracing = mprof_trace ~size:100000 () 9 | 10 | let () = 11 | add_to_opam_packages["mirage-clock-unix";"pcap-format"; "tcpip"; "mirage-net-pcap";"oUnit"]; 12 | add_to_ocamlfind_libraries["pcap-format"; "mirage-clock-unix";"tcpip.ethif"; "tcpip.ipv4"; 13 | "tcpip.udp"; "tcpip.dhcpv4"; "mirage-net-pcap"; 14 | "oUnit"; "cstruct.syntax"; "oUnit"]; 15 | register "test_arp" ~tracing [ main $ default_console $ disk1 ] 16 | -------------------------------------------------------------------------------- /arp_tester/unikernel.ml: -------------------------------------------------------------------------------- 1 | open V1_LWT 2 | open Lwt 3 | open OUnit 4 | 5 | module Main (C: CONSOLE) (K: KV_RO) = struct 6 | module P = Netif.Make(K)(OS.Time) 7 | module E = Ethif.Make(P) 8 | module I = Ipv4.Make(E)(Clock)(OS.Time) 9 | module A = Arpv4.Make(E) 10 | module U = Udp.Make(I) 11 | 12 | (* unfortunately, arp isn't exposed in wire_structs nor in Arpv4, so 13 | we reproduce it here, nonoptimally *) 14 | cstruct arp { 15 | uint8_t dst[6]; 16 | uint8_t src[6]; 17 | uint16_t ethertype; 18 | uint16_t htype; 19 | uint16_t ptype; 20 | uint8_t hlen; 21 | uint8_t plen; 22 | uint16_t op; 23 | uint8_t sha[6]; 24 | uint32_t spa; 25 | uint8_t tha[6]; 26 | uint32_t tpa 27 | } as big_endian 28 | 29 | cenum op { 30 | Op_request = 1; 31 | Op_reply 32 | } as uint16_t 33 | 34 | let file = "mirage_dhcp_discover.pcap" 35 | (* arbitrary IP on a network matching the one in the pcap *) 36 | let ip = Ipaddr.V4.of_string_exn "192.168.2.222" 37 | let nm = Ipaddr.V4.of_string_exn "255.255.255.0" 38 | (* GARP emitter in pcap *) 39 | let target = Ipaddr.V4.of_string_exn "192.168.2.7" 40 | (* one of many hosts for which there is no traffic in the pcap *) 41 | let silent_host = Ipaddr.V4.of_string_exn "192.168.2.4" 42 | 43 | let printer = function 44 | | `Success -> "Success" 45 | | `Failure s -> s 46 | 47 | let is_arp_request e packet = 48 | (* E.input only wants things that return unit Lwt.t, so 49 | we need to signal which branch we took through side effects *) 50 | let is_arp = ref false in 51 | let not_arp = fun buf -> (is_arp := false; Lwt.return_unit) in 52 | let is_arp_probe packet = 53 | match (get_arp_op packet) with 54 | | 1 -> true 55 | | _ -> false 56 | in 57 | let came_from_us packet = 58 | match Macaddr.compare (E.mac e) (Macaddr.of_bytes_exn (copy_arp_src 59 | packet)) with 60 | | 0 -> true 61 | | _ -> false 62 | in 63 | (* use E.input to get tcpip to parse this for us *) 64 | (* don't need to worry about mac filtering in ethif because we're 65 | looking for something that will have dst = broadcast *) 66 | E.input ~arpv4:(fun buf -> (if is_arp_probe buf && came_from_us buf then 67 | is_arp := true; Lwt.return_unit)) 68 | ~ipv4:not_arp ~ipv6:not_arp e packet >>= fun () -> Lwt.return !is_arp 69 | 70 | let send_traffic u = 71 | U.write ~source_port:1000 ~dest_ip:target ~dest_port:1024 u 72 | (Cstruct.create 0) >>= fun () -> 73 | Lwt.return `Success 74 | 75 | let test_send_arps p e u = 76 | let try_connecting _context = 77 | U.write ~source_port:1000 ~dest_ip:silent_host 78 | ~dest_port:1024 u (Cstruct.create 0) >>= fun () -> 79 | Lwt.return (`Failure "Sent a UDP packet for a host which can't have been 80 | in the ARP cache") 81 | in 82 | let timeout_then_succeed _context = 83 | OS.Time.sleep 1.0 >>= fun () -> 84 | (* check to make sure we wrote an ARP probe *) 85 | match (P.get_written p) with 86 | | [] -> Lwt.return (`Failure "Wrote nothing when should've ARP probed") 87 | | l -> is_arp_request e (List.hd (List.rev l)) >>= function 88 | | true -> Lwt.return `Success 89 | | false -> Lwt.return (`Failure "Waited for something, but the last 90 | thing we wrote wasn't an ARP request") 91 | in 92 | Lwt.pick [ 93 | try_connecting (); 94 | timeout_then_succeed (); 95 | ] 96 | 97 | let test_garp_was_read p e u = 98 | let timeout_then_fail _context = 99 | let timeout = 1.0 in 100 | OS.Time.sleep timeout >>= fun () -> 101 | (* make sure the failure is because we wrote an arp request packet *) 102 | match P.get_written p with 103 | | [] -> Lwt.return (`Failure "Timed out, although we didn't write anything?") 104 | | l -> 105 | is_arp_request e (List.hd (List.rev l)) >>= function 106 | | true -> Lwt.return (`Failure "sent an arp probe for something that 107 | just GARPed") 108 | | false -> Lwt.return (`Failure "Timed out and wrote something, but it 109 | doesn't look like an arp probe") 110 | in 111 | let try_connecting _context = 112 | U.write ~source_port:1000 ~dest_ip:target ~dest_port:1024 u (Cstruct.create 113 | 0) >>= fun () -> 114 | Lwt.return `Success 115 | in 116 | Lwt.pick [ 117 | try_connecting (); 118 | timeout_then_fail () 119 | ] 120 | 121 | let test_arp_aged_out p e u = 122 | (* attempt a connection, which we expect not to succeed *) 123 | let arp_age = 65.0 (* set to whatever the arp aging interval is; would be 124 | nice to have this visible *) in 125 | let try_connecting _context = 126 | (* make sure we were cool to write initially *) 127 | U.write ~source_port:1000 ~dest_ip:target ~dest_port:1024 u 128 | (Cstruct.create 0) >>= fun () -> 129 | OS.Time.sleep arp_age >>= fun () -> 130 | U.write ~source_port:1000 ~dest_ip:target ~dest_port:1024 u 131 | (Cstruct.create 0) >>= fun () -> 132 | (* spoo out the last packet sent for debugging *) 133 | let last_sent = (List.hd (List.rev (P.get_written p))) in 134 | match (Cstruct.len last_sent) with 135 | | 0 -> 136 | Printf.printf "Okay, this is obviously bananas."; 137 | List.iter (fun d -> Printf.printf "packet:\n"; Cstruct.hexdump d) 138 | (P.get_written p); 139 | Lwt.return (`Failure "Sent a packet with no contents 140 | when we had no ARP entry for the 141 | destination.") 142 | | n -> 143 | let b = Buffer.create (Cstruct.len last_sent) in 144 | Cstruct.hexdump_to_buffer b last_sent; 145 | Lwt.return (`Failure (Printf.sprintf "Sent a packet %s with length %d 146 | when we should've had no ARP entry for the destination" 147 | (Buffer.contents b) n)) 148 | in 149 | let timeout_then_succeed _context = 150 | OS.Time.sleep (arp_age +. 1.0) >>= fun () -> 151 | (* check to make sure we wrote an ARP probe *) 152 | match (P.get_written p) with 153 | | [] -> Lwt.return (`Failure "Wrote nothing when should've ARP probed") 154 | | l -> is_arp_request e (List.hd (List.rev l)) >>= function 155 | | true -> Lwt.return `Success 156 | | false -> Lwt.return (`Failure "Waited for something, but the last 157 | thing we wrote wasn't an ARP request") 158 | in 159 | Lwt.pick [ 160 | try_connecting (); 161 | timeout_then_succeed (); 162 | ] 163 | 164 | let test_queries_retried p e u = 165 | let try_connecting _context = 166 | try_lwt U.write ~source_port:1000 ~dest_ip:silent_host 167 | ~dest_port:1024 u (Cstruct.create 0) 168 | >>= fun () -> 169 | Lwt.return (`Failure "Sent a UDP packet for a host which can't have been 170 | in the ARP cache") 171 | (* with I.Routing.No_route_to_destination_address silent_host -> 172 | Lwt.return `Success *) 173 | with Not_found -> Lwt.return `Success 174 | in 175 | let timeout_then_succeed _context = 176 | let rec first_k_are_arp_requests l (k : int) = 177 | match l, k with 178 | | _, 0 -> Lwt.return true 179 | | [], _ -> Lwt.return false 180 | | p :: more, k when (k > 0) -> 181 | is_arp_request e p >>= fun this_one -> 182 | first_k_are_arp_requests more (k - 1) >>= fun others -> 183 | Lwt.return (this_one && others) 184 | | _, _ -> Lwt.return false 185 | in 186 | let retry_interval = 1.5 in (* would be better to ask Arp for these 187 | directly *) 188 | let number_of_retries = 3.0 in 189 | OS.Time.sleep (retry_interval *. number_of_retries +. 0.25) >>= fun () -> 190 | (* check to make sure we wrote three ARP probes *) 191 | match (P.get_written p) with 192 | | [] -> Lwt.return (`Failure "Wrote nothing when should've ARP probed") 193 | | l -> first_k_are_arp_requests (List.rev l) 194 | (int_of_float number_of_retries) >>= function 195 | | true -> Lwt.return `Success 196 | | false -> Lwt.return 197 | (`Failure (Printf.sprintf "Last %d sent packets weren't ARP probes" 198 | (int_of_float number_of_retries))) 199 | in 200 | Lwt.pick [ 201 | try_connecting (); 202 | timeout_then_succeed () 203 | ] 204 | 205 | let start c k = 206 | 207 | let or_error c name fn t = 208 | fn t >>= function 209 | | `Error e -> fail (Failure ("Error starting " ^ name)) 210 | | `Ok t -> return t 211 | in 212 | 213 | 214 | let setup_iface ?(timing=None) file ip nm = 215 | 216 | let pcap_netif_id = P.id_of_desc ~mac:Macaddr.broadcast ~timing ~source:k ~read:file in 217 | (* build interface on top of netif *) 218 | or_error c "pcap_netif" P.connect pcap_netif_id >>= fun p -> 219 | or_error c "ethif" E.connect p >>= fun e -> 220 | or_error c "ipv4" I.connect e >>= fun i -> 221 | or_error c "udpv4" U.connect i >>= fun u -> 222 | 223 | (* set up ipv4 statically *) 224 | I.set_ip i ip >>= fun () -> I.set_ip_netmask i nm >>= fun () -> 225 | 226 | Lwt.return (p, e, i, u) 227 | in 228 | let play_pcap (p, e, i, u) = 229 | P.listen p (E.input 230 | ~arpv4:(fun buf -> I.input_arpv4 i buf) 231 | ~ipv4:(fun buf -> Lwt.return_unit) 232 | ~ipv6:(fun buf -> Lwt.return_unit) e 233 | ) >>= fun () -> 234 | Lwt.return (p, e, i, u) 235 | in 236 | (* the capture contains a GARP from 192.168.2.7, so we should have an entry 237 | for that address in the arp cache now *) 238 | (* send a udp packet to that address, which will result in an attempt to 239 | resolve the address on the ARP layer. If the thread returns, all's well. *) 240 | (* 241 | x 1) we age out arp entries after some amount of time 242 | x 2) we update arp entries in the presence of new information 243 | x 3) we send out arp probes when trying to resolve unknown addresses 244 | x 4) we retry arp probes a predictable number of timesen 245 | 5) we stop retrying arp probes once one has succeeded 246 | x 6) on successful reception of an arp reply, we don't unnecessarily delay our response 247 | *) 248 | (* we really should be doing each of these with a fresh pcap_netif; 249 | otherwise we run the risk of contaminating state between runs *) 250 | C.log c "testing that arp probes are sent for entries that shouldn't be in 251 | the cache..."; 252 | setup_iface file ip nm >>= fun send_arp_test_stack -> 253 | play_pcap send_arp_test_stack >>= fun (p, e, i, u) -> 254 | test_send_arps p e u >>= fun result -> 255 | assert_equal ~printer `Success result; 256 | 257 | C.log c "testing that once a response is received, a query thread returns 258 | that response immediately..."; 259 | setup_iface file ip nm >>= fun (p, e, i, u) -> 260 | Lwt.pick [ 261 | (play_pcap (p, e, i, u) >>= fun query_stack -> 262 | Lwt.return (`Failure "return_on_reply: playback thread terminated 263 | first")); 264 | send_traffic u; (* these don't appear to actually be interleaved *) 265 | ] >>= fun result -> 266 | assert_equal ~printer `Success result; 267 | 268 | C.log c "testing that probes are retried..."; 269 | setup_iface file ip nm >>= fun arp_query_retry_stack -> 270 | play_pcap arp_query_retry_stack >>= fun (p, e, i, u) -> 271 | test_queries_retried p e u >>= fun result -> 272 | assert_equal ~printer `Success result; 273 | 274 | C.log c "testing that gratuitous arps are recorded in the cache..."; 275 | setup_iface file ip nm >>= fun garp_reads_test_stack -> 276 | play_pcap garp_reads_test_stack >>= fun (p, e, i, u) -> 277 | test_garp_was_read p e u >>= fun result -> 278 | assert_equal ~printer `Success result; 279 | 280 | C.log c "testing that entries are aged out..."; 281 | setup_iface file ip nm >>= fun arp_aging_test_stack -> 282 | play_pcap send_arp_test_stack >>= fun (p, e, i, u) -> 283 | test_arp_aged_out p e u >>= fun result -> 284 | assert_equal ~printer `Success result; 285 | 286 | Lwt.return_unit 287 | end 288 | -------------------------------------------------------------------------------- /https-client/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let secrets_dir = "sekrit" 4 | 5 | let disk = 6 | match get_mode () with 7 | | `Unix | `MacOSX -> direct_kv_ro secrets_dir 8 | | `Xen -> crunch secrets_dir 9 | 10 | let net = 11 | try match Sys.getenv "NET" with 12 | | "direct" -> `Direct 13 | | _ -> `Socket 14 | with Not_found -> 15 | match get_mode () with 16 | | `Unix | `MacOSX -> `Socket 17 | | `Xen -> `Direct 18 | 19 | let dhcp = 20 | try match Sys.getenv "ADDR" with 21 | | "static" -> `Static 22 | | _ -> `Dhcp 23 | with Not_found -> `Dhcp 24 | 25 | let stack console = 26 | match net with 27 | | `Direct -> direct_stackv4_with_dhcp console tap0 28 | | `Socket -> socket_stackv4 console [Ipaddr.V4.any] 29 | 30 | 31 | let build_stack console = 32 | let ns = Ipaddr.V4.of_string_exn "208.67.222.222" in 33 | let stack = stack console in 34 | (conduit_direct ~tls:true stack), (Mirage.resolver_dns ~ns stack) 35 | 36 | let tracing = mprof_trace ~size:1000000 () 37 | 38 | let client = 39 | foreign "Unikernel.Client" @@ console @-> resolver @-> conduit @-> kv_ro @-> job 40 | 41 | let () = 42 | let (con, res) = build_stack default_console in 43 | add_to_opam_packages [ "dns" ; "tls" ] ; 44 | add_to_ocamlfind_libraries [ "dns.mirage"; "tls"; "tls.mirage" ] ; 45 | register ~tracing "tls-client" [ client $ default_console $ res $ con $ disk ] 46 | -------------------------------------------------------------------------------- /https-client/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | open V1 4 | open V1_LWT 5 | 6 | 7 | type ('a, 'e, 'c) m = ([< `Ok of 'a | `Error of 'e | `Eof ] as 'c) Lwt.t 8 | 9 | let (>>==) (a : ('a, 'e, _) m) (f : 'a -> ('b, 'e, _) m) : ('b, 'e, _) m = 10 | a >>= function 11 | | `Ok x -> f x 12 | | `Error _ | `Eof as e -> return e 13 | 14 | 15 | module Color = struct 16 | open Printf 17 | let red fmt = sprintf ("\027[31m"^^fmt^^"\027[m") 18 | let green fmt = sprintf ("\027[32m"^^fmt^^"\027[m") 19 | let yellow fmt = sprintf ("\027[33m"^^fmt^^"\027[m") 20 | let blue fmt = sprintf ("\027[36m"^^fmt^^"\027[m") 21 | end 22 | 23 | 24 | module Log (C: CONSOLE) = struct 25 | 26 | let log_trace c str = C.log_s c (Color.green "+ %s" str) 27 | 28 | and log_data c str buf = 29 | let repr = String.escaped (Cstruct.to_string buf) in 30 | C.log_s c (Color.blue " %s: " str ^ repr) 31 | and log_error c e = C.log_s c (Color.red "+ err: %s" e) 32 | 33 | end 34 | 35 | let make_tracer dump = 36 | let traces = ref [] in 37 | let trace sexp = 38 | traces := Sexplib.Sexp.to_string_hum sexp :: !traces 39 | and flush () = 40 | let msgs = List.rev !traces in 41 | traces := [] ; 42 | Lwt_list.iter_s dump msgs in 43 | (trace, flush) 44 | 45 | module Client (C : CONSOLE) 46 | (Resolver : Resolver_lwt.S) 47 | (Conduit : Conduit_mirage.S) 48 | (KV : KV_RO) = 49 | struct 50 | 51 | module X509 = Tls_mirage.X509 (KV) (Clock) 52 | module L = Log (C) 53 | 54 | open Ipaddr 55 | 56 | let host, port = "https://mirage.io", 443 57 | 58 | let initial = Cstruct.of_string @@ 59 | "GET / HTTP/1.1\r\nConnection: Close\r\nHost: " ^ host ^ "\r\n\r\n" 60 | 61 | let chat c tls = 62 | let rec dump () = 63 | Conduit_mirage.Flow.read tls >>== fun buf -> 64 | L.log_data c "recv" buf >> dump () in 65 | Conduit_mirage.Flow.write tls initial >> dump () 66 | 67 | let start c res con kv = 68 | Resolver.resolve_uri (Uri.of_string host) res >>= function 69 | | `Unix_domain_socket _ | `Unknown _ | `Vchan_direct _ | 70 | `Vchan_domain_socket _ -> L.log_error c "Endpoint resolved to a non-network conduit type" 71 | | `TCP endp -> L.log_error c "Endpoint resolved to plain TCP; aborting" 72 | | `TLS (name, endp) -> 73 | match endp with 74 | | `Unix_domain_socket _ | `Unknown _ | `Vchan_direct _ | 75 | `Vchan_domain_socket _ -> L.log_error c "TLS-wrapped endpoint resolved to a non-network conduit type" 76 | | `TLS _ -> L.log_error c "TLS-wrapped endpoint claims to be TLS itself" 77 | | `TCP (server_ip, port) -> 78 | C.log c ("Lookup succeeded -- will contact " ^ (Ipaddr.to_string server_ip)); 79 | Conduit_mirage.client (`TLS (name, endp)) >>= fun client -> 80 | C.log c "Conduit client setup completed"; 81 | C.log c "Attempting connection..."; 82 | Conduit_mirage.connect con client >>= fun tls -> 83 | chat c tls 84 | >>= function 85 | | `Error e -> L.log_error c (Conduit_mirage.Flow.error_message e) 86 | | `Eof -> L.log_trace c "eof." 87 | | `Ok _ -> assert false 88 | end 89 | -------------------------------------------------------------------------------- /irmin-arp-node/README.md: -------------------------------------------------------------------------------- 1 | This example unikernel brings up a stack with an [irmin-arp](https://github.com/yomimono/irmin-arp) ARP implementation (using the Irmin in-memory backend). It then attempts to communicate with 192.168.3.2, which is expected to be running an echo server. (Such an implementation is included [in the examples directory of mirage-tcpip](https://github.com/mirage/mirage-tcpip/tree/master/examples).) 2 | -------------------------------------------------------------------------------- /irmin-arp-node/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = 4 | foreign "Unikernel.Client" (console @-> network @-> clock @-> random @-> job) 5 | 6 | let netif = (netif "0") 7 | 8 | let () = 9 | add_to_ocamlfind_libraries["irmin.mem";"irmin-arp";"tcpip.tcp";"tcpip.ethif"; 10 | "bin_prot"]; 11 | add_to_opam_packages["irmin";"irmin-arp";"tcpip";]; 12 | register "irmin-arp-client" [ main 13 | $ default_console 14 | $ netif 15 | $ default_clock 16 | $ default_random ] 17 | -------------------------------------------------------------------------------- /irmin-arp-node/mirarp.xl: -------------------------------------------------------------------------------- 1 | # Generated by Mirage (Wed, 15 Jul 2015 08:15:50 GMT). 2 | 3 | name = 'irmin-arp-client' 4 | kernel = 'mir-irmin-arp-client.xen' 5 | builder = 'linux' 6 | memory = 256 7 | on_crash = 'preserve' 8 | 9 | # You must define the network and block interfaces manually. 10 | 11 | # The disk configuration is defined here: 12 | # http://xenbits.xen.org/docs/4.3-testing/misc/xl-disk-configuration.txt 13 | # An example would look like: 14 | # disk = [ '/dev/loop0,,xvda' ] 15 | 16 | # The network configuration is defined here: 17 | # http://xenbits.xen.org/docs/4.3-testing/misc/xl-network-configuration.html 18 | # An example would look like: 19 | vif = [ 'bridge=xenbr0' ] 20 | -------------------------------------------------------------------------------- /irmin-arp-node/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" 4 | 5 | let echo_port = 7 6 | 7 | let pester_interval = 5.0 8 | let crosstalk_interval = 90.0 9 | 10 | let root = "demo_results" 11 | 12 | let strip = Ipaddr.V4.to_string 13 | 14 | module Client (C: V1_LWT.CONSOLE) (N: V1_LWT.NETWORK) (Clock: V1.CLOCK) 15 | (Random: V1.RANDOM) = struct 16 | module Time = OS.Time 17 | module E = Ethif.Make(N) 18 | module A = Irmin_arp.Arp.Make(E)(Clock)(Time)(Random)(Irmin_mem.Make) 19 | module IPV4 = Ipv4.Make(E)(A) 20 | module TCP = Tcp.Flow.Make(IPV4)(Time)(Clock)(Random) 21 | 22 | let ignore_errors c fn = function 23 | | `Ok q -> fn q 24 | | `Error _ -> C.log_s c "Server: error reading or writing from flow" 25 | | `Eof -> C.log_s c "Server: EOF reading or writing from flow" 26 | 27 | let get_arp ~netif ~root ~node ?(pull=[]) () = 28 | E.connect netif >>= function 29 | | `Error _ -> Lwt.fail (failwith "Ethif.connect failed!") 30 | | `Ok ethif -> 31 | (* for now, assume Irmin_mem *) 32 | let config = Irmin_mem.config () in 33 | A.connect ethif config ~node:[node] ~pull >>= function 34 | | `Ok arp -> Lwt.return (netif, ethif, arp) 35 | | `Error _ -> Lwt.fail (failwith "Arp.connect failed!") 36 | 37 | let start_ip ip_addr (netif, ethif, arp) = 38 | IPV4.connect ethif arp >>= function 39 | | `Error e -> Lwt.fail (failwith (Printf.sprintf "error starting ip %s" 40 | (Ipaddr.V4.to_string ip_addr))) 41 | | `Ok i -> 42 | IPV4.set_ip i ip_addr >>= fun () -> IPV4.set_ip_netmask i netmask >>= fun () -> 43 | Lwt.return (netif, ethif, arp, i) 44 | 45 | let arp_and_tcp_listeners netif ethif arp ip tcp () = 46 | N.listen netif (E.input 47 | ~ipv6:(fun buf -> Lwt.return_unit) 48 | ~arpv4:(fun buf -> A.input arp buf) 49 | ~ipv4:( 50 | IPV4.input 51 | ~tcp:(TCP.input tcp ~listeners:(fun _ -> None)) 52 | ~udp:(fun ~src ~dst _buf -> Lwt.return_unit) 53 | ~default:(fun ~proto ~src ~dst _ -> Lwt.return_unit) 54 | ip 55 | ) 56 | ethif ) 57 | 58 | let spawn_listeners (netif, ethif, arp, ip, tcp) = 59 | (* TODO: an async_hook for error reporting would be nice *) 60 | Lwt.async (arp_and_tcp_listeners netif ethif arp ip tcp); 61 | Lwt.return (netif, ethif, arp, ip, tcp) 62 | 63 | let converse c server_ip 64 | (_, _, client_arp, client_ip, client_tcp) 65 | = 66 | (* every second, bother the other end and see whether they have anything to 67 | say back to us *) 68 | let dest = server_ip in 69 | let src = List.hd (IPV4.get_ip client_ip) in 70 | Log.warn "DEMO: trying connection from %s to %s on port %d" 71 | (Ipaddr.V4.to_string src) (Ipaddr.V4.to_string dest) echo_port; 72 | TCP.create_connection client_tcp (dest, echo_port) >>= function 73 | | `Error _ -> Lwt.fail (failwith "couldn't establish connection between client and server") 74 | | `Ok flow -> 75 | let rec pester flow = 76 | let important_content = Cstruct.of_string "hi I love you I missed you" in 77 | TCP.write flow important_content >>= ignore_errors c 78 | ( 79 | Log.warn "%s -> %s: %s" (strip src) (strip dest) (Cstruct.to_string 80 | important_content); 81 | fun () -> TCP.read flow >>= ignore_errors c (fun buf -> 82 | Log.warn "%s -> %s: %s" (strip dest) (strip src) (Cstruct.to_string buf); 83 | Lwt.return_unit ) 84 | ) >>= fun () -> 85 | OS.Time.sleep pester_interval >>= fun () -> pester flow 86 | in 87 | Log.warn "DEMO: connection established between %s and %s!" (strip src) 88 | (strip dest); 89 | pester flow 90 | 91 | let crosstalk ((_, _, _, left_ip, _), 92 | (_, _, _, right_ip, _)) : unit Lwt.t = 93 | let rec gossip dst = 94 | let (frame, len) = IPV4.allocate_frame left_ip ~dst ~proto:`UDP in 95 | (* this is a broken packet -- no udp header *) 96 | let app_data = (Cstruct.shift frame len) in 97 | let secrets = "CONFIDENTIAL GOSSIP" in 98 | Cstruct.blit_from_string secrets 0 app_data 0 (String.length secrets); 99 | IPV4.write left_ip frame app_data >>= fun () -> 100 | Log.warn "%s -> %s: %s" (strip (List.hd (IPV4.get_ip left_ip))) (strip dst) 101 | secrets; 102 | OS.Time.sleep crosstalk_interval >>= fun () -> gossip dst 103 | in 104 | let dst = List.hd (IPV4.get_ip right_ip) in 105 | gossip dst 106 | 107 | let start console netif clock random = 108 | let client_ip = Ipaddr.V4.of_string_exn "192.168.3.10" in 109 | let server_ip = Ipaddr.V4.of_string_exn "192.168.3.2" in 110 | let name_repo ip = Printf.sprintf "client_%s" (Ipaddr.V4.to_string ip) in 111 | let start_tcp (n, e, a, ip) = 112 | TCP.connect ip >>= function 113 | | `Ok tcp -> Lwt.return (n, e, a, ip, tcp) 114 | | `Error _ -> Lwt.fail (failwith "error connecting TCP") 115 | in 116 | get_arp ~netif ~root ~node:(name_repo client_ip) () >>= 117 | start_ip client_ip >>= start_tcp >>= spawn_listeners >>= 118 | converse console server_ip >>= fun () -> 119 | Lwt.return_unit 120 | 121 | end 122 | -------------------------------------------------------------------------------- /oscon-demo/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let stack = generic_stackv4 default_network 4 | (* set ~tls to false to get a plain-http server *) 5 | let https_srv = http_server @@ conduit_direct ~tls:false stack 6 | 7 | let http_port = 8 | let doc = Key.Arg.info ~doc:"Listening HTTP port." ["port"] in 9 | Key.(create "http_port" Arg.(opt int 80 doc)) 10 | 11 | let main = 12 | let packages = [ 13 | package ~min:"0.4.1" "webmachine"; 14 | ] in 15 | let keys = [ Key.abstract http_port ] in 16 | foreign 17 | ~packages ~keys 18 | "Unikernel.App" (pclock @-> http @-> job) 19 | 20 | let () = 21 | register "app" [main $ default_posix_clock $ https_srv] 22 | -------------------------------------------------------------------------------- /oscon-demo/css.ml: -------------------------------------------------------------------------------- 1 | let crawl_style = 2 | "body { 3 | width: 100%; 4 | height: 100%; 5 | background: #000; 6 | overflow: hidden; 7 | } 8 | 9 | .fade { 10 | position: relative; 11 | width: 100%; 12 | min-height: 60vh; 13 | top: -25px; 14 | background-image: linear-gradient(0deg, transparent, black 75%); 15 | z-index: 1; 16 | } 17 | 18 | .star-wars { 19 | display: flex; 20 | justify-content: center; 21 | position: relative; 22 | height: 800px; 23 | color: #feda4a; 24 | font-family: 'Pathway Gothic One', sans-serif; 25 | font-size: 500%; 26 | font-weight: 600; 27 | letter-spacing: 6px; 28 | line-height: 150%; 29 | perspective: 400px; 30 | text-align: justify; 31 | } 32 | 33 | .crawl { 34 | position: relative; 35 | top: 99999px; 36 | transform-origin: 50% 100%; 37 | animation: crawl 30s linear; 38 | } 39 | 40 | .crawl > .title { 41 | font-size: 90%; 42 | text-align: center; 43 | } 44 | 45 | .crawl > .title h1 { 46 | margin: 0 0 100px; 47 | text-transform: uppercase; 48 | } 49 | 50 | @keyframes crawl { 51 | 0% { 52 | top: -100px; 53 | transform: rotateX(20deg) translateZ(0); 54 | } 55 | 100% { 56 | top: -6000px; 57 | transform: rotateX(25deg) translateZ(-2500px); 58 | } 59 | }" 60 | -------------------------------------------------------------------------------- /oscon-demo/names.ml: -------------------------------------------------------------------------------- 1 | let solo5 = [ 2 | "djwillia"; 3 | "mato"; 4 | "hannesm"; 5 | "ijc25"; 6 | "myechuri"; 7 | "waldyrious"; 8 | "avsm"; 9 | "sgrove"; 10 | "pqwy"; 11 | ] 12 | 13 | let packaging = [ 14 | "hannesm"; 15 | "drup"; 16 | "sgrove"; 17 | "mor1"; 18 | "yomimono"; 19 | "talex5"; 20 | "avsm"; 21 | "djs55"; 22 | "vbmithr"; 23 | "samoht"; 24 | ] 25 | 26 | let docs = [ 27 | "dbuenzli"; 28 | "avsm"; 29 | "samoht"; 30 | "talex5"; 31 | "yomimono"; 32 | "ryanrhymes"; 33 | "hannesm"; 34 | "dsheets"; 35 | "altgr"; 36 | ] 37 | 38 | let results = [ 39 | "hannesm"; 40 | "samoht"; 41 | "talex5"; 42 | "yomimono"; 43 | "agarwal"; 44 | "lpw25"; 45 | "avsm"; 46 | "djs55"; 47 | "dbuenzli"; 48 | ] 49 | 50 | let logs = [ 51 | "hannesm"; 52 | "verbosemode"; 53 | "drup"; 54 | "leonidas-from-xiv"; 55 | "wiredsister"; 56 | "dbuenzli"; 57 | "avsm"; 58 | "talex5"; 59 | ] 60 | 61 | let disaggregated_module_types = [ 62 | "hannesm"; 63 | "samoht"; 64 | "yomimono"; 65 | "avsm"; 66 | "djs55"; 67 | ] 68 | 69 | let clocks_and_time = [ 70 | "mattgray"; 71 | "dbuenzli"; 72 | "hannesm"; 73 | "matildah"; 74 | "yomimono"; 75 | "buzzheavyyear"; 76 | "samoht"; 77 | "talex5"; 78 | "dsheets"; 79 | "mor1"; 80 | "avsm"; 81 | ] 82 | 83 | let topkg = [ 84 | "dbuenzli"; 85 | "hannesm"; 86 | "fgimenez"; 87 | "pqwy"; 88 | "verbosemode"; 89 | "samoht"; 90 | "rleonid"; 91 | "avsm"; 92 | "yomimono"; 93 | "djs55"; 94 | ] 95 | 96 | let contributors = [ 97 | "Aaron Cornelius"; 98 | "Amir Chaudhry"; 99 | "Andrew Stuart"; 100 | "Anil Madhavapeddy"; 101 | "Ashish Agarwal"; 102 | "Balraj Singh"; 103 | "Cedric Cellier"; 104 | "Christiano Haesbaert"; 105 | "Daniel Buenzli"; 106 | "Dan Williams"; 107 | "Dave Scott"; 108 | "David Kaloper"; 109 | "David Sheets"; 110 | "Enguerrand Decorne"; 111 | "Eugene Bagdasaryan"; 112 | "Federico Gimenez"; 113 | "Gabriel de Perthuis"; 114 | "Gabriel Jaldon"; 115 | "Gabriel Radanne"; 116 | "Gemma Gordon"; 117 | "Gina Maini"; 118 | "Hannes Mehnert"; 119 | "Ian Campbell"; 120 | "John P. McDermott"; 121 | "Jon Ludlam"; 122 | "Kia"; 123 | "Leo White"; 124 | "Liang Wang"; 125 | "Madhuri Yechuri"; 126 | "Magnus Skjegstad"; 127 | "Martin Lucina"; 128 | "Matt Gray"; 129 | "Mindy Preston"; 130 | "Nick Betteridge"; 131 | "Nicolas Ojeda Bar"; 132 | "Nik Sultana"; 133 | "Pablo Polvorin"; 134 | "Petter A. Urkedal"; 135 | "Qi LI"; 136 | "Ramana Venkata"; 137 | "Ricardo Koller"; 138 | "Richard Mortier"; 139 | "Rudi Grinberg"; 140 | "Sean Grove"; 141 | "Takayuki Imada"; 142 | "Thomas Gazagnaire"; 143 | "Thomas Leonard"; 144 | "Vincent Bernardoff"; 145 | "Vittorio Cozzolino"; 146 | "Wassim Haddad"; 147 | "Jeremy Yallop"; 148 | ] 149 | -------------------------------------------------------------------------------- /oscon-demo/unikernel.ml: -------------------------------------------------------------------------------- 1 | module App (Clock : Mirage_clock.PCLOCK) 2 | (Server : Cohttp_lwt.Server) = struct 3 | 4 | open Lwt.Infix 5 | 6 | let app_log_src = Logs.Src.create "credits" ~doc:"roll credits!" 7 | module App_log = (val Logs.src_log app_log_src : Logs.LOG) 8 | 9 | (* Apply the [Webmachine.Make] functor to the Lwt_unix-based IO module 10 | * exported by cohttp. For added convenience, include the [Rd] module 11 | * as well so you don't have to go reaching into multiple modules to 12 | * access request-related information. *) 13 | module Wm = struct 14 | module Rd = Webmachine.Rd 15 | include Webmachine.Make(Server.IO) 16 | end 17 | 18 | (* Create a new class that inherits from [Wm.resource] and provides 19 | * implementations for its two virtual methods, and overrides some of 20 | * its default methods. 21 | *) 22 | class credits = object(self) 23 | inherit [Cohttp_lwt_body.t] Wm.resource 24 | 25 | (* Only allow GET requests to this resource *) 26 | method allowed_methods rd = 27 | Wm.continue [`POST; `GET] rd 28 | 29 | (* Setup the resource to handle multiple content-types. Webmachine will 30 | * perform content negotiation as described in RFC 7231: 31 | * 32 | * https://tools.ietf.org/html/rfc7231#section-5.3.2 33 | * 34 | * Content negotiation can be a complex process. However for simple Accept 35 | * headers its fairly straightforward. Here's what content negotiation will 36 | * produce in some of these simple cases: 37 | * 38 | * Accept | Called method 39 | * ---------------------+---------------- 40 | * "text/plain" | self#to_text 41 | * "text/html" | self#to_html 42 | * "text/*" | self#to_html 43 | * "application/json" | self#to_json 44 | * "application/*" | self#to_json 45 | * "*/*" | self#to_html 46 | *) 47 | method content_types_provided rd = 48 | Wm.continue [ 49 | ("text/html" , self#to_html); 50 | ("text/plain" , self#to_text); 51 | ] rd 52 | 53 | (* Since only GET requests are allowed, there's no need to provide handlers 54 | * for requests containing certain content types. This method will never be 55 | * called, but it's necessary to provide an implementation since it's 56 | * [virtual] in the [Wm.resource] virtual class. *) 57 | method content_types_accepted rd = 58 | Wm.continue [] rd 59 | 60 | method process_post rd = 61 | Cohttp_lwt_body.to_string rd.Wm.Rd.req_body >>= fun _body -> 62 | let rd = Wm.Rd.redirect "/" rd in 63 | Wm.continue true rd 64 | 65 | (* A helper method that returns what to say hello to. If a path wildcard 66 | * called ["what"] was introduced by a route, it will use whatever string in 67 | * that position. Otherwise, it defaults to the string ["world"]. *) 68 | method private what rd = 69 | try 70 | let name = Wm.Rd.lookup_path_info_exn "what" rd in 71 | let l = 72 | match name with 73 | | "solo5" -> Names.solo5 74 | | "packaging" -> Names.packaging 75 | | "docs" -> Names.docs 76 | | "results" -> Names.results 77 | | "logs" -> Names.logs 78 | | "disaggregated_module_types" | "module" | "module_types" 79 | -> Names.disaggregated_module_types 80 | | "clocks_and_time" | "clocks" | "time" -> Names.clocks_and_time 81 | | "topkg" -> Names.topkg 82 | in 83 | (name, l) 84 | with Match_failure _ | Not_found -> ("MirageOS 3", Names.contributors) 85 | 86 | (* Returns an html-based representation of the resource *) 87 | method private to_html rd = 88 | App_log.debug (fun f -> f "generating response with %s\n%!" 89 | @@ fst (self#what rd)); 90 | let body = 91 | let header, people = self#what rd in 92 | let li fmt = Format.fprintf fmt "
  • %s
    • " in 93 | Format.asprintf 94 | " 95 | 96 |
    97 |
    98 |
    99 |
    100 |

    heartfelt thanks to these folks who worked on %s

    101 |
    102 | 103 |
    104 | \n" 105 | Css.crawl_style 106 | header Fmt.(list li) people 107 | in 108 | Wm.continue (`String body) rd 109 | 110 | (* Returns a plaintext representation of the resource *) 111 | method private to_text rd = 112 | let name, people = self#what rd in 113 | let text = Format.asprintf "%s: %a!" name Fmt.(list string) people in 114 | Wm.continue (`String text) rd 115 | 116 | end 117 | 118 | let start _clock http = 119 | (* Listen on port 8080 *) 120 | let port = Key_gen.http_port () in 121 | (* The route table. Both routes use the [hello] resource defined above. 122 | * However, the second one contains the [:what] wildcard in the path. The 123 | * value of that wildcard can be accessed in the resource by calling 124 | * 125 | * [Wm.Rd.lookup_path_info "what" rd] 126 | *) 127 | let routes = [ 128 | ("/" , fun () -> new credits); 129 | ("/:what" , fun () -> new credits); 130 | ] in 131 | let callback (_ch,_conn) request body = 132 | let open Cohttp in 133 | (* Perform route dispatch. If [None] is returned, then the URI path did not 134 | * match any of the route patterns. In this case the server should return a 135 | * 404 [`Not_found]. *) 136 | Wm.dispatch' routes ~body ~request 137 | >|= begin function 138 | | None -> (`Not_found, Header.init (), `String "Not found", []) 139 | | Some result -> result 140 | end 141 | >>= fun (status, headers, body, path) -> 142 | App_log.debug (fun f -> f "%d - %s %s (path: %s)" 143 | (Code.code_of_status status) 144 | (Code.string_of_method (Request.meth request)) 145 | (Uri.path (Request.uri request)) 146 | (String.concat ", " path)); 147 | (* Finally, send the response to the client *) 148 | Server.respond ~headers ~body ~status () 149 | in 150 | (* Create the server and handle requests with the function defined above. Try 151 | * it out with some of these curl commands: 152 | * 153 | * [curl -H"Accept:text/html" "http://localhost:8080"] 154 | * [curl -H"Accept:text/plain" "http://localhost:8080"] 155 | * [curl -H"Accept:application/json" "http://localhost:8080"] 156 | *) 157 | let conn_closed (_ch,conn) = 158 | App_log.debug (fun f -> f "connection %s closed\n%!" 159 | @@ Cohttp.Connection.to_string conn) 160 | in 161 | let config = Server.make ~callback ~conn_closed () in 162 | (* Server.create ~mode:(`TCP(`Port port)) config >|= fun () -> 163 | Printf.eprintf "hello_lwt: listening on 0.0.0.0:%d%!" port *) 164 | let mode = `TCP port in 165 | http mode config 166 | 167 | end 168 | -------------------------------------------------------------------------------- /qubes-dhcpd/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = foreign "Unikernel.Main" (console @-> kv_ro @-> network @-> clock @-> job) 4 | 5 | let disk = crunch "files" 6 | 7 | let () = 8 | add_to_ocamlfind_libraries ([ "charrua-core.server"; "tcpip.ipv4"; 9 | "charrua-core.wire"; "tcpip.udp"; 10 | "tcpip"; "tcpip.ethif"; "tcpip.arpv4"; "str"]); 11 | add_to_opam_packages ["charrua-core"; "tcpip"]; 12 | register "dhcp" [ 13 | main $ default_console $ disk $ tap0 $ default_clock 14 | ] 15 | -------------------------------------------------------------------------------- /qubes-dhcpd/unikernel.ml: -------------------------------------------------------------------------------- 1 | open V1_LWT 2 | open Lwt.Infix 3 | 4 | (* IP Configuration, all you need besides dhcpd.conf. *) 5 | let ipaddr = Ipaddr.V4.of_string_exn "192.168.1.5" 6 | 7 | 8 | let red fmt = Printf.sprintf ("\027[31m"^^fmt^^"\027[m") 9 | let green fmt = Printf.sprintf ("\027[32m"^^fmt^^"\027[m") 10 | let yellow fmt = Printf.sprintf ("\027[33m"^^fmt^^"\027[m") 11 | let blue fmt = Printf.sprintf ("\027[36m"^^fmt^^"\027[m") 12 | 13 | let string_of_stream s = 14 | let s = List.map Cstruct.to_string s in 15 | (String.concat "" s) 16 | 17 | module Main (C: CONSOLE) (KV: KV_RO) (N: NETWORK) (Clock : V1.CLOCK) = struct 18 | module E = Ethif.Make(N) 19 | module A = Arpv4.Make(E)(Clock)(OS.Time) 20 | 21 | let log c s = 22 | Str.split_delim (Str.regexp "\n") s |> 23 | List.iter (fun line -> C.log c line) 24 | 25 | let of_interest dest net = 26 | Macaddr.compare dest (N.mac net) = 0 || not (Macaddr.is_unicast dest) 27 | 28 | let input_dhcp c net config leases buf = 29 | let open Dhcp_server.Input in 30 | match (Dhcp_wire.pkt_of_buf buf (Cstruct.len buf)) with 31 | | Error e -> log c (red "Can't parse packet: %s" e); 32 | Lwt.return leases 33 | | Ok pkt -> 34 | match (input_pkt config leases pkt (Clock.time ())) with 35 | | Silence -> Lwt.return leases 36 | | Update leases -> 37 | log c (blue "Received packet %s - updated lease database" (Dhcp_wire.pkt_to_string pkt)); 38 | Lwt.return leases 39 | | Warning w -> 40 | log c (yellow "%s" w); 41 | Lwt.return leases 42 | | Error e -> 43 | log c (red "%s" e); 44 | Lwt.return leases 45 | | Reply (reply, leases) -> 46 | log c (blue "Received packet %s" (Dhcp_wire.pkt_to_string pkt)); 47 | N.write net (Dhcp_wire.buf_of_pkt reply) 48 | >>= fun () -> 49 | log c (blue "Sent reply packet %s" (Dhcp_wire.pkt_to_string reply)); 50 | Lwt.return leases 51 | 52 | let start c kv net _ = 53 | let or_error _c name fn t = 54 | fn t >>= function 55 | | `Error _e -> Lwt.fail (Failure ("Error starting " ^ name)) 56 | | `Ok t -> Lwt.return t 57 | in 58 | (* Read the config file *) 59 | or_error c "Kv.size" (KV.size kv) "dhcpd.conf" 60 | >>= fun size -> 61 | or_error c "Kv.read" (KV.read kv "dhcpd.conf" 0) (Int64.to_int size) 62 | >>= fun v -> Lwt.return (string_of_stream v) 63 | >>= fun conf -> 64 | log c (green "Using configuration:"); 65 | log c (green "%s" conf); 66 | 67 | (* Get an ARP stack *) 68 | or_error c "Ethif" E.connect net 69 | >>= fun e -> 70 | or_error c "Arpv4" A.connect e 71 | >>= fun a -> 72 | A.add_ip a ipaddr 73 | >>= fun () -> 74 | 75 | (* Build a dhcp server *) 76 | let config = Dhcp_server.Config.parse conf (ipaddr, N.mac net) in 77 | let leases = ref (Dhcp_server.Lease.make_db ()) in 78 | let listener = N.listen net (fun buf -> 79 | match Ethif_packet.Unmarshal.of_cstruct buf with 80 | | Result.Error s -> 81 | C.log c "unparseable packet; dropping it"; 82 | Lwt.return_unit 83 | | Result.Ok (ethif_header, ethif_payload) -> 84 | if of_interest ethif_header.destination net && 85 | Dhcp_wire.is_dhcp buf (Cstruct.len buf) then begin 86 | input_dhcp c net config !leases buf >>= fun new_leases -> 87 | leases := new_leases; 88 | Lwt.return_unit 89 | end else if ethif_header.ethertype = Ethif_wire.ARP then 90 | A.input a ethif_payload 91 | else Lwt.return_unit 92 | ) in 93 | listener 94 | end 95 | -------------------------------------------------------------------------------- /read_pcap/README.md: -------------------------------------------------------------------------------- 1 | ## Dependencies 2 | 3 | This unikernel depends on [mirage-net-pcap](https://github.com/yomimono/mirage-net-pcap). To install it: 4 | 5 | ``` 6 | opam pin add mirage-net-pcap https://github.com/yomimono/mirage-net-pcap.git 7 | ``` 8 | 9 | ## Building 10 | 11 | Build with: 12 | 13 | ``` 14 | mirage configure --unix 15 | make 16 | ``` 17 | 18 | ## Running 19 | 20 | Have a [pcap](http://www.tcpdump.org) file handy. `mir-read_pcap` takes an optional argument of which pcap file to read; if none is specified, it will look for a file called "packets.pcap" in your current working directory. 21 | 22 | ``` 23 | ./mir-read_pcap -f packets.pcap 24 | ``` 25 | -------------------------------------------------------------------------------- /read_pcap/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let file_key = 4 | let doc = Key.Arg.info 5 | ~doc:"The file to read for pcaps." [ "f" ; "file" ] 6 | in 7 | Key.(create "file" Arg.(opt ~stage:`Both string "packets.pcap" doc)) 8 | 9 | let main = 10 | let libraries = [ 11 | "mirage-net-pcap"; "pcap-format"; ] in 12 | let packages = ["mirage-net-pcap" ] in 13 | foreign 14 | ~libraries ~packages ~keys:[Key.abstract file_key] 15 | "Unikernel.Main" (console @-> kv_ro @-> time @-> job) 16 | 17 | let () = 18 | let disk1 = direct_kv_ro "." in 19 | register "read_pcap" [ 20 | main $ default_console $ disk1 $ default_time 21 | ] 22 | -------------------------------------------------------------------------------- /read_pcap/unikernel.ml: -------------------------------------------------------------------------------- 1 | open V1_LWT 2 | open Lwt.Infix 3 | 4 | module Main (C: CONSOLE) (FS: KV_RO) (Time: TIME) = struct 5 | 6 | module P = Netif.Make(FS)(Time) 7 | 8 | let start c fs _ = 9 | let pcap_init_error ~fs ~read = 10 | let pcap_netif_id = P.id_of_desc ~mac:Macaddr.broadcast ~source:fs 11 | ~timing:None ~read in 12 | P.connect pcap_netif_id >>= function 13 | | `Error e -> C.log c "Failed to initialize from given pcap file"; 14 | Lwt.return None 15 | | `Ok p -> Lwt.return (Some p) 16 | in 17 | 18 | pcap_init_error ~fs ~read:(Key_gen.file ()) >>= function 19 | | None -> Lwt.return_unit (* exit cleanly for invalid pcap *) 20 | | Some net -> P.listen net ( fun _ -> Lwt.return_unit) 21 | end 22 | -------------------------------------------------------------------------------- /test-multiple-outbound/ask_thing.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open V1_LWT 3 | open OS 4 | 5 | module Client (C: V1_LWT.CONSOLE) (CLIENT_STACK: V1_LWT.STACKV4) = struct 6 | let remote_server="54.69.202.59" 7 | let port = 22 8 | 9 | let start c client_stack = 10 | let construct_request () = 11 | let buf = Io_page.(to_cstruct (get 1)) in 12 | let output = (Printf.sprintf "GET / HTTP/1.1\r\n\r\n") in 13 | Cstruct.blit_from_string output 0 buf 0 (String.length output); 14 | Cstruct.set_len buf (String.length output) 15 | in 16 | 17 | let rec make_connection c s = 18 | let my_tcpv4 = (CLIENT_STACK.tcpv4 s) in 19 | let webserver = remote_server in 20 | CLIENT_STACK.TCPV4.create_connection my_tcpv4 ((Ipaddr.V4.of_string_exn webserver), 21 | port) >>= 22 | fun conn -> ( 23 | C.log c "connection created\n"; 24 | match conn with 25 | | `Ok (outbound : CLIENT_STACK.TCPV4.flow) -> 26 | C.log c "writing to conn\n"; 27 | let request = construct_request () in 28 | (* send bogus request *) 29 | CLIENT_STACK.TCPV4.write outbound request >> 30 | CLIENT_STACK.TCPV4.close outbound 31 | | p -> 32 | (* continue retrying until successful or heat death of universe *) 33 | C.log c (Printf.sprintf "Couldn't initiate connection to %s:%d ; 34 | retrying\n" webserver port); 35 | make_connection c s 36 | ) 37 | in 38 | 39 | C.log c "client about to go"; 40 | (make_connection c client_stack) 41 | end 42 | -------------------------------------------------------------------------------- /test-multiple-outbound/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | (* foreign string (functor type) -> functor implementation (?)) *) 4 | (* 5 | utop # let main = foreign "Ask_thing.Main" (console @-> stackv4 @-> job);; 6 | val main : (console -> stackv4 -> job) impl = 7 | *) 8 | 9 | let main = foreign "Ask_thing.Client" (console @-> stackv4 @-> job) 10 | 11 | 12 | (* that (console -> stackv4 -> job) impl is what we need to call `register` with 13 | * later. *) 14 | 15 | (* default_console is defined in Mirage *) 16 | (* not sure why anyone knows what the hell a tap0 is *) 17 | (* huh, also in Mirage. is there a tap1, tap2, etc? Nope. *) 18 | (* can get our own with val netif: string -> network impl *) 19 | 20 | let primary_netif = (netif "0") 21 | let secondary_netif = (netif "1") (*netif actually needs an integer, shoved 22 | into a string, which maps to a device ID number assigned by Xen, to do anything 23 | helpful when xen is the target. Stuff that can't be turned into an int 24 | is silently dropped in that case and we just get the first Xen network iface. *) 25 | 26 | let primary_stack = direct_stackv4_with_dhcp default_console primary_netif 27 | let secondary_stack = direct_stackv4_with_dhcp default_console secondary_netif 28 | 29 | (* primary_stack and secondary_stack are stackv4 impl 's. Surely we can write a 30 | * stackv4 impl -> stackv4 impl that implements a mutating fuzzer, right? *) 31 | 32 | let () = 33 | (* register : string -> job impl list -> unit *) 34 | (* What actually happens if you have multiple items 35 | * in this list? *) 36 | (* they all get `join`'d and run in parallel. *) 37 | register "ask_thing" (*mirage uses this string for naming*) [ 38 | main $ default_console $ primary_stack; 39 | main $ default_console $ secondary_stack; 40 | ] 41 | --------------------------------------------------------------------------------