1 ! Copyright (C) 2010 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.enums alien.syntax arrays assocs
4 byte-arrays calendar combinators combinators.smart constructors
5 destructors fry grouping io io.binary io.buffers
6 io.encodings.binary io.encodings.string io.encodings.utf8
7 io.files io.ports io.sockets io.sockets.private
8 io.streams.byte-array io.timeouts kernel make math math.bitwise
9 math.parser math.ranges math.statistics memoize namespaces
10 nested-comments random sequences slots.syntax splitting strings
11 system unicode.categories vectors vocabs.loader unicode.case ;
15 { A 1 } { NS 2 } { MD 3 } { MF 4 }
16 { CNAME 5 } { SOA 6 } { MB 7 } { MG 8 }
17 { MR 9 } { NULL 10 } { WKS 11 } { PTR 12 }
18 { HINFO 13 } { MINFO 14 } { MX 15 } { TXT 16 }
19 { RP 17 } { AFSDB 18 } { SIG 24 } { KEY 25 }
20 { AAAA 28 } { LOC 29 } { SVR 33 } { NAPTR 35 }
21 { KX 36 } { CERT 37 } { DNAME 39 } { OPT 41 }
22 { APL 42 } { DS 43 } { SSHFP 44 } { IPSECKEY 45 }
23 { RRSIG 46 } { NSEC 47 } { DNSKEY 48 } { DHCID 49 }
24 { NSEC3 50 } { NSEC3PARAM 51 } { HIP 55 } { SPF 99 }
25 { TKEY 249 } { TSIG 250 } { IXFR 251 }
26 { TA 32768 } { DLV 32769 } ;
28 ENUM: dns-class { IN 1 } { CS 2 } { CH 3 } { HS 4 } ;
30 ENUM: dns-opcode QUERY IQUERY STATUS ;
32 ENUM: dns-rcode NO-ERROR FORMAT-ERROR SERVER-FAILURE
33 NAME-ERROR NOT-IMPLEMENTED REFUSED ;
37 : add-dns-server ( string -- )
38 dns-servers get push ;
40 : remove-dns-server ( string -- )
41 dns-servers get remove! drop ;
43 : clear-dns-servers ( -- )
44 V{ } clone dns-servers set-global ;
46 : >dotted ( domain -- domain' )
47 dup "." tail? [ "." append ] unless ;
49 : dotted> ( string -- string' )
52 TUPLE: query name type class ;
53 CONSTRUCTOR: query ( name type class -- obj )
54 [ >dotted ] change-name ;
56 TUPLE: rr name type class ttl rdata ;
60 TUPLE: mx preference exchange ;
62 TUPLE: soa mname rname serial refresh retry expire minimum ;
65 CONSTRUCTOR: a ( name -- obj ) ;
68 CONSTRUCTOR: aaaa ( name -- obj ) ;
71 CONSTRUCTOR: cname ( name -- obj ) ;
74 CONSTRUCTOR: ptr ( name -- obj ) ;
77 CONSTRUCTOR: ns ( name -- obj ) ;
79 TUPLE: message id qr opcode aa tc rd ra z rcode
80 query answer-section authority-section additional-section ;
82 CONSTRUCTOR: message ( query -- obj )
92 [ dup sequence? [ 1array ] unless ] change-query
94 { } >>authority-section
95 { } >>additional-section ;
97 : message>header ( message -- n )
101 [ opcode>> enum>number 11 shift ]
107 [ rcode>> enum>number 0 shift ]
111 : header>message-parts ( n -- qr opcode aa tc rd ra z rcode )
113 [ -15 shift BIN: 1 bitand ]
114 [ -11 shift BIN: 111 bitand <dns-opcode> ]
115 [ -10 shift BIN: 1 bitand ]
116 [ -9 shift BIN: 1 bitand ]
117 [ -8 shift BIN: 1 bitand ]
118 [ -7 shift BIN: 1 bitand ]
119 [ -4 shift BIN: 111 bitand ]
120 [ BIN: 1111 bitand <dns-rcode> ]
123 : byte-array>ipv4 ( byte-array -- string )
124 [ number>string ] { } map-as "." join ;
126 : byte-array>ipv6 ( byte-array -- string )
127 2 group [ be> >hex ] { } map-as ":" join ;
129 : ipv4>byte-array ( string -- byte-array )
130 "." split [ string>number ] B{ } map-as ;
132 : ipv6>byte-array ( string -- byte-array )
133 T{ inet6 } inet-pton ;
135 : expand-ipv6 ( ipv6 -- ipv6' ) ipv6>byte-array byte-array>ipv6 ;
137 : reverse-ipv4 ( string -- string )
138 ipv4>byte-array reverse byte-array>ipv4 ;
140 CONSTANT: ipv4-arpa-suffix ".in-addr.arpa"
142 : ipv4>arpa ( string -- string )
143 reverse-ipv4 ipv4-arpa-suffix append ;
145 CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
147 : ipv6>arpa ( string -- string )
148 ipv6>byte-array [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
149 B{ } concat-as reverse
150 [ >hex ] { } map-as "." join ipv6-arpa-suffix append ;
152 : trim-ipv4-arpa ( string -- string' )
153 dotted> ipv4-arpa-suffix ?tail drop ;
155 : trim-ipv6-arpa ( string -- string' )
156 dotted> ipv6-arpa-suffix ?tail drop ;
158 : arpa>ipv4 ( string -- ip ) trim-ipv4-arpa reverse-ipv4 ;
160 : arpa>ipv6 ( string -- ip )
161 trim-ipv6-arpa "." split 2 group reverse
163 first2 swap [ hex> ] bi@ [ 4 shift ] [ ] bi* bitor
164 ] B{ } map-as byte-array>ipv6 ;
166 : parse-length-bytes ( -- seq ) read1 read utf8 decode ;
168 : (parse-name) ( -- )
173 2 read be> HEX: 3fff bitand
174 seek-absolute [ parse-length-bytes , (parse-name) ] with-input-seek
176 parse-length-bytes , (parse-name)
180 : parse-name ( -- seq )
181 [ (parse-name) ] { } make "." join ;
183 : parse-query ( -- query )
185 2 read be> <dns-type>
186 2 read be> <dns-class> <query> ;
188 : parse-soa ( -- soa )
196 4 read be> >>minimum ;
200 2 read be> >>preference
201 parse-name >>exchange ;
203 GENERIC: parse-rdata ( n type -- obj )
205 M: object parse-rdata drop read ;
206 M: A parse-rdata 2drop 4 read byte-array>ipv4 <a> ;
207 M: AAAA parse-rdata 2drop 16 read byte-array>ipv6 <aaaa> ;
208 M: CNAME parse-rdata 2drop parse-name <cname> ;
209 M: MX parse-rdata 2drop parse-mx ;
210 M: NS parse-rdata 2drop parse-name <ns> ;
211 M: PTR parse-rdata 2drop parse-name <ptr> ;
212 M: SOA parse-rdata 2drop parse-soa ;
217 2 read be> <dns-type> >>type
218 2 read be> <dns-class> >>class
220 2 read be> over type>> parse-rdata >>rdata ;
222 : parse-message ( ba -- message )
226 2 read be> header>message-parts set-slots[ qr opcode aa tc rd ra z rcode ]
228 2 read be> >>answer-section
229 2 read be> >>authority-section
230 2 read be> >>additional-section
231 [ [ parse-query ] replicate ] change-query
232 [ [ parse-rr ] replicate ] change-answer-section
233 [ [ parse-rr ] replicate ] change-authority-section
234 [ [ parse-rr ] replicate ] change-additional-section
237 : >n/label ( string -- ba )
238 [ length 1array ] [ utf8 encode ] bi B{ } append-as ;
240 : >name ( dn -- ba ) "." split [ >n/label ] map concat ;
242 : query>byte-array ( query -- ba )
246 [ type>> enum>number 2 >be ]
247 [ class>> enum>number 2 >be ]
249 ] B{ } append-outputs-as ;
251 GENERIC: rdata>byte-array ( rdata type -- obj )
253 M: A rdata>byte-array drop ipv4>byte-array ;
255 M: CNAME rdata>byte-array drop >name ;
257 M: HINFO rdata>byte-array
260 [ os>> >name ] bi append ;
262 M: MX rdata>byte-array
264 [ preference>> 2 >be ]
265 [ exchange>> >name ] bi append ;
267 M: NS rdata>byte-array drop >name ;
269 M: PTR rdata>byte-array drop >name ;
271 M: SOA rdata>byte-array
283 ] B{ } append-outputs-as ;
285 : rr>byte-array ( rr -- ba )
289 [ type>> enum>number 2 >be ]
290 [ class>> enum>number 2 >be ]
293 [ rdata>> ] [ type>> ] bi rdata>byte-array
294 [ length 2 >be ] [ ] bi append
297 ] B{ } append-outputs-as ;
299 : message>byte-array ( message -- ba )
303 [ message>header 2 >be ]
304 [ query>> length 2 >be ]
305 [ answer-section>> length 2 >be ]
306 [ authority-section>> length 2 >be ]
307 [ additional-section>> length 2 >be ]
308 [ query>> [ query>byte-array ] map concat ]
309 [ answer-section>> [ rr>byte-array ] map concat ]
310 [ authority-section>> [ rr>byte-array ] map concat ]
311 [ additional-section>> [ rr>byte-array ] map concat ]
313 ] B{ } append-outputs-as ;
315 : udp-query ( bytes server -- bytes' )
316 f 0 <inet4> <datagram>
317 30 seconds over set-timeout [
318 [ send ] [ receive drop ] bi
321 : <dns-inet4> ( -- inet4 )
322 dns-servers get random 53 <inet4> ;
324 : dns-query ( query -- message )
325 <message> message>byte-array
326 <dns-inet4> udp-query parse-message ;
328 : dns-A-query ( domain -- message ) A IN <query> dns-query ;
329 : dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ;
330 : dns-MX-query ( domain -- message ) MX IN <query> dns-query ;
331 : dns-NS-query ( domain -- message ) NS IN <query> dns-query ;
333 : reverse-lookup ( reversed-ip -- message )
334 PTR IN <query> dns-query ;
336 : reverse-ipv4-lookup ( ip -- message )
337 ipv4>arpa reverse-lookup ;
339 : reverse-ipv6-lookup ( ip -- message )
340 ipv6>arpa reverse-lookup ;
342 : message>names ( message -- names )
343 answer-section>> [ rdata>> name>> ] map ;
345 : message>a-names ( message -- names )
347 [ rdata>> ] map [ a? ] filter [ name>> ] map ;
349 : message>mxs ( message -- assoc )
350 answer-section>> [ rdata>> [ preference>> ] [ exchange>> ] bi 2array ] map ;
352 : messages>names ( messages -- names )
353 [ message>names ] map concat ;
355 : forward-confirmed-reverse-dns-ipv4? ( ipv4-string -- ? )
356 dup reverse-ipv4-lookup message>names
357 [ dns-A-query ] map messages>names member? ;
359 : forward-confirmed-reverse-dns-ipv6? ( ipv6-string -- ? )
361 dup reverse-ipv6-lookup message>names
362 [ dns-AAAA-query ] map messages>names member? ;
364 : message>query-name ( message -- string )
365 query>> first name>> dotted> ;
369 M: string resolve-host
370 dup >lower "localhost" = [
371 drop resolve-localhost
373 dns-A-query message>a-names [ <ipv4> ] map
377 HOOK: initial-dns-servers os ( -- seq )
380 { [ os windows? ] [ "dns.windows" ] }
381 { [ os unix? ] [ "dns.unix" ] }
384 dns-servers [ initial-dns-servers >vector ] initialize