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