extra/dns/dns.factor

   1 ! Copyright (C) 2010 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.enums alien.syntax arrays calendar
   4 combinators combinators.smart constructors destructors grouping
   5 io io.binary io.encodings.binary io.encodings.string
   6 io.encodings.utf8 io.sockets io.sockets.private
   7 io.streams.byte-array io.timeouts kernel make math math.bitwise
   8 math.parser namespaces nested-comments random sequences
   9 slots.syntax splitting system vectors vocabs.loader ;
  10 IN: dns
  11
  12 ENUM: dns-type
  13 { A 1 } { NS 2 } { MD 3 } { MF 4 }
  14 { CNAME 5 } { SOA 6 } { MB 7 } { MG 8 }
  15 { MR 9 } { NULL 10 } { WKS 11 } { PTR 12 }
  16 { HINFO 13 } { MINFO 14 } { MX 15 } { TXT 16 }
  17 { RP 17 } { AFSDB 18 } { SIG 24 } { KEY 25 }
  18 { AAAA 28 } { LOC 29 } { SVR 33 } { NAPTR 35 }
  19 { KX 36 } { CERT 37 } { DNAME 39 } { OPT 41 }
  20 { APL 42 } { DS 43 } { SSHFP 44 } { IPSECKEY 45 }
  21 { RRSIG 46 } { NSEC 47 } { DNSKEY 48 } { DHCID 49 }
  22 { NSEC3 50 } { NSEC3PARAM 51 } { HIP 55 } { SPF 99 }
  23 { TKEY 249 } { TSIG 250 } { IXFR 251 }
  24 { TA 32768 } { DLV 32769 } ;
  25
  26 ENUM: dns-class { IN 1 } { CS 2 } { CH 3 } { HS 4 } ;
  27
  28 ENUM: dns-opcode QUERY IQUERY STATUS ;
  29
  30 ENUM: dns-rcode NO-ERROR FORMAT-ERROR SERVER-FAILURE
  31 NAME-ERROR NOT-IMPLEMENTED REFUSED ;
  32
  33 SYMBOL: dns-servers
  34
  35 : add-dns-server ( string -- )
  36     dns-servers get push ;
  37
  38 : remove-dns-server ( string -- )
  39     dns-servers get remove! drop ;
  40
  41 : clear-dns-servers ( -- )
  42     V{ } clone dns-servers set-global ;
  43
  44 : >dotted ( domain -- domain' )
  45     dup "." tail? [ "." append ] unless ;
  46
  47 : dotted> ( string -- string' )
  48     "." ?tail drop ;
  49
  50 TUPLE: query name type class ;
  51 CONSTRUCTOR: query ( name type class -- obj )
  52     [ >dotted ] change-name ;
  53
  54 TUPLE: rr name type class ttl rdata ;
  55
  56 TUPLE: hinfo cpu os ;
  57
  58 TUPLE: mx preference exchange ;
  59
  60 TUPLE: soa mname rname serial refresh retry expire minimum ;
  61
  62 TUPLE: a name ;
  63 CONSTRUCTOR: a ( name -- obj ) ;
  64
  65 TUPLE: aaaa name ;
  66 CONSTRUCTOR: aaaa ( name -- obj ) ;
  67
  68 TUPLE: cname name ;
  69 CONSTRUCTOR: cname ( name -- obj ) ;
  70
  71 TUPLE: ptr name ;
  72 CONSTRUCTOR: ptr ( name -- obj ) ;
  73
  74 TUPLE: ns name ;
  75 CONSTRUCTOR: ns ( name -- obj ) ;
  76
  77 TUPLE: message id qr opcode aa tc rd ra z rcode
  78 query answer-section authority-section additional-section ;
  79
  80 CONSTRUCTOR: message ( query -- obj )
  81     16 2^ random >>id
  82     0 >>qr
  83     QUERY >>opcode
  84     0 >>aa
  85     0 >>tc
  86     1 >>rd
  87     0 >>ra
  88     0 >>z
  89     NO-ERROR >>rcode
  90     [ dup sequence? [ 1array ] unless ] change-query
  91     { } >>answer-section
  92     { } >>authority-section
  93     { } >>additional-section ;
  94
  95 : message>header ( message -- n )
  96     [
  97         {
  98             [ qr>> 15 shift ]
  99             [ opcode>> enum>number 11 shift ]
 100             [ aa>> 10 shift ]
 101             [ tc>> 9 shift ]
 102             [ rd>> 8 shift ]
 103             [ ra>> 7 shift ]
 104             [ z>> 4 shift ]
 105             [ rcode>> enum>number 0 shift ]
 106         } cleave
 107     ] sum-outputs ;
 108
 109 : header>message-parts ( n -- qr opcode aa tc rd ra z rcode )
 110     {
 111         [ -15 shift BIN: 1 bitand ]
 112         [ -11 shift BIN: 111 bitand <dns-opcode> ]
 113         [ -10 shift BIN: 1 bitand ]
 114         [ -9 shift BIN: 1 bitand ]
 115         [ -8 shift BIN: 1 bitand ]
 116         [ -7 shift BIN: 1 bitand ]
 117         [ -4 shift BIN: 111 bitand ]
 118         [ BIN: 1111 bitand <dns-rcode> ]
 119     } cleave ;
 120
 121 : byte-array>ipv4 ( byte-array -- string )
 122     [ number>string ] { } map-as "." join ;
 123
 124 : byte-array>ipv6 ( byte-array -- string )
 125     2 group [ be> >hex ] { } map-as ":" join ;
 126
 127 : ipv4>byte-array ( string -- byte-array )
 128     "." split [ string>number ] B{ } map-as ;
 129
 130 : ipv6>byte-array ( string -- byte-array )
 131     T{ inet6 } inet-pton ;
 132
 133 : expand-ipv6 ( ipv6 -- ipv6' ) ipv6>byte-array byte-array>ipv6 ;
 134
 135 : reverse-ipv4 ( string -- string )
 136     ipv4>byte-array reverse byte-array>ipv4 ;
 137
 138 CONSTANT: ipv4-arpa-suffix ".in-addr.arpa"
 139
 140 : ipv4>arpa ( string -- string )
 141     reverse-ipv4 ipv4-arpa-suffix append ;
 142
 143 CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
 144
 145 : ipv6>arpa ( string -- string )
 146     ipv6>byte-array [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
 147     B{ } concat-as reverse
 148     [ >hex ] { } map-as "." join ipv6-arpa-suffix append ;
 149
 150 : trim-ipv4-arpa ( string -- string' )
 151     dotted> ipv4-arpa-suffix ?tail drop ;
 152
 153 : trim-ipv6-arpa ( string -- string' )
 154     dotted> ipv6-arpa-suffix ?tail drop ;
 155
 156 : arpa>ipv4 ( string -- ip ) trim-ipv4-arpa reverse-ipv4 ;
 157
 158 : arpa>ipv6 ( string -- ip )
 159     trim-ipv6-arpa "." split 2 group reverse
 160     [
 161         first2 swap [ hex> ] bi@ [ 4 shift ] [ ] bi* bitor
 162     ] B{ } map-as byte-array>ipv6 ;
 163
 164 : parse-length-bytes ( -- sequence ) read1 read utf8 decode ;
 165
 166 : (parse-name) ( -- )
 167     peek1 [
 168         read1 drop
 169     ] [
 170         HEX: C0 mask? [
 171             2 read be> HEX: 3fff bitand
 172             seek-absolute [ parse-length-bytes , (parse-name) ] with-input-seek
 173         ] [
 174             parse-length-bytes , (parse-name)
 175         ] if
 176     ] if-zero ;
 177
 178 : parse-name ( -- sequence )
 179     [ (parse-name) ] { } make "." join ;
 180
 181 : parse-query ( -- query )
 182     parse-name
 183     2 read be> <dns-type>
 184     2 read be> <dns-class> <query> ;
 185
 186 : parse-soa ( -- soa )
 187     soa new
 188         parse-name >>mname
 189         parse-name >>rname
 190         4 read be> >>serial
 191         4 read be> >>refresh
 192         4 read be> >>retry
 193         4 read be> >>expire
 194         4 read be> >>minimum ;
 195
 196 : parse-mx ( -- mx )
 197     mx new
 198         2 read be> >>preference
 199         parse-name >>exchange ;
 200
 201 GENERIC: parse-rdata ( n type -- obj )
 202
 203 M: object parse-rdata drop read ;
 204 M: A parse-rdata 2drop 4 read byte-array>ipv4 <a> ;
 205 M: AAAA parse-rdata 2drop 16 read byte-array>ipv6 <aaaa> ;
 206 M: CNAME parse-rdata 2drop parse-name <cname> ;
 207 M: MX parse-rdata 2drop parse-mx ;
 208 M: NS parse-rdata 2drop parse-name <ns> ;
 209 M: PTR parse-rdata 2drop parse-name <ptr> ;
 210 M: SOA parse-rdata 2drop parse-soa ;
 211
 212 : parse-rr ( -- rr )
 213     rr new
 214         parse-name >>name
 215         2 read be> <dns-type> >>type
 216         2 read be> <dns-class> >>class
 217         4 read be> >>ttl
 218         2 read be> over type>> parse-rdata >>rdata ;
 219
 220 : parse-message ( byte-array -- message )
 221     [ message new ] dip
 222     binary [
 223         2 read be> >>id
 224         2 read be> header>message-parts set-slots[ qr opcode aa tc rd ra z rcode ]
 225         2 read be> >>query
 226         2 read be> >>answer-section
 227         2 read be> >>authority-section
 228         2 read be> >>additional-section
 229         [ [ parse-query ] replicate ] change-query
 230         [ [ parse-rr ] replicate ] change-answer-section
 231         [ [ parse-rr ] replicate ] change-authority-section
 232         [ [ parse-rr ] replicate ] change-additional-section
 233     ] with-byte-reader ;
 234
 235 : >n/label ( string -- byte-array )
 236     [ length 1array ] [ utf8 encode ] bi B{ } append-as ;
 237
 238 : >name ( domain -- byte-array ) "." split [ >n/label ] map concat ;
 239
 240 : query>byte-array ( query -- byte-array )
 241     [
 242         {
 243             [ name>> >name ]
 244             [ type>> enum>number 2 >be ]
 245             [ class>> enum>number 2 >be ]
 246         } cleave
 247     ] B{ } append-outputs-as ;
 248
 249 GENERIC: rdata>byte-array ( rdata type -- obj )
 250
 251 M: A rdata>byte-array drop ipv4>byte-array ;
 252
 253 M: CNAME rdata>byte-array drop >name ;
 254
 255 M: HINFO rdata>byte-array
 256     drop
 257     [ cpu>> >name ]
 258     [ os>> >name ] bi append ;
 259
 260 M: MX rdata>byte-array
 261     drop
 262     [ preference>> 2 >be ]
 263     [ exchange>> >name ] bi append ;
 264
 265 M: NS rdata>byte-array drop >name ;
 266
 267 M: PTR rdata>byte-array drop >name ;
 268
 269 M: SOA rdata>byte-array
 270     drop
 271     [
 272         {
 273             [ mname>> >name ]
 274             [ rname>> >name ]
 275             [ serial>> 4 >be ]
 276             [ refresh>> 4 >be ]
 277             [ retry>> 4 >be ]
 278             [ expire>> 4 >be ]
 279             [ minimum>> 4 >be ]
 280         } cleave
 281     ] B{ } append-outputs-as ;
 282
 283 : rr>byte-array ( rr -- byte-array )
 284     [
 285         {
 286             [ name>> >name ]
 287             [ type>> enum>number 2 >be ]
 288             [ class>> enum>number 2 >be ]
 289             [ ttl>> 4 >be ]
 290             [
 291                 [ rdata>> ] [ type>> ] bi rdata>byte-array
 292                 [ length 2 >be ] [ ] bi append
 293             ]
 294         } cleave
 295     ] B{ } append-outputs-as ;
 296
 297 : message>byte-array ( message -- byte-array )
 298     [
 299         {
 300             [ id>> 2 >be ]
 301             [ message>header 2 >be ]
 302             [ query>> length 2 >be ]
 303             [ answer-section>> length 2 >be ]
 304             [ authority-section>> length 2 >be ]
 305             [ additional-section>> length 2 >be ]
 306             [ query>> [ query>byte-array ] map concat ]
 307             [ answer-section>> [ rr>byte-array ] map concat ]
 308             [ authority-section>> [ rr>byte-array ] map concat ]
 309             [ additional-section>> [ rr>byte-array ] map concat ]
 310         } cleave
 311     ] B{ } append-outputs-as ;
 312
 313 : udp-query ( bytes server -- bytes' )
 314     f 0 <inet4> <datagram>
 315     30 seconds over set-timeout [
 316         [ send ] [ receive drop ] bi
 317     ] with-disposal ;
 318
 319 : <dns-inet4> ( -- inet4 )
 320     dns-servers get random 53 <inet4> ;
 321
 322 : dns-query ( query -- message )
 323     <message> message>byte-array
 324     <dns-inet4> udp-query parse-message ;
 325
 326 : dns-A-query ( domain -- message ) A IN <query> dns-query ;
 327 : dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ;
 328 : dns-MX-query ( domain -- message ) MX IN <query> dns-query ;
 329 : dns-NS-query ( domain -- message ) NS IN <query> dns-query ;
 330
 331 : reverse-lookup ( reversed-ip -- message )
 332     PTR IN <query> dns-query ;
 333
 334 : reverse-ipv4-lookup ( ip -- message )
 335     ipv4>arpa reverse-lookup ;
 336
 337 : reverse-ipv6-lookup ( ip -- message )
 338     ipv6>arpa reverse-lookup ;
 339
 340 : message>names ( message -- names )
 341     answer-section>> [ rdata>> name>> ] map ;
 342
 343 : message>a-names ( message -- names )
 344     answer-section>>
 345     [ rdata>> ] map [ a? ] filter [ name>> ] map ;
 346
 347 : message>mxs ( message -- assoc )
 348     answer-section>> [ rdata>> [ preference>> ] [ exchange>> ] bi 2array ] map ;
 349
 350 : messages>names ( messages -- names )
 351     [ message>names ] map concat ;
 352
 353 : forward-confirmed-reverse-dns-ipv4? ( ipv4-string -- ? )
 354     dup reverse-ipv4-lookup message>names
 355     [ dns-A-query ] map messages>names member? ;
 356
 357 : forward-confirmed-reverse-dns-ipv6? ( ipv6-string -- ? )
 358     expand-ipv6
 359     dup reverse-ipv6-lookup message>names
 360     [ dns-AAAA-query ] map messages>names member? ;
 361
 362 : message>query-name ( message -- string )
 363     query>> first name>> dotted> ;
 364
 365 USE: nested-comments
 366 (*
 367 M: string resolve-host
 368     dup >lower "localhost" = [
 369         drop resolve-localhost
 370     ] [
 371         dns-A-query message>a-names [ <ipv4> ] map
 372     ] if ;
 373 *)
 374
 375 HOOK: initial-dns-servers os ( -- sequence )
 376
 377 {
 378     { [ os windows? ] [ "dns.windows" ] }
 379     { [ os unix? ] [ "dns.unix" ] }
 380 } cond require
 381
 382 dns-servers [ initial-dns-servers >vector ] initialize