Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-10-01 01:05:39 -04:00
Code Issues Packages Projects Releases Wiki Activity

Add some types to the rules

Browse Source 
Before, we inferred the types from rules.ml and then the compiler
checked that it was consistent with what firewall.ml expected. If it
wasn't it reported the problem as being with firewall.ml, which could be
confusing to users.
This commit is contained in:
Thomas Leonard 2019-04-17 10:26:32 +01:00
parent acf46b4231
commit 189a736368
2 changed files with 15 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
packet.ml
View File

@ -25,3 +25,14 @@ type 'a info = {
let is_tcp_start = function let is_tcp_start = function
| `IPv4 (_ip, `TCP (hdr, _body)) -> Tcp.Tcp_packet.(hdr.syn && not hdr.ack) | `IPv4 (_ip, `TCP (hdr, _body)) -> Tcp.Tcp_packet.(hdr.syn && not hdr.ack)
| _ -> false | _ -> false
(* The possible actions we can take for a packet: *)
type action = [
| `Accept (* Send the packet to its destination. *)
| `NAT (* Rewrite the packet's source field so packet appears to
have come from the firewall, via an unused port.
Also, add NAT rules so related packets will be translated accordingly. *)
| `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's
destination fields so it will be sent to [host:port]. *)
| `Drop of string (* Drop the packet and log the given reason. *)
]

23
rules.ml
View File

@ -8,23 +8,6 @@ open Packet
(* OCaml normally warns if you don't match all fields, but that's OK here. *) (* OCaml normally warns if you don't match all fields, but that's OK here. *)
[@@@ocaml.warning "-9"] [@@@ocaml.warning "-9"]
(** {2 Actions}
The possible actions are:
- [`Accept] : Send the packet to its destination.
- [`NAT] : Rewrite the packet's source field so packet appears to
have come from the firewall, via an unused port.
Also, add NAT rules so related packets will be translated accordingly.
- [`NAT_to (host, port)] :
As for [`NAT], but also rewrite the packet's destination fields so it
will be sent to [host:port].
- [`Drop reason] drop the packet and log the reason.
*)
(* List your AppVM IP addresses here if you want to match on them in the rules below. (* List your AppVM IP addresses here if you want to match on them in the rules below.
Any client not listed here will appear as [`Client `Unknown]. *) Any client not listed here will appear as [`Client `Unknown]. *)
let clients = [ let clients = [
@ -44,7 +27,8 @@ let externals = [
(** Decide what to do with a packet from a client VM. (** Decide what to do with a packet from a client VM.
Note: If the packet matched an existing NAT rule then this isn't called. *) Note: If the packet matched an existing NAT rule then this isn't called. *)
let from_client = function let from_client (info : _ info) : action =
match info with
(* Examples (add your own rules here): *) (* Examples (add your own rules here): *)
(* (*
| { src = `Client `Dev; dst = `Client `Untrusted; proto = `TCP { dport = 22 } } -> `Accept | { src = `Client `Dev; dst = `Client `Untrusted; proto = `TCP { dport = 22 } } -> `Accept
@ -59,5 +43,6 @@ let from_client = function
(** Decide what to do with a packet received from the outside world. (** Decide what to do with a packet received from the outside world.
Note: If the packet matched an existing NAT rule then this isn't called. *) Note: If the packet matched an existing NAT rule then this isn't called. *)
let from_netvm = function let from_netvm (info : _ info) : action =
match info with
| _ -> `Drop "drop by default" | _ -> `Drop "drop by default"