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 ;
12 : with-input-seek ( n seek-type quot -- )
14 [ seek-input ] dip call
15 ] dip seek-absolute seek-input ; inline
17 ! https://www.iana.org/assignments/dns-parameters/dns-parameters.xhtml
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 } ;
40 ENUM: dns-class { IN 1 } { CS 2 } { CH 3 } { HS 4 } ;
42 ENUM: dns-opcode QUERY IQUERY STATUS ;
44 ENUM: dns-rcode NO-ERROR FORMAT-ERROR SERVER-FAILURE
45 NAME-ERROR NOT-IMPLEMENTED REFUSED ;
49 : add-dns-server ( string -- )
50 dns-servers get push ;
52 : remove-dns-server ( string -- )
53 dns-servers get remove! drop ;
55 : clear-dns-servers ( -- )
56 V{ } clone dns-servers set-global ;
58 ERROR: domain-name-contains-empty-label domain ;
60 : check-domain-name ( domain -- domain )
61 dup ".." find-subseq? [ domain-name-contains-empty-label ] when ;
63 : >dotted ( domain -- domain' )
64 dup "." tail? [ "." append ] unless ;
66 : dotted> ( string -- string' )
69 TUPLE: query name type class ;
70 CONSTRUCTOR: <query> query ( name type class -- obj )
71 [ check-domain-name >dotted ] change-name ;
73 TUPLE: rr name type class ttl rdata ;
77 TUPLE: mx preference exchange ;
79 TUPLE: soa mname rname serial refresh retry expire minimum ;
81 TUPLE: srv priority weight port target ;
84 CONSTRUCTOR: <a> a ( name -- obj ) ;
87 CONSTRUCTOR: <aaaa> aaaa ( name -- obj ) ;
90 CONSTRUCTOR: <cname> cname ( name -- obj ) ;
93 CONSTRUCTOR: <ptr> ptr ( name -- obj ) ;
96 CONSTRUCTOR: <ns> ns ( name -- obj ) ;
98 TUPLE: message id qr opcode aa tc rd ra z rcode
99 query answer-section authority-section additional-section ;
101 CONSTRUCTOR: <message> message ( query -- obj )
111 [ dup sequence? [ 1array ] unless ] change-query
113 { } >>authority-section
114 { } >>additional-section ;
116 : message>header ( message -- n )
120 [ opcode>> enum>number 11 shift ]
126 [ rcode>> enum>number 0 shift ]
130 : header>message-parts ( n -- qr opcode aa tc rd ra z rcode )
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> ]
142 : byte-array>ipv4 ( byte-array -- string )
143 [ number>string ] { } map-as "." join ;
145 : byte-array>ipv6 ( byte-array -- string )
146 2 group [ be> >hex ] { } map-as ":" join ;
148 : ipv4>byte-array ( string -- byte-array )
149 "." split [ string>number ] B{ } map-as ;
151 : ipv6>byte-array ( string -- byte-array )
152 T{ inet6 } inet-pton ;
154 : expand-ipv6 ( ipv6 -- ipv6' ) ipv6>byte-array byte-array>ipv6 ;
156 : reverse-ipv4 ( string -- string )
157 ipv4>byte-array reverse byte-array>ipv4 ;
159 CONSTANT: ipv4-arpa-suffix ".in-addr.arpa"
161 : ipv4>arpa ( string -- string )
162 reverse-ipv4 ipv4-arpa-suffix append ;
164 CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
166 : ipv6>arpa ( string -- string )
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 ;
172 : trim-ipv4-arpa ( string -- string' )
173 dotted> ipv4-arpa-suffix ?tail drop ;
175 : trim-ipv6-arpa ( string -- string' )
176 dotted> ipv6-arpa-suffix ?tail drop ;
178 : arpa>ipv4 ( string -- ip ) trim-ipv4-arpa reverse-ipv4 ;
180 : arpa>ipv6 ( string -- ip )
181 trim-ipv6-arpa "." split 2 group reverse
183 first2 swap [ hex> ] bi@ [ 4 shift ] [ ] bi* bitor
184 ] B{ } map-as byte-array>ipv6 ;
186 : parse-length-bytes ( byte -- sequence ) read utf8 decode ;
188 : (parse-name) ( -- )
191 8 shift read1 bitor 0x3fff bitand
193 read1 parse-length-bytes , (parse-name)
196 parse-length-bytes , (parse-name)
200 : parse-name ( -- sequence )
201 [ (parse-name) ] { } make "." join ;
203 : parse-query ( -- query )
205 2 read be> <dns-type>
206 2 read be> <dns-class> <query> ;
208 : parse-soa ( -- soa )
216 4 read be> >>minimum ;
220 2 read be> >>preference
221 parse-name >>exchange ;
223 : parse-srv ( -- srv )
225 2 read be> >>priority
228 parse-name >>target ;
230 GENERIC: parse-rdata ( n type -- obj )
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 ;
245 2 read be> <dns-type> >>type
246 2 read be> <dns-class> >>class
248 2 read be> over type>> parse-rdata >>rdata ;
250 : parse-message ( byte-array -- message )
254 2 read be> header>message-parts set-slots[ qr opcode aa tc rd ra z rcode ]
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
265 ERROR: unsupported-domain-name string ;
267 : >n/label ( string -- byte-array )
269 [ unsupported-domain-name ] unless
270 [ length 1array ] [ ] bi B{ } append-as ;
272 : >name ( domain -- byte-array )
273 dup "." = [ drop B{ 0 } ] [
274 "." split [ >n/label ] map concat
277 : query>byte-array ( query -- byte-array )
281 [ type>> enum>number 2 >be ]
282 [ class>> enum>number 2 >be ]
284 ] B{ } append-outputs-as ;
286 GENERIC: rdata>byte-array ( rdata type -- obj )
288 M: A rdata>byte-array drop ipv4>byte-array ;
290 M: CNAME rdata>byte-array drop >name ;
292 M: HINFO rdata>byte-array
295 [ os>> >name ] bi append ;
297 M: MX rdata>byte-array
299 [ preference>> 2 >be ]
300 [ exchange>> >name ] bi append ;
302 M: NS rdata>byte-array drop >name ;
304 M: PTR rdata>byte-array drop >name ;
306 M: SOA rdata>byte-array
318 ] B{ } append-outputs-as ;
320 M: TXT rdata>byte-array
323 : rr>byte-array ( rr -- byte-array )
327 [ type>> enum>number 2 >be ]
328 [ class>> enum>number 2 >be ]
331 [ rdata>> ] [ type>> ] bi rdata>byte-array
332 [ length 2 >be ] [ ] bi append
335 ] B{ } append-outputs-as ;
337 : message>byte-array ( message -- byte-array )
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 ]
351 ] B{ } append-outputs-as ;
353 : udp-query ( bytes server -- bytes' )
355 10 seconds over set-timeout
356 [ send ] [ receive drop ] bi
357 ] with-any-port-local-datagram ;
359 : parse-ip ( str -- ipv4/ipv6 )
360 [ <ipv4> ] [ drop <ipv6> ] recover ;
362 : <dns-inet> ( -- inet4 )
364 [ parse-ip ] map [ ipv4? ] filter
365 random host>> 53 <inet4> ;
367 : dns-query ( name type class -- message )
368 <query> <message> message>byte-array
369 <dns-inet> udp-query parse-message ;
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 ;
380 : read-TXT-strings ( byte-array -- strings )
382 binary <byte-reader> [
383 [ read1 [ read , t ] [ f ] if* ] loop
387 : TXT-message>strings ( message -- strings )
390 read-TXT-strings [ utf8 decode ] map
394 dns-TXT-query TXT-message>strings [ [ write ] each nl ] each ;
396 : reverse-lookup ( reversed-ip -- message )
399 : reverse-ipv4-lookup ( ip -- message )
400 ipv4>arpa reverse-lookup ;
402 : reverse-ipv6-lookup ( ip -- message )
403 ipv6>arpa reverse-lookup ;
405 : message>names ( message -- names )
406 answer-section>> [ rdata>> name>> ] map ;
408 : filter-message-rdata>names ( message quot -- names )
409 [ answer-section>> [ rdata>> ] map ] dip filter [ name>> ] map ; inline
411 : message>a-names ( message -- names )
412 [ a? ] filter-message-rdata>names ;
414 : message>aaaa-names ( message -- names )
415 [ aaaa? ] filter-message-rdata>names ;
417 : message>mxs ( message -- assoc )
422 [ preference>> ] [ exchange>> ] bi 2array
426 : messages>names ( messages -- names )
427 [ message>names ] map concat ;
429 : forward-confirmed-reverse-dns-ipv4? ( ipv4-string -- ? )
430 dup reverse-ipv4-lookup message>names
431 [ dns-A-query ] map messages>names member? ;
433 : forward-confirmed-reverse-dns-ipv6? ( ipv6-string -- ? )
435 dup reverse-ipv6-lookup message>names
436 [ dns-AAAA-query ] map messages>names member? ;
438 : message>query-name ( message -- string )
439 query>> first name>> dotted> ;
441 ! XXX: Turn on someday for nonblocking DNS lookups
442 ! M: string resolve-host
443 ! dup >lower "localhost" = [
444 ! drop resolve-localhost
446 ! dns-A-query message>a-names [ <ipv4> ] map
449 HOOK: initial-dns-servers os ( -- sequence )
452 { [ os windows? ] [ "dns.windows" ] }
453 { [ os unix? ] [ "dns.unix" ] }
456 : with-dns-servers ( servers quot -- )
457 [ dns-servers ] dip with-variable ; inline
459 dns-servers [ initial-dns-servers >vector ] initialize