dns.server: Zone words. fill-authority. fill-additional.

diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor
index 90731cec43a3b40441b392500d0302e7e9db95d4..6e62513a80633dcb43c12165470429b7658b771c 100644 (file)
--- a/extra/dns/misc/misc.factor
+++ b/extra/dns/misc/misc.factor
@@ -1,12 +1,34 @@
 
-USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
+USING: kernel combinators sequences splitting math 
+       io.files io.encodings.utf8 random newfx dns.util ;
 
 IN: dns.misc
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : resolv-conf-servers ( -- seq )
   "/etc/resolv.conf" utf8 file-lines
   [ " " split ] map
   [ 1st "nameserver" = ] filter
   [ 2nd ] map ;
 
-: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
\ No newline at end of file
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: domain-has-name? ( domain name -- ? )
+    {
+      { [ 2dup =       ] [ 2drop t ] }
+      { [ 2dup longer? ] [ 2drop f ] }
+      { [ t            ] [ cdr-name domain-has-name? ] }
+    }
+  cond ;
+
+: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index e1c32af970c9335872544cfd3c555d594403d695..1e7d9cb622cf2c3d2b986bf55aa8ebd24d3c30de 100644 (file)
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -1,14 +1,9 @@
 
-USING: kernel
-       combinators
-       sequences
-       math
-       io.sockets
-       unicode.case
-       accessors
+USING: kernel combinators sequences sets math
+       io.sockets unicode.case accessors
        combinators.cleave combinators.lib
        newfx
-       dns dns.util ;
+       dns dns.util dns.misc ;
 
 IN: dns.server
 
@@ -27,6 +22,53 @@ IN: dns.server
 
 : matching-rrs  ( query -- rrs ) records [ rr=query? ] with filter ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zones    ( -- names ) records [ type>> NS  = ] filter [ name>> ] map prune ;
+: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
+
+: delegated-zones ( -- names ) zones my-zones diff ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! name->zone
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->zone ( name -- zone/f )
+  zones sort-largest-first [ name-in-domain? ] with find nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-authority
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-authority ( message -- message )
+  [ ]
+  [ message-query name>> name->zone NS IN query boa matching-rrs ]
+  [ answer-section>> ]
+  tri
+  diff >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-additional
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rr->rdata-names ( rr -- names/f )
+    {
+      { [ dup type>> NS = ] [ rdata>>            {1} ] }
+      { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
+      { [ t ]               [ drop f ] }
+    }
+  cond ;
+
+: fill-additional ( message -- message )
+  dup
+  [ answer-section>> ] [ authority-section>> ] bi append
+  [ rr->rdata-names ] map concat
+  [ A IN query boa matching-rrs ] map concat prune
+  over answer-section>> diff
+  >>additional-section ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! query->rrs
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -48,9 +90,16 @@ DEFER: query->rrs
 ! have-answers
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+! : have-answers ( message -- message/f )
+!   dup message-query query->rrs        ! message rrs/f
+!   [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ;
+
 : have-answers ( message -- message/f )
-  dup message-query query->rrs        ! message rrs/f
-  [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ;
+  dup message-query query->rrs
+  [ empty? ]
+    [ 2drop f ]
+    [ >>answer-section fill-authority fill-additional ]
+  1if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! have-delegates?
@@ -64,13 +113,13 @@ DEFER: query->rrs
   NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
 
 : name->delegates ( name -- rrs-ns )
-  {
-    [ "" =    { } and ]
-    [ is-soa? { } and ]
-    [ have-ns? ]
-    [ cdr-name name->delegates ]
-  }
-    1|| ;
+    {
+      [ "" =    { } and ]
+      [ is-soa? { } and ]
+      [ have-ns? ]
+      [ cdr-name name->delegates ]
+    }
+  1|| ;
 
 : have-delegates ( message -- message/f )
   dup message-query name>> name->delegates ! message rrs-ns
@@ -85,20 +134,49 @@ DEFER: query->rrs
     ]
   1if ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! outsize-zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: outside-zones ( message -- message/f )
+  dup message-query name>> name->zone f =
+    [ ]
+    [ drop f ]
+  if ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! is-nx
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : is-nx ( message -- message/f )
   [ message-query name>> records [ name>> = ] with filter empty? ]
-    [ NAME-ERROR >>rcode ]
+    [
+      NAME-ERROR >>rcode
+      dup
+        message-query name>> name->zone SOA IN query boa matching-rrs
+      >>authority-section
+    ]
     [ drop f ]
   1if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: none-of-type ( message -- message )
+  dup
+    message-query name>> name->zone SOA IN query boa matching-rrs
+  >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : find-answer ( message -- message )
-    { [ have-answers ] [ have-delegates ] [ is-nx ] [ ] } 1|| ;
+    {
+      [ have-answers   ]
+      [ have-delegates ]
+      [ outside-zones  ]
+      [ is-nx          ]
+      [ none-of-type   ]
+    }
+  1|| ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor
index bee1cc111ec3500c628d5aada2a6d95fdd69490a..5933216a3cc85e691fb6ac8a2ae9ee7d464d012d 100644 (file)
--- a/extra/dns/util/util.factor
+++ b/extra/dns/util/util.factor
@@ -1,5 +1,5 @@
 
-USING: kernel macros fry ;
+USING: kernel sequences sorting math math.order macros fry ;
 
 IN: dns.util
 
@@ -8,4 +8,12 @@ IN: dns.util
 
 MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
 
-! : 1if ( test then else -- ) >r >r >r dup r> call r> r> if ; inline ;
\ No newline at end of file
+! : 1if ( test then else -- ) >r >r >r dup r> call r> r> if ; inline ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sort-largest-first ( seq -- seq ) [ [ length ] compare ] sort reverse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: longer? ( seq seq -- ? ) [ length ] bi@ > ; 
\ No newline at end of file