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