From a474af582b1e0556f34bab59aa5a8ac2bee4540d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 19:29:33 +0200 Subject: [PATCH 01/11] Server: sign_outgoing --- server/udns_server.ml | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/server/udns_server.ml b/server/udns_server.ml index 9d9b580..18dc4c3 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -383,6 +383,18 @@ let handle_rr_update trie name = function Udns_trie.insert name k add trie end +let sign_outgoing ?max_size tsig_sign keyname key signed packet buf = + match Tsig.dnskey_to_tsig_algo key with + | Error (`Msg msg) -> + Log.err (fun m -> m "couldn't convert algorithm: %s" msg) ; None + | Ok algorithm -> + let original_id = fst packet.Packet.header in + match Tsig.tsig ~algorithm ~original_id ~signed () with + | None -> Log.err (fun m -> m "creation of tsig failed") ; None + | Some tsig -> match tsig_sign ?mac:None ?max_size keyname tsig ~key packet buf with + | None -> Log.err (fun m -> m "signing failed") ; None + | Some res -> Some res + module Notification = struct (* TODO dnskey authentication of outgoing packets (preserve in connections, name of key should be enough) *) @@ -847,19 +859,9 @@ module Secondary = struct in (create ~tsig_verify ~tsig_sign Udns_trie.empty (keys, a) rng, zones) - let maybe_sign ?max_size t name signed original_id packet buf = + let maybe_sign ?max_size t name signed packet buf = match Authentication.find_key t.auth name with - | Some key -> - begin match Tsig.dnskey_to_tsig_algo key with - | Ok algorithm -> - begin match Tsig.tsig ~algorithm ~original_id ~signed () with - | None -> Log.err (fun m -> m "creation of tsig failed") ; None - | Some tsig -> match t.tsig_sign ?mac:None ?max_size name tsig ~key packet buf with - | None -> Log.err (fun m -> m "signing failed") ; None - | Some res -> Some res - end - | Error (`Msg msg) -> Log.err (fun m -> m "couldn't convert algorithm: %s" msg) ; None - end + | Some key -> sign_outgoing ?max_size t.tsig_sign name key signed packet buf | _ -> Log.err (fun m -> m "key %a not found (or multiple)" Domain_name.pp name) ; None let header rng () = @@ -872,7 +874,7 @@ module Secondary = struct in let p = Packet.create header question `Axfr_request in let buf, max_size = Packet.encode proto p in - match maybe_sign ~max_size t name now (fst header) p buf with + match maybe_sign ~max_size t name now p buf with | None -> None | Some (buf, mac) -> Some (Requested_axfr (ts, fst header, mac), buf) @@ -882,7 +884,7 @@ module Secondary = struct in let p = Packet.create header question `Query in let buf, max_size = Packet.encode proto p in - match maybe_sign ~max_size t name now (fst header) p buf with + match maybe_sign ~max_size t name now p buf with | None -> None | Some (buf, mac) -> Some (Requested_soa (ts, fst header, retry, mac), buf) From d4ab3a3bbe06fd1bbd205c9d039c698350b6adea Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 19:57:13 +0200 Subject: [PATCH 02/11] sign --- mirage/server/udns_mirage_server.ml | 12 ++-- resolver/udns_resolver.ml | 2 +- server/udns_server.ml | 105 ++++++++++++++++------------ server/udns_server.mli | 12 ++-- 4 files changed, 75 insertions(+), 56 deletions(-) diff --git a/mirage/server/udns_mirage_server.ml b/mirage/server/udns_mirage_server.ml index 71a1bb7..b2feec5 100644 --- a/mirage/server/udns_mirage_server.ml +++ b/mirage/server/udns_mirage_server.ml @@ -55,12 +55,12 @@ 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 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 in @@ -71,7 +71,7 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME : 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 () -> + maybe_notify 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 () -> @@ -92,7 +92,7 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME : 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 maybe_update_state t >>= fun () -> - maybe_notify t elapsed n >>= fun () -> + maybe_notify t now elapsed n >>= fun () -> Lwt_list.iter_p send_notify notify >>= fun () -> match answer with | None -> Log.warn (fun m -> m "empty answer") ; loop () @@ -106,7 +106,9 @@ module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME : S.listen_tcpv4 stack ~port tcp_cb ; Log.info (fun m -> m "DNS server listening on TCP 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 () -> TIME.sleep_ns (Duration.of_sec timer) >>= fun () -> diff --git a/resolver/udns_resolver.ml b/resolver/udns_resolver.ml index 989339d..4f7a865 100644 --- a/resolver/udns_resolver.ml +++ b/resolver/udns_resolver.ml @@ -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 -> diff --git a/server/udns_server.ml b/server/udns_server.ml index 18dc4c3..0defc2a 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -383,17 +383,19 @@ let handle_rr_update trie name = function Udns_trie.insert name k add trie end -let sign_outgoing ?max_size tsig_sign keyname key signed packet buf = - match Tsig.dnskey_to_tsig_algo key with - | Error (`Msg msg) -> - Log.err (fun m -> m "couldn't convert algorithm: %s" msg) ; None - | Ok algorithm -> - let original_id = fst packet.Packet.header in - match Tsig.tsig ~algorithm ~original_id ~signed () with - | None -> Log.err (fun m -> m "creation of tsig failed") ; None - | Some tsig -> match tsig_sign ?mac:None ?max_size keyname tsig ~key packet buf with - | None -> Log.err (fun m -> m "signing failed") ; None - | Some res -> Some res +let sign_outgoing ~max_size server keyname signed packet buf = + match Authentication.find_key server.auth keyname with + | None -> Log.err (fun m -> m "key %a not found (or multiple)" Domain_name.pp keyname) ; None + | Some key -> match Tsig.dnskey_to_tsig_algo key with + | Error (`Msg msg) -> + Log.err (fun m -> m "couldn't convert algorithm: %s" msg) ; None + | Ok algorithm -> + let original_id = fst packet.Packet.header in + match Tsig.tsig ~algorithm ~original_id ~signed () with + | None -> Log.err (fun m -> m "creation of tsig failed") ; None + | Some tsig -> match server.tsig_sign ?mac:None ~max_size keyname tsig ~key packet buf with + | None -> Log.err (fun m -> m "signing failed") ; None + | Some res -> Some res module Notification = struct (* TODO dnskey authentication of outgoing packets (preserve in connections, name of key should be enough) *) @@ -478,10 +480,19 @@ module Notification = struct | xs -> Domain_name.Map.add name xs new_map) conn Domain_name.Map.empty + let encode_and_sign key_opt server now packet = + let buf, max_size = Packet.encode `Tcp packet in + match key_opt with + | None -> buf, None + | Some key -> + match sign_outgoing ~max_size server key now packet buf with + | None -> buf, None + | Some (out, mac) -> out, Some mac + (* outstanding notifications, with timestamp and retry count (at most one per zone per ip) *) type outstanding = - (int64 * int * Packet.t * Domain_name.t option) Domain_name.Map.t IPM.t + (int64 * int * Cstruct.t option * Packet.t * Domain_name.t option) Domain_name.Map.t IPM.t (* operations: - timer occured, retransmit outstanding or drop @@ -490,31 +501,32 @@ module Notification = struct *) let retransmit = Array.map Duration.of_sec [| 1 ; 3 ; 7 ; 20 ; 40 ; 60 ; 180 |] - let retransmit ns now = + let retransmit server ns now ts = let max = pred (Array.length retransmit) in IPM.fold (fun ip map (new_ns, out) -> let new_map, out = Domain_name.Map.fold - (fun name (ts, count, packet, key) (new_map, out) -> - if Int64.add ts retransmit.(count) < now then + (fun name (oldts, count, mac, packet, key) (new_map, outs) -> + if Int64.sub ts retransmit.(count) > oldts then + let out, mac = encode_and_sign key server now packet in (if count = max then begin Log.warn (fun m -> m "retransmitting notify to %a the last time %a" Ipaddr.V4.pp ip Packet.pp packet) ; new_map end else - (Domain_name.Map.add name (ts, succ count, packet, key) new_map)), - (ip, fst (Packet.encode `Udp packet)) :: out + (Domain_name.Map.add name (oldts, succ count, mac, packet, key) new_map)), + (ip, out) :: outs else - (Domain_name.Map.add name (ts, count, packet, key) new_map, out)) + (Domain_name.Map.add name (oldts, count, mac, packet, key) new_map, outs)) map (Domain_name.Map.empty, out) in (if Domain_name.Map.is_empty new_map then new_ns else IPM.add ip new_map new_ns), out) ns (IPM.empty, []) - let notify conn ns server now zone soa = + let notify conn ns server now ts zone soa = let remotes = to_notify conn ~data:server.data ~auth:server.auth zone in - Log.debug (fun m -> m "notifying %a %a" Domain_name.pp zone + Log.debug (fun m -> m "notifying %a: %a" Domain_name.pp zone Fmt.(list ~sep:(unit ",@ ") (pair ~sep:(unit ", key") Ipaddr.V4.pp (option ~none:(unit "no key") Domain_name.pp))) @@ -528,8 +540,8 @@ module Notification = struct in Packet.create header question (`Notify (Some soa)) in - let add_to_ns ns ip key = - let data = (now, 0, packet, key) in + let add_to_ns ns ip key mac = + let data = (ts, 0, mac, packet, key) in let map = match IPM.find_opt ip ns with | None -> Domain_name.Map.empty | Some map -> map @@ -538,8 +550,9 @@ module Notification = struct IPM.add ip map' ns in IPM.fold (fun ip key (ns, outs) -> - let ns = add_to_ns ns ip key in - ns, (ip, fst (Packet.encode `Udp packet)) :: outs) + let out, mac = encode_and_sign key server now packet in + let ns = add_to_ns ns ip key mac in + ns, (ip, out) :: outs) remotes (ns, []) let received_reply ns ip reply = @@ -547,7 +560,7 @@ module Notification = struct | None -> ns | Some map -> let map' = match Domain_name.Map.find (fst reply.Packet.question) map with - | Some (_, _, request, _) -> + | Some (_, _, _, request, _) -> begin match Packet.reply_matches_request ~request reply with | Ok r -> let map' = Domain_name.Map.remove (fst reply.question) map in @@ -564,6 +577,14 @@ module Notification = struct IPM.remove ip ns else IPM.add ip map' ns + + let mac ns ip reply = + match IPM.find_opt ip ns with + | None -> None + | Some map -> + match Domain_name.Map.find (fst reply.Packet.question) map with + | Some (_, _, mac, _, _) -> mac + | None -> None end let in_zone zone name = Domain_name.sub ~subdomain:name ~domain:zone @@ -641,17 +662,17 @@ module Primary = struct let data (t, _, _) = t.data - let with_data (t, l, n) now data = + let with_data (t, l, n) now ts data = (* we're the primary and need to notify our friends! *) let n', out = Udns_trie.fold Soa data (fun name soa (n, outs) -> match Udns_trie.lookup name Soa t.data with | Error _ -> - let n', outs' = Notification.notify l n t now name soa in + let n', outs' = Notification.notify l n t now ts name soa in (n', outs @ outs') | Ok old when Soa.newer ~old soa -> - let n', outs' = Notification.notify l n t now name soa in + let n', outs' = Notification.notify l n t now ts name soa in (n', outs @ outs') | Ok _ -> (n, outs)) (n, []) @@ -661,7 +682,7 @@ module Primary = struct match Udns_trie.lookup name Soa data with | Error _ -> let soa' = { soa with Soa.serial = Int32.succ soa.Soa.serial } in - let n', outs' = Notification.notify l n t now name soa' in + let n', outs' = Notification.notify l n t now ts name soa' in (n', outs @ outs') | Ok _ -> (n, outs)) (n', []) @@ -675,7 +696,7 @@ module Primary = struct let f name soa ns = Log.debug (fun m -> m "soa found for %a" Domain_name.pp name) ; (* we drop notifications, the first call to timer will solve this :) *) - fst (Notification.notify Domain_name.Map.empty ns t 0L name soa) + fst (Notification.notify Domain_name.Map.empty ns t Ptime.epoch 0L name soa) in Udns_trie.fold Rr_map.Soa data f IPM.empty in @@ -686,7 +707,7 @@ module Primary = struct | `Tcp, `K (Rr_map.K Soa) -> Ok name | _ -> Error () - let handle_packet (t, l, ns) ts proto ip _port p key = + let handle_packet (t, l, ns) now ts proto ip _port p key = match p.Packet.data with | `Query -> (* if there was a (transfer-key) signed SOA, and tcp, we add to notification list! *) @@ -711,7 +732,7 @@ module Primary = struct in let ns, out = match stuff with | None -> ns, [] - | Some (zone, soa) -> Notification.notify l ns t' ts zone soa + | Some (zone, soa) -> Notification.notify l ns t' now ts zone soa in let answer' = Packet.create (fst p.header, flags) p.question answer in (t', l, ns), Some answer', out, None @@ -752,7 +773,7 @@ module Primary = struct | Ok p -> let handle_inner keyname = let t, answer, out, notify = - handle_packet t ts proto ip port p keyname + handle_packet t now ts proto ip port p keyname in let answer = match answer with | Some answer -> @@ -765,8 +786,9 @@ module Primary = struct in t, answer, out, notify in - let server, _, _ = t in - match handle_tsig server now p buf with + let server, _, ns = t in + let mac = Notification.mac ns ip p in + match handle_tsig ?mac server now p buf with | Error (e, data) -> Log.err (fun m -> m "error %a while handling tsig" Tsig_op.pp_e e) ; t, data, [], None @@ -796,8 +818,8 @@ module Primary = struct let l' = Notification.remove l ip in (t, l', ns) - let timer (t, l, ns) now = - let ns', out = Notification.retransmit ns now in + let timer (t, l, ns) now ts = + let ns', out = Notification.retransmit t ns now ts in (t, l, ns'), out end @@ -859,11 +881,6 @@ module Secondary = struct in (create ~tsig_verify ~tsig_sign Udns_trie.empty (keys, a) rng, zones) - let maybe_sign ?max_size t name signed packet buf = - match Authentication.find_key t.auth name with - | Some key -> sign_outgoing ?max_size t.tsig_sign name key signed packet buf - | _ -> Log.err (fun m -> m "key %a not found (or multiple)" Domain_name.pp name) ; None - let header rng () = let id = Randomconv.int ~bound:(1 lsl 16 - 1) rng in id, Packet.Flags.empty @@ -874,7 +891,7 @@ module Secondary = struct in let p = Packet.create header question `Axfr_request in let buf, max_size = Packet.encode proto p in - match maybe_sign ~max_size t name now p buf with + match sign_outgoing ~max_size t name now p buf with | None -> None | Some (buf, mac) -> Some (Requested_axfr (ts, fst header, mac), buf) @@ -884,7 +901,7 @@ module Secondary = struct in let p = Packet.create header question `Query in let buf, max_size = Packet.encode proto p in - match maybe_sign ~max_size t name now p buf with + match sign_outgoing ~max_size t name now p buf with | None -> None | Some (buf, mac) -> Some (Requested_soa (ts, fst header, retry, mac), buf) diff --git a/server/udns_server.mli b/server/udns_server.mli index 1a31311..4b4c678 100644 --- a/server/udns_server.mli +++ b/server/udns_server.mli @@ -61,8 +61,8 @@ module Primary : sig val data : s -> Udns_trie.t (** [data s] is the data store of [s]. *) - val with_data : s -> int64 -> Udns_trie.t -> s * (Ipaddr.V4.t * Cstruct.t) list - (** [with_data s ts trie] replaces the current data with [trie] in [s]. + val with_data : s -> Ptime.t -> int64 -> Udns_trie.t -> s * (Ipaddr.V4.t * Cstruct.t) list + (** [with_data s now ts trie] replaces the current data with [trie] in [s]. The returned notifications should be send out. *) val create : ?keys:(Domain_name.t * Dnskey.t) list -> @@ -70,10 +70,10 @@ module Primary : sig ?tsig_sign:Tsig_op.sign -> rng:(int -> Cstruct.t) -> Udns_trie.t -> s (** [create ~keys ~a ~tsig_verify ~tsig_sign ~rng data] creates a primary server. *) - val handle_packet : s -> int64 -> proto -> Ipaddr.V4.t -> int -> + val handle_packet : s -> Ptime.t -> int64 -> proto -> Ipaddr.V4.t -> int -> Packet.t -> Domain_name.t option -> s * Packet.t option * (Ipaddr.V4.t * Cstruct.t) list * [ `Notify of Soa.t option | `Signed_notify of Soa.t option ] option - (** [handle_packet s now src src_port proto key packet] handles the given + (** [handle_packet s now ts src src_port proto key packet] handles the given [packet], returning new state, an answer, and potentially notify packets to secondary name servers. *) @@ -86,8 +86,8 @@ module Primary : sig val closed : s -> Ipaddr.V4.t -> s (** [closed s ip] marks the connection to [ip] closed. *) - val timer : s -> int64 -> s * (Ipaddr.V4.t * Cstruct.t) list - (** [timer s now] may encode some notify if they were not acknowledget by the + val timer : s -> Ptime.t -> int64 -> s * (Ipaddr.V4.t * Cstruct.t) list + (** [timer s now ts] may encode some notify if they were not acknowledget by the other side. *) end From 36568d9d8ebc658c687cce25a24fb0381af5976b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 20:10:24 +0200 Subject: [PATCH 03/11] only some mac --- server/udns_server.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/server/udns_server.ml b/server/udns_server.ml index 0defc2a..ac8e066 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -528,8 +528,8 @@ module Notification = struct let remotes = to_notify conn ~data:server.data ~auth:server.auth zone in Log.debug (fun m -> m "notifying %a: %a" Domain_name.pp zone Fmt.(list ~sep:(unit ",@ ") - (pair ~sep:(unit ", key") Ipaddr.V4.pp - (option ~none:(unit "no key") Domain_name.pp))) + (pair ~sep:(unit ", key ") Ipaddr.V4.pp + (option ~none:(unit "none") Domain_name.pp))) (IPM.bindings remotes)); let packet = let question = Packet.Question.create zone Soa @@ -787,7 +787,10 @@ module Primary = struct t, answer, out, notify in let server, _, ns = t in - let mac = Notification.mac ns ip p in + let mac = match p.Packet.data with + | `Notify_ack | `Rcode_error _ -> Notification.mac ns ip p + | _ -> None + in match handle_tsig ?mac server now p buf with | Error (e, data) -> Log.err (fun m -> m "error %a while handling tsig" Tsig_op.pp_e e) ; From 2e315ac7847d78db62edb620f65460e8d18eea92 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 20:21:04 +0200 Subject: [PATCH 04/11] . --- server/udns_server.ml | 2 +- src/udns.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/server/udns_server.ml b/server/udns_server.ml index ac8e066..b98c5c2 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -746,7 +746,7 @@ module Primary = struct | `Axfr_reply data -> Logs.warn (fun m -> m "unsolicited AXFR reply %a, ignoring" Packet.Axfr.pp data); (t, l, ns), None, [], None - | `Notify_ack -> + | `Notify_ack | `Rcode_error (Rcode.NotAuth, Opcode.Notify, _) -> let ns' = Notification.received_reply ns ip p in (t, l, ns'), None, [], None | `Notify soa -> diff --git a/src/udns.ml b/src/udns.ml index 0816e08..b302b0e 100644 --- a/src/udns.ml +++ b/src/udns.ml @@ -1172,7 +1172,7 @@ module Tsig = struct let fudge = Ptime.Span.of_int_s fudge in { algorithm ; signed ; fudge ; mac ; original_id ; error ; other }, names, - off + 16 + mac_len + other_len + off' + 16 + mac_len + other_len let encode_48bit_time buf ?(off = 0) ts = match ptime_span_to_int64 (Ptime.to_span ts) with From fb7ee203ef7061acb4e57ef9abcd925d413a93e6 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 20:29:24 +0200 Subject: [PATCH 05/11] secondary: only mac for replies --- server/udns_server.ml | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/server/udns_server.ml b/server/udns_server.ml index b98c5c2..0894376 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -1172,12 +1172,15 @@ module Secondary = struct Fmt.(option ~none:(unit "no") Packet.Query.pp) data); (t, zones), None, [] - let find_mac zones (name, _) = - match Domain_name.Map.find name zones with - | None -> None - | Some (Requested_axfr (_, _, mac), _, _) -> Some mac - | Some (Requested_soa (_, _, _, mac), _, _) -> Some mac - | _ -> None + let find_mac zones p = + match p.Packet.data with + | #Packet.request -> None + | #Packet.reply -> + match Domain_name.Map.find (fst p.question) zones with + | None -> None + | Some (Requested_axfr (_, _, mac), _, _) -> Some mac + | Some (Requested_soa (_, _, _, mac), _, _) -> Some mac + | _ -> None let handle_buf t now ts proto ip buf = match @@ -1200,7 +1203,7 @@ module Secondary = struct t, answer, out in let server, zones = t in - let mac = find_mac zones p.question in + let mac = find_mac zones p in match handle_tsig ?mac server now p buf with | Error (e, data) -> Logs.err (fun m -> m "error %a while handling tsig" Tsig_op.pp_e e) ; From 51b08227f4f2322af6182105263713962944447a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 20:47:03 +0200 Subject: [PATCH 06/11] debug --- tsig/udns_tsig.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/tsig/udns_tsig.ml b/tsig/udns_tsig.ml index 07105f4..0bc5fce 100644 --- a/tsig/udns_tsig.ml +++ b/tsig/udns_tsig.ml @@ -49,7 +49,10 @@ let sign ?mac ?max_size name tsig ~key p buf = - only question is preserved - _one_ additional, the TSIG itself *) match add_tsig ?max_size name tsig buf with - | Some out -> Some (out, mac) + | Some out -> + Log.debug (fun m -> m "dns_tsig sign for %X: %a" + (fst p.Packet.header) Cstruct.hexdump_pp mac); + Some (out, mac) | None -> match p.Packet.data with | #Packet.request -> @@ -76,7 +79,10 @@ let sign ?mac ?max_size name tsig ~key p buf = Fmt.(option ~none:(unit "none") int) max_size Cstruct.hexdump_pp new_buf) ; None - | Some out -> Some (out, mac) + | Some out -> + Log.debug (fun m -> m "dns_tsig sign for %X: %a" + (fst p.header) Cstruct.hexdump_pp mac); + Some (out, mac) let verify_raw ?mac now name ~key tsig tbs = Rresult.R.of_option ~none:(fun () -> Error (`Bad_key (name, tsig))) @@ -85,6 +91,10 @@ let verify_raw ?mac now name ~key tsig tbs = Cstruct.BE.set_uint16 tbs 10 (pred ac) ; let prep = mac_to_prep mac in let computed = compute_tsig name tsig ~key:priv (Cstruct.append prep tbs) in + Log.debug (fun m -> m "incoming mac %a@.computed is@.%a@.tsig mac@.%a" + Fmt.(option ~none:(unit "no") Cstruct.hexdump_pp) mac + Cstruct.hexdump_pp computed + Cstruct.hexdump_pp tsig.Tsig.mac); let mac = tsig.Tsig.mac in guard (Cstruct.len mac = Cstruct.len computed) (`Bad_truncation (name, tsig)) >>= fun () -> guard (Cstruct.equal computed mac) (`Invalid_mac (name, tsig)) >>= fun () -> From 9041578693ab2b3dd44955c46968bffedb2286c7 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 21:12:06 +0200 Subject: [PATCH 07/11] . --- server/udns_server.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/server/udns_server.ml b/server/udns_server.ml index 0894376..2ce2c66 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -987,11 +987,17 @@ module Secondary = struct Domain_name.pp zone) ; (* TODO should we look in zones and if there's a fresh Requested_soa, leave it as is? *) let zones, out = - match query_soa t `Tcp now ts zone name with - | None -> zones, [] - | Some (st, buf) -> - Domain_name.Map.add zone (st, ip, name) zones, - [ (`Tcp, ip, buf) ] + match Domain_name.Map.find zone zones with + | None | Some (Transferred _, _, _) -> + begin match query_soa t `Tcp now ts zone name with + | None -> zones, [] + | Some (st, buf) -> + Domain_name.Map.add zone (st, ip, name) zones, + [ (`Tcp, ip, buf) ] + end + | Some _ -> + Log.warn (fun m -> m "already in zones requesting, skipping"); + zones, [] in Ok (zones, out) | Some (_, ip', _) -> From a5cfccb23526cafd4443a8ca7b9dea4c6aa01ebe Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 21:48:26 +0200 Subject: [PATCH 08/11] server: improve notify handling, esp if signed and soa is around --- server/udns_server.ml | 118 +++++++++++++++++++++++++++++++++--------- 1 file changed, 94 insertions(+), 24 deletions(-) diff --git a/server/udns_server.ml b/server/udns_server.ml index 2ce2c66..2c192c5 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -974,36 +974,106 @@ module Secondary = struct in t, out - let handle_notify t zones now ts ip (zone, typ) _notify = + let handle_notify t zones now ts ip (zone, typ) notify keyname = match typ with | `K (Rr_map.K Soa) -> - begin match Domain_name.Map.find zone zones with - | None -> (* we don't know anything about the notified zone *) + let kzone = match keyname with + | None -> None + | Some key -> match Authentication.find_zone_ips key with + | Some (z, _, _) -> Some (key, z) + | None -> None + in + begin match Domain_name.Map.find zone zones, kzone with + | None, None -> + (* we don't know anything about the notified zone *) Log.warn (fun m -> m "ignoring notify for %a, no such zone" - Domain_name.pp zone) ; + Domain_name.pp zone); Error Rcode.Refused - | Some (_, ip', name) when Ipaddr.V4.compare ip ip' = 0 -> - Log.debug (fun m -> m "received notify for %a, replying and requesting SOA" - Domain_name.pp zone) ; - (* TODO should we look in zones and if there's a fresh Requested_soa, leave it as is? *) - let zones, out = - match Domain_name.Map.find zone zones with - | None | Some (Transferred _, _, _) -> + | None, Some (kname, kzone) -> + if Domain_name.(equal root kzone) then + (* new zone, let's AXFR directly! *) + let r = match axfr t `Tcp now ts zone kname with + | None -> + Log.warn (fun m -> m "new zone %a, couldn't AXFR" Domain_name.pp zone); + zones, [] + | Some (st, buf) -> + Domain_name.Map.add zone (st, ip, kname) zones, + [ `Tcp, ip, buf ] + in + Ok r + else begin + Log.warn (fun m -> m "ignoring notify for %a, (key %a, kzone %a): no such zone" + Domain_name.pp zone Domain_name.pp kname Domain_name.pp kzone); + Error Rcode.Refused + end + | Some (Transferred _, ip', name), None -> + if Ipaddr.V4.compare ip ip' = 0 then begin + Log.debug (fun m -> m "received notify for %a, replying and requesting SOA" + Domain_name.pp zone) ; + let zones, out = + match query_soa t `Tcp now ts zone name with + | None -> zones, [] + | Some (st, buf) -> + Domain_name.Map.add zone (st, ip, name) zones, + [ `Tcp, ip, buf ] + in + Ok (zones, out) + end else begin + Log.warn (fun m -> m "ignoring notify for %a from %a (%a is primary)" + Domain_name.pp zone Ipaddr.V4.pp ip Ipaddr.V4.pp ip'); + Error Rcode.Refused + end + | Some _, None -> + Log.warn (fun m -> m "received unsigned notify, but %a already in progress" + Domain_name.pp zone); + Ok (zones, []) + | Some (st, ip', name), Some _ -> + if Ipaddr.V4.compare ip ip' = 0 then begin + (* we received a signed notify! let's check SOA if present, and act *) + match st, notify, Udns_trie.lookup zone Rr_map.Soa t.data with + | Transferred _, None, _ -> begin match query_soa t `Tcp now ts zone name with - | None -> zones, [] + | None -> + Log.warn (fun m -> m "received signed notify for %a, but couldn't sign soa?" Domain_name.pp zone); + Ok (zones, []) | Some (st, buf) -> - Domain_name.Map.add zone (st, ip, name) zones, - [ (`Tcp, ip, buf) ] + Ok (Domain_name.Map.add zone (st, ip, name) zones, + [ `Tcp, ip, buf ]) end - | Some _ -> - Log.warn (fun m -> m "already in zones requesting, skipping"); - zones, [] - in - Ok (zones, out) - | Some (_, ip', _) -> - Log.warn (fun m -> m "ignoring notify for %a from %a (%a is primary)" - Domain_name.pp zone Ipaddr.V4.pp ip Ipaddr.V4.pp ip') ; - Error Rcode.Refused + | _, None, _ -> + Log.warn (fun m -> m "received signed notify for %a, but no SOA (already in progress)" + Domain_name.pp zone); + Ok (zones, []) + | _, Some soa, Error _ -> + Log.info (fun m -> m "received signed notify for %a, soa %a couldn't find a local SOA" + Domain_name.pp zone Soa.pp soa); + begin match axfr t `Tcp now ts zone name with + | None -> + Log.warn (fun m -> m "received signed notify for %a, but couldn't sign axfr" Domain_name.pp zone); + Ok (zones, []) + | Some (st, buf) -> + Ok (Domain_name.Map.add zone (st, ip, name) zones, + [ `Tcp, ip, buf ]) + end + | _, Some soa, Ok old -> + if Soa.newer ~old soa then + match axfr t `Tcp now ts zone name with + | None -> + Log.warn (fun m -> m "received signed notify for %a, but couldn't sign axfr" Domain_name.pp zone); + Ok (zones, []) + | Some (st, buf) -> + Log.info (fun m -> m "received signed notify for %a, axfr" Domain_name.pp zone); + Ok (Domain_name.Map.add zone (st, ip, name) zones, + [ `Tcp, ip, buf ]) + else begin + Log.warn (fun m -> m "received signed notify for %a with SOA %a not newer %a" Domain_name.pp zone Soa.pp soa Soa.pp old); + Ok (Domain_name.Map.add zone (Transferred ts, ip, name) zones, []) + end + end else begin + Log.warn (fun m -> m "ignoring notify for %a from %a (%a is primary)" + Domain_name.pp zone Ipaddr.V4.pp ip Ipaddr.V4.pp ip'); + Error Rcode.Refused + end end | _ -> Log.warn (fun m -> m "ignoring notify %a" Packet.Question.pp (zone, typ)); @@ -1164,7 +1234,7 @@ module Secondary = struct Log.warn (fun m -> m "ignoring update reply (we'll never send updates out)"); (t, zones), None, [] | `Notify n -> - let zones, flags, answer, out = match handle_notify t zones now ts ip p.question n with + let zones, flags, answer, out = match handle_notify t zones now ts ip p.question n keyname with | Ok (zones, out) -> zones, authoritative, `Notify_ack, out | Error rcode -> zones, err_flags rcode, `Rcode_error (rcode, Opcode.Notify, None), [] in From 272b38d2469a6e5c313099952a8f22d9017bf51f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 21:59:47 +0200 Subject: [PATCH 09/11] meh --- mirage/server/udns_mirage_server.ml | 41 ++++++++++++----------------- 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/mirage/server/udns_mirage_server.ml b/mirage/server/udns_mirage_server.ml index b2feec5..e3ed638 100644 --- a/mirage/server/udns_mirage_server.ml +++ b/mirage/server/udns_mirage_server.ml @@ -120,7 +120,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 @@ -175,29 +174,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 () -> + 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 @@ -226,11 +218,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 @@ -246,7 +239,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 From 4c02b3c66e0755d6e1e10a2a0a931996eacfa865 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 22:36:23 +0200 Subject: [PATCH 10/11] primary mirage revise --- mirage/server/udns_mirage_server.ml | 87 ++++++++++++++++------------- 1 file changed, 47 insertions(+), 40 deletions(-) diff --git a/mirage/server/udns_mirage_server.ml b/mirage/server/udns_mirage_server.ml index e3ed638..b6f6003 100644 --- a/mirage/server/udns_mirage_server.ml +++ b/mirage/server/udns_mirage_server.ml @@ -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 @@ -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 = @@ -55,62 +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 now 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 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 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 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 now 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 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 From 445035a96f3aab000aa97d84a548e966fe81756e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Apr 2019 23:26:48 +0200 Subject: [PATCH 11/11] server: register SOA . to all zones, also notify such a client with all zones --- server/udns_server.ml | 51 ++++++++++++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 15 deletions(-) diff --git a/server/udns_server.ml b/server/udns_server.ml index 2c192c5..5f8477f 100644 --- a/server/udns_server.ml +++ b/server/udns_server.ml @@ -524,17 +524,10 @@ module Notification = struct out) ns (IPM.empty, []) - let notify conn ns server now ts zone soa = - let remotes = to_notify conn ~data:server.data ~auth:server.auth zone in - Log.debug (fun m -> m "notifying %a: %a" Domain_name.pp zone - Fmt.(list ~sep:(unit ",@ ") - (pair ~sep:(unit ", key ") Ipaddr.V4.pp - (option ~none:(unit "none") Domain_name.pp))) - (IPM.bindings remotes)); + let notify_one ns server now ts zone soa ip key = let packet = let question = Packet.Question.create zone Soa and header = - (* TODO: all are getting the same ID *) let id = Randomconv.int ~bound:(1 lsl 16 - 1) server.rng in (id, authoritative) in @@ -549,10 +542,20 @@ module Notification = struct let map' = Domain_name.Map.add zone data map in IPM.add ip map' ns in + let out, mac = encode_and_sign key server now packet in + let ns = add_to_ns ns ip key mac in + (ns, (ip, out)) + + let notify conn ns server now ts zone soa = + let remotes = to_notify conn ~data:server.data ~auth:server.auth zone in + Log.debug (fun m -> m "notifying %a: %a" Domain_name.pp zone + Fmt.(list ~sep:(unit ",@ ") + (pair ~sep:(unit ", key ") Ipaddr.V4.pp + (option ~none:(unit "none") Domain_name.pp))) + (IPM.bindings remotes)); IPM.fold (fun ip key (ns, outs) -> - let out, mac = encode_and_sign key server now packet in - let ns = add_to_ns ns ip key mac in - ns, (ip, out) :: outs) + let ns, out = notify_one ns server now ts zone soa ip key in + ns, out :: outs) remotes (ns, []) let received_reply ns ip reply = @@ -711,10 +714,28 @@ module Primary = struct match p.Packet.data with | `Query -> (* if there was a (transfer-key) signed SOA, and tcp, we add to notification list! *) - let l' = match tcp_soa_query proto p.question, key with + let l', ns', outs = match tcp_soa_query proto p.question, key with | Ok zone, Some key when Authentication.is_op `Transfer key -> - Notification.insert ~data:t.data ~auth:t.auth l ~zone ~key ip - | _ -> l + let zones, notify = + if Domain_name.(equal root zone) then + Udns_trie.fold Soa t.data (fun name soa (zs, n) -> + Domain_name.Set.add name zs, (name, soa)::n) + (Domain_name.Set.empty, []) + else + Domain_name.Set.singleton zone, [] + in + let l' = Domain_name.Set.fold (fun zone l -> + Notification.insert ~data:t.data ~auth:t.auth l ~zone ~key ip) + zones l + in + let ns, outs = + List.fold_left (fun (ns, outs) (name, soa) -> + let ns, out = Notification.notify_one ns t now ts name soa ip (Some key) in + ns, out :: outs) + (ns, []) notify + in + l', ns, outs + | _ -> l, ns, [] in let answer = let flags, data, additional = match handle_question t p.question with @@ -723,7 +744,7 @@ module Primary = struct in Packet.create ?additional (fst p.header, flags) p.question data in - (t, l', ns), Some answer, [], None + (t, l', ns'), Some answer, outs, None | `Update u -> let t', (flags, answer), stuff = match handle_update t proto key p.question u with