├── .gitignore ├── .travis.yml ├── GNUmakefile ├── README.md ├── certificate ├── config.ml └── unikernel.ml ├── client ├── config.ml └── unikernel.ml ├── fw-rules-reader ├── config.ml └── unikernel.ml ├── primary-with-zone ├── config.ml ├── data │ └── zone └── unikernel.ml ├── primary ├── config.ml └── unikernel.ml ├── resolver-no-stack ├── config.ml └── unikernel.ml ├── resolver ├── config.ml └── unikernel.ml ├── stub-resolver ├── config.ml └── unikernel.ml └── unikernels.opam /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile.config 2 | .mirage.config 3 | */Makefile 4 | Makefile.solo5-hvt 5 | _build-solo5-hvt/ 6 | _build/ 7 | *.hvt 8 | key_gen.ml 9 | main.ml 10 | .merlin 11 | dune.config 12 | dune.build 13 | dune 14 | dune-project 15 | mirage-unikernel-*.opam 16 | *install 17 | myocamlbuild.ml 18 | solo5-hvt 19 | secondary_git 20 | certificate 21 | client 22 | letsencrypt 23 | primary-git 24 | primary 25 | resolver 26 | secondary 27 | tlstunnel 28 | 29 | *pcap 30 | *out 31 | *key 32 | *private 33 | *native 34 | static*ml* 35 | info_gen.ml* 36 | 37 | *req 38 | *pem 39 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | sudo: false 7 | env: 8 | global: 9 | - PACKAGE="unikernels" 10 | - TESTS=false 11 | - DISTRO=alpine 12 | matrix: 13 | - OCAML_VERSION=4.10 POST_INSTALL_HOOK="make ci MODE=unix" 14 | - OCAML_VERSION=4.10 POST_INSTALL_HOOK="make ci MODE=spt" 15 | - OCAML_VERSION=4.09 POST_INSTALL_HOOK="make ci MODE=hvt" 16 | - OCAML_VERSION=4.09 POST_INSTALL_HOOK="make ci MODE=xen" 17 | - OCAML_VERSION=4.08 POST_INSTALL_HOOK="make ci MODE=virtio" 18 | - OCAML_VERSION=4.08 POST_INSTALL_HOOK="make ci MODE=qubes" 19 | -------------------------------------------------------------------------------- /GNUmakefile: -------------------------------------------------------------------------------- 1 | -include Makefile.config 2 | 3 | UNIKERNELS = \ 4 | primary \ 5 | primary-with-zone \ 6 | resolver \ 7 | stub-resolver \ 8 | certificate \ 9 | client 10 | 11 | MODE ?= "unix" 12 | 13 | BUILD = $(patsubst %, %-build, $(UNIKERNELS)) 14 | CI = $(patsubst %, %-ci, $(UNIKERNELS)) 15 | CLEAN = $(patsubst %, %-clean, $(UNIKERNELS)) 16 | 17 | build: $(BUILD) 18 | ci: $(CI) 19 | clean: $(CLEAN) 20 | 21 | %-build: 22 | cd $* && \ 23 | mirage configure -t $(MODE) $(MIRAGE_FLAGS) && \ 24 | $(MAKE) 25 | 26 | %-ci: 27 | cd $* && \ 28 | mirage configure -t $(MODE) $(MIRAGE_FLAGS) && \ 29 | make depend && \ 30 | $(MAKE) 31 | 32 | %-clean: 33 | -cd $* && mirage clean 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Unikernels 2 | 3 | [![Build Status](https://travis-ci.org/roburio/unikernels.svg?branch=master)](https://travis-ci.org/roburio/unikernels) 4 | 5 | A MirageOS unikernel repository 6 | 7 | All source code in this repository was developed from scratch by the specific authors. This code is put in the public domain. 8 | 9 | If you want to use them in a corporate environment, and avoid any legal issues, you can buy a license, please contact https://robur.io 10 | 11 | ## Installation 12 | 13 | ### Dependencies 14 | 15 | Follow the [MirageOS installation instructions](https://mirage.io/wiki/install) 16 | unless you already have OCaml (at least 4.08.0), opam (at least 2.0.0), and the 17 | `mirage` command line utility (at least 3.7.7 from May 2020) installed. 18 | 19 | In any of the subdirectories, run `mirage configure` (see `mirage help 20 | configure` for options), followed by `make depend` and `make` (read more 21 | information [Hello MirageOS world](https://mirage.io/wiki/hello-world)). 22 | 23 | Depending on the target, the name and type of the resulting binary varies. In 24 | the default target, `unix`, its name is `./main.native`, and which may require 25 | superuser privileges to listen on privileged ports 26 | (use `doas (or sudo) ./main.native -l \*:debug`). 27 | 28 | If you want to compile for Linux KVM, FreeBSD BHyve, OpenBSD VMM (by using 29 | [solo5](https://github.com/solo5/solo5)), run `mirage configure -t hvt` (or 30 | `-t virtio` for Google Compute Engine). 31 | 32 | All unikernels use the default stack implementation, and thus will listen on 33 | 10.0.0.2/24, their gateway being 10.0.0.1. 34 | 35 | ## Primary authoritative nameservers 36 | 37 | The [`primary`](primary/) subdirectory contains an unikernel with the hardcoded 38 | zone (in its [unikernel.ml](primary/unikernel.ml)) named `mirage` and some 39 | resource records. It also configures several TSIG keys, one for the secondary, 40 | one for update operations and another one for transfer operations. 41 | 42 | The [`primary-with-zone`](primary-with-zone/) contains no hardcoded 43 | configuration, but serves [`data/zone`](primary-with-zone/data/zone) instead. 44 | 45 | ## Let's encrypt certification unikernel 46 | 47 | The [`certificate`](certificate/) subdirectory contains an unikernel which 48 | receives a key seed, and looks in DNS for a let's encrypt certificate. If none 49 | is found, a certificate signing request (`TLSA` record, type private (255)) is 50 | put into DNS, and DNS is polled until a certificate occurs. 51 | 52 | ## Caching resolvers 53 | 54 | The [`resolver`](resolver/) subdirectory contains an iterative resolver. 55 | 56 | The [`stub-resolver`](stub-resolver/) subdirectory contains a stub resolver, 57 | which forwards all requests to `141.1.1.1`. 58 | 59 | -------------------------------------------------------------------------------- /certificate/config.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Mirage 4 | 5 | let port = 6 | let doc = Key.Arg.info ~doc:"The TCP port on which to listen for incoming connections." ["port"] in 7 | Key.(create "port" Arg.(opt int 443 doc)) 8 | 9 | let dns_key = 10 | let doc = Key.Arg.info ~doc:"nsupdate key (name:type:value,...)" ["dns-key"] in 11 | Key.(create "dns-key" Arg.(required string doc)) 12 | 13 | let dns_server = 14 | let doc = Key.Arg.info ~doc:"dns server IP" ["dns-server"] in 15 | Key.(create "dns-server" Arg.(required ipv4_address doc)) 16 | 17 | let dns_port = 18 | let doc = Key.Arg.info ~doc:"dns server port" ["dns-port"] in 19 | Key.(create "dns-port" Arg.(opt int 53 doc)) 20 | 21 | let hostname = 22 | let doc = Key.Arg.info ~doc:"hostname" ["hostname"] in 23 | Key.(create "hostname" Arg.(required string doc)) 24 | 25 | let additional = 26 | let doc = Key.Arg.info ~doc:"additional" ["additional"] in 27 | Key.(create "additional" Arg.(opt string "" doc)) 28 | 29 | let key_seed = 30 | let doc = Key.Arg.info ~doc:"private key seed" ["key-seed"] in 31 | Key.(create "key-seed" Arg.(opt (some string) None doc)) 32 | 33 | let keys = Key.[ 34 | abstract port ; abstract dns_key ; abstract dns_server ; abstract dns_port ; 35 | abstract hostname ; abstract additional ; abstract key_seed 36 | ] 37 | 38 | let packages = 39 | [ 40 | package "x509" ; 41 | package "duration" ; 42 | package "randomconv" ; 43 | package "logs" ; 44 | package ~sublibs:[ "mirage" ] "dns-certify"; 45 | package "tls-mirage" ; 46 | ] 47 | 48 | let main = 49 | foreign ~keys ~packages "Unikernel.Main" 50 | (random @-> pclock @-> mclock @-> time @-> stackv4 @-> job) 51 | 52 | let () = 53 | register "certificate" [ 54 | main $ default_random $ default_posix_clock $ default_monotonic_clock $ default_time $ generic_stackv4 default_network 55 | ] 56 | -------------------------------------------------------------------------------- /certificate/unikernel.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | open Lwt.Infix 3 | 4 | module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MCLOCK) (T : Mirage_time.S) (S: Mirage_stack.V4) = struct 5 | module D = Dns_certify_mirage.Make(R)(P)(T)(S) 6 | module TLS = Tls_mirage.Make(S.TCPV4) 7 | 8 | let rec handle flow = 9 | TLS.read flow >>= function 10 | | Ok `Eof -> 11 | Logs.info (fun f -> f "Closing connection!") ; 12 | TLS.close flow 13 | | Error e -> 14 | Logs.warn (fun f -> f "Error reading data from established connection: %a" TLS.pp_error e) ; 15 | TLS.close flow 16 | | Ok (`Data data) -> 17 | Logs.debug (fun f -> f "read: %d bytes:\n%s" (Cstruct.len data) (Cstruct.to_string data)); 18 | TLS.write flow data >>= function 19 | | Ok () -> handle flow 20 | | Error e -> 21 | Logs.warn (fun m -> m "error %a while echoing" TLS.pp_write_error e) ; 22 | TLS.close flow 23 | 24 | let accept conf handle flow = 25 | let dst, dst_port = S.TCPV4.dst flow in 26 | Logs.info (fun f -> f "new tls connection from IP %s on port %d" 27 | (Ipaddr.V4.to_string dst) dst_port); 28 | TLS.server_of_flow conf flow >>= function 29 | | Ok tls -> 30 | (match TLS.epoch tls with 31 | | Ok e -> 32 | Logs.info (fun m -> m "established TLS %a %a,%a,extended_ms=%b" 33 | Sexplib.Sexp.pp_hum (Tls.Core.sexp_of_tls_version e.Tls.Core.protocol_version) 34 | Sexplib.Sexp.pp_hum (Tls.Ciphersuite.sexp_of_ciphersuite e.Tls.Core.ciphersuite) 35 | Fmt.(option ~none:(unit "no SNI") string) e.Tls.Core.own_name 36 | e.Tls.Core.extended_ms) 37 | | Error () -> 38 | Logs.warn (fun m -> m "error while retrieving TLS epoch")) ; 39 | handle tls 40 | | Error e -> 41 | Logs.err (fun m -> m "TLS handshake error %a" TLS.pp_write_error e) ; 42 | Lwt.return_unit 43 | 44 | (* TODO: move to TLS *) 45 | let log_certchain (chain, priv) = 46 | let certs = 47 | String.concat "\n" (List.map (fun c -> 48 | Cstruct.to_string (X509.Certificate.encode_pem c)) 49 | chain) 50 | and key = 51 | Cstruct.to_string (X509.Private_key.encode_pem (`RSA priv)) 52 | in 53 | Logs.app (fun m -> m "certificate chain:@.%s" certs); 54 | Logs.app (fun m -> m "private key:@.%s" key) 55 | 56 | let start _random _pclock _mclock _ stack = 57 | let hostname = Domain_name.(host_exn (of_string_exn (Key_gen.hostname ()))) in 58 | let additional_hostnames = 59 | List.map (fun n -> Domain_name.(host_exn (of_string_exn n))) 60 | (Astring.String.cuts ~empty:false ~sep:"," (Key_gen.additional ())) 61 | in 62 | D.retrieve_certificate stack ~dns_key:(Key_gen.dns_key ()) 63 | ~hostname ~additional_hostnames ?key_seed:(Key_gen.key_seed ()) 64 | (Key_gen.dns_server ()) (Key_gen.dns_port ()) >>= function 65 | | Error (`Msg msg) -> 66 | Logs.err (fun m -> m "error %s while retrieving certificate, giving up" msg); 67 | Lwt.return_unit 68 | | Ok own_cert -> 69 | (match own_cert with 70 | | `None -> Logs.err (fun m -> m "own_cert is none") 71 | | `Single chain -> log_certchain chain 72 | | `Multiple chains -> List.iter log_certchain chains 73 | | `Multiple_default (chain, chains) -> 74 | log_certchain chain ; 75 | List.iter log_certchain chains) ; 76 | let config = Tls.Config.server ~certificates:own_cert () in 77 | S.listen_tcpv4 stack ~port:(Key_gen.port ()) (accept config handle) ; 78 | S.listen stack 79 | end 80 | -------------------------------------------------------------------------------- /client/config.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Mirage 4 | 5 | let hostname = 6 | let doc = Key.Arg.info ~doc:"Hostname to resolve" ["hostname"] in 7 | Key.(create "hostname" Arg.(opt string "robur.io" doc)) 8 | 9 | let dns_handler = 10 | let packages = 11 | [ 12 | package "logs" ; 13 | package ~min:"4.5.0" ~sublibs:[ "mirage" ] "dns-client"; 14 | ] 15 | in 16 | foreign 17 | ~keys:[Key.abstract hostname] 18 | ~packages 19 | "Unikernel.Main" (random @-> time @-> mclock @-> stackv4 @-> job) 20 | 21 | let () = 22 | register "client" [dns_handler $ default_random $ default_time $ default_monotonic_clock $ generic_stackv4 default_network ] 23 | -------------------------------------------------------------------------------- /client/unikernel.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Lwt.Infix 4 | 5 | module Main (R : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) (S : Mirage_stack.V4) = struct 6 | 7 | module DNS = Dns_client_mirage.Make(R)(T)(M)(S) 8 | 9 | let start _ _ _ s = 10 | let t = DNS.create s in 11 | let host = Domain_name.(host_exn (of_string_exn (Key_gen.hostname ()))) in 12 | DNS.gethostbyname t host >|= function 13 | | Ok ip -> Logs.app (fun m -> m "%a is at %a" Domain_name.pp host Ipaddr.V4.pp ip) 14 | | Error (`Msg e) -> Logs.err (fun m -> m "%s while gethostbyname" e) 15 | end 16 | -------------------------------------------------------------------------------- /fw-rules-reader/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = 4 | foreign 5 | ~packages:[ package "mirage-qubes" ] 6 | "Unikernel.Main" (time @-> job) 7 | 8 | let () = 9 | register "fw-rules-reader" [main $ default_time] 10 | -------------------------------------------------------------------------------- /fw-rules-reader/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let src = Logs.Src.create "firewall_reader" ~doc:"FW reader" 4 | module Log = (val Logs.src_log src : Logs.LOG) 5 | 6 | module Main(Time : Mirage_time_lwt.S) = struct 7 | 8 | let start t = 9 | Qubes.DB.connect ~domid:0 () >>= fun qubesDB -> 10 | let bindings = Qubes.DB.bindings qubesDB in 11 | let rec print_and_loop bindings = 12 | Qubes.DB.KeyMap.iter (fun k v -> Logs.info (fun m -> m "%s %s" k v)) bindings; 13 | Qubes.DB.after qubesDB bindings >>= print_and_loop 14 | in 15 | print_and_loop bindings 16 | (* Time.sleep_ns 1_000_000L >>= fun () -> *) 17 | 18 | end 19 | -------------------------------------------------------------------------------- /primary-with-zone/config.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Mirage 4 | 5 | let disk = generic_kv_ro "data" 6 | 7 | let dns_handler = 8 | let packages = 9 | [ 10 | package "logs" ; 11 | package ~sublibs:[ "zone" ; "mirage" ] "dns-server"; 12 | package "dns-tsig"; 13 | package ~min:"2.0.0" "mirage-kv"; 14 | ] 15 | in 16 | foreign 17 | ~packages 18 | "Unikernel.Main" 19 | (random @-> pclock @-> mclock @-> time @-> stackv4 @-> kv_ro @-> job) 20 | 21 | let () = 22 | register "primary" 23 | [dns_handler $ default_random $ default_posix_clock $ default_monotonic_clock $ default_time $ generic_stackv4 default_network $ disk ] 24 | -------------------------------------------------------------------------------- /primary-with-zone/data/zone: -------------------------------------------------------------------------------- 1 | $ORIGIN example. 2 | $TTL 86400 3 | 4 | @ SOA (ns hostmaster 1 3600 1800 3024000 1800) 5 | 6 | @ NS ns 7 | @ NS ns2 8 | @ MX 10 mail 9 | 10 | ns A 10.0.42.2 11 | ns2 A 10.0.42.4 12 | mail A 10.0.42.3 13 | -------------------------------------------------------------------------------- /primary-with-zone/unikernel.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | open Lwt.Infix 3 | 4 | module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MCLOCK) (T : Mirage_time.S) (S : Mirage_stack.V4) (KV : Mirage_kv.RO) = struct 5 | 6 | module D = Dns_server_mirage.Make(P)(M)(T)(S) 7 | 8 | let start _rng _pclock _mclock _ s kv = 9 | KV.get kv (Mirage_kv.Key.v "zone") >>= function 10 | | Error e -> 11 | Logs.err (fun m -> m "couldn't get zone file %a" KV.pp_error e) ; exit 64 12 | | Ok data -> match Dns_zone.parse data with 13 | | Error (`Msg msg) -> 14 | Logs.err (fun m -> m "zonefile.load: %s" msg) ; exit 64 15 | | Ok rrs -> 16 | let trie = Dns_trie.insert_map rrs Dns_trie.empty in 17 | match Dns_trie.check trie with 18 | | Error e -> 19 | Logs.err (fun m -> m "error %a during check()" Dns_trie.pp_zone_check e) ; exit 64 20 | | Ok () -> 21 | let t = Dns_server.Primary.create ~rng:R.generate trie in 22 | D.primary s t ; 23 | S.listen s 24 | end 25 | -------------------------------------------------------------------------------- /primary/config.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Mirage 4 | 5 | let axfr = 6 | let doc = Key.Arg.info ~doc:"Allow unauthenticated zone transfer." ["axfr"] in 7 | Key.(create "axfr" Arg.(flag doc)) 8 | 9 | let dns_handler = 10 | let packages = 11 | [ 12 | package "logs" ; 13 | package ~min:"4.3.0" ~sublibs:[ "mirage" ] "dns-server"; 14 | package "dns-tsig"; 15 | ] 16 | in 17 | foreign 18 | ~keys:[Key.abstract axfr] 19 | ~packages 20 | "Unikernel.Main" 21 | (random @-> pclock @-> mclock @-> time @-> stackv4 @-> job) 22 | 23 | let () = 24 | register "primary" [dns_handler $ default_random $ default_posix_clock $ default_monotonic_clock $ default_time $ generic_stackv4 default_network ] 25 | -------------------------------------------------------------------------------- /primary/unikernel.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MCLOCK) (T : Mirage_time.S) (S : Mirage_stack.V4) = struct 3 | 4 | module D = Dns_server_mirage.Make(P)(M)(T)(S) 5 | 6 | let data = 7 | let open Dns in 8 | let n = Domain_name.of_string_exn 9 | and ip = Ipaddr.V4.of_string_exn 10 | and s n = Domain_name.Host_set.singleton (Domain_name.host_exn n) 11 | in 12 | let s_ip ipaddr = Rr_map.Ipv4_set.singleton (ip ipaddr) in 13 | let domain = n "mirage" in 14 | let m = Domain_name.prepend_label_exn domain in 15 | let h lbl = Domain_name.host_exn (m lbl) in 16 | let ns = m "ns" 17 | and ns' = m "secondary" 18 | and ttl = 2560l 19 | in 20 | let ns_set = Domain_name.(Host_set.add (host_exn ns') (s ns)) in 21 | let soa = { Dns.Soa.nameserver = ns ; 22 | hostmaster = m "hostmaster" ; 23 | serial = 1l ; refresh = 10l ; retry = 5l ; 24 | expiry = 600l ; minimum = ttl } 25 | in 26 | let open Dns_trie in 27 | let open Rr_map in 28 | let t = insert domain Soa soa Dns_trie.empty in 29 | let t = insert domain Ns (ttl, ns_set) t in 30 | let t = insert (m "router") A (ttl, s_ip "10.0.42.1") t in 31 | let t = insert ns A (ttl, s_ip "10.0.42.2") t in 32 | let t = insert (m "charrua") A (ttl, s_ip "10.0.42.3") t in 33 | let t = insert ns' A (ttl, s_ip "10.0.42.4") t in 34 | let t = insert (m "resolver") A (ttl, s_ip "10.0.42.5") t in 35 | let t = insert (m "letsencrypt") A (ttl, s_ip "10.0.42.6") t in 36 | let t = insert (m "certificate") A (ttl, s_ip "10.0.42.7") t in 37 | let t = insert (m "www") Cname (ttl, m "router") t in 38 | let ptr_zone = n "42.0.10.in-addr.arpa" in 39 | let ptr_soa = { Dns.Soa.nameserver = ns ; 40 | hostmaster = n "hostmaster.example" ; 41 | serial = 1l ; refresh = 16384l ; retry = 2048l ; 42 | expiry = 1048576l ; minimum = ttl } 43 | in 44 | let ptr_name = Domain_name.prepend_label_exn ptr_zone in 45 | let t = insert ptr_zone Soa ptr_soa t in 46 | let t = insert ptr_zone Ns (ttl, ns_set) t in 47 | let t = insert (ptr_name "1") Ptr (ttl, h "router") t in 48 | let t = insert (ptr_name "2") Ptr (ttl, h "ns") t in 49 | let t = insert (ptr_name "3") Ptr (ttl, h "charrua") t in 50 | let t = insert (ptr_name "4") Ptr (ttl, h "secondary") t in 51 | let t = insert (ptr_name "5") Ptr (ttl, h "resolver") t in 52 | let t = insert (ptr_name "6") Ptr (ttl, h "letsencrypt") t in 53 | let t = insert (ptr_name "7") Ptr (ttl, h "certificate") t in 54 | t 55 | 56 | let start _rng _pclock _mclock _ s = 57 | let trie = data in 58 | (match Dns_trie.check trie with 59 | | Ok () -> () 60 | | Error e -> 61 | Logs.err (fun m -> m "error %a during check()" Dns_trie.pp_zone_check e) ; 62 | invalid_arg "check") ; 63 | let keys = 64 | let key key = 65 | let key = Cstruct.of_string key in 66 | Dns.Dnskey.{ flags = 0 ; algorithm = SHA256 ; key } 67 | in 68 | [ 69 | Domain_name.of_string_exn "10.0.42.2.10.0.42.4._transfer.mirage" , 70 | key "G/7zDZr98BTzoi9N6HEUFOg7byKfH9rsPav5JMm9l8Y=" ; 71 | Domain_name.of_string_exn "barf.10.0.42.2._transfer.mirage" , 72 | key "sCgZ0SgEaFbpBxv+n74bognpLdR7gdutn8lO0/wpGJY=" ; 73 | Domain_name.of_string_exn "key._transfer.mirage" , 74 | key "/WcnjpqrErYrXi1dd4sv8dfwCwDFg0ZGm6N6Bq1VwMI=" ; 75 | Domain_name.of_string_exn "one._update.mirage" , 76 | key "eRhj4OoaGIIJ3I9hJFwYGhAkdiR5DNzia0WoGrYy70k=" ; 77 | ] 78 | in 79 | let t = 80 | let unauthenticated_zone_transfer = Key_gen.axfr () in 81 | Dns_server.Primary.create ~keys ~unauthenticated_zone_transfer 82 | ~tsig_verify:Dns_tsig.verify ~tsig_sign:Dns_tsig.sign ~rng:R.generate 83 | trie 84 | in 85 | Logs.info (fun m -> m "loaded zone: %a" 86 | (Rresult.R.pp ~ok:Fmt.string ~error:Rresult.R.pp_msg) 87 | (Dns_server.text (Domain_name.of_string_exn "mirage") trie)) ; 88 | D.primary s t ; 89 | S.listen s 90 | end 91 | -------------------------------------------------------------------------------- /resolver-no-stack/config.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Mirage 4 | 5 | let dns_handler = 6 | let packages = 7 | let pin = "git+https://github.com/mirage/ocaml-dns.git" in 8 | [ 9 | package "logs" ; 10 | package "ethernet"; 11 | package "arp"; 12 | package "arp-mirage"; 13 | package "ipaddr"; 14 | package "tcpip" ~sublibs:["stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp"]; 15 | package "mirage-qubes"; 16 | package "mirage-qubes-ipv4"; 17 | package ~pin:"0.3.0" "domain-name"; 18 | package ~pin "dns"; 19 | package ~pin "dns-mirage"; 20 | package ~pin "dns-resolver"; 21 | package ~pin "dns-client"; 22 | package "randomconv" ; 23 | package "lru" ; 24 | package "rresult" ; 25 | package "duration" ; 26 | ] 27 | in 28 | foreign 29 | ~deps:[abstract nocrypto] 30 | ~packages 31 | "Unikernel.Main" (random @-> pclock @-> mclock @-> time @-> network @-> qubesdb @-> job) 32 | 33 | let db = default_qubesdb 34 | 35 | let () = 36 | register "resolver" [dns_handler $ default_random $ default_posix_clock $ default_monotonic_clock $ default_time $ default_network $ db ] 37 | -------------------------------------------------------------------------------- /resolver-no-stack/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | open Mirage_types_lwt 4 | 5 | let src = Logs.Src.create "resolver_no_stack" ~doc:"Resolver no stack" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | module Main (R : RANDOM) (P : PCLOCK) (M : MCLOCK) (TIME : TIME) (N : NETWORK) (DB : Qubes.S.DB) = struct 9 | module E = Ethernet.Make(N) 10 | module A = Arp.Make(E)(TIME) 11 | module I = Qubesdb_ipv4.Make(DB)(R)(M)(E)(A) 12 | module U = Udp.Make(I)(R) 13 | module T = Tcp.Flow.Make(I)(TIME)(M)(R) 14 | 15 | let dns_src_ports : int list ref = ref [] 16 | module NameMvar = Map.Make(String) 17 | 18 | let start _r _pclock mclock _t net db _nc = 19 | E.connect net >>= fun ethernet -> 20 | A.connect ethernet >>= fun arp -> 21 | I.connect db mclock ethernet arp >>= fun ipv4 -> 22 | U.connect ipv4 >>= fun udp -> 23 | T.connect ipv4 mclock >>= fun tcp -> 24 | 25 | let now = M.elapsed_ns mclock in 26 | let server = 27 | Dns_server.Primary.create ~rng:R.generate Dns_resolver_root.reserved in 28 | let resolver = ref @@ Dns_resolver.create ~mode:(`Recursive) now R.generate server in 29 | 30 | let name_mvar = ref NameMvar.empty in 31 | name_mvar := NameMvar.add "robur.io" (Lwt_mvar.create_empty ()) !name_mvar; 32 | 33 | let is_dns src_port dst_port = 34 | List.mem dst_port !dns_src_ports && src_port = 53 in 35 | 36 | let rec free_port () = 37 | let port = Cstruct.BE.get_uint16 (R.generate 2) 0 in 38 | if List.mem port !dns_src_ports 39 | then free_port () 40 | else port 41 | in 42 | 43 | let send_dns_query src_port (_, dst, buf) = 44 | dns_src_ports := src_port :: !dns_src_ports ; 45 | U.write ~src_port ~dst ~dst_port:53 udp buf >>= fun _res -> 46 | Lwt.return_unit 47 | in 48 | 49 | let handle_answers answers = 50 | Log.info (fun f -> f "sitting on %d answers" (List.length answers)); 51 | let records = List.map (fun (_, _, _, record) -> record) answers in 52 | 53 | let answers_for_us us records = 54 | let open Dns.Packet in 55 | let get_ip_set acc record = 56 | let find_me (answer, authority) = 57 | Dns.Name_rr_map.find (Domain_name.of_string_exn "robur.io") Dns.Rr_map.A answer 58 | in 59 | 60 | match record.data with 61 | | `Answer maps -> begin match find_me maps with 62 | | Some q -> q :: acc 63 | | None -> acc 64 | end 65 | | _ -> acc 66 | in 67 | let replies = List.fold_left get_ip_set [] records in 68 | replies 69 | in 70 | let decode acc packet = match Dns.Packet.decode packet with 71 | | Error _ -> acc 72 | | Ok decoded -> decoded :: acc 73 | in 74 | let arecord_map = List.fold_left decode [] records in 75 | answers_for_us "robur.io" arecord_map 76 | in 77 | 78 | let handle_dns sender src_port buf = 79 | let p_now = Ptime.v (P.now_d_ps ()) in 80 | let ts = M.elapsed_ns () in 81 | let query_or_reply = true in 82 | let proto = `Udp in 83 | let post_request_resolver, answers', upstream_queries = 84 | Dns_resolver.handle_buf !resolver p_now ts query_or_reply proto sender src_port buf in 85 | resolver := post_request_resolver; 86 | Dns_resolver.stats !resolver; 87 | Log.info (fun f -> f "sending %d upstream queries" @@ List.length upstream_queries); 88 | Lwt_list.iter_p (send_dns_query @@ free_port ()) upstream_queries >>= fun () -> 89 | let answers = handle_answers answers' in 90 | if answers <> [] 91 | then Lwt_mvar.put (NameMvar.find "robur.io" !name_mvar) answers 92 | else Lwt.return_unit in 93 | 94 | let udp_listener = (fun ~src ~dst:_ ~src_port dst_port buf -> 95 | if is_dns src_port dst_port 96 | then begin 97 | Log.info (fun f -> f "before removing %d, we have ports %a in the port list" src_port Fmt.(list int) !dns_src_ports); 98 | dns_src_ports := List.filter (fun f -> f <> dst_port) !dns_src_ports; 99 | Log.info (fun f -> f "after removing %d, we have ports %a in the port list" src_port Fmt.(list int) !dns_src_ports); 100 | handle_dns src src_port buf 101 | end 102 | else begin 103 | Log.debug (fun f -> f "non-dns packet received; dropping it"); 104 | Lwt.return_unit end) 105 | in 106 | 107 | let listeners = (fun ~dst_port -> Some (udp_listener dst_port)) in 108 | 109 | let udp_arg : U.ipinput = U.input ~listeners udp in 110 | 111 | (* ask resolver about a name, send a request, we get the reply, but we have control over the network *) 112 | (* at least one other service runs on it - another listener, not network but udp service *) 113 | (* you=firewall can't take all packets and send them to dns *) 114 | 115 | Lwt.async (fun () -> 116 | N.listen net ~header_size:Ethernet_wire.sizeof_ethernet 117 | (E.input ~arpv4:(A.input arp) 118 | ~ipv4:(I.input 119 | ~udp:udp_arg 120 | ~tcp:(fun ~src:_ ~dst:_ _contents -> Lwt.return_unit) 121 | ~default:(fun ~proto:_ ~src:_ ~dst:_ _ -> 122 | (* TODO: handle ICMP destination unreachable messages here, 123 | possibly with some detailed help text? *) 124 | Lwt.return_unit) 125 | ipv4 126 | ) 127 | ~ipv6:(fun _ -> Lwt.return_unit) 128 | ethernet 129 | ) >>= fun _ -> Lwt.return_unit 130 | 131 | ); 132 | 133 | let query_cstruct, _ = Dns_client.make_query `Udp (Domain_name.of_string_exn "robur.io") Dns.Rr_map.A in 134 | 135 | let get_cache_response_or_queries name = 136 | let src_port = free_port () in 137 | let p_now = Ptime.v (P.now_d_ps ()) in 138 | let ts = M.elapsed_ns () in 139 | let query_or_reply = true in 140 | let proto = `Udp in 141 | let sender = List.hd @@ I.get_ip ipv4 in 142 | 143 | let new_resolver, answers', upstream_queries = Dns_resolver.handle_buf !resolver p_now ts query_or_reply proto sender src_port query_cstruct in 144 | resolver := new_resolver; 145 | Dns_resolver.stats !resolver; 146 | let answers = handle_answers answers' in 147 | if answers <> [] 148 | then 149 | `Known answers 150 | else 151 | begin 152 | let mvar = Lwt_mvar.create_empty () in 153 | name_mvar := NameMvar.add name mvar !name_mvar; 154 | `Unknown (mvar, upstream_queries) 155 | end 156 | in 157 | 158 | let wait_and_clean_state mvar name = 159 | Lwt_mvar.take mvar >>= fun answers -> 160 | name_mvar := NameMvar.remove name !name_mvar; 161 | Lwt.return answers 162 | in 163 | 164 | let lookup_and_check name ip = 165 | let ip_in_sets ip answers = 166 | List.iter (fun (_, ipset) -> 167 | let iplist = Dns.Rr_map.Ipv4_set.elements ipset in 168 | Log.info (fun f -> f "%a in ipset" Fmt.(list Ipaddr.V4.pp) iplist); 169 | match Dns.Rr_map.Ipv4_set.find_opt ip ipset with 170 | | None -> Log.err (fun f -> f "we expected to find %a in the ipset returned for %s, but we didn't :(" Ipaddr.V4.pp ip "robur.io") 171 | | Some ip -> Log.err (fun f -> f "the IP we expected was in the set, yay! :)") 172 | ) answers; 173 | Lwt.return_unit 174 | in 175 | match get_cache_response_or_queries "robur.io" with 176 | | `Known answers -> ip_in_sets ip answers 177 | | `Unknown (mvar, queries) -> 178 | begin 179 | Lwt_list.iter_p (send_dns_query @@ free_port ()) queries >>= fun () -> 180 | Log.info (fun f -> f "waiting for mvar..."); 181 | wait_and_clean_state mvar name >>= fun answers -> 182 | ip_in_sets ip answers 183 | end 184 | in 185 | 186 | let timed_lookup_and_check name ip = 187 | let pre_wait = M.elapsed_ns () in 188 | lookup_and_check name ip >>= fun () -> 189 | let post_wait = M.elapsed_ns () in 190 | Log.info (fun f -> f "Got answers in %Ld nanoseconds" Int64.(sub post_wait pre_wait)); 191 | Lwt.return_unit 192 | in 193 | 194 | (* make sure there are no outstanding requests *) 195 | let show_state () = 196 | Log.info (fun f -> f "checking name_mvar:"); 197 | List.iter (fun (k, _v) -> 198 | Log.info (fun f -> f "outstanding resolution attempt: %s" k) 199 | ) (NameMvar.bindings !name_mvar); 200 | Log.info (fun f -> f "port list contents: %a" Fmt.(list ~sep:comma int) !dns_src_ports) 201 | in 202 | 203 | let name = "robur.io" in 204 | let ip = Ipaddr.V4.of_string_exn "198.167.222.215" in 205 | 206 | timed_lookup_and_check name ip >>= fun () -> 207 | show_state (); 208 | (* do it again: is it any faster? name should be cached *) 209 | timed_lookup_and_check name ip >>= fun () -> 210 | 211 | Lwt.return_unit 212 | 213 | end 214 | -------------------------------------------------------------------------------- /resolver/config.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Mirage 4 | 5 | let dns_handler = 6 | let packages = 7 | [ 8 | package "logs" ; 9 | package "dns-server"; 10 | package ~sublibs:[ "mirage" ] "dns-resolver"; 11 | ] 12 | in 13 | foreign 14 | ~packages 15 | "Unikernel.Main" (random @-> pclock @-> mclock @-> time @-> stackv4 @-> job) 16 | 17 | let () = 18 | register "resolver" [dns_handler $ default_random $ default_posix_clock $ default_monotonic_clock $ default_time $ generic_stackv4 default_network ] 19 | -------------------------------------------------------------------------------- /resolver/unikernel.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MCLOCK) (T : Mirage_time.S) (S : Mirage_stack.V4) = struct 3 | module D = Dns_resolver_mirage.Make(R)(P)(M)(T)(S) 4 | 5 | let start _r _pclock _mclock _ s = 6 | let now = M.elapsed_ns () in 7 | let server = 8 | Dns_server.Primary.create ~rng:R.generate Dns_resolver_root.reserved 9 | in 10 | let p = Dns_resolver.create now R.generate server in 11 | D.resolver ~timer:1000 ~root:true s p ; 12 | S.listen s 13 | end 14 | -------------------------------------------------------------------------------- /stub-resolver/config.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Mirage 4 | 5 | let resolver = 6 | let doc = Key.Arg.info ~doc:"Recursive resolver to query" ["resolver"] in 7 | Key.(create "resolver" Arg.(opt ipv4_address (Ipaddr.V4.of_string_exn "141.1.1.1") doc)) 8 | 9 | let dns_handler = 10 | let packages = 11 | [ 12 | package "logs" ; 13 | package ~sublibs:["mirage"] "dns-resolver"; 14 | package "dns-server"; 15 | ] 16 | in 17 | foreign 18 | ~keys:[Key.abstract resolver] 19 | ~packages 20 | "Unikernel.Main" (random @-> pclock @-> mclock @-> time @-> stackv4 @-> job) 21 | 22 | let () = 23 | register "stub-resolver" [dns_handler $ default_random $ default_posix_clock $ default_monotonic_clock $ default_time $ generic_stackv4 default_network ] 24 | -------------------------------------------------------------------------------- /stub-resolver/unikernel.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | module Main (R : Mirage_random.S) (P : Mirage_clock.PCLOCK) (M : Mirage_clock.MCLOCK) (T : Mirage_time.S) (S : Mirage_stack.V4) = struct 3 | module D = Dns_resolver_mirage.Make(R)(P)(M)(T)(S) 4 | 5 | let start _r _pclock _mclock _ s = 6 | let trie = 7 | let name = Domain_name.of_string_exn "resolver" 8 | and ip = Key_gen.resolver () 9 | in 10 | let trie = 11 | Dns_trie.insert Domain_name.root 12 | Dns.Rr_map.Ns (300l, Domain_name.(Host_set.singleton (host_exn name))) 13 | Dns_resolver_root.reserved 14 | in 15 | Dns_trie.insert name Dns.Rr_map.A 16 | (300l, Dns.Rr_map.Ipv4_set.singleton ip) 17 | trie 18 | in 19 | (match Dns_trie.check trie with 20 | | Ok () -> () 21 | | Error e -> 22 | Logs.err (fun m -> m "check after update returned %a" Dns_trie.pp_zone_check e)) ; 23 | let now = M.elapsed_ns () in 24 | let server = Dns_server.Primary.create ~rng:R.generate trie in 25 | let p = Dns_resolver.create ~mode:`Stub now R.generate server in 26 | D.resolver s p ; 27 | S.listen s 28 | end 29 | -------------------------------------------------------------------------------- /unikernels.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team@robur.io" 3 | authors: ["team@robur.io"] 4 | homepage: "https://github.com/roburio/unikernels" 5 | doc: "https://roburio.github.io/unikernels/doc" 6 | dev-repo: "git+https://github.com/roburio/unikernels.git" 7 | bug-reports: "https://github.com/roburio/unikernels/issues" 8 | license: "public domain" 9 | 10 | depends: [ 11 | "lwt" 12 | "mirage" {>= "3.7.7"} 13 | "ocaml" {>= "4.08.0"} 14 | ] 15 | 16 | synopsis: "Unikernels developed by the robur.io team" 17 | --------------------------------------------------------------------------------