From 9f131b7e45ec95d9600e0dbf212c232c64652399 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 18 Oct 2008 12:54:05 -0500
Subject: [PATCH] dns.forwarding: Check in rewritten version

---
 extra/dns/forwarding/forwarding.factor | 167 ++++++++++++-------------
 1 file changed, 82 insertions(+), 85 deletions(-)

diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor
index 87f9821153..d22de16eb5 100644
--- a/extra/dns/forwarding/forwarding.factor
+++ b/extra/dns/forwarding/forwarding.factor
@@ -1,105 +1,102 @@
 
-USING: combinators.short-circuit kernel
-       combinators
-       vectors
-       sequences
+USING: kernel sequences combinators accessors locals random
+       combinators.short-circuit
        io.sockets
-       accessors
-       combinators.lib
-       newfx
-       dns dns.cache dns.misc ;
+       dns dns.util dns.cache.rr dns.cache.nx ;
 
 IN: dns.forwarding
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! DNS server - caching, forwarding
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: (socket) ( -- vec ) V{ f } ;
-
-: socket ( -- socket ) (socket) 1st ;
-
-: init-socket-on-port ( port -- )
-  f swap <inet4> <datagram> 0 (socket) as-mutate ;
-
-: init-socket ( -- ) 53 init-socket-on-port ;
+: forever ( quot -- ) [ call ] [ forever ] bi ;         inline recursive
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: (upstream-server) ( -- vec ) V{ f } ;
+:: query->rrs ( QUERY -- rrs/f )
+   [let | RRS [ QUERY cache-get ] |
+     RRS
+       [ RRS ]
+       [
+         [let | NAME  [ QUERY name>>  ]
+                TYPE  [ QUERY type>>  ]
+                CLASS [ QUERY class>> ] |
+               
+           [let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
 
-: upstream-server ( -- ip ) (upstream-server) 1st ;
+             RRS/CNAME f =
+               [ f ]
+               [
+                 [let | RR/CNAME [ RRS/CNAME first ] |
+            
+                   [let | REAL-NAME [ RR/CNAME rdata>> ] |
+              
+                     [let | RRS [
+                                  T{ query f REAL-NAME TYPE CLASS } query->rrs
+                                ] |
 
-: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
+                       RRS
+                         [ RRS/CNAME RRS append ]
+                         [ f ]
+                       if
+                     ] ] ]
+               ]
+             if
+           ] ]
+       ]
+     if
+   ] ;
 
-: init-upstream-server ( -- )
-  upstream-server not
-    [ resolv-conf-server set-upstream-server ]
-  when ;
+:: answer-from-cache ( MSG -- msg/f )
+   [let | QUERY [ MSG message-query ] |
+
+     [let | NX  [ QUERY name>> non-existent-name? ]
+            RRS [ QUERY query->rrs                ] |
+
+       {
+         { [ NX  ] [ MSG NAME-ERROR >>rcode          ] }
+         { [ RRS ] [ MSG RRS        >>answer-section ] }
+         { [ t   ] [ f                               ] }
+       }
+       cond
+     ]
+   ] ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
+: message-soa ( message -- rr/soa )
+  authority-section>> [ type>> SOA = ] filter first ;
+
+:: cache-message ( MSG -- msg )
+   MSG rcode>> NAME-ERROR =
+     [
+       [let | NAME [ MSG message-query name>> ]
+              TTL  [ MSG message-soa   ttl>>  ] |
+         NAME TTL cache-non-existent-name
+       ]
+     ]
+   when
+   MSG answer-section>>     [ cache-add ] each
+   MSG authority-section>>  [ cache-add ] each
+   MSG additional-section>> [ cache-add ] each
+   MSG ;
+
+: answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
+
+:: find-answer ( MSG SERVERS -- msg )
+   { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-server ( ADDR-SPEC SERVERS -- )
+
+  [let | SOCKET [ ADDR-SPEC <datagram> ] |
 
-: query->answer/cache ( query -- rrs/NX/f )
-  dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
-    [ nip ]
     [
-      drop
-      dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
-        [ nip ]
-        [                                       ! query rrs
-          tuck                                  ! rrs query rrs
-          1st                                   ! rrs query rr/cname
-          rdata>>                               ! rrs query name
-          >r clone r> >>name                    ! rrs query
-          query->answer/cache                   ! rrs rrs/NX/f
-          dup rrs? [ append ] [ nip ] if
-        ]
-      if
+      SOCKET receive-packet
+        [ parse-message SERVERS find-answer message->ba ]
+      change-data
+      respond
     ]
-  if ;
+    forever
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: answer-from-cache ( message -- message/f )
-  dup message-query                        ! message query
-  dup query->answer/cache                  ! message query rrs/NX/f
-    {
-      { [ dup f = ]  [ 3drop f ] }
-      { [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
-      { [ t ]        [ nip >>answer-section ] }
-    }
-  cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: answer-from-server ( message -- message )
-  upstream-server ask-server
-  cache-message ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: find-answer ( message -- message )
-  dup answer-from-cache dup
-    [ nip ]
-    [ drop answer-from-server ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: loop ( -- )
-  socket receive                              ! byte-array addr-spec
-  swap                                        ! addr-spec byte-array
-  parse-message                               ! addr-spec message
-  find-answer                                 ! addr-spec message
-  message->ba                                 ! addr-spec byte-array
-  swap                                        ! byte-array addr-spec
-  socket send
-  loop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start ( -- ) init-socket init-upstream-server loop ;
-
-MAIN: start
\ No newline at end of file
+  ] ;