Merge branch 'master' of git://factorcode.org/git/factor
Anton Gorenko
commit
f7573bf329
|
|
@ -1,6 +1,7 @@
|
|||
! (c)2010 Joe Groff, Erik Charlebois bsd license
|
||||
USING: accessors alien.c-types arrays combinators delegate fry
|
||||
generic.parser kernel macros math parser sequences words words.symbol ;
|
||||
generic.parser kernel macros math parser sequences words words.symbol
|
||||
classes.singleton assocs ;
|
||||
IN: alien.enums
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -34,11 +35,11 @@ M: enum-c-type c-type-setter
|
|||
: define-enum-value ( class value -- )
|
||||
"enum-value" set-word-prop ;
|
||||
|
||||
: define-enum-members ( member-names -- )
|
||||
: define-enum-members ( members -- )
|
||||
[
|
||||
[ first define-symbol ]
|
||||
[ first2 define-enum-value ] bi
|
||||
] each ;
|
||||
[ drop define-singleton-class ]
|
||||
[ define-enum-value ] 2bi
|
||||
] assoc-each ;
|
||||
|
||||
: define-enum-constructor ( word -- )
|
||||
[ name>> "<" ">" surround create-in ] keep
|
||||
|
|
@ -48,8 +49,8 @@ PRIVATE>
|
|||
|
||||
: define-enum ( word base-type members -- )
|
||||
[ dup define-enum-constructor ] 2dip
|
||||
dup define-enum-members
|
||||
<enum-c-type> swap typedef ;
|
||||
[ define-enum-members ]
|
||||
[ <enum-c-type> swap typedef ] bi ;
|
||||
|
||||
PREDICATE: enum-c-type-word < c-type-word
|
||||
"c-type" word-prop enum-c-type? ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ HELP: <action>
|
|||
|
||||
HELP: <chloe-content>
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "pair" "a pair with shape " { $snippet "{ class string }" } }
|
||||
{ "response" response }
|
||||
}
|
||||
{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! Copyright (C) 2005 Alex Chapman
|
||||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! Copyright (C) 2006, 2010 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting accessors
|
||||
|
|
@ -26,7 +26,7 @@ M: template-lexer skip-word
|
|||
DEFER: <% delimiter
|
||||
|
||||
: check-<% ( lexer -- col )
|
||||
"<%" over line-text>> rot column>> start* ;
|
||||
"<%" swap [ line-text>> ] [ column>> ] bi start* ;
|
||||
|
||||
: found-<% ( accum lexer col -- accum )
|
||||
[
|
||||
|
|
@ -59,10 +59,10 @@ SYNTAX: %> lexer get parse-%> ;
|
|||
: parse-template ( string -- quot )
|
||||
[
|
||||
[
|
||||
"quiet" on
|
||||
parser-notes off
|
||||
"html.templates.fhtml" use-vocab
|
||||
string-lines parse-template-lines
|
||||
"quiet" on
|
||||
parser-notes off
|
||||
"html.templates.fhtml" use-vocab
|
||||
string-lines parse-template-lines
|
||||
] with-file-vocabs
|
||||
] with-compilation-unit ;
|
||||
|
||||
|
|
@ -74,6 +74,6 @@ TUPLE: fhtml path ;
|
|||
C: <fhtml> fhtml
|
||||
|
||||
M: fhtml call-template* ( filename -- )
|
||||
[ path>> utf8 file-contents eval-template ] call( filename -- ) ;
|
||||
path>> utf8 file-contents eval-template ;
|
||||
|
||||
INSTANCE: fhtml template
|
||||
|
|
|
|||
|
|
@ -235,6 +235,13 @@ test-db [
|
|||
servers>> random addr>> port>>
|
||||
] with-scope "port" set ;
|
||||
|
||||
: add-port ( url -- url' )
|
||||
>url clone "port" get >>port ;
|
||||
|
||||
: stop-test-httpd ( -- )
|
||||
"http://localhost/quit" add-port http-get nip
|
||||
"Goodbye" assert= ;
|
||||
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
add-quit-action
|
||||
|
|
@ -248,9 +255,6 @@ test-db [
|
|||
test-httpd
|
||||
] unit-test
|
||||
|
||||
: add-port ( url -- url' )
|
||||
>url clone "port" get >>port ;
|
||||
|
||||
[ t ] [
|
||||
"vocab:http/test/foo.html" ascii file-contents
|
||||
"http://localhost/nested/foo.html" add-port http-get nip =
|
||||
|
|
@ -279,7 +283,7 @@ test-db [
|
|||
|
||||
|
||||
[ ] [
|
||||
[ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
|
||||
[ stop-test-httpd ] ignore-errors
|
||||
] unit-test
|
||||
|
||||
! Dispatcher bugs
|
||||
|
|
@ -402,7 +406,7 @@ SYMBOL: a
|
|||
"vocab:http/test/foo.html" ascii file-contents =
|
||||
] unit-test
|
||||
|
||||
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
|
||||
[ ] [ stop-test-httpd ] unit-test
|
||||
|
||||
! Check behavior of 307 redirect (reported by Chris Double)
|
||||
[ ] [
|
||||
|
|
@ -429,4 +433,16 @@ SYMBOL: a
|
|||
] with-directory
|
||||
] must-fail
|
||||
|
||||
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
|
||||
[ ] [ stop-test-httpd ] unit-test
|
||||
|
||||
! Check that index.fhtml works
|
||||
[ ] [
|
||||
<dispatcher>
|
||||
"resource:basis/http/test/" <static> enable-fhtml >>default
|
||||
add-quit-action
|
||||
test-httpd
|
||||
] unit-test
|
||||
|
||||
[ "OK\n\n" ] [ "http://localhost/" add-port http-get nip ] unit-test
|
||||
|
||||
[ ] [ stop-test-httpd ] unit-test
|
||||
|
|
|
|||
|
|
@ -7,9 +7,10 @@ io.files.info io.directories io.pathnames io.encodings.binary
|
|||
fry xml.entities destructors urls html xml.syntax
|
||||
html.templates.fhtml http http.server http.server.responses
|
||||
http.server.redirection xml.writer ;
|
||||
FROM: sets => adjoin ;
|
||||
IN: http.server.static
|
||||
|
||||
TUPLE: file-responder root hook special allow-listings ;
|
||||
TUPLE: file-responder root hook special index-names allow-listings ;
|
||||
|
||||
: modified-since ( request -- date )
|
||||
"if-modified-since" header ";" split1 drop
|
||||
|
|
@ -23,7 +24,8 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
file-responder new
|
||||
swap >>hook
|
||||
swap >>root
|
||||
H{ } clone >>special ;
|
||||
H{ } clone >>special
|
||||
V{ "index.html" } >>index-names ;
|
||||
|
||||
: (serve-static) ( path mime-type -- response )
|
||||
[
|
||||
|
|
@ -75,7 +77,9 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
] if ;
|
||||
|
||||
: find-index ( filename -- path )
|
||||
"index.html" append-path dup exists? [ drop f ] unless ;
|
||||
file-responder get index-names>>
|
||||
[ append-path dup exists? [ drop f ] unless ] with map-find
|
||||
drop ;
|
||||
|
||||
: serve-directory ( filename -- response )
|
||||
url get path>> "/" tail? [
|
||||
|
|
@ -97,8 +101,12 @@ M: file-responder call-responder* ( path responder -- response )
|
|||
".." over member?
|
||||
[ drop <400> ] [ "/" join serve-object ] if ;
|
||||
|
||||
! file responder integration
|
||||
: add-index ( name responder -- )
|
||||
index-names>> adjoin ;
|
||||
|
||||
: serve-fhtml ( path -- response )
|
||||
<fhtml> "text/html" <content> ;
|
||||
|
||||
: enable-fhtml ( responder -- responder )
|
||||
[ <fhtml> "text/html" <content> ]
|
||||
"application/x-factor-server-page"
|
||||
pick special>> set-at ;
|
||||
[ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
|
||||
"index.fhtml" over add-index ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
<% USE: io "OK" write %>
|
||||
|
|
@ -726,6 +726,7 @@ audio/mpa
|
|||
audio/mpa-robust
|
||||
audio/mpeg mpga mp2 mp2a mp3 m2a m3a
|
||||
audio/mpeg4-generic
|
||||
audio/ogg oga
|
||||
audio/parityfec
|
||||
audio/pcma
|
||||
audio/pcmu
|
||||
|
|
@ -954,6 +955,7 @@ video/mpeg mpeg mpg mpe m1v m2v
|
|||
video/mpeg4-generic
|
||||
video/mpv
|
||||
video/nv
|
||||
video/ogg ogv
|
||||
video/parityfec
|
||||
video/pointer
|
||||
video/quicktime qt mov
|
||||
|
|
@ -976,6 +978,7 @@ video/vnd.sealed.mpeg4
|
|||
video/vnd.sealed.swf
|
||||
video/vnd.sealedmedia.softseal.mov
|
||||
video/vnd.vivo viv
|
||||
video/webm webm
|
||||
video/x-dv dv dif
|
||||
video/x-fli fli
|
||||
video/x-ms-asf asf asx
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,408 @@
|
|||
! Copyright (C) 2010 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.enums alien.syntax arrays assocs
|
||||
byte-arrays calendar combinators combinators.smart constructors
|
||||
destructors fry grouping io io.binary io.buffers
|
||||
io.encodings.binary io.encodings.string io.encodings.utf8
|
||||
io.files io.ports io.sockets io.streams.byte-array io.timeouts
|
||||
kernel make math math.bitwise math.parser math.ranges
|
||||
math.statistics memoize namespaces random sequences
|
||||
slots.syntax splitting strings system unicode.categories
|
||||
vectors nested-comments io.sockets.private ;
|
||||
IN: dns
|
||||
|
||||
GENERIC: stream-peek1 ( stream -- byte/f )
|
||||
|
||||
M: input-port stream-peek1
|
||||
dup check-disposed dup wait-to-read
|
||||
[ drop f ] [ buffer>> buffer-peek ] if ; inline
|
||||
|
||||
M: byte-reader stream-peek1
|
||||
[ i>> ] [ underlying>> ] bi ?nth ;
|
||||
|
||||
: peek1 ( -- byte ) input-stream get stream-peek1 ;
|
||||
|
||||
: with-temporary-input-seek ( n seek-type quot -- )
|
||||
tell-input [
|
||||
[ seek-input ] dip call
|
||||
] dip seek-absolute seek-input ; inline
|
||||
|
||||
ENUM: dns-type
|
||||
{ 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 }
|
||||
{ RP 17 } { AFSDB 18 } { SIG 24 } { KEY 25 }
|
||||
{ AAAA 28 } { LOC 29 } { SVR 33 } { NAPTR 35 }
|
||||
{ KX 36 } { CERT 37 } { DNAME 39 } { OPT 41 }
|
||||
{ APL 42 } { DS 43 } { SSHFP 44 } { IPSECKEY 45 }
|
||||
{ RRSIG 46 } { NSEC 47 } { DNSKEY 48 } { DHCID 49 }
|
||||
{ NSEC3 50 } { NSEC3PARAM 51 } { HIP 55 } { SPF 99 }
|
||||
{ TKEY 249 } { TSIG 250 } { IXFR 251 }
|
||||
{ TA 32768 } { DLV 32769 } ;
|
||||
|
||||
ENUM: dns-class { IN 1 } { CS 2 } { CH 3 } { HS 4 } ;
|
||||
|
||||
ENUM: dns-opcode QUERY IQUERY STATUS ;
|
||||
|
||||
ENUM: dns-rcode NO-ERROR FORMAT-ERROR SERVER-FAILURE
|
||||
NAME-ERROR NOT-IMPLEMENTED REFUSED ;
|
||||
|
||||
SYMBOL: dns-servers
|
||||
|
||||
: add-dns-server ( string -- )
|
||||
dns-servers get push ;
|
||||
|
||||
: remove-dns-server ( string -- )
|
||||
dns-servers get remove! drop ;
|
||||
|
||||
: clear-dns-servers ( -- )
|
||||
V{ } clone dns-servers set-global ;
|
||||
|
||||
! Google DNS servers
|
||||
CONSTANT: initial-dns-servers { "8.8.8.8" "8.8.4.4" }
|
||||
|
||||
: load-resolve.conf ( -- seq )
|
||||
"/etc/resolv.conf" utf8 file-lines
|
||||
[ [ blank? ] trim ] map
|
||||
[ "#" head? not ] filter
|
||||
[ [ " " split1 swap ] dip push-at ] sequence>hashtable "nameserver" swap at ;
|
||||
|
||||
dns-servers [ initial-dns-servers >vector ] initialize
|
||||
|
||||
: >dotted ( domain -- domain' )
|
||||
dup "." tail? [ "." append ] unless ;
|
||||
|
||||
: dotted> ( string -- string' )
|
||||
"." ?tail drop ;
|
||||
|
||||
TUPLE: query name type class ;
|
||||
CONSTRUCTOR: query ( name type class -- obj )
|
||||
[ >dotted ] change-name ;
|
||||
|
||||
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: a name ;
|
||||
CONSTRUCTOR: a ( name -- obj ) ;
|
||||
|
||||
TUPLE: aaaa name ;
|
||||
CONSTRUCTOR: aaaa ( name -- obj ) ;
|
||||
|
||||
TUPLE: cname name ;
|
||||
CONSTRUCTOR: cname ( name -- obj ) ;
|
||||
|
||||
TUPLE: ptr name ;
|
||||
CONSTRUCTOR: ptr ( name -- obj ) ;
|
||||
|
||||
TUPLE: ns name ;
|
||||
CONSTRUCTOR: ns ( name -- obj ) ;
|
||||
|
||||
TUPLE: message id qr opcode aa tc rd ra z rcode
|
||||
query answer-section authority-section additional-section ;
|
||||
|
||||
CONSTRUCTOR: message ( query -- obj )
|
||||
16 2^ random >>id
|
||||
0 >>qr
|
||||
QUERY >>opcode
|
||||
0 >>aa
|
||||
0 >>tc
|
||||
1 >>rd
|
||||
0 >>ra
|
||||
0 >>z
|
||||
NO-ERROR >>rcode
|
||||
[ dup sequence? [ 1array ] unless ] change-query
|
||||
{ } >>answer-section
|
||||
{ } >>authority-section
|
||||
{ } >>additional-section ;
|
||||
|
||||
: message>header ( message -- n )
|
||||
[
|
||||
{
|
||||
[ qr>> 15 shift ]
|
||||
[ opcode>> enum>number 11 shift ]
|
||||
[ aa>> 10 shift ]
|
||||
[ tc>> 9 shift ]
|
||||
[ rd>> 8 shift ]
|
||||
[ ra>> 7 shift ]
|
||||
[ z>> 4 shift ]
|
||||
[ rcode>> enum>number 0 shift ]
|
||||
} cleave
|
||||
] sum-outputs ;
|
||||
|
||||
: header>message-parts ( n -- qr opcode aa tc rd ra z rcode )
|
||||
{
|
||||
[ -15 shift BIN: 1 bitand ]
|
||||
[ -11 shift BIN: 111 bitand <dns-opcode> ]
|
||||
[ -10 shift BIN: 1 bitand ]
|
||||
[ -9 shift BIN: 1 bitand ]
|
||||
[ -8 shift BIN: 1 bitand ]
|
||||
[ -7 shift BIN: 1 bitand ]
|
||||
[ -4 shift BIN: 111 bitand ]
|
||||
[ BIN: 1111 bitand <dns-rcode> ]
|
||||
} cleave ;
|
||||
|
||||
: byte-array>ipv4 ( byte-array -- string )
|
||||
[ number>string ] { } map-as "." join ;
|
||||
|
||||
: byte-array>ipv6 ( byte-array -- string )
|
||||
2 group [ be> >hex ] { } map-as ":" join ;
|
||||
|
||||
: ipv4>byte-array ( string -- byte-array )
|
||||
"." split [ string>number ] B{ } map-as ;
|
||||
|
||||
: ipv6>byte-array ( string -- byte-array )
|
||||
T{ inet6 } inet-pton ;
|
||||
|
||||
: expand-ipv6 ( ipv6 -- ipv6' ) ipv6>byte-array byte-array>ipv6 ;
|
||||
|
||||
: reverse-ipv4 ( string -- string )
|
||||
ipv4>byte-array reverse byte-array>ipv4 ;
|
||||
|
||||
CONSTANT: ipv4-arpa-suffix ".in-addr.arpa"
|
||||
|
||||
: ipv4>arpa ( string -- string )
|
||||
reverse-ipv4 ipv4-arpa-suffix append ;
|
||||
|
||||
CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
|
||||
|
||||
: ipv6>arpa ( string -- string )
|
||||
ipv6>byte-array [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
|
||||
B{ } concat-as reverse
|
||||
[ >hex ] { } map-as "." join ipv6-arpa-suffix append ;
|
||||
|
||||
: trim-ipv4-arpa ( string -- string' )
|
||||
dotted> ipv4-arpa-suffix ?tail drop ;
|
||||
|
||||
: trim-ipv6-arpa ( string -- string' )
|
||||
dotted> ipv6-arpa-suffix ?tail drop ;
|
||||
|
||||
: arpa>ipv4 ( string -- ip ) trim-ipv4-arpa reverse-ipv4 ;
|
||||
|
||||
: arpa>ipv6 ( string -- ip )
|
||||
trim-ipv6-arpa "." split 2 group reverse
|
||||
[
|
||||
first2 swap [ hex> ] bi@ [ 4 shift ] [ ] bi* bitor
|
||||
] B{ } map-as byte-array>ipv6 ;
|
||||
|
||||
: parse-length-bytes ( -- seq ) read1 read utf8 decode ;
|
||||
|
||||
: (parse-name) ( -- )
|
||||
peek1 [
|
||||
read1 drop
|
||||
] [
|
||||
HEX: C0 mask? [
|
||||
2 read be> HEX: 3fff bitand
|
||||
seek-absolute [ parse-length-bytes , (parse-name) ] with-temporary-input-seek
|
||||
] [
|
||||
parse-length-bytes , (parse-name)
|
||||
] if
|
||||
] if-zero ;
|
||||
|
||||
: parse-name ( -- seq )
|
||||
[ (parse-name) ] { } make "." join ;
|
||||
|
||||
: parse-query ( -- query )
|
||||
parse-name
|
||||
2 read be> <dns-type>
|
||||
2 read be> <dns-class> <query> ;
|
||||
|
||||
: parse-soa ( -- soa )
|
||||
soa new
|
||||
parse-name >>mname
|
||||
parse-name >>rname
|
||||
4 read be> >>serial
|
||||
4 read be> >>refresh
|
||||
4 read be> >>retry
|
||||
4 read be> >>expire
|
||||
4 read be> >>minimum ;
|
||||
|
||||
: parse-mx ( -- mx )
|
||||
mx new
|
||||
2 read be> >>preference
|
||||
parse-name >>exchange ;
|
||||
|
||||
GENERIC: parse-rdata ( n type -- obj )
|
||||
|
||||
M: object parse-rdata drop read ;
|
||||
M: A parse-rdata 2drop 4 read byte-array>ipv4 <a> ;
|
||||
M: AAAA parse-rdata 2drop 16 read byte-array>ipv6 <aaaa> ;
|
||||
M: CNAME parse-rdata 2drop parse-name <cname> ;
|
||||
M: MX parse-rdata 2drop parse-mx ;
|
||||
M: NS parse-rdata 2drop parse-name <ns> ;
|
||||
M: PTR parse-rdata 2drop parse-name <ptr> ;
|
||||
M: SOA parse-rdata 2drop parse-soa ;
|
||||
|
||||
: parse-rr ( -- rr )
|
||||
rr new
|
||||
parse-name >>name
|
||||
2 read be> <dns-type> >>type
|
||||
2 read be> <dns-class> >>class
|
||||
4 read be> >>ttl
|
||||
2 read be> over type>> parse-rdata >>rdata ;
|
||||
|
||||
: parse-message ( ba -- message )
|
||||
[ message new ] dip
|
||||
binary [
|
||||
2 read be> >>id
|
||||
2 read be> header>message-parts set-slots[ qr opcode aa tc rd ra z rcode ]
|
||||
2 read be> >>query
|
||||
2 read be> >>answer-section
|
||||
2 read be> >>authority-section
|
||||
2 read be> >>additional-section
|
||||
[ [ parse-query ] replicate ] change-query
|
||||
[ [ parse-rr ] replicate ] change-answer-section
|
||||
[ [ parse-rr ] replicate ] change-authority-section
|
||||
[ [ parse-rr ] replicate ] change-additional-section
|
||||
] with-byte-reader ;
|
||||
|
||||
: >n/label ( string -- ba )
|
||||
[ length 1array ] [ utf8 encode ] bi B{ } append-as ;
|
||||
|
||||
: >name ( dn -- ba ) "." split [ >n/label ] map concat ;
|
||||
|
||||
: query>byte-array ( query -- ba )
|
||||
[
|
||||
{
|
||||
[ name>> >name ]
|
||||
[ type>> enum>number 2 >be ]
|
||||
[ class>> enum>number 2 >be ]
|
||||
} cleave
|
||||
] output>array concat ;
|
||||
|
||||
GENERIC: rdata>byte-array ( rdata type -- obj )
|
||||
|
||||
M: A rdata>byte-array drop ipv4>byte-array ;
|
||||
|
||||
M: CNAME rdata>byte-array drop >name ;
|
||||
|
||||
M: HINFO rdata>byte-array
|
||||
drop
|
||||
[ cpu>> >name ]
|
||||
[ os>> >name ] bi append ;
|
||||
|
||||
M: MX rdata>byte-array
|
||||
drop
|
||||
[ preference>> 2 >be ]
|
||||
[ exchange>> >name ] bi append ;
|
||||
|
||||
M: NS rdata>byte-array drop >name ;
|
||||
|
||||
M: PTR rdata>byte-array drop >name ;
|
||||
|
||||
M: SOA rdata>byte-array
|
||||
drop
|
||||
[
|
||||
{
|
||||
[ mname>> >name ]
|
||||
[ rname>> >name ]
|
||||
[ serial>> 4 >be ]
|
||||
[ refresh>> 4 >be ]
|
||||
[ retry>> 4 >be ]
|
||||
[ expire>> 4 >be ]
|
||||
[ minimum>> 4 >be ]
|
||||
} cleave
|
||||
] output>array concat ;
|
||||
|
||||
: rr>byte-array ( rr -- ba )
|
||||
[
|
||||
{
|
||||
[ name>> >name ]
|
||||
[ type>> enum>number 2 >be ]
|
||||
[ class>> enum>number 2 >be ]
|
||||
[ ttl>> 4 >be ]
|
||||
[
|
||||
[ rdata>> ] [ type>> ] bi rdata>byte-array
|
||||
[ length 2 >be ] [ ] bi append
|
||||
]
|
||||
} cleave
|
||||
] output>array concat ;
|
||||
|
||||
: message>byte-array ( message -- ba )
|
||||
[
|
||||
{
|
||||
[ id>> 2 >be ]
|
||||
[ message>header 2 >be ]
|
||||
[ query>> length 2 >be ]
|
||||
[ answer-section>> length 2 >be ]
|
||||
[ authority-section>> length 2 >be ]
|
||||
[ additional-section>> length 2 >be ]
|
||||
[ query>> [ query>byte-array ] map concat ]
|
||||
[ answer-section>> [ rr>byte-array ] map concat ]
|
||||
[ authority-section>> [ rr>byte-array ] map concat ]
|
||||
[ additional-section>> [ rr>byte-array ] map concat ]
|
||||
} cleave
|
||||
] output>array concat ;
|
||||
|
||||
: udp-query ( bytes server -- bytes' )
|
||||
f 0 <inet4> <datagram>
|
||||
5 seconds over set-timeout [
|
||||
[ send ] [ receive drop ] bi
|
||||
] with-disposal ;
|
||||
|
||||
: <dns-inet4> ( -- inet4 )
|
||||
dns-servers get random 53 <inet4> ;
|
||||
|
||||
: dns-query ( query -- message )
|
||||
<message> message>byte-array
|
||||
<dns-inet4> udp-query parse-message ;
|
||||
|
||||
: dns-A-query ( domain -- message ) A IN <query> dns-query ;
|
||||
: dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ;
|
||||
: dns-MX-query ( domain -- message ) MX IN <query> dns-query ;
|
||||
: dns-NS-query ( domain -- message ) NS IN <query> dns-query ;
|
||||
|
||||
: reverse-lookup ( reversed-ip -- message )
|
||||
PTR IN <query> dns-query ;
|
||||
|
||||
: reverse-ipv4-lookup ( ip -- message )
|
||||
ipv4>arpa reverse-lookup ;
|
||||
|
||||
: reverse-ipv6-lookup ( ip -- message )
|
||||
ipv6>arpa reverse-lookup ;
|
||||
|
||||
: message>names ( message -- names )
|
||||
answer-section>> [ rdata>> name>> ] map ;
|
||||
|
||||
: message>mxs ( message -- assoc )
|
||||
answer-section>> [ rdata>> [ preference>> ] [ exchange>> ] bi 2array ] map ;
|
||||
|
||||
: messages>names ( messages -- names )
|
||||
[ message>names ] map concat ;
|
||||
|
||||
: forward-confirmed-reverse-dns-ipv4? ( ipv4-string -- ? )
|
||||
dup reverse-ipv4-lookup message>names
|
||||
[ dns-A-query ] map messages>names member? ;
|
||||
|
||||
: forward-confirmed-reverse-dns-ipv6? ( ipv6-string -- ? )
|
||||
expand-ipv6
|
||||
dup reverse-ipv6-lookup message>names
|
||||
[ dns-AAAA-query ] map messages>names member? ;
|
||||
|
||||
: message>query-name ( message -- string )
|
||||
query>> first name>> dotted> ;
|
||||
|
||||
: a-line. ( host ip -- )
|
||||
[ write " has address " write ] [ print ] bi* ;
|
||||
|
||||
: a-message. ( message -- )
|
||||
[ message>query-name ] [ message>names ] bi
|
||||
[ a-line. ] with each ;
|
||||
|
||||
: mx-line. ( host pair -- )
|
||||
[ write " mail is handled by " write ]
|
||||
[ first2 [ number>string write bl ] [ print ] bi* ] bi* ;
|
||||
|
||||
: mx-message. ( message -- )
|
||||
[ message>query-name ] [ message>mxs ] bi
|
||||
[ mx-line. ] with each ;
|
||||
|
||||
: host ( domain -- )
|
||||
[ dns-A-query a-message. ]
|
||||
[ dns-AAAA-query a-message. ]
|
||||
[ dns-MX-query mx-message. ] tri ;
|
||||
|
|
@ -2,7 +2,7 @@ USING: accessors arrays assocs byte-vectors checksums
|
|||
checksums.md5 constructors continuations destructors fry
|
||||
hashtables io.encodings.binary io.encodings.string
|
||||
io.encodings.utf8 io.sockets io.streams.duplex kernel locals
|
||||
math math.parser mongodb.cmd mongodb.msg
|
||||
math math.parser mongodb.cmd mongodb.msg strings
|
||||
namespaces sequences splitting ;
|
||||
IN: mongodb.connection
|
||||
|
||||
|
|
@ -112,10 +112,13 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
|||
":" split [ first ] [ second string>number ] bi ; inline
|
||||
|
||||
: eval-ismaster-result ( node result -- )
|
||||
[ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
|
||||
[ [ "remote" ] dip at
|
||||
[ split-host-str <inet> f <mdb-node> >>remote ] when*
|
||||
drop ] 2bi ;
|
||||
[
|
||||
[ "ismaster" ] dip at dup string?
|
||||
[ >integer 1 = ] [ ] if >>master? drop
|
||||
] [
|
||||
[ "remote" ] dip at
|
||||
[ split-host-str <inet> f <mdb-node> >>remote ] when* drop
|
||||
] 2bi ;
|
||||
|
||||
: check-node ( mdb node -- )
|
||||
[ <mdb-connection> &dispose ] dip
|
||||
|
|
|
|||
|
|
@ -98,10 +98,12 @@ SYNTAX: r/ ( token -- mdbregexp )
|
|||
[ <mdb-pool> ] dip
|
||||
[ mdb-pool swap with-variable ] curry with-disposal ; inline
|
||||
|
||||
: with-mdb-connection ( quot -- )
|
||||
[ mdb-pool get ] dip
|
||||
: with-mdb-pool ( ..a mdb-pool quot -- ..b )
|
||||
'[ _ with-connection ] with-pooled-connection ; inline
|
||||
|
||||
: with-mdb-connection ( quot -- )
|
||||
[ mdb-pool get ] dip with-mdb-pool ; inline
|
||||
|
||||
: >id-selector ( assoc -- selector )
|
||||
[ MDB_OID_FIELD swap at ] keep
|
||||
H{ } clone [ set-at ] keep ;
|
||||
|
|
@ -225,6 +227,15 @@ M: mdb-query-msg find
|
|||
M: mdb-cursor find
|
||||
get-more ;
|
||||
|
||||
: each-chunk ( selector quot: ( seq -- ) -- )
|
||||
swap find
|
||||
[ pick call( seq -- ) ] when*
|
||||
[ swap each-chunk ] [ drop ] if* ;
|
||||
|
||||
: find-all ( selector -- seq )
|
||||
[ V{ } clone ] dip
|
||||
over '[ _ push-all ] each-chunk >array ;
|
||||
|
||||
: explain. ( mdb-query-msg -- )
|
||||
t >>explain find nip . ;
|
||||
|
||||
|
|
|
|||
|
|
@ -38,6 +38,8 @@ SYNTAX: MDBTUPLE:
|
|||
[ drop-table ]
|
||||
[ ensure-table ] bi ;
|
||||
|
||||
DEFER: tuple>query
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: id-selector ( object -- selector )
|
||||
|
|
@ -52,6 +54,10 @@ M: mdb-persistent id-selector
|
|||
swap '[ [ _ ] 2dip
|
||||
[ id-selector ] dip
|
||||
<update> >upsert update ] assoc-each ; inline
|
||||
|
||||
: prepare-tuple-query ( tuple/query -- query )
|
||||
dup mdb-query-msg? [ tuple>query ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: save-tuple-deep ( tuple -- )
|
||||
|
|
@ -83,12 +89,16 @@ PRIVATE>
|
|||
tuple>selector <query> ;
|
||||
|
||||
: select-tuple ( tuple/query -- tuple/f )
|
||||
dup mdb-query-msg? [ tuple>query ] unless
|
||||
prepare-tuple-query
|
||||
find-one [ assoc>tuple ] [ f ] if* ;
|
||||
|
||||
: select-tuples ( tuple/query -- cursor tuples/f )
|
||||
dup mdb-query-msg? [ tuple>query ] unless
|
||||
prepare-tuple-query
|
||||
find [ assoc>tuple ] map ;
|
||||
|
||||
: select-all-tuples ( tuple/query -- tuples )
|
||||
prepare-tuple-query
|
||||
find-all [ assoc>tuple ] map ;
|
||||
|
||||
: count-tuples ( tuple/query -- n )
|
||||
dup mdb-query-msg? [ tuple>query ] unless count ;
|
||||
|
|
|
|||
|
|
@ -22,11 +22,33 @@ HELP: slots{
|
|||
"{ 3 5 }"
|
||||
} ;
|
||||
|
||||
HELP: set-slots{
|
||||
{ $description "Sets slot values in a tuple from an array." }
|
||||
{ $example "USING: prettyprint slots.syntax kernel ;"
|
||||
"IN: slots.syntax.example"
|
||||
"TUPLE: rectangle width height ;"
|
||||
"rectangle new { 3 5 } set-slots{ width height } ."
|
||||
"T{ rectangle { width 3 } { height 5 } }"
|
||||
} ;
|
||||
|
||||
HELP: set-slots[
|
||||
{ $description "Sets slot values in a tuple from the stack." }
|
||||
{ $example "USING: prettyprint slots.syntax kernel ;"
|
||||
"IN: slots.syntax.example"
|
||||
"TUPLE: rectangle width height ;"
|
||||
"rectangle new 3 5 set-slots[ width height ] ."
|
||||
"T{ rectangle { width 3 } { height 5 } }"
|
||||
} ;
|
||||
|
||||
ARTICLE: "slots.syntax" "Slots syntax sugar"
|
||||
"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for taking a sequence of slots from a tuple." $nl
|
||||
"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for getting and setting multiple values of a tuple." $nl
|
||||
"Syntax sugar for cleaving slots to the stack:"
|
||||
{ $subsections POSTPONE: slots[ }
|
||||
"Syntax sugar for cleaving slots to an array:"
|
||||
{ $subsections POSTPONE: slots{ } ;
|
||||
"Cleaving slots to an array:"
|
||||
{ $subsections POSTPONE: slots{ }
|
||||
"Setting slots from the stack:"
|
||||
{ $subsections POSTPONE: set-slots[ }
|
||||
"Setting slots from an array:"
|
||||
{ $subsections POSTPONE: set-slots{ } ;
|
||||
|
||||
ABOUT: "slots.syntax"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2010 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators combinators.smart fry lexer quotations
|
||||
sequences slots ;
|
||||
USING: combinators combinators.smart fry kernel lexer
|
||||
quotations sequences sequences.generalizations slots words ;
|
||||
IN: slots.syntax
|
||||
|
||||
SYNTAX: slots[
|
||||
|
|
@ -11,3 +11,15 @@ SYNTAX: slots[
|
|||
SYNTAX: slots{
|
||||
"}" [ reader-word 1quotation ] map-tokens
|
||||
'[ [ _ cleave ] output>array ] append! ;
|
||||
|
||||
: writer-word* ( name -- word )
|
||||
">>" prepend "accessors" lookup ;
|
||||
|
||||
SYNTAX: set-slots[
|
||||
"]" [ writer-word* 1quotation ] map-tokens
|
||||
'[ _ spread ] append! ;
|
||||
|
||||
SYNTAX: set-slots{
|
||||
"}" [ writer-word* 1quotation ] map-tokens
|
||||
[ length ] [ ] bi
|
||||
'[ _ firstn _ spread ] append! ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue