Skip to content
This repository has been archived by the owner on Jun 30, 2019. It is now read-only.

adapt to domain-name phantom type API #31

Open
wants to merge 11 commits into
base: master
Choose a base branch
from
Open

adapt to domain-name phantom type API #31

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
11 commits
Select commit Hold shift + click to select a range
a474af5
Server: sign_outgoing
hannesm Apr 28, 2019
d4ab3a3
sign
hannesm Apr 28, 2019
36568d9
only some mac
hannesm Apr 28, 2019
2e315ac
.
hannesm Apr 28, 2019
fb7ee20
secondary: only mac for replies
hannesm Apr 28, 2019
51b0822
debug
hannesm Apr 28, 2019
9041578
.
hannesm Apr 28, 2019
a5cfccb
server: improve notify handling, esp if signed and soa is around
hannesm Apr 28, 2019
272b38d
meh
hannesm Apr 28, 2019
4c02b3c
primary mirage revise
hannesm Apr 28, 2019
445035a
server: register SOA . to all zones, also notify such a client with a…
hannesm Apr 28, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
134 changes: 68 additions & 66 deletions mirage/server/udns_mirage_server.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,21 +19,23 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME :
tcp_out := Dns.IM.remove ip !tcp_out ;
state := Udns_server.Primary.closed !state ip
in
let send_notify (ip, data) =

let connect recv_task ip =
let dport = 53 in
let connect ip =
Log.info (fun m -> m "creating connection to %a:%d" Ipaddr.V4.pp ip dport) ;
T.create_connection (S.tcpv4 stack) (ip, dport) >>= function
| Error e ->
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.V4.pp ip port) ;
Lwt.return (Error ())
| Ok flow ->
tcp_out := Dns.IM.add ip flow !tcp_out;
Lwt.return (Ok flow)
in
Log.info (fun m -> m "creating connection to %a:%d" Ipaddr.V4.pp ip dport) ;
T.create_connection (S.tcpv4 stack) (ip, dport) >>= function
| Error e ->
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.V4.pp ip port) ;
Lwt.return (Error ())
| Ok flow ->
Lwt.async (recv_task ip dport flow);
Lwt.return (Ok flow)
in

let send_notify recv_task (ip, data) =
let connect_and_send ip =
connect ip >>= function
connect recv_task ip >>= function
| Ok flow -> Dns.send_tcp flow data
| Error () -> Lwt.return (Error ())
in
Expand All @@ -44,7 +46,7 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME :
| Error () -> drop ip ; connect_and_send ip) >>= function
| Ok () -> Lwt.return_unit
| Error () ->
drop ip ; Dns.send_udp stack port ip dport data
drop ip ; Dns.send_udp stack port ip 53 data
in

let maybe_update_state t =
Expand All @@ -55,60 +57,67 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME :
Lwt.return_unit
else
on_update ~old:(trie old) t
and maybe_notify t ts = function
and maybe_notify recv_task t now ts = function
| None -> Lwt.return_unit
| Some n -> on_notify n t >>= function
| None -> Lwt.return_unit
| Some trie ->
let state', outs = Udns_server.Primary.with_data t ts trie in
let state', outs = Udns_server.Primary.with_data t now ts trie in
state := state';
Lwt_list.iter_p send_notify outs
Lwt_list.iter_p (send_notify recv_task) outs
in

let udp_cb ~src ~dst:_ ~src_port buf =
Log.info (fun m -> m "udp frame from %a:%d" Ipaddr.V4.pp src src_port) ;
let now = Ptime.v (P.now_d_ps ()) in
let elapsed = M.elapsed_ns () in
let t, answer, notify, n = Udns_server.Primary.handle_buf !state now elapsed `Udp src src_port buf in
maybe_update_state t >>= fun () ->
maybe_notify t elapsed n >>= fun () ->
(match answer with
| None -> Log.warn (fun m -> m "empty answer") ; Lwt.return_unit
| Some answer -> Dns.send_udp stack port src src_port answer) >>= fun () ->
Lwt_list.iter_p send_notify notify
in
S.listen_udpv4 stack ~port udp_cb ;
Log.info (fun m -> m "DNS server listening on UDP port %d" port) ;
let tcp_cb flow =
let dst_ip, dst_port = T.dst flow in
Log.info (fun m -> m "tcp connection from %a:%d" Ipaddr.V4.pp dst_ip dst_port) ;
let rec recv_task ip port flow () =
let f = Dns.of_flow flow in
tcp_out := Dns.IM.add dst_ip flow !tcp_out ;
tcp_out := Dns.IM.add ip flow !tcp_out ;
let rec loop () =
Dns.read_tcp f >>= function
| Error () -> drop dst_ip ; Lwt.return_unit
| Error () -> drop ip ; Lwt.return_unit
| Ok data ->
let now = Ptime.v (P.now_d_ps ()) in
let elapsed = M.elapsed_ns () in
let t, answer, notify, n = Udns_server.Primary.handle_buf !state now elapsed `Tcp dst_ip dst_port data in
let t, answer, notify, n = Udns_server.Primary.handle_buf !state now elapsed `Tcp ip port data in
maybe_update_state t >>= fun () ->
maybe_notify t elapsed n >>= fun () ->
Lwt_list.iter_p send_notify notify >>= fun () ->
maybe_notify recv_task t now elapsed n >>= fun () ->
Lwt_list.iter_p (send_notify recv_task) notify >>= fun () ->
match answer with
| None -> Log.warn (fun m -> m "empty answer") ; loop ()
| Some answer ->
Dns.send_tcp flow answer >>= function
| Ok () -> loop ()
| Error () -> drop dst_ip ; Lwt.return_unit
| Error () -> drop ip ; Lwt.return_unit
in
loop ()
in

let tcp_cb flow =
let dst_ip, dst_port = T.dst flow in
Log.info (fun m -> m "tcp connection from %a:%d" Ipaddr.V4.pp dst_ip dst_port) ;
recv_task dst_ip dst_port flow ()
in
S.listen_tcpv4 stack ~port tcp_cb ;
Log.info (fun m -> m "DNS server listening on TCP port %d" port) ;

let udp_cb ~src ~dst:_ ~src_port buf =
Log.info (fun m -> m "udp frame from %a:%d" Ipaddr.V4.pp src src_port) ;
let now = Ptime.v (P.now_d_ps ()) in
let elapsed = M.elapsed_ns () in
let t, answer, notify, n = Udns_server.Primary.handle_buf !state now elapsed `Udp src src_port buf in
maybe_update_state t >>= fun () ->
maybe_notify recv_task t now elapsed n >>= fun () ->
(match answer with
| None -> Log.warn (fun m -> m "empty answer") ; Lwt.return_unit
| Some answer -> Dns.send_udp stack port src src_port answer) >>= fun () ->
Lwt_list.iter_p (send_notify recv_task) notify
in
S.listen_udpv4 stack ~port udp_cb ;
Log.info (fun m -> m "DNS server listening on UDP port %d" port) ;
let rec time () =
let t, notifies = Udns_server.Primary.timer !state (M.elapsed_ns ()) in
let now = Ptime.v (P.now_d_ps ()) in
let elapsed = M.elapsed_ns () in
let t, notifies = Udns_server.Primary.timer !state now elapsed in
maybe_update_state t >>= fun () ->
Lwt_list.iter_p send_notify notifies >>= fun () ->
Lwt_list.iter_p (send_notify recv_task) notifies >>= fun () ->
TIME.sleep_ns (Duration.of_sec timer) >>= fun () ->
time ()
in
Expand All @@ -118,7 +127,6 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME :
let state = ref t in
let tcp_out = ref Dns.IM.empty in
let tcp_packet_transit = ref Dns.IM.empty in
let in_flight = ref Dns.IS.empty in

