Hello
I'm newbie Factor developer. First of all, I'd like to say "thank you
very much" for really great language. Having all the power and
simplicity of Lisp without closing ten or more damn brackets at the
end of each complex function - this is my wet dream from school days.
I have choosen Factor for my next web-related project. One part of
this project is dynamic DNS server. I think, general DNS library will
be usefull not only for me, so I'd like to share. For now, it is
pretty low-level, only DNS message parsing and generation, but with
two-way name packing. Library is not not yet tested in real-life
environment and may be buggy, but before investing more time into it,
i'd like to show my code to more experienced Factor developers. Am I
doing something wrong?
Thank you.
Maxim Savchenko.
! Copyright (C) 2008 Maxim Savchenko.
! See http://factorcode.org/license.txt for BSD license.
USING: bitfields kernel arrays combinators sequences io math namespaces
io.binary strings assocs byte-arrays splitting tuples ;
IN: dns
<PRIVATE ! Helper stream for DNS message compression
TUPLE: dns-stream counter pointers ;
: <dns-stream> ( stream -- stream )
0 H{ } clone dns-stream construct-boa tuck set-delegate ;
PRIVATE> ! Helper stream for DNS message compression
TUPLE: dns-message id flags qd an ns ar ;
C: <dns-message> dns-message
BITFIELD: dns-flags qr:1 opcode:4 aa:1 tc:1 rd:1 ra:1 z:3 rcode:4 ;
TUPLE: dns-question name type class ;
C: <dns-question> dns-question
TUPLE: dns-record name type class ttl resource ;
C: <dns-record> dns-record
TUPLE: rdata-soa mname rname serial refresh retry expire minimum ;
C: <rdata-soa> rdata-soa
TUPLE: rdata-wks address protocol bitmap ;
C: <rdata-wks> rdata-wks
TUPLE: rdata-minfo rmailbx emailbx ;
C: <rdata-minfo> rdata-minfo
TUPLE: rdata-mx preference exchange ;
C: <rdata-mx> rdata-mx
<PRIVATE ! Helpers for DNS parsing
: read2be ( -- int ) 2 read be> ; inline
: read4be ( -- int ) 4 read be> ; inline
M: dns-stream stream-read1
dup delegate stream-read1 tuck
[ dup dns-stream-counter 1+ swap set-dns-stream-counter ]
[ drop ] if ;
M: dns-stream stream-read
tuck delegate stream-read dup length
pick dns-stream-counter + rot set-dns-stream-counter ;
TUPLE: rdata-istream limit ;
: <rdata-istream> ( int stream -- stream )
swap rdata-istream construct-boa tuck set-delegate ;
M: rdata-istream stream-read1
dup rdata-istream-limit dup 0 >
[ 1- over set-rdata-istream-limit delegate stream-read1 ]
[ 2drop f ] if ;
M: rdata-istream stream-read
dup rdata-istream-limit dup roll min dup 0 >
[ tuck - pick set-rdata-istream-limit swap delegate stream-read ]
[ 3drop f ] if ;
: rdata-readall ( -- data )
stdio get dup rdata-istream-limit swap stream-read ;
: (dns-name-read) ( list -- list )
stdio get dns-stream-counter read1 {
{
[ dup -6 shift BIN: 11 = ]
[
nip BIN: 111111 bitand 8 shift read1 +
stdio get dns-stream-pointers at
dup 1 roll set-nth
]
}
{
[ dup dup -6 shift 0 = swap 0 > and ]
[
read >string f 2array swap dupd
stdio get dns-stream-pointers set-at
dup 1 roll set-nth (dns-name-read)
]
}
{ [ dup 0 = ] [ 2drop ] }
} cond ;
: dns-name-read ( -- list )
{ f f } clone dup (dns-name-read) drop second ;
: dns-rdata-read ( type -- data )
{
{ 1 [ 4 read >byte-array ] } ! A
{ 2 [ dns-name-read ] } ! NS
{ 5 [ dns-name-read ] } ! CNAME
{ 6 [
dns-name-read ! MNAME
dns-name-read ! RNAME
read4be ! SERIAL
read4be ! REFRESH
read4be ! RETRY
read4be ! EXPIRE
read4be ! MINIMUM
<rdata-soa> ] } ! SOA
{ 11 [
4 read >byte-array ! ADDRESS
read1 ! PROTOCOL
rdata-readall >byte-array ! <BIT MAP>
<rdata-wks> ] } ! WKS
{ 12 [ dns-name-read ] } ! PTR
{ 14 [
dns-name-read
dns-name-read
<rdata-minfo> ] } ! MINFO
{ 15 [ read2be dns-name-read <rdata-mx> ] } ! MX
{ 16 [ rdata-readall >string ] } ! TXT
[ drop f ]
} case rdata-readall drop ; inline
: dns-question-read ( -- question )
dns-name-read ! QNAME
read2be ! QTYPE
read2be ! QCLASS
<dns-question> ;
: dns-record-read ( -- record )
dns-name-read ! NAME
read2be ! TYPE
read2be ! CLASS
read4be ! TTL
read2be ! RDLENGTH
>r pick r> stdio get
<rdata-istream> [ dns-rdata-read ] with-stream* <dns-record> ;
: (domain-name>string) ( list -- )
[ dup first % CHAR: . , second (domain-name>string) ] when* ;
PRIVATE> ! Helpers for DNS parsing
: dns-read ( stream -- message )
<dns-stream> [
read2be ! ID
read2be ! flags
read2be ! QDCOUNT
read2be ! ANCOUNT
read2be ! NSCOUNT
read2be ! ARCOUNT
roll [ drop dns-question-read ] map ! questions
roll [ drop dns-record-read ] map ! answers
roll [ drop dns-record-read ] map ! autorities
roll [ drop dns-record-read ] map ! additional
] with-stream* <dns-message> ;
: domain-name>string ( list -- string )
[ (domain-name>string) ] "" make ;
<PRIVATE ! Helpers for DNS generation
: write2be ( int -- ) 2 >be write ; inline
: write4be ( int -- ) 4 >be write ; inline
: tuple-each ( tuple seq -- )
>r tuple-slots r> [ call ] 2each ; inline
M: dns-stream stream-write1
dup dns-stream-counter 1+ over set-dns-stream-counter
delegate stream-write1 ;
M: dns-stream stream-write
2dup dns-stream-counter swap length + over set-dns-stream-counter
delegate stream-write ;
TUPLE: rdata-ostream buffer length ;
: <rdata-ostream> ( stream -- stream )
V{ } clone 0 rdata-ostream construct-boa tuck set-delegate ;
M: rdata-ostream stream-write1
tuck rdata-ostream-buffer push
dup rdata-ostream-length 1+ swap set-rdata-ostream-length ;
M: rdata-ostream stream-write
2dup rdata-ostream-buffer push
tuck rdata-ostream-length swap length + swap set-rdata-ostream-length ;
M: rdata-ostream stream-close
dup rdata-ostream-length 2 >be over delegate tuck stream-write
>r rdata-ostream-buffer r>
[ over integer? [ stream-write1 ] [ stream-write ] if ] curry each ;
: dns-name-write ( list -- )
dup not [ drop 0 write1 ] [
stdio get 2dup dns-stream-pointers at
[ 2nip BIN: 11 14 shift bitor write2be ] [
dup dns-stream-counter pick rot
dns-stream-pointers set-at dup first dup
length write1 write second dns-name-write
] if*
] if ;
: dns-rdata-write ( rdata type -- )
{
{ 1 [ write ] } ! A
{ 2 [ dns-name-write ] } ! NS
{ 5 [ dns-name-write ] } ! CNAME
{ 6 [ {
[ dns-name-write ] ! MNAME
[ dns-name-write ] ! RNAME
[ write4be ] ! SERIAL
[ write4be ] ! REFRESH
[ write4be ] ! RETRY
[ write4be ] ! EXPIRE
[ write4be ] ! MINIMUM
} tuple-each ] } ! SOA
{ 11 [ {
[ write ] ! ADDRESS
[ write1 ] ! PROTOCOL
[ write ] ! <BIT MAP>
} tuple-each ] } ! WKS
{ 12 [ dns-name-write ] } ! PTR
{ 14 [ {
[ dns-name-write ]
[ dns-name-write ]
} tuple-each ] } ! MINFO
{ 15 [ {
[ write2be ]
[ dns-name-write ]
} tuple-each ] } ! MX
{ 16 [ write ] } ! TXT
[ 2drop ]
} case ; inline
: dns-question-write ( question -- )
{
[ dns-name-write ] ! QNAME
[ write2be ] ! QTYPE
[ write2be ] ! QCLASS
} tuple-each ;
: dns-record-write ( record -- )
dup {
[ dns-name-write ] ! NAME
[ write2be ] ! TYPE
[ write2be ] ! CLASS
[ write4be ] ! TTL
[ drop ]
} tuple-each
dup dns-record-resource swap dns-record-type
stdio get <rdata-ostream> [ dns-rdata-write ] with-stream ;
: (string>domain-name) ( list name -- list name )
dup empty?
[ "." split1 >r f 2array tuck 1 rot set-nth r> (string>domain-name) ]
unless ;
PRIVATE> ! Helpers for DNS generation
: dns-write ( message stream -- )
<dns-stream> [
dup {
[ write2be ] ! ID
[ write2be ] ! flags
[ length write2be ] ! QDCOUNT
[ length write2be ] ! ANCOUNT
[ length write2be ] ! NSCOUNT
[ length write2be ] ! ARCOUNT
} tuple-each {
[ drop ]
[ drop ]
[ [ dns-question-write ] each ] ! questions
[ [ dns-record-write ] each ] ! answers
[ [ dns-record-write ] each ] ! autorities
[ [ dns-record-write ] each ] ! additional
} tuple-each
] with-stream* ;
: string>domain-name ( string -- list )
{ f f } clone swap dupd (string>domain-name) 2drop second ;
-------------------------------------------------------------------------
Check out the new SourceForge.net Marketplace.
It's the best place to buy or sell services for
just about anything Open Source.
http://ad.doubleclick.net/clk;164216239;13503038;w?http://sf.net/marketplace
_______________________________________________
Factor-talk mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/factor-talk
