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