let maybe_update_state t =
let old = !state in
Expand Down Expand Up @@ -173,29 +181,22 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME :
match Dns.IM.find ip !tcp_out with
| None ->
begin
if Dns.IS.mem ip !in_flight then
Log.info (fun m -> m "creating connection to %a:%d" Ipaddr.V4.pp ip dport) ;
T.create_connection (S.tcpv4 stack) (ip, dport) >>= function
| Error e ->
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.V4.pp ip dport) ;
Lwt.async (fun () ->
TIME.sleep_ns (Duration.of_sec 5) >>= fun () ->
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why are we waiting 5 seconds here before closing?

close ip) ;
Lwt.return_unit
else begin
Log.info (fun m -> m "creating connection to %a:%d" Ipaddr.V4.pp ip dport) ;
in_flight := Dns.IS.add ip !in_flight ;
T.create_connection (S.tcpv4 stack) (ip, dport) >>= function
| Error e ->
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.V4.pp ip dport) ;
in_flight := Dns.IS.remove ip !in_flight ;
Lwt.async (fun () ->
TIME.sleep_ns (Duration.of_sec 5) >>= fun () ->
close ip) ;
| Ok flow ->
tcp_out := Dns.IM.add ip flow !tcp_out ;
Dns.send_tcp flow data >>= function
| Error () -> close ip
| Ok () ->
Lwt.async (fun () -> read_and_handle ip (Dns.of_flow flow)) ;
Lwt.return_unit
| Ok flow ->
Dns.send_tcp flow data >>= function
| Error () -> close ip
| Ok () ->
tcp_out := Dns.IM.add ip flow !tcp_out ;
in_flight := Dns.IS.remove ip !in_flight ;
Lwt.async (fun () -> read_and_handle ip (Dns.of_flow flow)) ;
Lwt.return_unit
end
end
| Some flow ->
Dns.send_tcp flow data >>= function
Expand Down Expand Up @@ -224,11 +225,12 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME :

let tcp_cb flow =
let dst_ip, dst_port = T.dst flow in
tcp_out := Dns.IM.add dst_ip flow !tcp_out ;
Log.info (fun m -> m "tcp connection from %a:%d" Ipaddr.V4.pp dst_ip dst_port) ;
let f = Dns.of_flow flow in
let rec loop () =
Dns.read_tcp f >>= function
| Error () -> Lwt.return_unit
| Error () -> tcp_out := Dns.IM.remove dst_ip !tcp_out ; Lwt.return_unit
| Ok data ->
let now = Ptime.v (P.now_d_ps ()) in
let elapsed = M.elapsed_ns () in
Expand All @@ -244,7 +246,7 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME :
| Some data ->
Dns.send_tcp flow data >>= function
| Ok () -> loop ()
| Error () -> Lwt.return_unit
| Error () -> tcp_out := Dns.IM.remove dst_ip !tcp_out ; Lwt.return_unit
in
loop ()
in
Expand Down
2 changes: 1 addition & 1 deletion resolver/udns_resolver.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -215,7 +215,7 @@ let scrub_it mode t proto zone edns ts p =
let handle_primary t now ts proto sender sport packet _request buf =
(* makes only sense to ask primary for query=true since we'll never issue questions from primary *)
let handle_inner name =
let t, answer, _, _ = Udns_server.Primary.handle_packet t ts proto sender sport packet name in
let t, answer, _, _ = Udns_server.Primary.handle_packet t now ts proto sender sport packet name in
match answer with
| None -> `None (* TODO incoming ??? are never replied to - should be revised!? *)
| Some reply ->
Expand Down
Loading