mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2024-09-30 12:46:07 +00:00
Add ICMP ping support
This commit is contained in:
parent
15fb063137
commit
ac711f4eee
@ -45,6 +45,7 @@ let classify t packet =
|
|||||||
match transport with
|
match transport with
|
||||||
| `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port}
|
| `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port}
|
||||||
| `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port}
|
| `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port}
|
||||||
|
| `ICMP _ -> `ICMP
|
||||||
in
|
in
|
||||||
Some {
|
Some {
|
||||||
packet;
|
packet;
|
||||||
|
25
my_nat.ml
25
my_nat.ml
@ -29,8 +29,8 @@ let create (type c t) (nat:(module Mirage_nat.S with type config = c and type t
|
|||||||
|
|
||||||
let translate (Nat ((module Nat), _, table)) packet =
|
let translate (Nat ((module Nat), _, table)) packet =
|
||||||
Nat.translate table.current packet >|= function
|
Nat.translate table.current packet >|= function
|
||||||
| Mirage_nat.Untranslated -> None
|
| Error `Untranslated -> None
|
||||||
| Mirage_nat.Translated packet -> Some packet
|
| Ok packet -> Some packet
|
||||||
|
|
||||||
let random_user_port () =
|
let random_user_port () =
|
||||||
1024 + Random.int (0xffff - 1024)
|
1024 + Random.int (0xffff - 1024)
|
||||||
@ -44,17 +44,12 @@ let reset (Nat ((module Nat), c, table)) =
|
|||||||
|
|
||||||
let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet =
|
let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet =
|
||||||
let apply_action xl_port =
|
let apply_action xl_port =
|
||||||
Lwt.try_bind (fun () ->
|
Lwt.catch (fun () ->
|
||||||
match action with
|
match action with
|
||||||
| `Rewrite ->
|
| `Rewrite ->
|
||||||
Nat.add_nat table.current packet (xl_host, xl_port)
|
Nat.add_nat table.current packet (xl_host, xl_port)
|
||||||
| `Redirect target ->
|
| `Redirect target ->
|
||||||
Nat.add_redirect table.current packet (xl_host, xl_port) target
|
Nat.add_redirect table.current packet (xl_host, xl_port) target
|
||||||
)
|
|
||||||
(function
|
|
||||||
| Nat.Ok -> Lwt.return (Ok ())
|
|
||||||
| Nat.Overlap -> Lwt.return (Error `Overlap)
|
|
||||||
| Nat.Unparseable -> Lwt.return (Error `Unparseable)
|
|
||||||
)
|
)
|
||||||
(function
|
(function
|
||||||
| Out_of_memory -> Lwt.return (Error `Out_of_memory)
|
| Out_of_memory -> Lwt.return (Error `Out_of_memory)
|
||||||
@ -86,8 +81,8 @@ let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host ac
|
|||||||
) else (
|
) else (
|
||||||
aux ~retries:(retries - 1)
|
aux ~retries:(retries - 1)
|
||||||
)
|
)
|
||||||
| Error `Unparseable ->
|
| Error `Cannot_NAT ->
|
||||||
Lwt.return (Error "Unparseable by mirage-nat")
|
Lwt.return (Error "Cannot NAT this packet")
|
||||||
| Ok () ->
|
| Ok () ->
|
||||||
translate t packet >|= function
|
translate t packet >|= function
|
||||||
| None -> Error "No NAT entry, even after adding one!"
|
| None -> Error "No NAT entry, even after adding one!"
|
||||||
|
Loading…
Reference in New Issue
Block a user