2 USING: kernel byte-arrays combinators strings arrays sequences splitting
4 math math.functions math.parser random
6 io io.binary io.sockets io.encodings.binary
14 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 TUPLE: query name type class ;
18 TUPLE: rr name type class ttl rdata ;
22 TUPLE: mx preference exchange ;
24 TUPLE: soa mname rname serial refresh retry expire minimum ;
27 id qr opcode aa tc rd ra z rcode
33 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
35 : random-id ( -- id ) 2 16 ^ random ;
37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
39 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
41 SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
43 : type-table ( -- table )
64 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
66 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
68 SYMBOLS: IN CS CH HS ;
70 : class-table ( -- table )
78 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
80 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
82 SYMBOLS: QUERY IQUERY STATUS ;
84 : opcode-table ( -- table )
91 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
95 SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
98 : rcode-table ( -- table )
104 { NOT-IMPLEMENTED 4 }
108 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
110 : <message> ( -- message )
121 { } >>question-section
123 { } >>authority-section
124 { } >>additional-section ;
126 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
128 : ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
130 : ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
132 : label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
134 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
136 : uint8->ba ( n -- ba ) 1 >be ;
137 : uint16->ba ( n -- ba ) 2 >be ;
138 : uint32->ba ( n -- ba ) 4 >be ;
139 : uint64->ba ( n -- ba ) 8 >be ;
141 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
143 : dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
145 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
147 : query->ba ( query -- ba )
151 [ type>> type-table at uint16->ba ]
152 [ class>> class-table at uint16->ba ]
154 ] output>array concat ;
156 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
158 : hinfo->ba ( rdata -- ba )
163 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
165 : mx->ba ( rdata -- ba )
166 [ preference>> uint16->ba ]
167 [ exchange>> dn->ba ]
170 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
172 : soa->ba ( rdata -- ba )
177 [ serial>> uint32->ba ]
178 [ refresh>> uint32->ba ]
179 [ retry>> uint32->ba ]
180 [ expire>> uint32->ba ]
181 [ minimum>> uint32->ba ]
183 ] output>array concat ;
185 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
187 : rdata->ba ( type rdata -- ba )
191 { HINFO [ hinfo->ba ] }
200 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
202 : rr->ba ( rr -- ba )
206 [ type>> type-table at uint16->ba ]
207 [ class>> class-table at uint16->ba ]
210 [ type>> ] [ rdata>> ] bi rdata->ba
211 [ length uint16->ba ] [ ] bi append
214 ] output>array concat ;
216 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
218 : header-bits-ba ( message -- ba )
222 [ opcode>> opcode-table at 11 shift ]
228 [ rcode>> rcode-table at 0 shift ]
230 ] sum-outputs uint16->ba ;
232 : message->ba ( message -- ba )
237 [ question-section>> length uint16->ba ]
238 [ answer-section>> length uint16->ba ]
239 [ authority-section>> length uint16->ba ]
240 [ additional-section>> length uint16->ba ]
241 [ question-section>> [ query->ba ] map concat ]
242 [ answer-section>> [ rr->ba ] map concat ]
243 [ authority-section>> [ rr->ba ] map concat ]
244 [ additional-section>> [ rr->ba ] map concat ]
246 ] output>array concat ;
248 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
250 : get-single ( ba i -- n ) at ;
251 : get-double ( ba i -- n ) dup 2 + subseq be> ;
252 : get-quad ( ba i -- n ) dup 4 + subseq be> ;
254 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
256 : label-length ( ba i -- length ) get-single ;
258 : skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
260 : null-label? ( ba i -- ? ) get-single 0 = ;
262 : get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
264 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
266 : bit-test ( a b -- ? ) bitand 0 = not ;
268 : pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
270 : pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
272 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
274 : skip-name ( ba i -- ba i )
276 { [ 2dup null-label? ] [ 1 + ] }
277 { [ 2dup pointer? ] [ 2 + ] }
278 { [ t ] [ skip-label skip-name ] }
282 : get-name ( ba i -- name )
284 { [ 2dup null-label? ] [ 2drop "" ] }
285 { [ 2dup pointer? ] [ dupd pointer get-name ] }
290 [ skip-label get-name ]
298 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
300 : get-query ( ba i -- query )
304 [ 0 + get-double type-table value-at ]
305 [ 2 + get-double class-table value-at ]
310 : skip-query ( ba i -- ba i ) skip-name 4 + ;
312 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
314 : get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
316 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
318 : get-soa ( ba i -- soa )
321 [ skip-name get-name ]
337 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
339 : get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
341 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
343 : get-ipv6 ( ba i -- ip )
344 dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
346 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
348 : get-rdata ( ba i type -- rdata )
350 { CNAME [ get-name ] }
356 { AAAA [ get-ipv6 ] }
360 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
362 : get-rr ( ba i -- rr )
367 [ 0 + get-double type-table value-at ]
368 [ 2 + get-double class-table value-at ]
370 [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
376 : skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
378 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
380 : get-question-section ( ba i count -- seq ba i )
381 [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
383 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
385 : get-rr-section ( ba i count -- seq ba i )
386 [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
388 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
390 : >> ( x n -- y ) neg shift ;
392 : get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
395 [ 15 >> BIN: 1 bitand ]
396 [ 11 >> BIN: 111 bitand opcode-table value-at ]
397 [ 10 >> BIN: 1 bitand ]
398 [ 9 >> BIN: 1 bitand ]
399 [ 8 >> BIN: 1 bitand ]
400 [ 7 >> BIN: 1 bitand ]
401 [ 4 >> BIN: 111 bitand ]
402 [ BIN: 1111 bitand rcode-table value-at ]
406 : parse-message ( ba -- message )
410 [ 2 + get-header-bits ]
422 [ get-question-section ]
430 2cleave message boa ;
432 : ba->message ( ba -- message ) parse-message ;
434 : with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
436 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
438 : send-receive-udp ( ba server -- ba )
439 f 0 <inet4> <datagram>
441 [ send ] [ receive drop ] bi
445 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
447 : send-receive-tcp ( ba server -- ba )
448 [ dup length 2 >be prepend ] [ ] bi*
456 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
458 : >dns-inet4 ( obj -- inet4 )
464 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
466 : ask-server ( message server -- message )
467 [ message->ba ] [ >dns-inet4 ] bi*
469 send-receive-udp parse-message
471 [ drop send-receive-tcp parse-message ]
475 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
477 : dns-servers ( -- seq ) V{ } ;
479 : dns-server ( -- server ) dns-servers random ;
481 : ask ( message -- message ) dns-server ask-server ;
483 : query->message ( query -- message ) <message> swap 1array >>question-section ;
485 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
487 : message-query ( message -- query ) question-section>> first ;
489 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
491 ERROR: name-error name ;
493 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
495 : fully-qualified ( name -- name )
497 { [ dup empty? ] [ "." append ] }
498 { [ dup peek CHAR: . = ] [ ] }
499 { [ t ] [ "." append ] }