diff --git a/config.ml b/config.ml index 00ddc71..5c06a4b 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.8.0 & < 4.9.0 *) +(* mirage >= 4.9.0 & < 4.10.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) @@ -24,7 +24,7 @@ let main = package ~min:"6.4.0" "dns-client"; package "pf-qubes"; ] - "Unikernel.Main" (random @-> mclock @-> time @-> job) + "Unikernel" job let () = - register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time] + register "qubes-firewall" [main] diff --git a/dispatcher.ml b/dispatcher.ml index d929822..9f6db7f 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -8,14 +8,9 @@ let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" module Log = (val Logs.src_log src : Logs.LOG) -module Make - (R : Mirage_crypto_rng_mirage.S) - (Clock : Mirage_clock.MCLOCK) - (Time : Mirage_time.S) = -struct - module Arp = Arp.Make (UplinkEth) (Time) - module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) - module U = Udp.Make (I) (R) + module Arp = Arp.Make (UplinkEth) + module I = Static_ipv4.Make (UplinkEth) (Arp) + module U = Udp.Make (I) class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = @@ -632,4 +627,3 @@ struct >>= fun () -> aux new_db in aux Qubes.DB.KeyMap.empty -end diff --git a/my_dns.ml b/my_dns.ml index cbfa763..6000e80 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,9 +1,7 @@ open Lwt.Infix -module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int - module Dispatcher = Dispatcher.Make(R)(C)(Time) type stack = Dispatcher.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> string -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * string) Lwt_mvar.t @@ -20,8 +18,8 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim type context = t let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] - let rng = R.generate ?g:None - let clock = C.elapsed_ns + let rng = Mirage_crypto_rng.generate ?g:None + let clock = Mirage_mtime.elapsed_ns let rec read t = let _, _, answer = t.stack in @@ -45,7 +43,7 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim t let with_timeout timeout_ns f = - let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in + let timeout = Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in Lwt.pick [ f ; timeout ] let connect (t : t) = Lwt.return (Ok (t.protocol, t)) @@ -72,5 +70,3 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim let bind = Lwt.bind let lift = Lwt.return -end - diff --git a/unikernel.ml b/unikernel.ml index f0e12df..28115d1 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -28,10 +28,7 @@ let ipv4_dns2 = let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc) -module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct - module Dispatcher = Dispatcher.Make(R)(Clock)(Time) - module Dns_transport = My_dns.Transport(R)(Clock)(Time) - module Dns_client = Dns_client.Make(Dns_transport) + module Dns_client = Dns_client.Make(My_dns) (* Set up networking and listen for incoming packets. *) let network dns_client dns_responses dns_servers qubesDB router = @@ -39,22 +36,22 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) Lwt.choose [ - Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ; + Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers qubesDB router ; Dispatcher.uplink_wait_update qubesDB router ; - Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router + Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router ] (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock _time = + let start () = let open Lwt.Syntax in - let start_time = Clock.elapsed_ns () in + let start_time = Mirage_mtime.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) let* qrexec = RExec.connect ~domid:0 () in let agent_listener = RExec.listen qrexec Command.handler in let* qubesDB = DB.connect ~domid:0 () in let startup_time = let (-) = Int64.sub in - let time_in_ns = Clock.elapsed_ns () - start_time in + let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in Int64.to_float time_in_ns /. 1e9 in Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); @@ -113,5 +110,4 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : (* Run until something fails or we get a shutdown request. *) Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () -> (* Give the console daemon time to show any final log messages. *) - Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) -end + Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float)