New vocabulary: dns
Eduardo Cavazos
parent
9c569034f6
commit
ff553f6aa0
|
|
@ -0,0 +1,142 @@
|
|||
|
||||
USING: kernel system
|
||||
combinators
|
||||
vectors sequences assocs
|
||||
math math.functions
|
||||
prettyprint unicode.case
|
||||
accessors
|
||||
combinators.cleave
|
||||
newfx
|
||||
dns ;
|
||||
|
||||
IN: dns.cache
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cache ( -- table ) H{ } ;
|
||||
|
||||
! key: 'name type class' (as string)
|
||||
! val: entry
|
||||
|
||||
TUPLE: entry time data ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: query->key ( query -- key )
|
||||
{ [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } <arr> " " join ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: table-get ( query -- result ) query->key cache of ;
|
||||
|
||||
: table-check ( query -- ? ) query->key cache key? ;
|
||||
|
||||
: table-add ( query value -- ) [ query->key ] [ ] bi* cache at-mutate ;
|
||||
|
||||
: table-rem ( query -- ) query->key cache delete-key-of drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: now ( -- seconds ) millis 1000.0 / round >integer ;
|
||||
|
||||
: ttl->time ( ttl -- seconds ) now + ;
|
||||
|
||||
: time->ttl ( time -- ttl ) now - ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: NX
|
||||
|
||||
: cache-nx ( query ttl -- )
|
||||
ttl->time NX entry boa
|
||||
table-add ;
|
||||
|
||||
: nx? ( obj -- ? )
|
||||
dup entry?
|
||||
[ data>> NX = ]
|
||||
[ drop f ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: query->rr ( query -- rr ) [ name>> ] [ type>> ] [ class>> ] tri f f rr boa ;
|
||||
|
||||
: query+entry->rrs ( query entry -- rrs )
|
||||
swap ! entry query
|
||||
query->rr ! entry rr
|
||||
over ! entry rr entry
|
||||
time>> time->ttl >>ttl ! entry rr
|
||||
swap ! rr entry
|
||||
data>> [ >r dup clone r> >>rdata ] map
|
||||
nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: entry-expired? ( entry -- ? ) time>> time->ttl 0 <= ;
|
||||
|
||||
: cache-get ( query -- result )
|
||||
dup table-get ! query result
|
||||
{
|
||||
{
|
||||
[ dup f = ] ! not in the cache
|
||||
[ 2drop f ]
|
||||
}
|
||||
{
|
||||
[ dup entry-expired? ] ! here but expired
|
||||
[ drop table-rem f ]
|
||||
}
|
||||
{
|
||||
[ dup nx? ] ! negative result has been cached
|
||||
[ 2drop NX ]
|
||||
}
|
||||
{
|
||||
[ t ]
|
||||
[ query+entry->rrs ]
|
||||
}
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rr->entry ( rr -- entry )
|
||||
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
|
||||
|
||||
: maybe-pushed-on ( obj seq -- )
|
||||
2dup member-of?
|
||||
[ 2drop ]
|
||||
[ pushed-on ]
|
||||
if ;
|
||||
|
||||
: add-rr-to-entry ( rr entry -- )
|
||||
over ttl>> ttl->time >>time
|
||||
[ rdata>> ] [ data>> ] bi* maybe-pushed-on ;
|
||||
|
||||
: cache-add ( query rr -- )
|
||||
over table-get ! query rr entry
|
||||
{
|
||||
{
|
||||
[ dup f = ] ! not in the cache
|
||||
[ drop rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ dup nx? ]
|
||||
[ drop over table-rem rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ dup entry-expired? ]
|
||||
[ drop rr->entry table-add ]
|
||||
}
|
||||
{
|
||||
[ t ]
|
||||
[ rot drop add-rr-to-entry ]
|
||||
}
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rr->query ( rr -- query ) [ name>> ] [ type>> ] [ class>> ] tri query boa ;
|
||||
|
||||
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
|
||||
|
||||
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
|
||||
|
|
@ -0,0 +1,462 @@
|
|||
|
||||
USING: kernel byte-arrays combinators strings arrays sequences splitting
|
||||
math math.functions math.parser random
|
||||
destructors
|
||||
io io.binary io.sockets io.encodings.binary
|
||||
accessors
|
||||
combinators.cleave
|
||||
newfx
|
||||
symbols
|
||||
;
|
||||
|
||||
IN: dns
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: query name type class ;
|
||||
|
||||
TUPLE: rr name type class ttl rdata ;
|
||||
|
||||
TUPLE: hinfo cpu os ;
|
||||
|
||||
TUPLE: mx preference exchange ;
|
||||
|
||||
TUPLE: soa mname rname serial refresh retry expire minimum ;
|
||||
|
||||
TUPLE: message
|
||||
id qr opcode aa tc rd ra z rcode
|
||||
question-section
|
||||
answer-section
|
||||
authority-section
|
||||
additional-section ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: random-id ( -- id ) 2 16 ^ random ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! TYPE
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
|
||||
|
||||
: type-table ( -- table )
|
||||
{
|
||||
{ A 1 }
|
||||
{ NS 2 }
|
||||
{ MD 3 }
|
||||
{ MF 4 }
|
||||
{ CNAME 5 }
|
||||
{ SOA 6 }
|
||||
{ MB 7 }
|
||||
{ MG 8 }
|
||||
{ MR 9 }
|
||||
{ NULL 10 }
|
||||
{ WKS 11 }
|
||||
{ PTR 12 }
|
||||
{ HINFO 13 }
|
||||
{ MINFO 14 }
|
||||
{ MX 15 }
|
||||
{ TXT 16 }
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! CLASS
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOLS: IN CS CH HS ;
|
||||
|
||||
: class-table ( -- table )
|
||||
{
|
||||
{ IN 1 }
|
||||
{ CS 2 }
|
||||
{ CH 3 }
|
||||
{ HS 4 }
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! OPCODE
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOLS: QUERY IQUERY STATUS ;
|
||||
|
||||
: opcode-table ( -- table )
|
||||
{
|
||||
{ QUERY 0 }
|
||||
{ IQUERY 1 }
|
||||
{ STATUS 2 }
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! RCODE
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
||||
REFUSED ;
|
||||
|
||||
: rcode-table ( -- table )
|
||||
{
|
||||
{ NO-ERROR 0 }
|
||||
{ FORMAT-ERROR 1 }
|
||||
{ SERVER-FAILURE 2 }
|
||||
{ NAME-ERROR 3 }
|
||||
{ NOT-IMPLEMENTED 4 }
|
||||
{ REFUSED 5 }
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: <message> ( -- message )
|
||||
message new
|
||||
random-id >>id
|
||||
0 >>qr
|
||||
QUERY >>opcode
|
||||
0 >>aa
|
||||
0 >>tc
|
||||
1 >>rd
|
||||
0 >>ra
|
||||
0 >>z
|
||||
NO-ERROR >>rcode
|
||||
{ } >>question-section
|
||||
{ } >>answer-section
|
||||
{ } >>authority-section
|
||||
{ } >>additional-section ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
|
||||
|
||||
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: uint8->ba ( n -- ba ) 1 >be ;
|
||||
: uint16->ba ( n -- ba ) 2 >be ;
|
||||
: uint32->ba ( n -- ba ) 4 >be ;
|
||||
: uint64->ba ( n -- ba ) 8 >be ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: query->ba ( query -- ba )
|
||||
{
|
||||
[ name>> dn->ba ]
|
||||
[ type>> type-table of uint16->ba ]
|
||||
[ class>> class-table of uint16->ba ]
|
||||
}
|
||||
<arr> concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: hinfo->ba ( rdata -- ba )
|
||||
[ cpu>> label->ba ]
|
||||
[ os>> label->ba ]
|
||||
bi append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: mx->ba ( rdata -- ba )
|
||||
[ preference>> uint16->ba ]
|
||||
[ exchange>> dn->ba ]
|
||||
bi append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: soa->ba ( rdata -- ba )
|
||||
{
|
||||
[ mname>> dn->ba ]
|
||||
[ rname>> dn->ba ]
|
||||
[ serial>> uint32->ba ]
|
||||
[ refresh>> uint32->ba ]
|
||||
[ retry>> uint32->ba ]
|
||||
[ expire>> uint32->ba ]
|
||||
[ minimum>> uint32->ba ]
|
||||
}
|
||||
<arr> concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rdata->ba ( type rdata -- ba )
|
||||
swap
|
||||
{
|
||||
{ CNAME [ dn->ba ] }
|
||||
{ HINFO [ hinfo->ba ] }
|
||||
{ MX [ mx->ba ] }
|
||||
{ NS [ dn->ba ] }
|
||||
{ PTR [ dn->ba ] }
|
||||
{ SOA [ soa->ba ] }
|
||||
{ A [ ip->ba ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rr->ba ( rr -- ba )
|
||||
{
|
||||
[ name>> dn->ba ]
|
||||
[ type>> type-table of uint16->ba ]
|
||||
[ class>> class-table of uint16->ba ]
|
||||
[ ttl>> uint32->ba ]
|
||||
[
|
||||
[ type>> ] [ rdata>> ] bi rdata->ba
|
||||
[ length uint16->ba ] [ ] bi append
|
||||
]
|
||||
}
|
||||
<arr> concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: header-bits-ba ( message -- ba )
|
||||
{
|
||||
[ qr>> 15 shift ]
|
||||
[ opcode>> opcode-table of 11 shift ]
|
||||
[ aa>> 10 shift ]
|
||||
[ tc>> 9 shift ]
|
||||
[ rd>> 8 shift ]
|
||||
[ ra>> 7 shift ]
|
||||
[ z>> 4 shift ]
|
||||
[ rcode>> rcode-table of 0 shift ]
|
||||
}
|
||||
<arr> sum uint16->ba ;
|
||||
|
||||
: message->ba ( message -- ba )
|
||||
{
|
||||
[ id>> uint16->ba ]
|
||||
[ header-bits-ba ]
|
||||
[ question-section>> length uint16->ba ]
|
||||
[ answer-section>> length uint16->ba ]
|
||||
[ authority-section>> length uint16->ba ]
|
||||
[ additional-section>> length uint16->ba ]
|
||||
[ question-section>> [ query->ba ] map concat ]
|
||||
[ answer-section>> [ rr->ba ] map concat ]
|
||||
[ authority-section>> [ rr->ba ] map concat ]
|
||||
[ additional-section>> [ rr->ba ] map concat ]
|
||||
}
|
||||
<arr> concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-single ( ba i -- n ) at ;
|
||||
: get-double ( ba i -- n ) dup 2 + subseq be> ;
|
||||
: get-quad ( ba i -- n ) dup 4 + subseq be> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: label-length ( ba i -- length ) get-single ;
|
||||
|
||||
: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
|
||||
|
||||
: null-label? ( ba i -- ? ) get-single 0 = ;
|
||||
|
||||
: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: bit-test ( a b -- ? ) bitand 0 = not ;
|
||||
|
||||
: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
|
||||
|
||||
: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: skip-name ( ba i -- ba i )
|
||||
{
|
||||
{ [ 2dup null-label? ] [ 1 + ] }
|
||||
{ [ 2dup pointer? ] [ 2 + ] }
|
||||
{ [ t ] [ skip-label skip-name ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
: get-name ( ba i -- name )
|
||||
{
|
||||
{ [ 2dup null-label? ] [ 2drop "" ] }
|
||||
{ [ 2dup pointer? ] [ dupd pointer get-name ] }
|
||||
{
|
||||
[ t ]
|
||||
[
|
||||
[ get-label ]
|
||||
[ skip-label get-name ]
|
||||
2bi
|
||||
"." swap 3append
|
||||
]
|
||||
}
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-query ( ba i -- query )
|
||||
[ get-name ]
|
||||
[
|
||||
skip-name
|
||||
[ 0 + get-double type-table key-of ]
|
||||
[ 2 + get-double class-table key-of ]
|
||||
2bi
|
||||
]
|
||||
2bi query boa ;
|
||||
|
||||
: skip-query ( ba i -- ba i ) skip-name 4 + ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-soa ( ba i -- soa )
|
||||
{
|
||||
[ get-name ]
|
||||
[ skip-name get-name ]
|
||||
[
|
||||
skip-name
|
||||
skip-name
|
||||
{
|
||||
[ 0 + get-quad ]
|
||||
[ 4 + get-quad ]
|
||||
[ 8 + get-quad ]
|
||||
[ 12 + get-quad ]
|
||||
[ 16 + get-quad ]
|
||||
}
|
||||
2cleave
|
||||
]
|
||||
}
|
||||
2cleave soa boa ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
|
||||
|
||||
: get-rdata ( ba i type -- rdata )
|
||||
{
|
||||
{ CNAME [ get-name ] }
|
||||
{ NS [ get-name ] }
|
||||
{ PTR [ get-name ] }
|
||||
{ MX [ get-mx ] }
|
||||
{ SOA [ get-soa ] }
|
||||
{ A [ get-ip ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-rr ( ba i -- rr )
|
||||
[ get-name ]
|
||||
[
|
||||
skip-name
|
||||
{
|
||||
[ 0 + get-double type-table key-of ]
|
||||
[ 2 + get-double class-table key-of ]
|
||||
[ 4 + get-quad ]
|
||||
[ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ]
|
||||
}
|
||||
2cleave
|
||||
]
|
||||
2bi rr boa ;
|
||||
|
||||
: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-question-section ( ba i count -- seq ba i )
|
||||
[ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-rr-section ( ba i count -- seq ba i )
|
||||
[ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: >> neg shift ;
|
||||
|
||||
: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
|
||||
get-double
|
||||
{
|
||||
[ 15 >> BIN: 1 bitand ]
|
||||
[ 11 >> BIN: 111 bitand opcode-table key-of ]
|
||||
[ 10 >> BIN: 1 bitand ]
|
||||
[ 9 >> BIN: 1 bitand ]
|
||||
[ 8 >> BIN: 1 bitand ]
|
||||
[ 7 >> BIN: 1 bitand ]
|
||||
[ 4 >> BIN: 111 bitand ]
|
||||
[ BIN: 1111 bitand rcode-table key-of ]
|
||||
}
|
||||
cleave ;
|
||||
|
||||
: parse-message ( ba -- message )
|
||||
0
|
||||
{
|
||||
[ get-double ]
|
||||
[ 2 + get-header-bits ]
|
||||
[
|
||||
4 +
|
||||
{
|
||||
[ 8 + ]
|
||||
[ 0 + get-double ]
|
||||
[ 2 + get-double ]
|
||||
[ 4 + get-double ]
|
||||
[ 6 + get-double ]
|
||||
}
|
||||
2cleave
|
||||
>r >r >r
|
||||
get-question-section r>
|
||||
get-rr-section r>
|
||||
get-rr-section r>
|
||||
get-rr-section
|
||||
2drop
|
||||
]
|
||||
}
|
||||
2cleave message boa ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: send-receive-udp ( ba server -- ba )
|
||||
f 0 <inet4> <datagram>
|
||||
[
|
||||
[ send ] [ receive drop ] bi
|
||||
]
|
||||
with-disposal ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: send-receive-tcp ( ba server -- ba )
|
||||
[ dup length 2 >be prepend ] [ ] bi*
|
||||
binary
|
||||
[
|
||||
write flush
|
||||
2 read be> read
|
||||
]
|
||||
with-client ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: >dns-inet4 ( obj -- inet4 )
|
||||
dup string?
|
||||
[ 53 <inet4> ]
|
||||
[ ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: ask-server ( message server -- message )
|
||||
[ message->ba ] [ >dns-inet4 ] bi*
|
||||
2dup
|
||||
send-receive-udp parse-message
|
||||
dup tc>> 1 =
|
||||
[ drop send-receive-tcp parse-message ]
|
||||
[ nip nip ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: dns-servers ( -- seq ) V{ } ;
|
||||
|
||||
: dns-server ( -- server ) dns-servers random ;
|
||||
|
||||
: ask ( message -- message ) dns-server ask-server ;
|
||||
|
||||
: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
|
||||
Loading…
Reference in New Issue