extra/dns/server/server.factor

   1
   2 USING: kernel combinators sequences sets math threads namespaces continuations
   3        debugger io io.sockets unicode.case accessors destructors
   4        combinators.cleave combinators.short-circuit
   5        newfx fry
   6        dns dns.util dns.misc ;
   7
   8 IN: dns.server
   9
  10 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  11
  12 SYMBOL: records-var
  13
  14 : records ( -- records ) records-var get ;
  15
  16 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  17
  18 : {name-type-class} ( obj -- array )
  19   { [ name>> >lower ] [ type>> ] [ class>> ] } <arr> ;
  20
  21 : rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
  22
  23 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  24
  25 : matching-rrs  ( query -- rrs ) records [ rr=query? ] with filter ;
  26
  27 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  28 ! zones
  29 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  30
  31 : zones    ( -- names ) records [ type>> NS  = ] filter [ name>> ] map prune ;
  32 : my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
  33
  34 : delegated-zones ( -- names ) zones my-zones diff ;
  35
  36 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  37 ! name->zone
  38 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  39
  40 : name->zone ( name -- zone/f )
  41   zones sort-largest-first [ name-in-domain? ] with find nip ;
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44 ! name->authority
  45 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  46
  47 : name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
  48
  49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50 ! extract-names
  51 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52
  53 : rr->rdata-names ( rr -- names/f )
  54     {
  55       { [ dup type>> NS    = ] [ rdata>>            {1} ] }
  56       { [ dup type>> MX    = ] [ rdata>> exchange>> {1} ] }
  57       { [ dup type>> CNAME = ] [ rdata>>            {1} ] }
  58       { [ t ]                  [ drop f ] }
  59     }
  60   cond ;
  61
  62 : extract-rdata-names ( message -- names )
  63   [ answer-section>> ] [ authority-section>> ] bi append
  64   [ rr->rdata-names ] map concat ;
  65
  66 : extract-names ( message -- names )
  67   [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ;
  68
  69 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  70 ! fill-authority
  71 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  72
  73 : fill-authority ( message -- message )
  74   dup
  75     extract-names [ name->authority ] map concat prune
  76     over answer-section>> diff
  77   >>authority-section ;
  78
  79 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  80 ! fill-additional
  81 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  82
  83 : name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
  84
  85 : fill-additional ( message -- message )
  86   dup
  87     extract-rdata-names [ name->rrs-a ] map concat prune
  88     over answer-section>> diff
  89   >>additional-section ;
  90
  91 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  92 ! query->rrs
  93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  94
  95 DEFER: query->rrs
  96
  97 : matching-rrs? ( query -- rrs/f ) matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
  98
  99 : matching-cname? ( query -- rrs/f )
 100   [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
 101   [ empty? not ]
 102     [ 1st swap clone over rdata>> >>name query->rrs prefix-on ]
 103     [ 2drop f ]
 104   1if ;
 105
 106 : query->rrs ( query -- rrs/f ) { [ matching-rrs? ] [ matching-cname? ] } 1|| ;
 107
 108 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 109 ! have-answers
 110 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 111
 112 : have-answers ( message -- message/f )
 113   dup message-query query->rrs
 114   [ empty? ]
 115     [ 2drop f ]
 116     [ >>answer-section fill-authority fill-additional ]
 117   1if ;
 118
 119 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 120 ! have-delegates?
 121 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 122
 123 : cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
 124
 125 : is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
 126
 127 : have-ns? ( name -- rrs/f )
 128   NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
 129
 130 : name->delegates ( name -- rrs-ns )
 131     {
 132       [ "" =    { } and ]
 133       [ is-soa? { } and ]
 134       [ have-ns? ]
 135       [ cdr-name name->delegates ]
 136     }
 137   1|| ;
 138
 139 : have-delegates ( message -- message/f )
 140   dup message-query name>> name->delegates ! message rrs-ns
 141   [ empty? ]
 142     [ 2drop f ]
 143     [
 144       dup [ rdata>> A IN query boa matching-rrs ] map concat
 145                                            ! message rrs-ns rrs-a
 146       [ >>authority-section ]
 147       [ >>additional-section ]
 148       bi*
 149     ]
 150   1if ;
 151
 152 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 153 ! outsize-zones
 154 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 155
 156 : outside-zones ( message -- message/f )
 157   dup message-query name>> name->zone f =
 158     [ ]
 159     [ drop f ]
 160   if ;
 161
 162 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 163 ! is-nx
 164 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 165
 166 : is-nx ( message -- message/f )
 167   [ message-query name>> records [ name>> = ] with filter empty? ]
 168     [
 169       NAME-ERROR >>rcode
 170       dup
 171         message-query name>> name->zone SOA IN query boa matching-rrs
 172       >>authority-section
 173     ]
 174     [ drop f ]
 175   1if ;
 176
 177 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 178
 179 : none-of-type ( message -- message )
 180   dup
 181     message-query name>> name->zone SOA IN query boa matching-rrs
 182   >>authority-section ;
 183
 184 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 185
 186 : find-answer ( message -- message )
 187     {
 188       [ have-answers   ]
 189       [ have-delegates ]
 190       [ outside-zones  ]
 191       [ is-nx          ]
 192       [ none-of-type   ]
 193     }
 194   1|| ;
 195
 196 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 197
 198 : (handle-request) ( packet -- )
 199   [ [ find-answer ] with-message-bytes ] change-data respond ;
 200
 201 : handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
 202
 203 : receive-loop ( socket -- )
 204   [ receive-packet handle-request ] [ receive-loop ] bi ;
 205
 206 : loop ( addr-spec -- )
 207   [ <datagram> '[ _ [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
 208