mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2024-12-24 22:59:31 -05:00
commit
8f739c610e
@ -23,7 +23,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes
|
||||
# Remove this line (and the base image pin above) if you want to test with the
|
||||
# latest versions.
|
||||
# taken from https://github.com/ocaml/opam-repository
|
||||
RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#13acffc3de9c22953d1e08bad3e56ee6e965eeed
|
||||
RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#26c09ff1da6a07b20a0f9474e3a6ed6315c6388b
|
||||
RUN opam switch create myswitch 4.14.2
|
||||
RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5
|
||||
RUN mkdir /tmp/orb-build
|
||||
|
@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall .
|
||||
echo Building Firewall...
|
||||
$builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall
|
||||
echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)"
|
||||
echo "SHA2 last known: 5805e94755334af02fd4244b0b163c7a90fef9061d826e365db3be8adfe8abcc"
|
||||
echo "SHA2 last known: 4b1f743bf4540bc8a9366cf8f23a78316e4f2d477af77962e50618753c4adf10"
|
||||
echo "(hashes should match for released versions)"
|
||||
|
@ -1,4 +1,4 @@
|
||||
(* mirage >= 4.5.0 & < 5.0.0 *)
|
||||
(* mirage >= 4.8.0 & < 4.9.0 *)
|
||||
(* Copyright (C) 2017, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||
See the README file for details. *)
|
||||
|
||||
@ -6,15 +6,8 @@
|
||||
|
||||
open Mirage
|
||||
|
||||
let nat_table_size = runtime_arg ~pos:__POS__ "Unikernel.nat_table_size"
|
||||
let ipv4 = runtime_arg ~pos:__POS__ "Unikernel.ipv4"
|
||||
let ipv4_gw = runtime_arg ~pos:__POS__ "Unikernel.ipv4_gw"
|
||||
let ipv4_dns = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns"
|
||||
let ipv4_dns2 = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns2"
|
||||
|
||||
let main =
|
||||
main
|
||||
~runtime_args:[ nat_table_size; ipv4; ipv4_gw; ipv4_dns; ipv4_dns2; ]
|
||||
~packages:[
|
||||
package "vchan" ~min:"4.0.2";
|
||||
package "cstruct";
|
||||
|
@ -9,7 +9,7 @@ let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
module Make
|
||||
(R : Mirage_random.S)
|
||||
(R : Mirage_crypto_rng_mirage.S)
|
||||
(Clock : Mirage_clock.MCLOCK)
|
||||
(Time : Mirage_time.S) =
|
||||
struct
|
||||
@ -453,7 +453,7 @@ struct
|
||||
| Some uplink -> (
|
||||
Lwt.catch
|
||||
(fun () ->
|
||||
U.write ~src_port ~dst ~dst_port uplink.udp buf >|= function
|
||||
U.write ~src_port ~dst ~dst_port uplink.udp (Cstruct.of_string buf) >|= function
|
||||
| Error s ->
|
||||
Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s);
|
||||
Error (`Msg "failure")
|
||||
@ -506,7 +506,7 @@ struct
|
||||
"found a DNS packet whose dst_port (%d) was in the list of \
|
||||
dns_client ports"
|
||||
header.dst_port);
|
||||
Lwt_mvar.put dns_responses (header, packet)
|
||||
Lwt_mvar.put dns_responses (header, Cstruct.to_string packet)
|
||||
| _ -> ipv4_from_netvm router (`IPv4 (header, packet))
|
||||
end
|
||||
end)
|
||||
|
16
my_dns.ml
16
my_dns.ml
@ -1,10 +1,12 @@
|
||||
open Lwt.Infix
|
||||
|
||||
module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
|
||||
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 -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
|
||||
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
|
||||
|
||||
module IM = Map.Make(Int)
|
||||
|
||||
@ -13,7 +15,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
|
||||
nameserver : io_addr ;
|
||||
stack : stack ;
|
||||
timeout_ns : int64 ;
|
||||
mutable requests : Cstruct.t Lwt_condition.t IM.t ;
|
||||
mutable requests : string Lwt_condition.t IM.t ;
|
||||
}
|
||||
type context = t
|
||||
|
||||
@ -24,8 +26,8 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
|
||||
let rec read t =
|
||||
let _, _, answer = t.stack in
|
||||
Lwt_mvar.take answer >>= fun (_, data) ->
|
||||
if Cstruct.length data > 2 then begin
|
||||
match IM.find_opt (Cstruct.BE.get_uint16 data 0) t.requests with
|
||||
if String.length data > 2 then begin
|
||||
match IM.find_opt (String.get_uint16_be data 0) t.requests with
|
||||
| Some cond -> Lwt_condition.broadcast cond data
|
||||
| None -> ()
|
||||
end;
|
||||
@ -48,13 +50,13 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
|
||||
|
||||
let connect (t : t) = Lwt.return (Ok (t.protocol, t))
|
||||
|
||||
let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
|
||||
let send_recv (ctx : context) buf : (string, [> `Msg of string ]) result Lwt.t =
|
||||
let dst, dst_port = ctx.nameserver in
|
||||
let router, send_udp, _ = ctx.stack in
|
||||
let src_port, evict =
|
||||
My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53
|
||||
in
|
||||
let id = Cstruct.BE.get_uint16 buf 0 in
|
||||
let id = String.get_uint16_be buf 0 in
|
||||
with_timeout ctx.timeout_ns
|
||||
(let cond = Lwt_condition.create () in
|
||||
ctx.requests <- IM.add id cond ctx.requests;
|
||||
|
@ -42,7 +42,7 @@ let netvm = "10.137.0.5"
|
||||
(* default "nameserver"s, which netvm redirects to whatever its real nameservers are *)
|
||||
let nameserver_1, nameserver_2 = "10.139.1.1", "10.139.1.2"
|
||||
|
||||
module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct
|
||||
module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct
|
||||
module E = Ethernet.Make(NET)
|
||||
module A = Arp.Make(E)(Time)
|
||||
module I = Qubesdb_ipv4.Make(DB)(R)(Clock)(E)(A)
|
||||
|
30
unikernel.ml
30
unikernel.ml
@ -10,25 +10,25 @@ module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
let nat_table_size =
|
||||
let doc = Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] in
|
||||
Arg.(value & opt int 5_000 doc)
|
||||
Mirage_runtime.register_arg Arg.(value & opt int 5_000 doc)
|
||||
|
||||
let ipv4 =
|
||||
let doc = Arg.info ~doc:"Manual IP setting." [ "ipv4" ] in
|
||||
Arg.(value & opt string "0.0.0.0" doc)
|
||||
Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc)
|
||||
|
||||
let ipv4_gw =
|
||||
let doc = Arg.info ~doc:"Manual Gateway IP setting." [ "ipv4-gw" ] in
|
||||
Arg.(value & opt string "0.0.0.0" doc)
|
||||
Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc)
|
||||
|
||||
let ipv4_dns =
|
||||
let doc = Arg.info ~doc:"Manual DNS IP setting." [ "ipv4-dns" ] in
|
||||
Arg.(value & opt string "10.139.1.1" doc)
|
||||
Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.1" doc)
|
||||
|
||||
let ipv4_dns2 =
|
||||
let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in
|
||||
Arg.(value & opt string "10.139.1.2" doc)
|
||||
Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc)
|
||||
|
||||
module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct
|
||||
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)
|
||||
@ -45,7 +45,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
|
||||
]
|
||||
|
||||
(* Main unikernel entry point (called from auto-generated main.ml). *)
|
||||
let start _random _clock _time nat_table_size ipv4 ipv4_gw ipv4_dns ipv4_dns2 =
|
||||
let start _random _clock _time =
|
||||
let start_time = Clock.elapsed_ns () in
|
||||
(* Start qrexec agent and QubesDB agent in parallel *)
|
||||
let qrexec = RExec.connect ~domid:0 () in
|
||||
@ -66,15 +66,15 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
|
||||
Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
|
||||
Lwt.return_unit in
|
||||
(* Set up networking *)
|
||||
let nat = My_nat.create ~max_entries:nat_table_size in
|
||||
let nat = My_nat.create ~max_entries:(nat_table_size ()) in
|
||||
|
||||
let netvm_ip = Ipaddr.V4.of_string_exn (ipv4_gw ()) in
|
||||
let our_ip = Ipaddr.V4.of_string_exn (ipv4 ()) in
|
||||
let dns = Ipaddr.V4.of_string_exn (ipv4_dns ()) in
|
||||
let dns2 = Ipaddr.V4.of_string_exn (ipv4_dns2 ()) in
|
||||
|
||||
let zero_ip = Ipaddr.V4.any in
|
||||
|
||||
let netvm_ip = Ipaddr.V4.of_string_exn ipv4_gw in
|
||||
let our_ip = Ipaddr.V4.of_string_exn ipv4 in
|
||||
let dns = Ipaddr.V4.of_string_exn ipv4_dns in
|
||||
let dns2 = Ipaddr.V4.of_string_exn ipv4_dns2 in
|
||||
|
||||
let zero_ip = (Ipaddr.V4.make 0 0 0 0) in
|
||||
|
||||
let network_config =
|
||||
if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *)
|
||||
Dao.read_network_config qubesDB >>= fun config ->
|
||||
|
Loading…
Reference in New Issue
Block a user