Merge branch 'master' of git://factorcode.org/git/factor

extra/dns/misc/misc.factor

@@ -1,8 +1,11 @@
 
-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
@@ -10,3 +13,22 @@ IN: dns.misc
   [ 2nd ] map ;
 
 : 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? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/dns/server/server.factor

@@ -1,14 +1,9 @@
 
-USING: kernel
+USING: kernel combinators sequences sets math
-       combinators
+       io.sockets unicode.case accessors
-       sequences
-       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
+  dup message-query query->rrs
-  [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ;
+  [ empty? ]
+    [ 2drop f ]
+    [ >>answer-section fill-authority fill-additional ]
+  1if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! have-delegates?
@@ -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|| ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

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
 
@@ -9,3 +9,11 @@ IN: dns.util
 MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
 
 ! : 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@ > ;