From ff553f6aa0a67039ff2f3a1822d265e83f3b7237 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 23 May 2008 00:12:38 -0500 Subject: [PATCH] New vocabulary: dns --- extra/dns/cache/cache.factor | 142 +++++++++++ extra/dns/dns.factor | 462 +++++++++++++++++++++++++++++++++++ 2 files changed, 604 insertions(+) create mode 100644 extra/dns/cache/cache.factor create mode 100644 extra/dns/dns.factor diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor new file mode 100644 index 0000000000..e497192b04 --- /dev/null +++ b/extra/dns/cache/cache.factor @@ -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 ] } " " 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 ; diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor new file mode 100644 index 0000000000..560db69bb2 --- /dev/null +++ b/extra/dns/dns.factor @@ -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 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 ] + } + 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 ] + } + 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 + ] + } + 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 ] + } + 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 ] + } + 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 + [ + [ 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 ] + [ ] + 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 ) swap {1} >>question-section ; \ No newline at end of file