basis/dns/dns.factor

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