extra/dns/forwarding/forwarding.factor

   1
   2 USING: kernel sequences combinators accessors locals random
   3        combinators.short-circuit
   4        io.sockets
   5        dns dns.util dns.cache.rr dns.cache.nx
   6        dns.resolver ;
   7
   8 IN: dns.forwarding
   9
  10 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  11
  12 :: query->rrs ( QUERY -- rrs/f )
  13    [let | RRS [ QUERY cache-get ] |
  14      RRS
  15        [ RRS ]
  16        [
  17          [let | NAME  [ QUERY name>>  ]
  18                 TYPE  [ QUERY type>>  ]
  19                 CLASS [ QUERY class>> ] |
  20
  21            [let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
  22
  23              RRS/CNAME f =
  24                [ f ]
  25                [
  26                  [let | RR/CNAME [ RRS/CNAME first ] |
  27
  28                    [let | REAL-NAME [ RR/CNAME rdata>> ] |
  29
  30                      [let | RRS [
  31                                   T{ query f REAL-NAME TYPE CLASS } query->rrs
  32                                 ] |
  33
  34                        RRS
  35                          [ RRS/CNAME RRS append ]
  36                          [ f ]
  37                        if
  38                      ] ] ]
  39                ]
  40              if
  41            ] ]
  42        ]
  43      if
  44    ] ;
  45
  46 :: answer-from-cache ( MSG -- msg/f )
  47    [let | QUERY [ MSG message-query ] |
  48
  49      [let | NX  [ QUERY name>> non-existent-name? ]
  50             RRS [ QUERY query->rrs                ] |
  51
  52        {
  53          { [ NX  ] [ MSG NAME-ERROR >>rcode          ] }
  54          { [ RRS ] [ MSG RRS        >>answer-section ] }
  55          { [ t   ] [ f                               ] }
  56        }
  57        cond
  58      ]
  59    ] ;
  60
  61 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  62
  63 : message-soa ( message -- rr/soa )
  64   authority-section>> [ type>> SOA = ] filter first ;
  65
  66 ! :: cache-message ( MSG -- msg )
  67 !    MSG rcode>> NAME-ERROR =
  68 !      [
  69 !        [let | NAME [ MSG message-query name>> ]
  70 !               TTL  [ MSG message-soa   ttl>>  ] |
  71 !          NAME TTL cache-non-existent-name
  72 !        ]
  73 !      ]
  74 !    when
  75 !    MSG answer-section>>     [ cache-add ] each
  76 !    MSG authority-section>>  [ cache-add ] each
  77 !    MSG additional-section>> [ cache-add ] each
  78 !    MSG ;
  79
  80 :: cache-message ( MSG -- msg )
  81    MSG rcode>> NAME-ERROR =
  82      [
  83        [let | RR/SOA [ MSG
  84                          authority-section>>
  85                          [ type>> SOA = ] filter
  86                        dup empty? [ drop f ] [ first ] if ] |
  87          RR/SOA
  88            [
  89              [let | NAME [ MSG message-query name>> ]
  90                     TTL  [ MSG message-soa   ttl>>  ] |
  91                NAME TTL cache-non-existent-name
  92              ]
  93            ]
  94          when
  95        ]
  96      ]
  97    when
  98    MSG answer-section>>     [ cache-add ] each
  99    MSG authority-section>>  [ cache-add ] each
 100    MSG additional-section>> [ cache-add ] each
 101    MSG ;
 102
 103 ! : answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
 104
 105 : answer-from-server ( msg servers -- msg ) ask-servers cache-message ;
 106
 107 :: find-answer ( MSG SERVERS -- msg )
 108    { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
 109
 110 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 111
 112 :: start-server ( ADDR-SPEC SERVERS -- )
 113
 114   [let | SOCKET [ ADDR-SPEC <datagram> ] |
 115
 116     [
 117       SOCKET receive-packet
 118         [ parse-message SERVERS find-answer message->ba ]
 119       change-data
 120       respond
 121     ]
 122     forever
 123
 124   ] ;