Merge branch 'master' of git://factorcode.org/git/factor
commit
21b47bdc3c
|
@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
|
||||
GENERIC: >alist ( assoc -- newassoc )
|
||||
|
||||
: (assoc-each) ( assoc quot -- seq quot' )
|
||||
>r >alist r> [ first2 ] prepose ; inline
|
||||
|
||||
: assoc-find ( assoc quot -- key value ? )
|
||||
>r >alist r> [ first2 ] prepose find swap
|
||||
[ first2 t ] [ drop f f f ] if ; inline
|
||||
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
|
||||
|
||||
: key? ( key assoc -- ? ) at* nip ; inline
|
||||
|
||||
: assoc-each ( assoc quot -- )
|
||||
[ f ] compose assoc-find 3drop ; inline
|
||||
|
||||
: (assoc>map) ( quot accum -- quot' )
|
||||
[ push ] curry compose ; inline
|
||||
(assoc-each) each ; inline
|
||||
|
||||
: assoc>map ( assoc quot exemplar -- seq )
|
||||
>r over assoc-size
|
||||
<vector> [ (assoc>map) assoc-each ] keep
|
||||
r> like ; inline
|
||||
>r accumulator >r assoc-each r> r> like ; inline
|
||||
|
||||
: assoc-map-as ( assoc quot exemplar -- newassoc )
|
||||
>r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline
|
||||
|
||||
: assoc-map ( assoc quot -- newassoc )
|
||||
over >r [ 2array ] compose V{ } assoc>map r> assoc-like ;
|
||||
inline
|
||||
over assoc-map-as ; inline
|
||||
|
||||
: assoc-push-if ( key value quot accum -- )
|
||||
>r 2keep r> roll
|
||||
|
|
|
@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors"
|
|||
{ $subsection missing-effect } ;
|
||||
|
||||
ARTICLE: "inference" "Stack effect inference"
|
||||
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
|
||||
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
|
||||
$nl
|
||||
"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
|
||||
{ $subsection infer. }
|
||||
|
|
|
@ -28,23 +28,62 @@ ERROR: encode-error ;
|
|||
|
||||
! Decoding
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: object <decoder> f decoder boa ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: cr+ t >>cr drop ; inline
|
||||
|
||||
: cr- f >>cr drop ; inline
|
||||
|
||||
: >decoder< ( decoder -- stream encoding )
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
[ stream>> ] [ code>> ] bi ; inline
|
||||
|
||||
: cr+ t swap set-decoder-cr ; inline
|
||||
: fix-read1 ( stream char -- char )
|
||||
over cr>> [
|
||||
over cr-
|
||||
dup CHAR: \n = [
|
||||
drop dup stream-read1
|
||||
] when
|
||||
] when nip ; inline
|
||||
|
||||
: cr- f swap set-decoder-cr ; inline
|
||||
M: decoder stream-read1
|
||||
dup >decoder< decode-char fix-read1 ;
|
||||
|
||||
: fix-read ( stream string -- string )
|
||||
over cr>> [
|
||||
over cr-
|
||||
"\n" ?head [
|
||||
over stream-read1 [ suffix ] when*
|
||||
] when
|
||||
] when nip ; inline
|
||||
|
||||
: (read) ( n quot -- n string )
|
||||
over 0 <string> [
|
||||
[
|
||||
>r call dup
|
||||
[ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
|
||||
] 2curry find-integer
|
||||
] keep ; inline
|
||||
|
||||
: finish-read ( n string -- string/f )
|
||||
{
|
||||
{ [ over 0 = ] [ 2drop f ] }
|
||||
{ [ over not ] [ nip ] }
|
||||
[ swap head ]
|
||||
} cond ; inline
|
||||
|
||||
M: decoder stream-read
|
||||
tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
|
||||
|
||||
M: decoder stream-read-partial stream-read ;
|
||||
|
||||
: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
|
||||
|
||||
: line-ends\r ( stream str -- str ) swap cr+ ; inline
|
||||
|
||||
: line-ends\n ( stream str -- str )
|
||||
over decoder-cr over empty? and
|
||||
over cr>> over empty? and
|
||||
[ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
|
||||
|
||||
: handle-readln ( stream str ch -- str )
|
||||
|
@ -52,61 +91,30 @@ M: object <decoder> f decoder boa ;
|
|||
{ f [ line-ends/eof ] }
|
||||
{ CHAR: \r [ line-ends\r ] }
|
||||
{ CHAR: \n [ line-ends\n ] }
|
||||
} case ;
|
||||
} case ; inline
|
||||
|
||||
: fix-read ( stream string -- string )
|
||||
over decoder-cr [
|
||||
over cr-
|
||||
"\n" ?head [
|
||||
over stream-read1 [ suffix ] when*
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
: read-loop ( n stream -- string )
|
||||
SBUF" " clone [
|
||||
[
|
||||
>r nip stream-read1 dup
|
||||
[ r> push f ] [ r> 2drop t ] if
|
||||
] 2curry find-integer drop
|
||||
] keep "" like f like ;
|
||||
|
||||
M: decoder stream-read
|
||||
tuck read-loop fix-read ;
|
||||
|
||||
M: decoder stream-read-partial stream-read ;
|
||||
|
||||
: (read-until) ( buf quot -- string/f sep/f )
|
||||
: ((read-until)) ( buf quot -- string/f sep/f )
|
||||
! quot: -- char stop?
|
||||
dup call
|
||||
[ >r drop "" like r> ]
|
||||
[ pick push (read-until) ] if ; inline
|
||||
[ pick push ((read-until)) ] if ; inline
|
||||
|
||||
M: decoder stream-read-until
|
||||
: (read-until) ( seps stream -- string/f sep/f )
|
||||
SBUF" " clone -rot >decoder<
|
||||
[ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
|
||||
(read-until) ;
|
||||
[ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
|
||||
((read-until)) ; inline
|
||||
|
||||
: fix-read1 ( stream char -- char )
|
||||
over decoder-cr [
|
||||
over cr-
|
||||
dup CHAR: \n = [
|
||||
drop dup stream-read1
|
||||
] when
|
||||
] when nip ;
|
||||
M: decoder stream-read-until (read-until) ;
|
||||
|
||||
M: decoder stream-read1
|
||||
dup >decoder< decode-char fix-read1 ;
|
||||
M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
|
||||
|
||||
M: decoder stream-readln ( stream -- str )
|
||||
"\r\n" over stream-read-until handle-readln ;
|
||||
|
||||
M: decoder dispose decoder-stream dispose ;
|
||||
M: decoder dispose stream>> dispose ;
|
||||
|
||||
! Encoding
|
||||
M: object <encoder> encoder boa ;
|
||||
|
||||
: >encoder< ( encoder -- stream encoding )
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
[ stream>> ] [ code>> ] bi ; inline
|
||||
|
||||
M: encoder stream-write1
|
||||
>encoder< encode-char ;
|
||||
|
|
|
@ -2,14 +2,14 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: optimizer.known-words
|
||||
USING: alien arrays generic hashtables inference.dataflow
|
||||
inference.class kernel assocs math math.private kernel.private
|
||||
sequences words parser vectors strings sbufs io namespaces
|
||||
assocs quotations sequences.private io.binary
|
||||
inference.class kernel assocs math math.order math.private
|
||||
kernel.private sequences words parser vectors strings sbufs io
|
||||
namespaces assocs quotations sequences.private io.binary
|
||||
io.streams.string layouts splitting math.intervals
|
||||
math.floats.private classes.tuple classes.tuple.private classes
|
||||
classes.algebra optimizer.def-use optimizer.backend
|
||||
optimizer.pattern-match optimizer.inlining float-arrays
|
||||
sequences.private combinators ;
|
||||
sequences.private combinators byte-arrays byte-vectors ;
|
||||
|
||||
{ <tuple> <tuple-boa> } [
|
||||
[
|
||||
|
@ -59,15 +59,59 @@ sequences.private combinators ;
|
|||
node-in-d peek dup value?
|
||||
[ value-literal sequence? ] [ drop f ] if ;
|
||||
|
||||
: member-quot ( seq -- newquot )
|
||||
[ literalize [ t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ nip case ] curry ;
|
||||
: expand-member ( #call quot -- )
|
||||
>r dup node-in-d peek value-literal r> call f splice-quot ;
|
||||
|
||||
: expand-member ( #call -- )
|
||||
dup node-in-d peek value-literal member-quot f splice-quot ;
|
||||
: bit-member-n 256 ; inline
|
||||
|
||||
: bit-member? ( seq -- ? )
|
||||
#! Can we use a fast byte array test here?
|
||||
{
|
||||
{ [ dup length 8 < ] [ f ] }
|
||||
{ [ dup [ integer? not ] contains? ] [ f ] }
|
||||
{ [ dup [ 0 < ] contains? ] [ f ] }
|
||||
{ [ dup [ bit-member-n >= ] contains? ] [ f ] }
|
||||
[ t ]
|
||||
} cond nip ;
|
||||
|
||||
: bit-member-seq ( seq -- flags )
|
||||
bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
|
||||
|
||||
: exact-float? ( f -- ? )
|
||||
dup float? [ dup >integer >float = ] [ drop f ] if ; inline
|
||||
|
||||
: bit-member-quot ( seq -- newquot )
|
||||
[
|
||||
[ drop ] % ! drop the sequence itself; we don't use it at run time
|
||||
bit-member-seq ,
|
||||
[
|
||||
{
|
||||
{ [ over fixnum? ] [ ?nth 1 eq? ] }
|
||||
{ [ over bignum? ] [ ?nth 1 eq? ] }
|
||||
{ [ over exact-float? ] [ ?nth 1 eq? ] }
|
||||
[ 2drop f ]
|
||||
} cond
|
||||
] %
|
||||
] [ ] make ;
|
||||
|
||||
: member-quot ( seq -- newquot )
|
||||
dup bit-member? [
|
||||
bit-member-quot
|
||||
] [
|
||||
[ literalize [ t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ nip case ] curry
|
||||
] if ;
|
||||
|
||||
\ member? {
|
||||
{ [ dup literal-member? ] [ expand-member ] }
|
||||
{ [ dup literal-member? ] [ [ member-quot ] expand-member ] }
|
||||
} define-optimizers
|
||||
|
||||
: memq-quot ( seq -- newquot )
|
||||
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ nip cond ] curry ;
|
||||
|
||||
\ memq? {
|
||||
{ [ dup literal-member? ] [ [ memq-quot ] expand-member ] }
|
||||
} define-optimizers
|
||||
|
||||
! if the result of eq? is t and the second input is a literal,
|
||||
|
@ -97,7 +141,7 @@ sequences.private combinators ;
|
|||
] each
|
||||
|
||||
\ push-all
|
||||
{ { string sbuf } { array vector } }
|
||||
{ { string sbuf } { array vector } { byte-array byte-vector } }
|
||||
"specializer" set-word-prop
|
||||
|
||||
\ append
|
||||
|
|
|
@ -419,10 +419,11 @@ PRIVATE>
|
|||
: interleave ( seq between quot -- )
|
||||
[ (interleave) ] 2curry >r dup length swap r> 2each ; inline
|
||||
|
||||
: accumulator ( quot -- quot' vec )
|
||||
V{ } clone [ [ push ] curry compose ] keep ; inline
|
||||
|
||||
: unfold ( pred quot tail -- seq )
|
||||
V{ } clone [
|
||||
swap >r [ push ] curry compose r> while
|
||||
] keep { } like ; inline
|
||||
swap accumulator >r swap while r> { } like ; inline
|
||||
|
||||
: follow ( obj quot -- seq )
|
||||
>r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
|
||||
|
|
|
@ -0,0 +1,4 @@
|
|||
IN: assocs.lib.tests
|
||||
USING: assocs.lib tools.test vectors ;
|
||||
|
||||
{ 1 1 } [ [ ?push ] histogram ] must-infer-as
|
|
@ -41,4 +41,4 @@ IN: assocs.lib
|
|||
: histogram ( assoc quot -- assoc' )
|
||||
H{ } clone [
|
||||
swap [ change-at ] 2curry assoc-each
|
||||
] keep ;
|
||||
] keep ; inline
|
||||
|
|
|
@ -1,8 +1,18 @@
|
|||
USING: kernel tools.test base64 strings ;
|
||||
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
|
||||
] unit-test
|
||||
[ "" ] [ "" >base64 base64> ] unit-test
|
||||
[ "a" ] [ "a" >base64 base64> ] unit-test
|
||||
[ "ab" ] [ "ab" >base64 base64> ] unit-test
|
||||
[ "abc" ] [ "abc" >base64 base64> ] unit-test
|
||||
[ "" ] [ "" >base64 base64> >string ] unit-test
|
||||
[ "a" ] [ "a" >base64 base64> >string ] unit-test
|
||||
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
|
||||
[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
|
||||
|
||||
! From http://en.wikipedia.org/wiki/Base64
|
||||
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
|
||||
[
|
||||
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
|
||||
>base64 >string
|
||||
] unit-test
|
||||
|
||||
\ >base64 must-infer
|
||||
\ base64> must-infer
|
||||
|
|
|
@ -1,11 +1,10 @@
|
|||
USING: kernel math sequences namespaces io.binary splitting
|
||||
grouping strings hashtables ;
|
||||
USING: kernel math sequences io.binary splitting grouping ;
|
||||
IN: base64
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: count-end ( seq quot -- count )
|
||||
>r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ;
|
||||
>r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
|
||||
|
||||
: ch>base64 ( ch -- ch )
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
|
||||
|
@ -20,28 +19,26 @@ IN: base64
|
|||
} nth ;
|
||||
|
||||
: encode3 ( seq -- seq )
|
||||
be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ;
|
||||
be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
|
||||
|
||||
: decode4 ( str -- str )
|
||||
[ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ;
|
||||
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
|
||||
|
||||
: >base64-rem ( str -- str )
|
||||
[ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ;
|
||||
[ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >base64 ( seq -- base64 )
|
||||
#! cut string into two pieces, convert 3 bytes at a time
|
||||
#! pad string with = when not enough bits
|
||||
dup length dup 3 mod - cut swap
|
||||
[
|
||||
3 <groups> [ encode3 % ] each
|
||||
dup empty? [ drop ] [ >base64-rem % ] if
|
||||
] "" make ;
|
||||
dup length dup 3 mod - cut
|
||||
[ 3 <groups> [ encode3 ] map concat ]
|
||||
[ dup empty? [ drop "" ] [ >base64-rem ] if ]
|
||||
bi* append ;
|
||||
|
||||
: base64> ( base64 -- str )
|
||||
#! input length must be a multiple of 4
|
||||
[
|
||||
[ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
|
||||
] SBUF" " make swap [ dup pop* ] times >string ;
|
||||
|
||||
[ 4 <groups> [ decode4 ] map concat ]
|
||||
[ [ CHAR: = = not ] count-end ]
|
||||
bi head* ;
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
IN: concurrency.distributed.tests
|
||||
USING: tools.test concurrency.distributed kernel io.files
|
||||
arrays io.sockets system combinators threads math sequences
|
||||
concurrency.messaging continuations ;
|
||||
concurrency.messaging continuations accessors prettyprint ;
|
||||
|
||||
: test-node
|
||||
: test-node ( -- addrspec )
|
||||
{
|
||||
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
|
||||
{ [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
|
||||
|
@ -11,9 +11,9 @@ concurrency.messaging continuations ;
|
|||
|
||||
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
|
||||
|
||||
[ ] [ test-node dup 1array swap (start-node) ] unit-test
|
||||
[ ] [ test-node dup (start-node) ] unit-test
|
||||
|
||||
[ ] [ 100 sleep ] unit-test
|
||||
[ ] [ 1000 sleep ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
|
@ -30,4 +30,6 @@ concurrency.messaging continuations ;
|
|||
receive
|
||||
] unit-test
|
||||
|
||||
[ ] [ 1000 sleep ] unit-test
|
||||
|
||||
[ ] [ test-node stop-node ] unit-test
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005 Chris Double. All Rights Reserved.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: serialize sequences concurrency.messaging threads io
|
||||
io.server qualified arrays namespaces kernel io.encodings.binary
|
||||
accessors ;
|
||||
io.servers.connection io.encodings.binary
|
||||
qualified arrays namespaces kernel accessors ;
|
||||
FROM: io.sockets => host-name <inet> with-client ;
|
||||
IN: concurrency.distributed
|
||||
|
||||
|
@ -10,21 +10,21 @@ SYMBOL: local-node
|
|||
|
||||
: handle-node-client ( -- )
|
||||
deserialize
|
||||
[ first2 get-process send ]
|
||||
[ stop-server ] if* ;
|
||||
[ first2 get-process send ] [ stop-server ] if* ;
|
||||
|
||||
: (start-node) ( addrspecs addrspec -- )
|
||||
: (start-node) ( addrspec addrspec -- )
|
||||
local-node set-global
|
||||
[
|
||||
"concurrency.distributed"
|
||||
binary
|
||||
[ handle-node-client ] with-server
|
||||
<threaded-server>
|
||||
swap >>insecure
|
||||
binary >>encoding
|
||||
"concurrency.distributed" >>name
|
||||
[ handle-node-client ] >>handler
|
||||
start-server
|
||||
] curry "Distributed concurrency server" spawn drop ;
|
||||
|
||||
: start-node ( port -- )
|
||||
[ internet-server ]
|
||||
[ host-name swap <inet> ] bi
|
||||
(start-node) ;
|
||||
host-name over <inet> (start-node) ;
|
||||
|
||||
TUPLE: remote-process id node ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copysecond (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences sorting math math.order
|
||||
arrays combinators kernel ;
|
||||
|
|
|
@ -424,6 +424,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
|
|||
}
|
||||
2cleave message boa ;
|
||||
|
||||
: ba->message ( ba -- message ) parse-message ;
|
||||
|
||||
: with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: send-receive-udp ( ba server -- ba )
|
||||
|
|
|
@ -1,15 +1,17 @@
|
|||
|
||||
USING: kernel combinators sequences sets math
|
||||
io.sockets unicode.case accessors
|
||||
USING: kernel combinators sequences sets math threads namespaces continuations
|
||||
debugger io io.sockets unicode.case accessors destructors
|
||||
combinators.cleave combinators.lib
|
||||
newfx
|
||||
newfx fry
|
||||
dns dns.util dns.misc ;
|
||||
|
||||
IN: dns.server
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: records ( -- vector ) V{ } ;
|
||||
SYMBOL: records-var
|
||||
|
||||
: records ( -- records ) records-var get ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
@ -50,9 +52,10 @@ IN: dns.server
|
|||
|
||||
: rr->rdata-names ( rr -- names/f )
|
||||
{
|
||||
{ [ dup type>> NS = ] [ rdata>> {1} ] }
|
||||
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
|
||||
{ [ t ] [ drop f ] }
|
||||
{ [ dup type>> NS = ] [ rdata>> {1} ] }
|
||||
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
|
||||
{ [ dup type>> CNAME = ] [ rdata>> {1} ] }
|
||||
{ [ t ] [ drop f ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
|
@ -192,31 +195,14 @@ DEFER: query->rrs
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (socket) ( -- vec ) V{ f } ;
|
||||
: (handle-request) ( packet -- )
|
||||
[ [ find-answer ] with-message-bytes ] change-data respond ;
|
||||
|
||||
: socket ( -- socket ) (socket) 1st ;
|
||||
: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
|
||||
|
||||
: init-socket-on-port ( port -- )
|
||||
f swap <inet4> <datagram> 0 (socket) as-mutate ;
|
||||
: receive-loop ( socket -- )
|
||||
[ receive-packet handle-request ] [ receive-loop ] bi ;
|
||||
|
||||
: init-socket ( -- ) 53 init-socket-on-port ;
|
||||
: loop ( addr-spec -- )
|
||||
[ <datagram> '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: loop ( -- )
|
||||
socket receive
|
||||
swap
|
||||
parse-message
|
||||
find-answer
|
||||
message->ba
|
||||
swap
|
||||
socket send
|
||||
loop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: start ( -- ) init-socket loop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MAIN: start
|
||||
|
|
|
@ -16,4 +16,15 @@ MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: longer? ( seq seq -- ? ) [ length ] bi@ > ;
|
||||
: longer? ( seq seq -- ? ) [ length ] bi@ > ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: io.sockets accessors ;
|
||||
|
||||
TUPLE: packet data addr socket ;
|
||||
|
||||
: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
|
||||
|
||||
: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
|
||||
|
||||
|
|
|
@ -3,14 +3,12 @@ namespaces sequences system combinators
|
|||
editors.vim editors.gvim.backend vocabs.loader ;
|
||||
IN: editors.gvim
|
||||
|
||||
TUPLE: gvim ;
|
||||
SINGLETON: gvim
|
||||
|
||||
M: gvim vim-command ( file line -- string )
|
||||
[ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
|
||||
[ gvim-path , swap , "+" swap number>string append , ] { } make ;
|
||||
|
||||
t vim-detach set-global ! don't block the ui
|
||||
|
||||
T{ gvim } vim-editor set-global
|
||||
gvim vim-editor set-global
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "editors.gvim.unix" ] }
|
||||
|
|
|
@ -11,7 +11,5 @@ $nl
|
|||
"USE: vim"
|
||||
"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
|
||||
}
|
||||
"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
|
||||
$nl
|
||||
"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ;
|
||||
"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ;
|
||||
|
||||
|
|
|
@ -3,24 +3,20 @@ namespaces parser prettyprint sequences editors accessors ;
|
|||
IN: editors.vim
|
||||
|
||||
SYMBOL: vim-path
|
||||
SYMBOL: vim-detach
|
||||
|
||||
SYMBOL: vim-editor
|
||||
HOOK: vim-command vim-editor
|
||||
HOOK: vim-command vim-editor ( file line -- array )
|
||||
|
||||
TUPLE: vim ;
|
||||
SINGLETON: vim
|
||||
|
||||
M: vim vim-command ( file line -- array )
|
||||
M: vim vim-command
|
||||
[
|
||||
vim-path get , swap , "+" swap number>string append ,
|
||||
] { } make ;
|
||||
|
||||
: vim-location ( file line -- )
|
||||
vim-command
|
||||
<process> swap >>command
|
||||
vim-detach get-global [ t >>detached ] when
|
||||
try-process ;
|
||||
vim-command try-process ;
|
||||
|
||||
"vim" vim-path set-global
|
||||
[ vim-location ] edit-hook set-global
|
||||
T{ vim } vim-editor set-global
|
||||
vim vim-editor set-global
|
||||
|
|
|
@ -1,11 +0,0 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: listener io.server strings parser byte-arrays ;
|
||||
IN: eval-server
|
||||
|
||||
: eval-server ( -- )
|
||||
9998 local-server "eval-server" [
|
||||
>string eval>string >byte-array
|
||||
] with-datagrams ;
|
||||
|
||||
MAIN: eval-server
|
|
@ -1 +0,0 @@
|
|||
Listens for UDP packets on localhost:9998, evaluates them and sends back result
|
|
@ -1,4 +0,0 @@
|
|||
demos
|
||||
network
|
||||
tools
|
||||
applications
|
|
@ -7,6 +7,7 @@ sequences.deep unicode.categories ;
|
|||
IN: farkup
|
||||
|
||||
SYMBOL: relative-link-prefix
|
||||
SYMBOL: disable-images?
|
||||
SYMBOL: link-no-follow?
|
||||
|
||||
<PRIVATE
|
||||
|
@ -88,18 +89,22 @@ MEMO: eq ( -- parser )
|
|||
escape-link
|
||||
[
|
||||
"<a" ,
|
||||
" href=\"" , >r , r>
|
||||
" href=\"" , >r , r> "\"" ,
|
||||
link-no-follow? get [ " nofollow=\"true\"" , ] when
|
||||
"\">" , , "</a>" ,
|
||||
">" , , "</a>" ,
|
||||
] { } make ;
|
||||
|
||||
: make-image-link ( href alt -- seq )
|
||||
escape-link
|
||||
[
|
||||
"<img src=\"" , swap , "\"" ,
|
||||
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
|
||||
"/>" , ]
|
||||
{ } make ;
|
||||
disable-images? get [
|
||||
2drop "<strong>Images are not allowed</strong>"
|
||||
] [
|
||||
escape-link
|
||||
[
|
||||
"<img src=\"" , swap , "\"" ,
|
||||
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
|
||||
"/>" ,
|
||||
] { } make
|
||||
] if ;
|
||||
|
||||
MEMO: image-link ( -- parser )
|
||||
[
|
||||
|
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators io io.encodings.8-bit
|
||||
io.encodings io.encodings.binary io.encodings.utf8 io.files
|
||||
io.server io.sockets kernel math.parser namespaces sequences
|
||||
io.sockets kernel math.parser namespaces sequences
|
||||
ftp io.unix.launcher.parser unicode.case splitting assocs
|
||||
classes io.server destructors calendar io.timeouts
|
||||
classes io.servers.connection destructors calendar io.timeouts
|
||||
io.streams.duplex threads continuations math
|
||||
concurrency.promises byte-arrays ;
|
||||
IN: ftp.server
|
||||
|
@ -305,7 +305,10 @@ ERROR: not-a-directory ;
|
|||
[ drop unrecognized-command t ]
|
||||
} case [ handle-client-loop ] when ;
|
||||
|
||||
: handle-client ( -- )
|
||||
TUPLE: ftp-server < threaded-server ;
|
||||
|
||||
M: ftp-server handle-client* ( server -- )
|
||||
drop
|
||||
[
|
||||
"" [
|
||||
host-name <ftp-client> client set
|
||||
|
@ -313,9 +316,14 @@ ERROR: not-a-directory ;
|
|||
] with-directory
|
||||
] with-destructors ;
|
||||
|
||||
: <ftp-server> ( port -- server )
|
||||
ftp-server new-threaded-server
|
||||
swap >>insecure
|
||||
"ftp.server" >>name
|
||||
latin1 >>encoding ;
|
||||
|
||||
: ftpd ( port -- )
|
||||
internet-server "ftp.server"
|
||||
latin1 [ handle-client ] with-server ;
|
||||
<ftp-server> start-server ;
|
||||
|
||||
: ftpd-main ( -- ) 2100 ftpd ;
|
||||
|
||||
|
|
|
@ -8,6 +8,7 @@ http.server
|
|||
http.server.responses
|
||||
furnace
|
||||
furnace.flash
|
||||
html.forms
|
||||
html.elements
|
||||
html.components
|
||||
html.components
|
||||
|
@ -20,10 +21,10 @@ SYMBOL: params
|
|||
SYMBOL: rest
|
||||
|
||||
: render-validation-messages ( -- )
|
||||
validation-messages get
|
||||
form get errors>>
|
||||
dup empty? [ drop ] [
|
||||
<ul "errors" =class ul>
|
||||
[ <li> message>> escape-string write </li> ] each
|
||||
[ <li> escape-string write </li> ] each
|
||||
</ul>
|
||||
] if ;
|
||||
|
||||
|
@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ;
|
|||
: <action> ( -- action )
|
||||
action new-action ;
|
||||
|
||||
: flashed-variables ( -- seq )
|
||||
{ validation-messages named-validation-messages } ;
|
||||
: set-nested-form ( form name -- )
|
||||
dup empty? [
|
||||
drop form set
|
||||
] [
|
||||
dup length 1 = [
|
||||
first set-value
|
||||
] [
|
||||
unclip [ set-nested-form ] nest-form
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: restore-validation-errors ( -- )
|
||||
form fget [
|
||||
nested-forms fget set-nested-form
|
||||
] when* ;
|
||||
|
||||
: handle-get ( action -- response )
|
||||
'[
|
||||
|
@ -46,25 +60,12 @@ TUPLE: action rest authorize init display validate submit ;
|
|||
{
|
||||
[ init>> call ]
|
||||
[ authorize>> call ]
|
||||
[ drop flashed-variables restore-flash ]
|
||||
[ drop restore-validation-errors ]
|
||||
[ display>> call ]
|
||||
} cleave
|
||||
] [ drop <400> ] if
|
||||
] with-exit-continuation ;
|
||||
|
||||
: validation-failed ( -- * )
|
||||
post-request? [ f ] [ <400> ] if exit-with ;
|
||||
|
||||
: (handle-post) ( action -- response )
|
||||
'[
|
||||
, dup submit>> [
|
||||
[ validate>> call ]
|
||||
[ authorize>> call ]
|
||||
[ submit>> call ]
|
||||
tri
|
||||
] [ drop <400> ] if
|
||||
] with-exit-continuation ;
|
||||
|
||||
: param ( name -- value )
|
||||
params get at ;
|
||||
|
||||
|
@ -74,24 +75,29 @@ TUPLE: action rest authorize init display validate submit ;
|
|||
revalidate-url-key param
|
||||
dup [ >url [ same-host? ] keep and ] when ;
|
||||
|
||||
: validation-failed ( -- * )
|
||||
post-request? revalidate-url and
|
||||
[
|
||||
nested-forms-key param " " split harvest nested-forms set
|
||||
{ form nested-forms } <flash-redirect>
|
||||
] [ <400> ] if*
|
||||
exit-with ;
|
||||
|
||||
: handle-post ( action -- response )
|
||||
'[
|
||||
form-nesting-key params get at " " split
|
||||
[ , (handle-post) ]
|
||||
[ swap '[ , , nest-values ] ] reduce
|
||||
call
|
||||
] with-exit-continuation
|
||||
[
|
||||
revalidate-url
|
||||
[ flashed-variables <flash-redirect> ] [ <403> ] if*
|
||||
] unless* ;
|
||||
, dup submit>> [
|
||||
[ validate>> call ]
|
||||
[ authorize>> call ]
|
||||
[ submit>> call ]
|
||||
tri
|
||||
] [ drop <400> ] if
|
||||
] with-exit-continuation ;
|
||||
|
||||
: handle-rest ( path action -- assoc )
|
||||
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
|
||||
|
||||
: init-action ( path action -- )
|
||||
blank-values
|
||||
init-validation
|
||||
begin-form
|
||||
handle-rest
|
||||
request get request-params assoc-union params set ;
|
||||
|
||||
|
@ -110,8 +116,7 @@ M: action modify-form
|
|||
validation-failed? [ validation-failed ] when ;
|
||||
|
||||
: validate-params ( validators -- )
|
||||
params get swap validate-values from-object
|
||||
check-validation ;
|
||||
params get swap validate-values check-validation ;
|
||||
|
||||
: validate-integer-id ( -- )
|
||||
{ { "id" [ v-number ] } } validate-params ;
|
||||
|
|
|
@ -7,7 +7,8 @@ furnace.flash
|
|||
furnace.sessions
|
||||
furnace.referrer
|
||||
furnace.db
|
||||
furnace.auth.providers ;
|
||||
furnace.auth.providers
|
||||
furnace.auth.login.permits ;
|
||||
IN: furnace.alloy
|
||||
|
||||
: <alloy> ( responder db params -- responder' )
|
||||
|
@ -19,7 +20,7 @@ IN: furnace.alloy
|
|||
<check-form-submissions>
|
||||
] call ;
|
||||
|
||||
: state-classes { session flash-scope aside } ; inline
|
||||
: state-classes { session flash-scope aside permit } ; inline
|
||||
|
||||
: init-furnace-tables ( -- )
|
||||
state-classes ensure-tables
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors namespaces sequences arrays kernel
|
|||
assocs assocs.lib hashtables math.parser urls combinators
|
||||
html.elements html.templates.chloe.syntax db.types db.tuples
|
||||
http http.server http.server.filters
|
||||
furnace furnace.cache furnace.sessions ;
|
||||
furnace furnace.cache furnace.sessions furnace.redirection ;
|
||||
IN: furnace.asides
|
||||
|
||||
TUPLE: aside < server-state session method url post-data ;
|
||||
|
|
|
@ -0,0 +1,6 @@
|
|||
USING: furnace.auth tools.test ;
|
||||
IN: furnace.auth.tests
|
||||
|
||||
\ logged-in-username must-infer
|
||||
\ <protected> must-infer
|
||||
\ new-realm must-infer
|
|
@ -1,15 +1,25 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs namespaces kernel sequences sets
|
||||
destructors combinators fry
|
||||
io.encodings.utf8 io.encodings.string io.binary random
|
||||
checksums checksums.sha2
|
||||
html.forms
|
||||
http.server
|
||||
http.server.filters
|
||||
http.server.dispatchers
|
||||
furnace.sessions
|
||||
furnace.auth.providers ;
|
||||
furnace
|
||||
furnace.actions
|
||||
furnace.redirection
|
||||
furnace.boilerplate
|
||||
furnace.auth.providers
|
||||
furnace.auth.providers.db ;
|
||||
IN: furnace.auth
|
||||
|
||||
SYMBOL: logged-in-user
|
||||
|
||||
: logged-in? ( -- ? ) logged-in-user get >boolean ;
|
||||
|
||||
GENERIC: init-user-profile ( responder -- )
|
||||
|
||||
M: object init-user-profile drop ;
|
||||
|
@ -20,6 +30,9 @@ M: dispatcher init-user-profile
|
|||
M: filter-responder init-user-profile
|
||||
responder>> init-user-profile ;
|
||||
|
||||
: have-capability? ( capability -- ? )
|
||||
logged-in-user get capabilities>> member? ;
|
||||
|
||||
: profile ( -- assoc ) logged-in-user get profile>> ;
|
||||
|
||||
: user-changed ( -- )
|
||||
|
@ -41,3 +54,100 @@ SYMBOL: capabilities
|
|||
V{ } clone capabilities set-global
|
||||
|
||||
: define-capability ( word -- ) capabilities get adjoin ;
|
||||
|
||||
TUPLE: realm < dispatcher name users checksum secure ;
|
||||
|
||||
GENERIC: login-required* ( realm -- response )
|
||||
|
||||
GENERIC: logged-in-username ( realm -- username )
|
||||
|
||||
: login-required ( -- * ) realm get login-required* exit-with ;
|
||||
|
||||
: new-realm ( responder name class -- realm )
|
||||
new-dispatcher
|
||||
swap >>name
|
||||
swap >>default
|
||||
users-in-db >>users
|
||||
sha-256 >>checksum
|
||||
t >>secure ; inline
|
||||
|
||||
: users ( -- provider )
|
||||
realm get users>> ;
|
||||
|
||||
TUPLE: user-saver user ;
|
||||
|
||||
C: <user-saver> user-saver
|
||||
|
||||
M: user-saver dispose
|
||||
user>> dup changed?>> [ users update-user ] [ drop ] if ;
|
||||
|
||||
: save-user-after ( user -- )
|
||||
<user-saver> &dispose drop ;
|
||||
|
||||
: init-user ( user -- )
|
||||
[ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
|
||||
|
||||
M: realm call-responder* ( path responder -- response )
|
||||
dup realm set
|
||||
dup logged-in-username dup [ users get-user ] when init-user
|
||||
call-next-method ;
|
||||
|
||||
: encode-password ( string salt -- bytes )
|
||||
[ utf8 encode ] [ 4 >be ] bi* append
|
||||
realm get checksum>> checksum-bytes ;
|
||||
|
||||
: >>encoded-password ( user string -- user )
|
||||
32 random-bits [ encode-password ] keep
|
||||
[ >>password ] [ >>salt ] bi* ; inline
|
||||
|
||||
: valid-login? ( password user -- ? )
|
||||
[ salt>> encode-password ] [ password>> ] bi = ;
|
||||
|
||||
: check-login ( password username -- user/f )
|
||||
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
|
||||
|
||||
: if-secure-realm ( quot -- )
|
||||
realm get secure>> [ if-secure ] [ call ] if ; inline
|
||||
|
||||
TUPLE: secure-realm-only < filter-responder ;
|
||||
|
||||
C: <secure-realm-only> secure-realm-only
|
||||
|
||||
M: secure-realm-only call-responder*
|
||||
'[ , , call-next-method ] if-secure-realm ;
|
||||
|
||||
TUPLE: protected < filter-responder description capabilities ;
|
||||
|
||||
: <protected> ( responder -- protected )
|
||||
protected new
|
||||
swap >>responder ;
|
||||
|
||||
: check-capabilities ( responder user/f -- ? )
|
||||
{
|
||||
{ [ dup not ] [ 2drop f ] }
|
||||
{ [ dup deleted>> 1 = ] [ 2drop f ] }
|
||||
[ [ capabilities>> ] bi@ subset? ]
|
||||
} cond ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
'[
|
||||
, ,
|
||||
dup protected set
|
||||
dup logged-in-user get check-capabilities
|
||||
[ call-next-method ] [ 2drop realm get login-required* ] if
|
||||
] if-secure-realm ;
|
||||
|
||||
: <auth-boilerplate> ( responder -- responder' )
|
||||
<boilerplate> { realm "boilerplate" } >>template ;
|
||||
|
||||
: password-mismatch ( -- * )
|
||||
"passwords do not match" validation-error
|
||||
validation-failed ;
|
||||
|
||||
: same-password-twice ( -- )
|
||||
"new-password" value "verify-password" value =
|
||||
[ password-mismatch ] unless ;
|
||||
|
||||
: user-exists ( -- * )
|
||||
"username taken" validation-error
|
||||
validation-failed ;
|
||||
|
|
|
@ -1,41 +1,29 @@
|
|||
! Copyright (c) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors quotations assocs kernel splitting
|
||||
base64 html.elements io combinators sequences
|
||||
http http.server.filters http.server.responses http.server
|
||||
furnace.auth.providers furnace.auth.login ;
|
||||
USING: accessors kernel splitting base64 namespaces strings
|
||||
http http.server.responses furnace.auth ;
|
||||
IN: furnace.auth.basic
|
||||
|
||||
TUPLE: basic-auth < filter-responder realm provider ;
|
||||
TUPLE: basic-auth-realm < realm ;
|
||||
|
||||
C: <basic-auth> basic-auth
|
||||
: <basic-auth-realm> ( responder name -- realm )
|
||||
basic-auth-realm new-realm ;
|
||||
|
||||
: authorization-ok? ( provider header -- ? )
|
||||
#! Given the realm and the 'Authorization' header,
|
||||
#! authenticate the user.
|
||||
: parse-basic-auth ( header -- username/f password/f )
|
||||
dup [
|
||||
" " split1 swap "Basic" = [
|
||||
base64> ":" split1 spin check-login
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
base64> >string ":" split1
|
||||
] [ drop f f ] if
|
||||
] [ drop f f ] if ;
|
||||
|
||||
: <401> ( realm -- response )
|
||||
401 "Unauthorized" <trivial-response>
|
||||
"Basic realm=\"" rot "\"" 3append
|
||||
"WWW-Authenticate" set-header
|
||||
[
|
||||
<html> <body>
|
||||
"Username or Password is invalid" write
|
||||
</body> </html>
|
||||
] >>body ;
|
||||
401 "Invalid username or password" <trivial-response>
|
||||
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
|
||||
|
||||
: logged-in? ( request responder -- ? )
|
||||
provider>> swap "authorization" header authorization-ok? ;
|
||||
M: basic-auth-realm login-required* ( realm -- response )
|
||||
name>> <401> ;
|
||||
|
||||
M: basic-auth call-responder* ( request path responder -- response )
|
||||
pick over logged-in?
|
||||
[ call-next-method ] [ 2nip realm>> <401> ] if ;
|
||||
M: basic-auth-realm logged-in-username ( realm -- uid )
|
||||
drop
|
||||
request get "authorization" header parse-basic-auth
|
||||
dup [ over check-login swap and ] [ 2drop f ] if ;
|
||||
|
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs namespaces accessors db db.tuples urls
|
||||
http.server.dispatchers
|
||||
furnace.asides furnace.actions furnace.auth furnace.auth.providers ;
|
||||
IN: furnace.auth.features.deactivate-user
|
||||
|
||||
: <deactivate-user-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
logged-in-user get
|
||||
1 >>deleted
|
||||
t >>changed?
|
||||
drop
|
||||
URL" $realm" end-aside
|
||||
] >>submit ;
|
||||
|
||||
: allow-deactivation ( realm -- realm )
|
||||
<deactivate-user-action> <protected>
|
||||
"delete your profile" >>description
|
||||
"deactivate-user" add-responder ;
|
||||
|
||||
: allow-deactivation? ( -- ? )
|
||||
realm get responders>> "deactivate-user" swap key? ;
|
|
@ -0,0 +1,4 @@
|
|||
IN: furnace.auth.features.edit-profile.tests
|
||||
USING: tools.test furnace.auth.features.edit-profile ;
|
||||
|
||||
\ allow-edit-profile must-infer
|
|
@ -0,0 +1,67 @@
|
|||
! Copyright (c) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces sequences assocs
|
||||
validators urls
|
||||
html.forms
|
||||
http.server.dispatchers
|
||||
furnace.auth
|
||||
furnace.asides
|
||||
furnace.actions ;
|
||||
IN: furnace.auth.features.edit-profile
|
||||
|
||||
: <edit-profile-action> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
logged-in-user get
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
tri
|
||||
] >>init
|
||||
|
||||
{ realm "features/edit-profile/edit-profile" } >>template
|
||||
|
||||
[
|
||||
logged-in-user get username>> "username" set-value
|
||||
|
||||
{
|
||||
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||
{ "password" [ ] }
|
||||
{ "new-password" [ [ v-password ] v-optional ] }
|
||||
{ "verify-password" [ [ v-password ] v-optional ] }
|
||||
{ "email" [ [ v-email ] v-optional ] }
|
||||
} validate-params
|
||||
|
||||
{ "password" "new-password" "verify-password" }
|
||||
[ value empty? not ] contains? [
|
||||
"password" value logged-in-user get username>> check-login
|
||||
[ "incorrect password" validation-error ] unless
|
||||
|
||||
same-password-twice
|
||||
] when
|
||||
] >>validate
|
||||
|
||||
[
|
||||
logged-in-user get
|
||||
|
||||
"new-password" value dup empty?
|
||||
[ drop ] [ >>encoded-password ] if
|
||||
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
t >>changed?
|
||||
|
||||
drop
|
||||
|
||||
URL" $login" end-aside
|
||||
] >>submit
|
||||
|
||||
<protected>
|
||||
"edit your profile" >>description ;
|
||||
|
||||
: allow-edit-profile ( login -- login )
|
||||
<edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
|
||||
|
||||
: allow-edit-profile? ( -- ? )
|
||||
realm get responders>> "edit-profile" swap key? ;
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>Edit Profile</t:title>
|
||||
|
||||
<t:form t:action="$login/edit-profile">
|
||||
<t:form t:action="$realm/edit-profile">
|
||||
|
||||
<table>
|
||||
|
||||
|
@ -67,4 +67,7 @@
|
|||
|
||||
</t:form>
|
||||
|
||||
<t:if t:code="furnace.auth.features.deactivate-user:allow-deactivation?">
|
||||
<t:button t:action="$realm/deactivate-user">Delete User</t:button>
|
||||
</t:if>
|
||||
</t:chloe>
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
|
||||
|
||||
<t:form t:action="recover-password">
|
||||
<t:form t:action="$realm/recover-password">
|
||||
|
||||
<table>
|
||||
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
<p>Choose a new password for your account.</p>
|
||||
|
||||
<t:form t:action="new-password">
|
||||
<t:form t:action="$realm/recover-3">
|
||||
|
||||
<table>
|
||||
|
|
@ -4,6 +4,6 @@
|
|||
|
||||
<t:title>Recover lost password: step 4 of 4</t:title>
|
||||
|
||||
<p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>
|
||||
<p>Your password has been reset. You may now <t:a t:href="$realm">proceed</t:a>.</p>
|
||||
|
||||
</t:chloe>
|
|
@ -0,0 +1,4 @@
|
|||
IN: furnace.auth.features.recover-password
|
||||
USING: tools.test furnace.auth.features.recover-password ;
|
||||
|
||||
\ allow-password-recovery must-infer
|
|
@ -0,0 +1,124 @@
|
|||
! Copyright (c) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces accessors kernel assocs arrays io.sockets threads
|
||||
fry urls smtp validators html.forms present
|
||||
http http.server.responses http.server.redirection
|
||||
http.server.dispatchers
|
||||
furnace furnace.actions furnace.auth furnace.auth.providers
|
||||
furnace.redirection ;
|
||||
IN: furnace.auth.features.recover-password
|
||||
|
||||
SYMBOL: lost-password-from
|
||||
|
||||
: current-host ( -- string )
|
||||
request get url>> host>> host-name or ;
|
||||
|
||||
: new-password-url ( user -- url )
|
||||
URL" recover-3" clone
|
||||
swap
|
||||
[ username>> "username" set-query-param ]
|
||||
[ ticket>> "ticket" set-query-param ]
|
||||
bi
|
||||
adjust-url relative-to-request ;
|
||||
|
||||
: password-email ( user -- email )
|
||||
<email>
|
||||
[ "[ " % current-host % " ] password recovery" % ] "" make >>subject
|
||||
lost-password-from get >>from
|
||||
over email>> 1array >>to
|
||||
[
|
||||
"This e-mail was sent by the application server on " % current-host % "\n" %
|
||||
"because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
|
||||
"login form, and requested a new password for the user named ``" %
|
||||
over username>> % "''.\n" %
|
||||
"\n" %
|
||||
"If you believe that this request was legitimate, you may click the below link in\n" %
|
||||
"your browser to set a new password for your account:\n" %
|
||||
"\n" %
|
||||
swap new-password-url present %
|
||||
"\n\n" %
|
||||
"Love,\n" %
|
||||
"\n" %
|
||||
" FactorBot\n" %
|
||||
] "" make >>body ;
|
||||
|
||||
: send-password-email ( user -- )
|
||||
'[ , password-email send-email ]
|
||||
"E-mail send thread" spawn drop ;
|
||||
|
||||
: <recover-action-1> ( -- action )
|
||||
<page-action>
|
||||
{ realm "features/recover-password/recover-1" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "email" [ v-email ] }
|
||||
{ "captcha" [ v-captcha ] }
|
||||
} validate-params
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"email" value "username" value
|
||||
users issue-ticket [
|
||||
send-password-email
|
||||
] when*
|
||||
|
||||
URL" $realm/recover-2" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <recover-action-2> ( -- action )
|
||||
<page-action>
|
||||
{ realm "features/recover-password/recover-2" } >>template ;
|
||||
|
||||
: <recover-action-3> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "ticket" [ v-required ] }
|
||||
} validate-params
|
||||
] >>init
|
||||
|
||||
{ realm "features/recover-password/recover-3" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "ticket" [ v-required ] }
|
||||
{ "new-password" [ v-password ] }
|
||||
{ "verify-password" [ v-password ] }
|
||||
} validate-params
|
||||
|
||||
same-password-twice
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"ticket" value
|
||||
"username" value
|
||||
users claim-ticket [
|
||||
"new-password" value >>encoded-password
|
||||
users update-user
|
||||
|
||||
URL" $realm/recover-4" <redirect>
|
||||
] [
|
||||
<403>
|
||||
] if*
|
||||
] >>submit ;
|
||||
|
||||
: <recover-action-4> ( -- action )
|
||||
<page-action>
|
||||
{ realm "features/recover-password/recover-4" } >>template ;
|
||||
|
||||
: allow-password-recovery ( login -- login )
|
||||
<recover-action-1> <auth-boilerplate>
|
||||
"recover-password" add-responder
|
||||
<recover-action-2> <auth-boilerplate>
|
||||
"recover-2" add-responder
|
||||
<recover-action-3> <auth-boilerplate>
|
||||
"recover-3" add-responder
|
||||
<recover-action-4> <auth-boilerplate>
|
||||
"recover-4" add-responder ;
|
||||
|
||||
: allow-password-recovery? ( -- ? )
|
||||
realm get responders>> "recover-password" swap key? ;
|
|
@ -0,0 +1,4 @@
|
|||
IN: furnace.auth.features.registration.tests
|
||||
USING: tools.test furnace.auth.features.registration ;
|
||||
|
||||
\ allow-registration must-infer
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (c) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces validators html.forms urls
|
||||
http.server.dispatchers
|
||||
furnace furnace.auth furnace.auth.providers furnace.actions
|
||||
furnace.redirection ;
|
||||
IN: furnace.auth.features.registration
|
||||
|
||||
: <register-action> ( -- action )
|
||||
<page-action>
|
||||
{ realm "features/registration/register" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||
{ "new-password" [ v-password ] }
|
||||
{ "verify-password" [ v-password ] }
|
||||
{ "email" [ [ v-email ] v-optional ] }
|
||||
{ "captcha" [ v-captcha ] }
|
||||
} validate-params
|
||||
|
||||
same-password-twice
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"new-password" value >>encoded-password
|
||||
"email" value >>email
|
||||
H{ } clone >>profile
|
||||
|
||||
users new-user [ user-exists ] unless*
|
||||
|
||||
realm get init-user-profile
|
||||
|
||||
URL" $realm" <redirect>
|
||||
] >>submit
|
||||
<auth-boilerplate> ;
|
||||
|
||||
: allow-registration ( login -- login )
|
||||
<register-action> "register" add-responder ;
|
||||
|
||||
: allow-registration? ( -- ? )
|
||||
realm get responders>> "register" swap key? ;
|
|
@ -1,6 +1,4 @@
|
|||
IN: furnace.auth.login.tests
|
||||
USING: tools.test furnace.auth.login ;
|
||||
|
||||
\ <login> must-infer
|
||||
\ allow-registration must-infer
|
||||
\ allow-password-recovery must-infer
|
||||
\ <login-realm> must-infer
|
||||
|
|
|
@ -1,99 +1,71 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors quotations assocs kernel splitting
|
||||
combinators sequences namespaces hashtables sets
|
||||
fry arrays threads qualified random validators words
|
||||
io
|
||||
io.sockets
|
||||
io.encodings.utf8
|
||||
io.encodings.string
|
||||
io.binary
|
||||
continuations
|
||||
destructors
|
||||
checksums
|
||||
checksums.sha2
|
||||
validators
|
||||
html.components
|
||||
html.elements
|
||||
urls
|
||||
http
|
||||
http.server
|
||||
http.server.dispatchers
|
||||
http.server.filters
|
||||
http.server.responses
|
||||
USING: kernel accessors namespaces sequences math.parser
|
||||
calendar validators urls html.forms
|
||||
http http.server http.server.dispatchers
|
||||
furnace
|
||||
furnace.auth
|
||||
furnace.auth.providers
|
||||
furnace.auth.providers.db
|
||||
furnace.actions
|
||||
furnace.asides
|
||||
furnace.flash
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
furnace.sessions
|
||||
furnace.boilerplate ;
|
||||
QUALIFIED: smtp
|
||||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.auth.login.permits ;
|
||||
IN: furnace.auth.login
|
||||
|
||||
: word>string ( word -- string )
|
||||
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
|
||||
SYMBOL: permit-id
|
||||
|
||||
: words>strings ( seq -- seq' )
|
||||
[ word>string ] map ;
|
||||
: permit-id-key ( realm -- string )
|
||||
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat
|
||||
"__p_" prepend ;
|
||||
|
||||
: string>word ( string -- word )
|
||||
":" split1 swap lookup ;
|
||||
: client-permit-id ( realm -- id/f )
|
||||
permit-id-key client-state dup [ string>number ] when ;
|
||||
|
||||
: strings>words ( seq -- seq' )
|
||||
[ string>word ] map ;
|
||||
TUPLE: login-realm < realm timeout domain ;
|
||||
|
||||
TUPLE: login < dispatcher users checksum ;
|
||||
M: login-realm call-responder*
|
||||
[ name>> client-permit-id permit-id set ]
|
||||
[ call-next-method ]
|
||||
bi ;
|
||||
|
||||
TUPLE: protected < filter-responder description capabilities ;
|
||||
M: login-realm logged-in-username
|
||||
drop permit-id get dup [ get-permit-uid ] when ;
|
||||
|
||||
: <protected> ( responder -- protected )
|
||||
protected new
|
||||
swap >>responder ;
|
||||
M: login-realm modify-form ( responder -- )
|
||||
drop permit-id get realm get name>> permit-id-key hidden-form-field ;
|
||||
|
||||
: users ( -- provider )
|
||||
login get users>> ;
|
||||
: <permit-cookie> ( -- cookie )
|
||||
permit-id get realm get name>> permit-id-key <cookie>
|
||||
"$login-realm" resolve-base-path >>path
|
||||
realm get
|
||||
[ timeout>> from-now >>expires ]
|
||||
[ domain>> >>domain ]
|
||||
[ secure>> >>secure ]
|
||||
tri ;
|
||||
|
||||
: encode-password ( string salt -- bytes )
|
||||
[ utf8 encode ] [ 4 >be ] bi* append
|
||||
login get checksum>> checksum-bytes ;
|
||||
: put-permit-cookie ( response -- response' )
|
||||
<permit-cookie> put-cookie ;
|
||||
|
||||
: >>encoded-password ( user string -- user )
|
||||
32 random-bits [ encode-password ] keep
|
||||
[ >>password ] [ >>salt ] bi* ; inline
|
||||
|
||||
: valid-login? ( password user -- ? )
|
||||
[ salt>> encode-password ] [ password>> ] bi = ;
|
||||
|
||||
: check-login ( password username -- user/f )
|
||||
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
|
||||
|
||||
! Destructor
|
||||
TUPLE: user-saver user ;
|
||||
|
||||
C: <user-saver> user-saver
|
||||
|
||||
M: user-saver dispose
|
||||
user>> dup changed?>> [ users update-user ] [ drop ] if ;
|
||||
|
||||
: save-user-after ( user -- )
|
||||
<user-saver> &dispose drop ;
|
||||
|
||||
! ! ! Login
|
||||
: successful-login ( user -- response )
|
||||
username>> set-uid URL" $login" end-aside ;
|
||||
[ username>> make-permit permit-id set ] [ init-user ] bi
|
||||
URL" $realm" end-aside
|
||||
put-permit-cookie ;
|
||||
|
||||
: login-failed ( -- * )
|
||||
"invalid username or password" validation-error
|
||||
validation-failed ;
|
||||
: logout ( -- )
|
||||
permit-id get [ delete-permit ] when*
|
||||
URL" $realm" end-aside ;
|
||||
|
||||
SYMBOL: description
|
||||
SYMBOL: capabilities
|
||||
|
||||
: flashed-variables { description capabilities } ;
|
||||
|
||||
: login-failed ( -- * )
|
||||
"invalid username or password" validation-error
|
||||
validation-failed ;
|
||||
|
||||
: <login-action> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
|
@ -102,7 +74,7 @@ SYMBOL: capabilities
|
|||
capabilities get words>strings "capabilities" set-value
|
||||
] >>init
|
||||
|
||||
{ login "login" } >>template
|
||||
{ login-realm "login" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
@ -113,288 +85,25 @@ SYMBOL: capabilities
|
|||
"password" value
|
||||
"username" value check-login
|
||||
[ successful-login ] [ login-failed ] if*
|
||||
] >>submit ;
|
||||
|
||||
! ! ! New user registration
|
||||
|
||||
: user-exists ( -- * )
|
||||
"username taken" validation-error
|
||||
validation-failed ;
|
||||
|
||||
: password-mismatch ( -- * )
|
||||
"passwords do not match" validation-error
|
||||
validation-failed ;
|
||||
|
||||
: same-password-twice ( -- )
|
||||
"new-password" value "verify-password" value =
|
||||
[ password-mismatch ] unless ;
|
||||
|
||||
: <register-action> ( -- action )
|
||||
<page-action>
|
||||
{ login "register" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||
{ "new-password" [ v-password ] }
|
||||
{ "verify-password" [ v-password ] }
|
||||
{ "email" [ [ v-email ] v-optional ] }
|
||||
{ "captcha" [ v-captcha ] }
|
||||
} validate-params
|
||||
|
||||
same-password-twice
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"new-password" value >>encoded-password
|
||||
"email" value >>email
|
||||
H{ } clone >>profile
|
||||
|
||||
users new-user [ user-exists ] unless*
|
||||
|
||||
login get init-user-profile
|
||||
|
||||
successful-login
|
||||
] >>submit ;
|
||||
|
||||
! ! ! Editing user profile
|
||||
|
||||
: <edit-profile-action> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
logged-in-user get
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
tri
|
||||
] >>init
|
||||
|
||||
{ login "edit-profile" } >>template
|
||||
|
||||
[
|
||||
uid "username" set-value
|
||||
|
||||
{
|
||||
{ "realname" [ [ v-one-line ] v-optional ] }
|
||||
{ "password" [ ] }
|
||||
{ "new-password" [ [ v-password ] v-optional ] }
|
||||
{ "verify-password" [ [ v-password ] v-optional ] }
|
||||
{ "email" [ [ v-email ] v-optional ] }
|
||||
} validate-params
|
||||
|
||||
{ "password" "new-password" "verify-password" }
|
||||
[ value empty? not ] contains? [
|
||||
"password" value uid check-login
|
||||
[ "incorrect password" validation-error ] unless
|
||||
|
||||
same-password-twice
|
||||
] when
|
||||
] >>validate
|
||||
|
||||
[
|
||||
logged-in-user get
|
||||
|
||||
"new-password" value dup empty?
|
||||
[ drop ] [ >>encoded-password ] if
|
||||
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
t >>changed?
|
||||
|
||||
drop
|
||||
|
||||
URL" $login" end-aside
|
||||
] >>submit
|
||||
<auth-boilerplate>
|
||||
<secure-realm-only> ;
|
||||
|
||||
<protected>
|
||||
"edit your profile" >>description ;
|
||||
|
||||
! ! ! Password recovery
|
||||
|
||||
SYMBOL: lost-password-from
|
||||
|
||||
: current-host ( -- string )
|
||||
request get url>> host>> host-name or ;
|
||||
|
||||
: new-password-url ( user -- url )
|
||||
"recover-3"
|
||||
swap [
|
||||
[ username>> "username" set ]
|
||||
[ ticket>> "ticket" set ]
|
||||
bi
|
||||
] H{ } make-assoc
|
||||
derive-url ;
|
||||
|
||||
: password-email ( user -- email )
|
||||
smtp:<email>
|
||||
[ "[ " % current-host % " ] password recovery" % ] "" make >>subject
|
||||
lost-password-from get >>from
|
||||
over email>> 1array >>to
|
||||
[
|
||||
"This e-mail was sent by the application server on " % current-host % "\n" %
|
||||
"because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
|
||||
"login form, and requested a new password for the user named ``" %
|
||||
over username>> % "''.\n" %
|
||||
"\n" %
|
||||
"If you believe that this request was legitimate, you may click the below link in\n" %
|
||||
"your browser to set a new password for your account:\n" %
|
||||
"\n" %
|
||||
swap new-password-url %
|
||||
"\n\n" %
|
||||
"Love,\n" %
|
||||
"\n" %
|
||||
" FactorBot\n" %
|
||||
] "" make >>body ;
|
||||
|
||||
: send-password-email ( user -- )
|
||||
'[ , password-email smtp:send-email ]
|
||||
"E-mail send thread" spawn drop ;
|
||||
|
||||
: <recover-action-1> ( -- action )
|
||||
<page-action>
|
||||
{ login "recover-1" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "email" [ v-email ] }
|
||||
{ "captcha" [ v-captcha ] }
|
||||
} validate-params
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"email" value "username" value
|
||||
users issue-ticket [
|
||||
send-password-email
|
||||
] when*
|
||||
|
||||
URL" $login/recover-2" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <recover-action-2> ( -- action )
|
||||
<page-action>
|
||||
{ login "recover-2" } >>template ;
|
||||
|
||||
: <recover-action-3> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "ticket" [ v-required ] }
|
||||
} validate-params
|
||||
] >>init
|
||||
|
||||
{ login "recover-3" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
{ "username" [ v-username ] }
|
||||
{ "ticket" [ v-required ] }
|
||||
{ "new-password" [ v-password ] }
|
||||
{ "verify-password" [ v-password ] }
|
||||
} validate-params
|
||||
|
||||
same-password-twice
|
||||
] >>validate
|
||||
|
||||
[
|
||||
"ticket" value
|
||||
"username" value
|
||||
users claim-ticket [
|
||||
"new-password" value >>encoded-password
|
||||
users update-user
|
||||
|
||||
URL" $login/recover-4" <redirect>
|
||||
] [
|
||||
<403>
|
||||
] if*
|
||||
] >>submit ;
|
||||
|
||||
: <recover-action-4> ( -- action )
|
||||
<page-action>
|
||||
{ login "recover-4" } >>template ;
|
||||
|
||||
! ! ! Logout
|
||||
: <logout-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
f set-uid
|
||||
URL" $login" end-aside
|
||||
] >>submit ;
|
||||
[ logout ] >>submit
|
||||
<protected>
|
||||
"logout" >>description ;
|
||||
|
||||
! ! ! Authentication logic
|
||||
: show-login-page ( -- response )
|
||||
M: login-realm login-required*
|
||||
drop
|
||||
begin-aside
|
||||
protected get description>> description set
|
||||
protected get capabilities>> capabilities set
|
||||
URL" $login/login" flashed-variables <flash-redirect> ;
|
||||
URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;
|
||||
|
||||
: login-required ( -- * )
|
||||
show-login-page exit-with ;
|
||||
|
||||
: have-capability? ( capability -- ? )
|
||||
logged-in-user get capabilities>> member? ;
|
||||
|
||||
: check-capabilities ( responder user/f -- ? )
|
||||
dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
dup protected set
|
||||
dup logged-in-user get check-capabilities
|
||||
[ call-next-method ] [ 2drop show-login-page ] if ;
|
||||
|
||||
: init-user ( -- )
|
||||
uid [
|
||||
users get-user
|
||||
[ logged-in-user set ]
|
||||
[ save-user-after ] bi
|
||||
] when* ;
|
||||
|
||||
M: login call-responder* ( path responder -- response )
|
||||
dup login set
|
||||
init-user
|
||||
call-next-method ;
|
||||
|
||||
: <login-boilerplate> ( responder -- responder' )
|
||||
<boilerplate>
|
||||
{ login "boilerplate" } >>template ;
|
||||
|
||||
: <login> ( responder -- auth )
|
||||
login new-dispatcher
|
||||
swap >>default
|
||||
<login-action> <login-boilerplate> "login" add-responder
|
||||
<logout-action> <login-boilerplate> "logout" add-responder
|
||||
users-in-db >>users
|
||||
sha-256 >>checksum ;
|
||||
|
||||
! ! ! Configuration
|
||||
|
||||
: allow-edit-profile ( login -- login )
|
||||
<edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
|
||||
|
||||
: allow-registration ( login -- login )
|
||||
<register-action> <login-boilerplate>
|
||||
"register" add-responder ;
|
||||
|
||||
: allow-password-recovery ( login -- login )
|
||||
<recover-action-1> <login-boilerplate>
|
||||
"recover-password" add-responder
|
||||
<recover-action-2> <login-boilerplate>
|
||||
"recover-2" add-responder
|
||||
<recover-action-3> <login-boilerplate>
|
||||
"recover-3" add-responder
|
||||
<recover-action-4> <login-boilerplate>
|
||||
"recover-4" add-responder ;
|
||||
|
||||
: allow-edit-profile? ( -- ? )
|
||||
login get responders>> "edit-profile" swap key? ;
|
||||
|
||||
: allow-registration? ( -- ? )
|
||||
login get responders>> "register" swap key? ;
|
||||
|
||||
: allow-password-recovery? ( -- ? )
|
||||
login get responders>> "recover-password" swap key? ;
|
||||
: <login-realm> ( responder name -- auth )
|
||||
login-realm new-realm
|
||||
<login-action> "login" add-responder
|
||||
<logout-action> "logout" add-responder
|
||||
20 minutes >>timeout ;
|
||||
|
|
|
@ -43,11 +43,11 @@
|
|||
</t:form>
|
||||
|
||||
<p>
|
||||
<t:if t:code="furnace.auth.login:allow-registration?">
|
||||
<t:if t:code="furnace.auth.features.registration:allow-registration?">
|
||||
<t:a t:href="register">Register</t:a>
|
||||
</t:if>
|
||||
|
|
||||
<t:if t:code="furnace.auth.login:allow-password-recovery?">
|
||||
<t:if t:code="furnace.auth.features.recover-password:allow-password-recovery?">
|
||||
<t:a t:href="recover-password">Recover Password</t:a>
|
||||
</t:if>
|
||||
</p>
|
||||
|
|
|
@ -0,0 +1,30 @@
|
|||
USING: accessors namespaces combinators.lib kernel
|
||||
db.tuples db.types
|
||||
furnace.auth furnace.sessions furnace.cache ;
|
||||
IN: furnace.auth.login.permits
|
||||
|
||||
TUPLE: permit < server-state session uid ;
|
||||
|
||||
permit "PERMITS" {
|
||||
{ "session" "SESSION" BIG-INTEGER +not-null+ }
|
||||
{ "uid" "UID" { VARCHAR 255 } +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: touch-permit ( permit -- )
|
||||
realm get touch-state ;
|
||||
|
||||
: get-permit-uid ( id -- uid )
|
||||
permit get-state {
|
||||
[ ]
|
||||
[ session>> session get id>> = ]
|
||||
[ [ touch-permit ] [ uid>> ] bi ]
|
||||
} 1&& ;
|
||||
|
||||
: make-permit ( uid -- id )
|
||||
permit new
|
||||
swap >>uid
|
||||
session get id>> >>session
|
||||
[ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
|
||||
|
||||
: delete-permit ( id -- )
|
||||
permit new-server-state delete-tuples ;
|
|
@ -1,11 +1,11 @@
|
|||
IN: furnace.auth.providers.assoc.tests
|
||||
USING: furnace.actions furnace.auth.providers
|
||||
USING: furnace.actions furnace.auth furnace.auth.providers
|
||||
furnace.auth.providers.assoc furnace.auth.login
|
||||
tools.test namespaces accessors kernel ;
|
||||
|
||||
<action> <login>
|
||||
<action> "Test" <login-realm>
|
||||
<users-in-memory> >>users
|
||||
login set
|
||||
realm set
|
||||
|
||||
[ t ] [
|
||||
"slava" <user>
|
||||
|
|
|
@ -1,14 +1,13 @@
|
|||
IN: furnace.auth.providers.db.tests
|
||||
USING: furnace.actions
|
||||
furnace.auth
|
||||
furnace.auth.login
|
||||
furnace.auth.providers
|
||||
furnace.auth.providers.db tools.test
|
||||
namespaces db db.sqlite db.tuples continuations
|
||||
io.files accessors kernel ;
|
||||
|
||||
<action> <login>
|
||||
users-in-db >>users
|
||||
login set
|
||||
<action> "test" <login-realm> realm set
|
||||
|
||||
[ "auth-test.db" temp-file delete-file ] ignore-errors
|
||||
|
||||
|
|
|
@ -1,19 +1,32 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces
|
||||
html.templates html.templates.chloe
|
||||
USING: accessors kernel math.order namespaces combinators.lib
|
||||
html.forms
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
locals
|
||||
http.server
|
||||
http.server.filters
|
||||
furnace ;
|
||||
IN: furnace.boilerplate
|
||||
|
||||
TUPLE: boilerplate < filter-responder template ;
|
||||
TUPLE: boilerplate < filter-responder template init ;
|
||||
|
||||
: <boilerplate> ( responder -- boilerplate ) f boilerplate boa ;
|
||||
: <boilerplate> ( responder -- boilerplate )
|
||||
boilerplate new
|
||||
swap >>responder
|
||||
[ ] >>init ;
|
||||
|
||||
: wrap-boilerplate? ( response -- ? )
|
||||
{
|
||||
[ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
|
||||
[ content-type>> "text/html" = ]
|
||||
} 1&& ;
|
||||
|
||||
M:: boilerplate call-responder* ( path responder -- )
|
||||
begin-form
|
||||
path responder call-next-method
|
||||
responder init>> call
|
||||
dup content-type>> "text/html" = [
|
||||
clone [| body |
|
||||
[
|
||||
|
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors continuations namespaces destructors
|
||||
db db.pools io.pools http.server http.server.filters
|
||||
furnace.sessions ;
|
||||
db db.pools io.pools http.server http.server.filters ;
|
||||
IN: furnace.db
|
||||
|
||||
TUPLE: db-persistence < filter-responder pool ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: namespaces assocs assocs.lib kernel sequences accessors
|
||||
urls db.types db.tuples math.parser fry
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace furnace.cache furnace.sessions ;
|
||||
furnace furnace.cache furnace.sessions furnace.redirection ;
|
||||
IN: furnace.flash
|
||||
|
||||
TUPLE: flash-scope < server-state session namespace ;
|
||||
|
@ -25,7 +25,9 @@ TUPLE: flash-scopes < server-state-manager ;
|
|||
|
||||
SYMBOL: flash-scope
|
||||
|
||||
: fget ( key -- value ) flash-scope get at ;
|
||||
: fget ( key -- value )
|
||||
flash-scope get dup
|
||||
[ namespace>> at ] [ 2drop f ] if ;
|
||||
|
||||
: get-flash-scope ( id -- flash-scope )
|
||||
dup [ flash-scope get-state ] when
|
||||
|
|
|
@ -10,6 +10,7 @@ xml.entities
|
|||
xml.writer
|
||||
html.components
|
||||
html.elements
|
||||
html.forms
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
html.templates.chloe.syntax
|
||||
|
@ -30,7 +31,7 @@ IN: furnace
|
|||
|
||||
: base-path ( string -- pair )
|
||||
dup responder-nesting get
|
||||
[ second class word-name = ] with find nip
|
||||
[ second class superclasses [ word-name = ] with contains? ] with find nip
|
||||
[ first ] [ "No such responder: " swap append throw ] ?if ;
|
||||
|
||||
: resolve-base-path ( string -- string' )
|
||||
|
@ -62,13 +63,6 @@ M: url adjust-url
|
|||
|
||||
M: string adjust-url ;
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
adjust-url request get method>> {
|
||||
{ "GET" [ <temporary-redirect> ] }
|
||||
{ "HEAD" [ <temporary-redirect> ] }
|
||||
{ "POST" [ <permanent-redirect> ] }
|
||||
} case ;
|
||||
|
||||
GENERIC: modify-form ( responder -- )
|
||||
|
||||
M: object modify-form drop ;
|
||||
|
@ -95,6 +89,19 @@ M: object modify-form drop ;
|
|||
request get url>>
|
||||
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
|
||||
|
||||
: cookie-client-state ( key request -- value/f )
|
||||
swap get-cookie dup [ value>> ] when ;
|
||||
|
||||
: post-client-state ( key request -- value/f )
|
||||
request-params at ;
|
||||
|
||||
: client-state ( key -- value/f )
|
||||
request get dup method>> {
|
||||
{ "GET" [ cookie-client-state ] }
|
||||
{ "HEAD" [ cookie-client-state ] }
|
||||
{ "POST" [ post-client-state ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: exit-continuation
|
||||
|
||||
: exit-with ( value -- )
|
||||
|
@ -109,7 +116,8 @@ SYMBOL: exit-continuation
|
|||
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
||||
|
||||
: a-url-path ( tag -- string )
|
||||
[ "href" required-attr ] [ "rest" optional-attr value ] bi
|
||||
[ "href" required-attr ]
|
||||
[ "rest" optional-attr dup [ value ] when ] bi
|
||||
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
|
||||
|
||||
: a-url ( tag -- url )
|
||||
|
@ -153,11 +161,11 @@ CHLOE: a
|
|||
input/>
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: form-nesting-key "__n" ;
|
||||
: nested-forms-key "__n" ;
|
||||
|
||||
: form-magic ( tag -- )
|
||||
[ modify-form ] each-responder
|
||||
nested-values get " " join f like form-nesting-key hidden-form-field
|
||||
nested-forms get " " join f like nested-forms-key hidden-form-field
|
||||
"for" optional-attr [ "," split [ hidden render ] each ] when* ;
|
||||
|
||||
: form-start-tag ( tag -- )
|
||||
|
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors combinators namespaces fry
|
||||
io.servers.connection
|
||||
http http.server http.server.redirection http.server.filters
|
||||
furnace ;
|
||||
IN: furnace.redirection
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
adjust-url request get method>> {
|
||||
{ "GET" [ <temporary-redirect> ] }
|
||||
{ "HEAD" [ <temporary-redirect> ] }
|
||||
{ "POST" [ <permanent-redirect> ] }
|
||||
} case ;
|
||||
|
||||
: >secure-url ( url -- url' )
|
||||
clone
|
||||
"https" >>protocol
|
||||
secure-port >>port ;
|
||||
|
||||
: <secure-redirect> ( url -- response )
|
||||
>secure-url <redirect> ;
|
||||
|
||||
TUPLE: redirect-responder to ;
|
||||
|
||||
: <redirect-responder> ( url -- responder )
|
||||
redirect-responder boa ;
|
||||
|
||||
M: redirect-responder call-responder* nip to>> <redirect> ;
|
||||
|
||||
TUPLE: secure-only < filter-responder ;
|
||||
|
||||
C: <secure-only> secure-only
|
||||
|
||||
: if-secure ( quot -- )
|
||||
>r request get url>> protocol>> "http" =
|
||||
[ request get url>> <secure-redirect> ]
|
||||
r> if ; inline
|
||||
|
||||
M: secure-only call-responder*
|
||||
'[ , , call-next-method ] if-secure ;
|
|
@ -1,7 +1,7 @@
|
|||
IN: furnace.sessions.tests
|
||||
USING: tools.test http furnace.sessions
|
||||
furnace.actions http.server http.server.responses
|
||||
math namespaces kernel accessors io.sockets io.server
|
||||
math namespaces kernel accessors io.sockets io.servers.connection
|
||||
prettyprint io.streams.string io.files splitting destructors
|
||||
sequences db db.tuples db.sqlite continuations urls math.parser
|
||||
furnace ;
|
||||
|
@ -65,7 +65,7 @@ M: foo call-responder*
|
|||
|
||||
[
|
||||
[ ] [
|
||||
empty-session
|
||||
empty-session
|
||||
123 >>id session set
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -1,22 +1,22 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math.intervals math.parser namespaces
|
||||
random accessors quotations hashtables sequences continuations
|
||||
fry calendar combinators destructors alarms io.server
|
||||
strings random accessors quotations hashtables sequences continuations
|
||||
fry calendar combinators combinators.lib destructors alarms
|
||||
io.servers.connection
|
||||
db db.tuples db.types
|
||||
http http.server http.server.dispatchers http.server.filters
|
||||
html.elements
|
||||
furnace furnace.cache ;
|
||||
IN: furnace.sessions
|
||||
|
||||
TUPLE: session < server-state uid namespace user-agent client changed? ;
|
||||
TUPLE: session < server-state namespace user-agent client changed? ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session new-server-state ;
|
||||
|
||||
session "SESSIONS"
|
||||
{
|
||||
{ "uid" "UID" { VARCHAR 255 } }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
|
||||
{ "user-agent" "USER_AGENT" TEXT +not-null+ }
|
||||
{ "client" "CLIENT" TEXT +not-null+ }
|
||||
|
@ -57,19 +57,17 @@ TUPLE: sessions < server-state-manager domain verify? ;
|
|||
[ namespace>> swap change-at ] keep
|
||||
(session-changed) ; inline
|
||||
|
||||
: uid ( -- uid )
|
||||
session get uid>> ;
|
||||
|
||||
: set-uid ( uid -- )
|
||||
session get [ (>>uid) ] [ (session-changed) ] bi ;
|
||||
|
||||
: init-session ( session -- )
|
||||
session [ sessions get init-session* ] with-variable ;
|
||||
|
||||
: touch-session ( session -- )
|
||||
sessions get touch-state ;
|
||||
|
||||
: remote-host ( -- string ) remote-address get host>> ;
|
||||
: remote-host ( -- string )
|
||||
{
|
||||
[ request get "x-forwarded-for" header ]
|
||||
[ remote-address get host>> ]
|
||||
} 0|| ;
|
||||
|
||||
: empty-session ( -- session )
|
||||
f <session>
|
||||
|
@ -100,20 +98,6 @@ M: session-saver dispose
|
|||
|
||||
: session-id-key "__s" ;
|
||||
|
||||
: cookie-session-id ( request -- id/f )
|
||||
session-id-key get-cookie
|
||||
dup [ value>> string>number ] when ;
|
||||
|
||||
: post-session-id ( request -- id/f )
|
||||
session-id-key swap request-params at string>number ;
|
||||
|
||||
: request-session-id ( -- id/f )
|
||||
request get dup method>> {
|
||||
{ "GET" [ cookie-session-id ] }
|
||||
{ "HEAD" [ cookie-session-id ] }
|
||||
{ "POST" [ post-session-id ] }
|
||||
} case ;
|
||||
|
||||
: verify-session ( session -- session )
|
||||
sessions get verify?>> [
|
||||
dup [
|
||||
|
@ -125,16 +109,18 @@ M: session-saver dispose
|
|||
] when ;
|
||||
|
||||
: request-session ( -- session/f )
|
||||
request-session-id get-session verify-session ;
|
||||
session-id-key
|
||||
client-state dup string? [ string>number ] when
|
||||
get-session verify-session ;
|
||||
|
||||
: <session-cookie> ( id -- cookie )
|
||||
session-id-key <cookie>
|
||||
: <session-cookie> ( -- cookie )
|
||||
session get id>> session-id-key <cookie>
|
||||
"$sessions" resolve-base-path >>path
|
||||
sessions get timeout>> from-now >>expires
|
||||
sessions get domain>> >>domain ;
|
||||
|
||||
: put-session-cookie ( response -- response' )
|
||||
session get id>> number>string <session-cookie> put-cookie ;
|
||||
<session-cookie> put-cookie ;
|
||||
|
||||
M: sessions modify-form ( responder -- )
|
||||
drop session get id>> session-id-key hidden-form-field ;
|
||||
|
@ -143,6 +129,3 @@ M: sessions call-responder* ( path responder -- response )
|
|||
sessions set
|
||||
request-session [ begin-session ] unless*
|
||||
existing-session put-session-cookie ;
|
||||
|
||||
: logout-all-sessions ( uid -- )
|
||||
session new swap >>uid delete-tuples ;
|
||||
|
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words kernel sequences splitting ;
|
||||
IN: furnace.utilities
|
||||
|
||||
: word>string ( word -- string )
|
||||
[ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
|
||||
|
||||
: words>strings ( seq -- seq' )
|
||||
[ word>string ] map ;
|
||||
|
||||
ERROR: no-such-word name vocab ;
|
||||
|
||||
: string>word ( string -- word )
|
||||
":" split1 swap 2dup lookup dup
|
||||
[ 2nip ] [ drop no-such-word ] if ;
|
||||
|
||||
: strings>words ( seq -- seq' )
|
||||
[ string>word ] map ;
|
|
@ -1,9 +1,9 @@
|
|||
IN: html.components.tests
|
||||
USING: tools.test kernel io.streams.string
|
||||
io.streams.null accessors inspector html.streams
|
||||
html.elements html.components namespaces ;
|
||||
html.elements html.components html.forms namespaces ;
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
[ ] [ begin-form ] unit-test
|
||||
|
||||
[ ] [ 3 "hi" set-value ] unit-test
|
||||
|
||||
|
@ -63,7 +63,7 @@ TUPLE: color red green blue ;
|
|||
] with-null-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
[ ] [ begin-form ] unit-test
|
||||
|
||||
[ ] [ "new york" "city1" set-value ] unit-test
|
||||
|
||||
|
@ -101,7 +101,7 @@ TUPLE: color red green blue ;
|
|||
] with-null-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
[ ] [ begin-form ] unit-test
|
||||
|
||||
[ ] [ t "delivery" set-value ] unit-test
|
||||
|
||||
|
@ -156,7 +156,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
|||
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
|
||||
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
|
||||
[ "farkup" farkup render ] with-string-writer
|
||||
[ "farkup" T{ farkup } render ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [ { 1 2 3 } "object" set-value ] unit-test
|
||||
|
@ -167,12 +167,19 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
|||
=
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
[ ] [ begin-form ] unit-test
|
||||
|
||||
[ ] [
|
||||
"factor" [
|
||||
"concatenative" "model" set-value
|
||||
] nest-values
|
||||
] nest-form
|
||||
] unit-test
|
||||
|
||||
[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
|
||||
[
|
||||
H{
|
||||
{
|
||||
"factor"
|
||||
T{ form f V{ } H{ { "model" "concatenative" } } }
|
||||
}
|
||||
}
|
||||
] [ values ] unit-test
|
||||
|
|
|
@ -1,82 +1,26 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces io math.parser assocs classes
|
||||
classes.tuple words arrays sequences sequences.lib splitting
|
||||
mirrors hashtables combinators continuations math strings
|
||||
fry locals calendar calendar.format xml.entities validators
|
||||
html.elements html.streams xmode.code2html farkup inspector
|
||||
lcs.diff2html urls present ;
|
||||
classes.tuple words arrays sequences splitting mirrors
|
||||
hashtables combinators continuations math strings inspector
|
||||
fry locals calendar calendar.format xml.entities
|
||||
validators urls present
|
||||
xmode.code2html lcs.diff2html farkup
|
||||
html.elements html.streams html.forms ;
|
||||
IN: html.components
|
||||
|
||||
SYMBOL: values
|
||||
|
||||
: value ( name -- value ) values get at ;
|
||||
|
||||
: set-value ( value name -- ) values get set-at ;
|
||||
|
||||
: blank-values ( -- ) H{ } clone values set ;
|
||||
|
||||
: prepare-value ( name object -- value name object )
|
||||
[ [ value ] keep ] dip ; inline
|
||||
|
||||
: from-object ( object -- )
|
||||
dup assoc? [ <mirror> ] unless
|
||||
values get swap update ;
|
||||
|
||||
: deposit-values ( destination names -- )
|
||||
[ dup value ] H{ } map>assoc update ;
|
||||
|
||||
: deposit-slots ( destination names -- )
|
||||
[ <mirror> ] dip deposit-values ;
|
||||
|
||||
: with-each-value ( name quot -- )
|
||||
[ value ] dip '[
|
||||
[
|
||||
values [ clone ] change
|
||||
1+ "index" set-value
|
||||
"value" set-value
|
||||
@
|
||||
] with-scope
|
||||
] each-index ; inline
|
||||
|
||||
: with-each-object ( name quot -- )
|
||||
[ value ] dip '[
|
||||
[
|
||||
blank-values
|
||||
1+ "index" set-value
|
||||
from-object
|
||||
@
|
||||
] with-scope
|
||||
] each-index ; inline
|
||||
|
||||
SYMBOL: nested-values
|
||||
|
||||
: with-values ( name quot -- )
|
||||
'[
|
||||
,
|
||||
[ nested-values [ swap prefix ] change ]
|
||||
[ value blank-values from-object ]
|
||||
bi
|
||||
@
|
||||
] with-scope ; inline
|
||||
|
||||
: nest-values ( name quot -- )
|
||||
swap [
|
||||
[
|
||||
H{ } clone [ values set call ] keep
|
||||
] with-scope
|
||||
] dip set-value ; inline
|
||||
|
||||
GENERIC: render* ( value name render -- )
|
||||
|
||||
: render ( name renderer -- )
|
||||
over named-validation-messages get at [
|
||||
[ value>> ] [ message>> ] bi
|
||||
[ -rot render* ] dip
|
||||
render-error
|
||||
] [
|
||||
prepare-value render*
|
||||
] if* ;
|
||||
prepare-value
|
||||
[
|
||||
dup validation-error?
|
||||
[ [ message>> ] [ value>> ] bi ]
|
||||
[ f swap ]
|
||||
if
|
||||
] 2dip
|
||||
render*
|
||||
[ render-error ] when* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -200,10 +144,20 @@ M: code render*
|
|||
[ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
|
||||
|
||||
! Farkup component
|
||||
SINGLETON: farkup
|
||||
TUPLE: farkup no-follow disable-images ;
|
||||
|
||||
: string>boolean ( string -- boolean )
|
||||
{
|
||||
{ "true" [ t ] }
|
||||
{ "false" [ f ] }
|
||||
} case ;
|
||||
|
||||
M: farkup render*
|
||||
2drop string-lines "\n" join convert-farkup write ;
|
||||
[
|
||||
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
|
||||
[ disable-images>> [ string>boolean disable-images? set ] when* ] bi
|
||||
drop string-lines "\n" join convert-farkup write
|
||||
] with-scope ;
|
||||
|
||||
! Inspector component
|
||||
SINGLETON: inspector
|
||||
|
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
USING: io kernel namespaces prettyprint quotations
|
||||
sequences strings words xml.entities compiler.units effects
|
||||
urls math math.parser combinators present ;
|
||||
urls math math.parser combinators present fry ;
|
||||
|
||||
IN: html.elements
|
||||
|
||||
|
@ -70,7 +70,7 @@ SYMBOL: html
|
|||
: def-for-html-word-<foo> ( name -- )
|
||||
#! Return the name and code for the <foo> patterned
|
||||
#! word.
|
||||
dup <foo> swap [ <foo> write-html ] curry
|
||||
dup <foo> swap '[ , <foo> write-html ]
|
||||
(( -- )) html-word ;
|
||||
|
||||
: <foo ( str -- <str ) "<" prepend ;
|
||||
|
@ -78,7 +78,7 @@ SYMBOL: html
|
|||
: def-for-html-word-<foo ( name -- )
|
||||
#! Return the name and code for the <foo patterned
|
||||
#! word.
|
||||
<foo dup [ write-html ] curry
|
||||
<foo dup '[ , write-html ]
|
||||
(( -- )) html-word ;
|
||||
|
||||
: foo> ( str -- foo> ) ">" append ;
|
||||
|
@ -93,14 +93,14 @@ SYMBOL: html
|
|||
: def-for-html-word-</foo> ( name -- )
|
||||
#! Return the name and code for the </foo> patterned
|
||||
#! word.
|
||||
</foo> dup [ write-html ] curry (( -- )) html-word ;
|
||||
</foo> dup '[ , write-html ] (( -- )) html-word ;
|
||||
|
||||
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
|
||||
|
||||
: def-for-html-word-<foo/> ( name -- )
|
||||
#! Return the name and code for the <foo/> patterned
|
||||
#! word.
|
||||
dup <foo/> swap [ <foo/> write-html ] curry
|
||||
dup <foo/> swap '[ , <foo/> write-html ]
|
||||
(( -- )) html-word ;
|
||||
|
||||
: foo/> ( str -- str/> ) "/>" append ;
|
||||
|
@ -134,7 +134,7 @@ SYMBOL: html
|
|||
|
||||
: define-attribute-word ( name -- )
|
||||
dup "=" prepend swap
|
||||
[ write-attr ] curry (( string -- )) html-word ;
|
||||
'[ , write-attr ] (( string -- )) html-word ;
|
||||
|
||||
! Define some closed HTML tags
|
||||
[
|
||||
|
|
|
@ -0,0 +1,67 @@
|
|||
IN: html.forms.tests
|
||||
USING: kernel sequences tools.test assocs html.forms validators accessors
|
||||
namespaces ;
|
||||
|
||||
: with-validation ( quot -- messages )
|
||||
[
|
||||
begin-form
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
[ 14 ] [
|
||||
[
|
||||
"14" [ v-number 13 v-min-value 100 v-max-value ] validate
|
||||
] with-validation
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
"140" [ v-number 13 v-min-value 100 v-max-value ] validate
|
||||
[ validation-error? ]
|
||||
[ value>> "140" = ]
|
||||
bi and
|
||||
] with-validation
|
||||
] unit-test
|
||||
|
||||
TUPLE: person name age ;
|
||||
|
||||
person {
|
||||
{ "name" [ ] }
|
||||
{ "age" [ v-number 13 v-min-value 100 v-max-value ] }
|
||||
} define-validators
|
||||
|
||||
[ t t ] [
|
||||
[
|
||||
{ { "age" "" } }
|
||||
{ { "age" [ v-required ] } }
|
||||
validate-values
|
||||
validation-failed?
|
||||
"age" value
|
||||
[ validation-error? ]
|
||||
[ message>> "required" = ]
|
||||
bi and
|
||||
] with-validation
|
||||
] unit-test
|
||||
|
||||
[ H{ { "a" 123 } } f ] [
|
||||
[
|
||||
H{
|
||||
{ "a" "123" }
|
||||
{ "b" "c" }
|
||||
{ "c" "d" }
|
||||
}
|
||||
H{
|
||||
{ "a" [ v-integer ] }
|
||||
} validate-values
|
||||
values
|
||||
validation-failed?
|
||||
] with-validation
|
||||
] unit-test
|
||||
|
||||
[ t "foo" ] [
|
||||
[
|
||||
"foo" validation-error
|
||||
validation-failed?
|
||||
form get errors>> first
|
||||
] with-validation
|
||||
] unit-test
|
|
@ -0,0 +1,106 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors strings namespaces assocs hashtables
|
||||
mirrors math fry sequences sequences.lib words continuations ;
|
||||
IN: html.forms
|
||||
|
||||
TUPLE: form errors values validation-failed ;
|
||||
|
||||
: <form> ( -- form )
|
||||
form new
|
||||
V{ } clone >>errors
|
||||
H{ } clone >>values ;
|
||||
|
||||
M: form clone
|
||||
call-next-method
|
||||
[ clone ] change-errors
|
||||
[ clone ] change-values ;
|
||||
|
||||
: check-value-name ( name -- name )
|
||||
dup string? [ "Value name not a string" throw ] unless ;
|
||||
|
||||
: values ( -- assoc )
|
||||
form get values>> ;
|
||||
|
||||
: value ( name -- value )
|
||||
check-value-name values at ;
|
||||
|
||||
: set-value ( value name -- )
|
||||
check-value-name values set-at ;
|
||||
|
||||
: begin-form ( -- ) <form> form set ;
|
||||
|
||||
: prepare-value ( name object -- value name object )
|
||||
[ [ value ] keep ] dip ; inline
|
||||
|
||||
: from-object ( object -- )
|
||||
[ values ] [ make-mirror ] bi* update ;
|
||||
|
||||
: to-object ( destination names -- )
|
||||
[ make-mirror ] [ values extract-keys ] bi* update ;
|
||||
|
||||
: with-each-value ( name quot -- )
|
||||
[ value ] dip '[
|
||||
[
|
||||
form [ clone ] change
|
||||
1+ "index" set-value
|
||||
"value" set-value
|
||||
@
|
||||
] with-scope
|
||||
] each-index ; inline
|
||||
|
||||
: with-each-object ( name quot -- )
|
||||
[ value ] dip '[
|
||||
[
|
||||
begin-form
|
||||
1+ "index" set-value
|
||||
from-object
|
||||
@
|
||||
] with-scope
|
||||
] each-index ; inline
|
||||
|
||||
SYMBOL: nested-forms
|
||||
|
||||
: with-form ( name quot -- )
|
||||
'[
|
||||
,
|
||||
[ nested-forms [ swap prefix ] change ]
|
||||
[ value form set ]
|
||||
bi
|
||||
@
|
||||
] with-scope ; inline
|
||||
|
||||
: nest-form ( name quot -- )
|
||||
swap [
|
||||
[
|
||||
<form> form set
|
||||
call
|
||||
form get
|
||||
] with-scope
|
||||
] dip set-value ; inline
|
||||
|
||||
TUPLE: validation-error value message ;
|
||||
|
||||
C: <validation-error> validation-error
|
||||
|
||||
: validation-error ( message -- )
|
||||
form get
|
||||
t >>validation-failed
|
||||
errors>> push ;
|
||||
|
||||
: validation-failed? ( -- ? )
|
||||
form get validation-failed>> ;
|
||||
|
||||
: define-validators ( class validators -- )
|
||||
>hashtable "validators" set-word-prop ;
|
||||
|
||||
: validate ( value quot -- result )
|
||||
[ <validation-error> ] recover ; inline
|
||||
|
||||
: validate-value ( name value quot -- )
|
||||
validate
|
||||
dup validation-error? [ form get t >>validation-failed drop ] when
|
||||
swap set-value ;
|
||||
|
||||
: validate-values ( assoc validators -- assoc' )
|
||||
swap '[ dup , at _ validate-value ] assoc-each ;
|
|
@ -1,7 +1,7 @@
|
|||
USING: html.templates html.templates.chloe
|
||||
tools.test io.streams.string kernel sequences ascii boxes
|
||||
namespaces xml html.components
|
||||
splitting unicode.categories furnace ;
|
||||
namespaces xml html.components html.forms
|
||||
splitting unicode.categories furnace accessors ;
|
||||
IN: html.templates.chloe.tests
|
||||
|
||||
[ f ] [ f parse-query-attr ] unit-test
|
||||
|
@ -9,13 +9,13 @@ IN: html.templates.chloe.tests
|
|||
[ f ] [ "" parse-query-attr ] unit-test
|
||||
|
||||
[ H{ { "a" "b" } } ] [
|
||||
blank-values
|
||||
begin-form
|
||||
"b" "a" set-value
|
||||
"a" parse-query-attr
|
||||
] unit-test
|
||||
|
||||
[ H{ { "a" "b" } { "c" "d" } } ] [
|
||||
blank-values
|
||||
begin-form
|
||||
"b" "a" set-value
|
||||
"d" "c" set-value
|
||||
"a,c" parse-query-attr
|
||||
|
@ -69,7 +69,7 @@ IN: html.templates.chloe.tests
|
|||
] run-template
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
[ ] [ begin-form ] unit-test
|
||||
|
||||
[ ] [ "A label" "label" set-value ] unit-test
|
||||
|
||||
|
@ -157,10 +157,10 @@ TUPLE: person first-name last-name ;
|
|||
] run-template
|
||||
] unit-test
|
||||
|
||||
[ ] [ blank-values ] unit-test
|
||||
[ ] [ begin-form ] unit-test
|
||||
|
||||
[ ] [
|
||||
H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
|
||||
<form> H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } >>values "person" set-value
|
||||
] unit-test
|
||||
|
||||
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
|
||||
|
@ -170,7 +170,7 @@ TUPLE: person first-name last-name ;
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
blank-values
|
||||
begin-form
|
||||
{ "a" "b" } "choices" set-value
|
||||
"true" "b" set-value
|
||||
] unit-test
|
||||
|
|
|
@ -5,6 +5,7 @@ classes.tuple assocs splitting words arrays memoize
|
|||
io io.files io.encodings.utf8 io.streams.string
|
||||
unicode.case tuple-syntax mirrors fry math urls present
|
||||
multiline xml xml.data xml.writer xml.utilities
|
||||
html.forms
|
||||
html.elements
|
||||
html.components
|
||||
html.templates
|
||||
|
@ -76,7 +77,7 @@ CHLOE: each [ with-each-value ] (bind-tag) ;
|
|||
|
||||
CHLOE: bind-each [ with-each-object ] (bind-tag) ;
|
||||
|
||||
CHLOE: bind [ with-values ] (bind-tag) ;
|
||||
CHLOE: bind [ with-form ] (bind-tag) ;
|
||||
|
||||
: error-message-tag ( tag -- )
|
||||
children>string render-error ;
|
||||
|
@ -86,11 +87,10 @@ CHLOE: comment drop ;
|
|||
CHLOE: call-next-template drop call-next-template ;
|
||||
|
||||
: attr>word ( value -- word/f )
|
||||
dup ":" split1 swap lookup
|
||||
[ ] [ "No such word: " swap append throw ] ?if ;
|
||||
":" split1 swap lookup ;
|
||||
|
||||
: if-satisfied? ( tag -- ? )
|
||||
[ "code" optional-attr [ attr>word execute ] [ t ] if* ]
|
||||
[ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
|
||||
[ "value" optional-attr [ value ] [ t ] if* ]
|
||||
bi and ;
|
||||
|
||||
|
@ -98,12 +98,12 @@ CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
|
|||
|
||||
CHLOE-SINGLETON: label
|
||||
CHLOE-SINGLETON: link
|
||||
CHLOE-SINGLETON: farkup
|
||||
CHLOE-SINGLETON: inspector
|
||||
CHLOE-SINGLETON: comparison
|
||||
CHLOE-SINGLETON: html
|
||||
CHLOE-SINGLETON: hidden
|
||||
|
||||
CHLOE-TUPLE: farkup
|
||||
CHLOE-TUPLE: field
|
||||
CHLOE-TUPLE: textarea
|
||||
CHLOE-TUPLE: password
|
||||
|
|
|
@ -14,7 +14,7 @@ tuple-syntax namespaces urls ;
|
|||
method: "GET"
|
||||
version: "1.1"
|
||||
cookies: V{ }
|
||||
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
|
||||
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
|
||||
}
|
||||
] [
|
||||
"http://www.apple.com/index.html"
|
||||
|
@ -27,7 +27,7 @@ tuple-syntax namespaces urls ;
|
|||
method: "GET"
|
||||
version: "1.1"
|
||||
cookies: V{ }
|
||||
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
|
||||
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
|
||||
}
|
||||
] [
|
||||
"https://www.amazon.com/index.html"
|
||||
|
|
|
@ -79,13 +79,9 @@ ERROR: download-failed response body ;
|
|||
|
||||
M: download-failed error.
|
||||
"HTTP download failed:" print nl
|
||||
[
|
||||
response>>
|
||||
write-response-code
|
||||
write-response-message nl
|
||||
drop
|
||||
]
|
||||
[ body>> write ] bi ;
|
||||
[ response>> write-response-line nl drop ]
|
||||
[ body>> write ]
|
||||
bi ;
|
||||
|
||||
: check-response ( response data -- response data )
|
||||
over code>> success? [ download-failed ] unless ;
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
USING: http tools.test multiline tuple-syntax
|
||||
io.streams.string io.encodings.utf8 io.encodings.string
|
||||
kernel arrays splitting sequences
|
||||
assocs io.sockets db db.sqlite continuations urls hashtables ;
|
||||
assocs io.sockets db db.sqlite continuations urls hashtables
|
||||
accessors ;
|
||||
IN: http.tests
|
||||
|
||||
: lf>crlf "\n" split "\r\n" join ;
|
||||
|
@ -73,10 +74,21 @@ GET nested HTTP/1.0
|
|||
|
||||
;
|
||||
|
||||
[ read-request-test-3 [ read-request ] with-string-reader ]
|
||||
[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ]
|
||||
[ "Bad request: URL" = ]
|
||||
must-fail-with
|
||||
|
||||
STRING: read-request-test-4
|
||||
GET /blah HTTP/1.0
|
||||
Host: "www.amazon.com"
|
||||
;
|
||||
|
||||
[ "www.amazon.com" ]
|
||||
[
|
||||
read-request-test-4 lf>crlf [ read-request ] with-string-reader
|
||||
"host" header
|
||||
] unit-test
|
||||
|
||||
STRING: read-response-test-1
|
||||
HTTP/1.1 404 not found
|
||||
Content-Type: text/html; charset=UTF-8
|
||||
|
@ -117,15 +129,46 @@ read-response-test-1' 1array [
|
|||
|
||||
[ t ] [
|
||||
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
|
||||
dup parse-cookies unparse-cookies =
|
||||
dup parse-set-cookie first unparse-set-cookie =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"a="
|
||||
dup parse-set-cookie first unparse-set-cookie =
|
||||
] unit-test
|
||||
|
||||
STRING: read-response-test-2
|
||||
HTTP/1.1 200 Content follows
|
||||
Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
|
||||
|
||||
|
||||
;
|
||||
|
||||
[ 2 ] [
|
||||
read-response-test-2 lf>crlf
|
||||
[ read-response ] with-string-reader
|
||||
cookies>> length
|
||||
] unit-test
|
||||
|
||||
STRING: read-response-test-3
|
||||
HTTP/1.1 200 Content follows
|
||||
Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
|
||||
|
||||
|
||||
;
|
||||
|
||||
[ 1 ] [
|
||||
read-response-test-3 lf>crlf
|
||||
[ read-response ] with-string-reader
|
||||
cookies>> length
|
||||
] unit-test
|
||||
|
||||
! Live-fire exercise
|
||||
USING: http.server http.server.static furnace.sessions furnace.alloy
|
||||
furnace.actions furnace.auth.login furnace.db http.client
|
||||
io.server io.files io io.encodings.ascii
|
||||
furnace.actions furnace.auth furnace.auth.login furnace.db http.client
|
||||
io.servers.connection io.files io io.encodings.ascii
|
||||
accessors namespaces threads
|
||||
http.server.responses http.server.redirection
|
||||
http.server.responses http.server.redirection furnace.redirection
|
||||
http.server.dispatchers db.tuples ;
|
||||
|
||||
: add-quit-action
|
||||
|
@ -176,7 +219,7 @@ test-db [
|
|||
[
|
||||
<dispatcher>
|
||||
<action> <protected>
|
||||
<login>
|
||||
"Test" <login-realm>
|
||||
<sessions>
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
|
@ -206,7 +249,7 @@ test-db [
|
|||
[
|
||||
<dispatcher>
|
||||
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
|
||||
<login>
|
||||
"Test" <login-realm>
|
||||
<sessions>
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
|
@ -223,7 +266,8 @@ test-db [
|
|||
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
|
||||
|
||||
USING: html.components html.elements xml xml.utilities validators
|
||||
USING: html.components html.elements html.forms
|
||||
xml xml.utilities validators
|
||||
furnace furnace.flash ;
|
||||
|
||||
SYMBOL: a
|
||||
|
@ -275,3 +319,7 @@ SYMBOL: a
|
|||
[ 4 ] [ a get-global ] unit-test
|
||||
|
||||
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
|
||||
|
||||
! Test cloning
|
||||
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
|
||||
[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
|
||||
|
|
|
@ -1,16 +1,18 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel combinators math namespaces
|
||||
|
||||
assocs sequences splitting sorting sets debugger
|
||||
assocs assocs.lib sequences splitting sorting sets debugger
|
||||
strings vectors hashtables quotations arrays byte-arrays
|
||||
math.parser calendar calendar.format present
|
||||
|
||||
io io.encodings.iana io.encodings.binary io.encodings.8-bit
|
||||
io io.encodings io.encodings.iana io.encodings.binary
|
||||
io.encodings.8-bit
|
||||
|
||||
unicode.case unicode.categories qualified
|
||||
|
||||
urls html.templates xml xml.data xml.writer ;
|
||||
urls html.templates xml xml.data xml.writer
|
||||
|
||||
http.parsers ;
|
||||
|
||||
EXCLUDE: fry => , ;
|
||||
|
||||
|
@ -18,40 +20,20 @@ IN: http
|
|||
|
||||
: crlf ( -- ) "\r\n" write ;
|
||||
|
||||
: add-header ( value key assoc -- )
|
||||
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
|
||||
|
||||
: header-line ( line -- )
|
||||
dup first blank? [
|
||||
[ blank? ] left-trim
|
||||
"last-header" get
|
||||
"header" get
|
||||
add-header
|
||||
] [
|
||||
":" split1 dup [
|
||||
[ blank? ] left-trim
|
||||
swap >lower dup "last-header" set
|
||||
"header" get add-header
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: read-lf ( -- bytes )
|
||||
"\n" read-until CHAR: \n assert= ;
|
||||
|
||||
: read-crlf ( -- bytes )
|
||||
"\r" read-until
|
||||
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
|
||||
|
||||
: (read-header) ( -- )
|
||||
read-crlf dup
|
||||
empty? [ drop ] [ header-line (read-header) ] if ;
|
||||
: (read-header) ( -- alist )
|
||||
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
|
||||
|
||||
: process-header ( alist -- assoc )
|
||||
f swap [ [ swap or dup ] dip swap ] assoc-map nip
|
||||
[ ?push ] histogram [ "; " join ] assoc-map
|
||||
>hashtable ;
|
||||
|
||||
: read-header ( -- assoc )
|
||||
H{ } clone [
|
||||
"header" [ (read-header) ] with-variable
|
||||
] keep ;
|
||||
(read-header) process-header ;
|
||||
|
||||
: header-value>string ( value -- string )
|
||||
{
|
||||
|
@ -62,69 +44,100 @@ IN: http
|
|||
|
||||
: check-header-string ( str -- str )
|
||||
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
|
||||
dup "\r\n" intersect empty?
|
||||
dup "\r\n\"" intersect empty?
|
||||
[ "Header injection attack" throw ] unless ;
|
||||
|
||||
: write-header ( assoc -- )
|
||||
>alist sort-keys [
|
||||
swap
|
||||
check-header-string write ": " write
|
||||
header-value>string check-header-string write crlf
|
||||
[ check-header-string write ": " write ]
|
||||
[ header-value>string check-header-string write crlf ] bi*
|
||||
] assoc-each crlf ;
|
||||
|
||||
TUPLE: cookie name value path domain expires max-age http-only ;
|
||||
TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
|
||||
|
||||
: <cookie> ( value name -- cookie )
|
||||
cookie new
|
||||
swap >>name
|
||||
swap >>value ;
|
||||
|
||||
: parse-cookies ( string -- seq )
|
||||
: parse-set-cookie ( string -- seq )
|
||||
[
|
||||
f swap
|
||||
|
||||
";" split [
|
||||
[ blank? ] trim "=" split1 swap >lower {
|
||||
(parse-set-cookie)
|
||||
[
|
||||
swap {
|
||||
{ "version" [ >>version ] }
|
||||
{ "comment" [ >>comment ] }
|
||||
{ "expires" [ cookie-string>timestamp >>expires ] }
|
||||
{ "max-age" [ string>number seconds >>max-age ] }
|
||||
{ "domain" [ >>domain ] }
|
||||
{ "path" [ >>path ] }
|
||||
{ "httponly" [ drop t >>http-only ] }
|
||||
{ "" [ drop ] }
|
||||
{ "secure" [ drop t >>secure ] }
|
||||
[ <cookie> dup , nip ]
|
||||
} case
|
||||
] each
|
||||
|
||||
] assoc-each
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: (unparse-cookie) ( key value -- )
|
||||
: parse-cookie ( string -- seq )
|
||||
[
|
||||
f swap
|
||||
(parse-cookie)
|
||||
[
|
||||
swap {
|
||||
{ "$version" [ >>version ] }
|
||||
{ "$domain" [ >>domain ] }
|
||||
{ "$path" [ >>path ] }
|
||||
[ <cookie> dup , nip ]
|
||||
} case
|
||||
] assoc-each
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: check-cookie-string ( string -- string' )
|
||||
dup "=;'\"\r\n" intersect empty?
|
||||
[ "Bad cookie name or value" throw ] unless ;
|
||||
|
||||
: unparse-cookie-value ( key value -- )
|
||||
{
|
||||
{ f [ drop ] }
|
||||
{ t [ , ] }
|
||||
{ t [ check-cookie-string , ] }
|
||||
[
|
||||
{
|
||||
{ [ dup timestamp? ] [ timestamp>cookie-string ] }
|
||||
{ [ dup duration? ] [ dt>seconds number>string ] }
|
||||
{ [ dup real? ] [ number>string ] }
|
||||
[ ]
|
||||
} cond
|
||||
"=" swap 3append ,
|
||||
check-cookie-string "=" swap check-cookie-string 3append ,
|
||||
]
|
||||
} case ;
|
||||
|
||||
: unparse-cookie ( cookie -- strings )
|
||||
: (unparse-cookie) ( cookie -- strings )
|
||||
[
|
||||
dup name>> >lower over value>> (unparse-cookie)
|
||||
"path" over path>> (unparse-cookie)
|
||||
"domain" over domain>> (unparse-cookie)
|
||||
"expires" over expires>> (unparse-cookie)
|
||||
"max-age" over max-age>> (unparse-cookie)
|
||||
"httponly" over http-only>> (unparse-cookie)
|
||||
dup name>> check-cookie-string >lower
|
||||
over value>> unparse-cookie-value
|
||||
"$path" over path>> unparse-cookie-value
|
||||
"$domain" over domain>> unparse-cookie-value
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: unparse-cookies ( cookies -- string )
|
||||
[ unparse-cookie ] map concat "; " join ;
|
||||
: unparse-cookie ( cookies -- string )
|
||||
[ (unparse-cookie) ] map concat "; " join ;
|
||||
|
||||
: unparse-set-cookie ( cookie -- string )
|
||||
[
|
||||
dup name>> check-cookie-string >lower
|
||||
over value>> unparse-cookie-value
|
||||
"path" over path>> unparse-cookie-value
|
||||
"domain" over domain>> unparse-cookie-value
|
||||
"expires" over expires>> unparse-cookie-value
|
||||
"max-age" over max-age>> unparse-cookie-value
|
||||
"httponly" over http-only>> unparse-cookie-value
|
||||
"secure" over secure>> unparse-cookie-value
|
||||
drop
|
||||
] { } make "; " join ;
|
||||
|
||||
TUPLE: request
|
||||
method
|
||||
|
@ -134,6 +147,13 @@ header
|
|||
post-data
|
||||
cookies ;
|
||||
|
||||
: check-url ( string -- url )
|
||||
>url dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
|
||||
|
||||
: read-request-line ( request -- request )
|
||||
read-crlf parse-request-line first3
|
||||
[ >>method ] [ check-url >>url ] [ >>version ] tri* ;
|
||||
|
||||
: set-header ( request/response value key -- request/response )
|
||||
pick header>> set-at ;
|
||||
|
||||
|
@ -146,29 +166,11 @@ cookies ;
|
|||
H{ } clone >>header
|
||||
V{ } clone >>cookies
|
||||
"close" "connection" set-header
|
||||
"Factor http.client vocabulary" "user-agent" set-header ;
|
||||
|
||||
: read-method ( request -- request )
|
||||
" " read-until [ "Bad request: method" throw ] unless
|
||||
>>method ;
|
||||
"Factor http.client" "user-agent" set-header ;
|
||||
|
||||
: check-absolute ( url -- url )
|
||||
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
|
||||
|
||||
: read-url ( request -- request )
|
||||
" " read-until [
|
||||
dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
|
||||
] [ "Bad request: URL" throw ] if ;
|
||||
|
||||
: parse-version ( string -- version )
|
||||
"HTTP/" ?head [ "Bad request: version" throw ] unless
|
||||
dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
|
||||
|
||||
: read-request-version ( request -- request )
|
||||
read-crlf [ CHAR: \s = ] left-trim
|
||||
parse-version
|
||||
>>version ;
|
||||
|
||||
: read-request-header ( request -- request )
|
||||
read-header >>header ;
|
||||
|
||||
|
@ -203,7 +205,7 @@ TUPLE: post-data raw content content-type ;
|
|||
drop ;
|
||||
|
||||
: extract-cookies ( request -- request )
|
||||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
dup "cookie" header [ parse-cookie >>cookies ] when* ;
|
||||
|
||||
: parse-content-type-attributes ( string -- attributes )
|
||||
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
|
||||
|
@ -213,22 +215,18 @@ TUPLE: post-data raw content content-type ;
|
|||
|
||||
: read-request ( -- request )
|
||||
<request>
|
||||
read-method
|
||||
read-url
|
||||
read-request-version
|
||||
read-request-line
|
||||
read-request-header
|
||||
read-post-data
|
||||
extract-host
|
||||
extract-cookies ;
|
||||
|
||||
: write-method ( request -- request )
|
||||
dup method>> write bl ;
|
||||
|
||||
: write-request-url ( request -- request )
|
||||
dup url>> relative-url present write bl ;
|
||||
|
||||
: write-version ( request -- request )
|
||||
"HTTP/" write dup request-version write crlf ;
|
||||
: write-request-line ( request -- request )
|
||||
dup
|
||||
[ method>> write bl ]
|
||||
[ url>> relative-url present write bl ]
|
||||
[ "HTTP/" write version>> write crlf ]
|
||||
tri ;
|
||||
|
||||
: url-host ( url -- string )
|
||||
[ host>> ] [ port>> ] bi dup "http" protocol-port =
|
||||
|
@ -242,7 +240,7 @@ TUPLE: post-data raw content content-type ;
|
|||
[ content-type>> "content-type" pick set-at ]
|
||||
bi
|
||||
] when*
|
||||
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
|
||||
over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
|
||||
write-header ;
|
||||
|
||||
GENERIC: >post-data ( object -- post-data )
|
||||
|
@ -267,9 +265,7 @@ M: f >post-data ;
|
|||
|
||||
: write-request ( request -- )
|
||||
unparse-post-data
|
||||
write-method
|
||||
write-request-url
|
||||
write-version
|
||||
write-request-line
|
||||
write-request-header
|
||||
write-post-data
|
||||
flush
|
||||
|
@ -295,26 +291,22 @@ body ;
|
|||
H{ } clone >>header
|
||||
"close" "connection" set-header
|
||||
now timestamp>http-string "date" set-header
|
||||
"Factor http.server" "server" set-header
|
||||
latin1 >>content-charset
|
||||
V{ } clone >>cookies ;
|
||||
|
||||
: read-response-version ( response -- response )
|
||||
" \t" read-until
|
||||
[ "Bad response: version" throw ] unless
|
||||
parse-version
|
||||
>>version ;
|
||||
M: response clone
|
||||
call-next-method
|
||||
[ clone ] change-header
|
||||
[ clone ] change-cookies ;
|
||||
|
||||
: read-response-code ( response -- response )
|
||||
" \t" read-until [ "Bad response: code" throw ] unless
|
||||
string>number [ "Bad response: code" throw ] unless*
|
||||
>>code ;
|
||||
|
||||
: read-response-message ( response -- response )
|
||||
read-crlf >>message ;
|
||||
: read-response-line ( response -- response )
|
||||
read-crlf parse-response-line first3
|
||||
[ >>version ] [ >>code ] [ >>message ] tri* ;
|
||||
|
||||
: read-response-header ( response -- response )
|
||||
read-header >>header
|
||||
dup "set-cookie" header parse-cookies >>cookies
|
||||
dup "set-cookie" header parse-set-cookie >>cookies
|
||||
dup "content-type" header [
|
||||
parse-content-type
|
||||
[ >>content-type ]
|
||||
|
@ -323,20 +315,15 @@ body ;
|
|||
|
||||
: read-response ( -- response )
|
||||
<response>
|
||||
read-response-version
|
||||
read-response-code
|
||||
read-response-message
|
||||
read-response-line
|
||||
read-response-header ;
|
||||
|
||||
: write-response-version ( response -- response )
|
||||
"HTTP/" write
|
||||
dup version>> write bl ;
|
||||
|
||||
: write-response-code ( response -- response )
|
||||
dup code>> number>string write bl ;
|
||||
|
||||
: write-response-message ( response -- response )
|
||||
dup message>> write crlf ;
|
||||
: write-response-line ( response -- response )
|
||||
dup
|
||||
[ "HTTP/" write version>> write bl ]
|
||||
[ code>> present write bl ]
|
||||
[ message>> write crlf ]
|
||||
tri ;
|
||||
|
||||
: unparse-content-type ( request -- content-type )
|
||||
[ content-type>> "application/octet-stream" or ]
|
||||
|
@ -344,26 +331,40 @@ body ;
|
|||
bi
|
||||
[ "; charset=" swap 3append ] when* ;
|
||||
|
||||
: ensure-domain ( cookie -- cookie )
|
||||
[
|
||||
request get url>>
|
||||
host>> dup "localhost" =
|
||||
[ drop ] [ or ] if
|
||||
] change-domain ;
|
||||
|
||||
: write-response-header ( response -- response )
|
||||
dup header>> clone
|
||||
over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
|
||||
#! We send one set-cookie header per cookie, because that's
|
||||
#! what Firefox expects.
|
||||
dup header>> >alist >vector
|
||||
over unparse-content-type "content-type" pick set-at
|
||||
over cookies>> [
|
||||
ensure-domain unparse-set-cookie
|
||||
"set-cookie" swap 2array over push
|
||||
] each
|
||||
write-header ;
|
||||
|
||||
: write-response-body ( response -- response )
|
||||
dup body>> call-template ;
|
||||
|
||||
M: response write-response ( respose -- )
|
||||
write-response-version
|
||||
write-response-code
|
||||
write-response-message
|
||||
write-response-line
|
||||
write-response-header
|
||||
flush
|
||||
drop ;
|
||||
|
||||
M: response write-full-response ( request response -- )
|
||||
dup write-response
|
||||
swap method>> "HEAD" = [ write-response-body ] unless ;
|
||||
swap method>> "HEAD" = [
|
||||
[ content-charset>> encode-output ]
|
||||
[ write-response-body ]
|
||||
bi
|
||||
] unless ;
|
||||
|
||||
: get-cookie ( request/response name -- cookie/f )
|
||||
[ cookies>> ] dip '[ , _ name>> = ] find nip ;
|
||||
|
@ -386,9 +387,7 @@ body ;
|
|||
"1.1" >>version ;
|
||||
|
||||
M: raw-response write-response ( respose -- )
|
||||
write-response-version
|
||||
write-response-code
|
||||
write-response-message
|
||||
write-response-line
|
||||
write-response-body
|
||||
drop ;
|
||||
|
||||
|
|
|
@ -0,0 +1,166 @@
|
|||
USING: math math.order math.parser kernel combinators.lib
|
||||
sequences sequences.deep peg peg.parsers assocs arrays
|
||||
hashtables strings unicode.case namespaces ascii ;
|
||||
IN: http.parsers
|
||||
|
||||
: except ( quot -- parser )
|
||||
[ not ] compose satisfy ; inline
|
||||
|
||||
: except-these ( quots -- parser )
|
||||
[ 1|| ] curry except ; inline
|
||||
|
||||
: ctl? ( ch -- ? )
|
||||
{ [ 0 31 between? ] [ 127 = ] } 1|| ;
|
||||
|
||||
: tspecial? ( ch -- ? )
|
||||
"()<>@,;:\\\"/[]?={} \t" member? ;
|
||||
|
||||
: 'token' ( -- parser )
|
||||
{ [ ctl? ] [ tspecial? ] } except-these repeat1 ;
|
||||
|
||||
: case-insensitive ( parser -- parser' )
|
||||
[ flatten >string >lower ] action ;
|
||||
|
||||
: case-sensitive ( parser -- parser' )
|
||||
[ flatten >string ] action ;
|
||||
|
||||
: 'space' ( -- parser )
|
||||
[ " \t" member? ] satisfy repeat0 hide ;
|
||||
|
||||
: one-of ( strings -- parser )
|
||||
[ token ] map choice ;
|
||||
|
||||
: 'http-method' ( -- parser )
|
||||
{ "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
|
||||
|
||||
: 'url' ( -- parser )
|
||||
[ " \t\r\n" member? ] except repeat1 case-sensitive ;
|
||||
|
||||
: 'http-version' ( -- parser )
|
||||
[
|
||||
"HTTP" token hide ,
|
||||
'space' ,
|
||||
"/" token hide ,
|
||||
'space' ,
|
||||
"1" token ,
|
||||
"." token ,
|
||||
{ "0" "1" } one-of ,
|
||||
] seq* [ concat >string ] action ;
|
||||
|
||||
PEG: parse-request-line ( string -- triple )
|
||||
#! Triple is { method url version }
|
||||
[
|
||||
'space' ,
|
||||
'http-method' ,
|
||||
'space' ,
|
||||
'url' ,
|
||||
'space' ,
|
||||
'http-version' ,
|
||||
'space' ,
|
||||
] seq* just ;
|
||||
|
||||
: 'text' ( -- parser )
|
||||
[ ctl? ] except ;
|
||||
|
||||
: 'response-code' ( -- parser )
|
||||
[ digit? ] satisfy 3 exactly-n [ string>number ] action ;
|
||||
|
||||
: 'response-message' ( -- parser )
|
||||
'text' repeat0 case-sensitive ;
|
||||
|
||||
PEG: parse-response-line ( string -- triple )
|
||||
#! Triple is { version code message }
|
||||
[
|
||||
'space' ,
|
||||
'http-version' ,
|
||||
'space' ,
|
||||
'response-code' ,
|
||||
'space' ,
|
||||
'response-message' ,
|
||||
] seq* just ;
|
||||
|
||||
: 'crlf' ( -- parser )
|
||||
"\r\n" token ;
|
||||
|
||||
: 'lws' ( -- parser )
|
||||
[ " \t" member? ] satisfy repeat1 ;
|
||||
|
||||
: 'qdtext' ( -- parser )
|
||||
{ [ CHAR: " = ] [ ctl? ] } except-these ;
|
||||
|
||||
: 'quoted-char' ( -- parser )
|
||||
"\\" token hide any-char 2seq ;
|
||||
|
||||
: 'quoted-string' ( -- parser )
|
||||
'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ;
|
||||
|
||||
: 'ctext' ( -- parser )
|
||||
{ [ ctl? ] [ "()" member? ] } except-these ;
|
||||
|
||||
: 'comment' ( -- parser )
|
||||
'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ;
|
||||
|
||||
: 'field-name' ( -- parser )
|
||||
'token' case-insensitive ;
|
||||
|
||||
: 'field-content' ( -- parser )
|
||||
'quoted-string' case-sensitive
|
||||
'text' repeat0 case-sensitive
|
||||
2choice ;
|
||||
|
||||
PEG: parse-header-line ( string -- pair )
|
||||
#! Pair is either { name value } or { f value }. If f, its a
|
||||
#! continuation of the previous header line.
|
||||
[
|
||||
'field-name' ,
|
||||
'space' ,
|
||||
":" token hide ,
|
||||
'space' ,
|
||||
'field-content' ,
|
||||
] seq*
|
||||
[
|
||||
'lws' [ drop f ] action ,
|
||||
'field-content' ,
|
||||
] seq*
|
||||
2choice ;
|
||||
|
||||
: 'word' ( -- parser )
|
||||
'token' 'quoted-string' 2choice ;
|
||||
|
||||
: 'value' ( -- parser )
|
||||
'quoted-string'
|
||||
[ ";" member? ] except repeat0
|
||||
2choice case-sensitive ;
|
||||
|
||||
: 'attr' ( -- parser )
|
||||
'token' case-insensitive ;
|
||||
|
||||
: 'av-pair' ( -- parser )
|
||||
[
|
||||
'space' ,
|
||||
'attr' ,
|
||||
'space' ,
|
||||
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action
|
||||
epsilon [ drop f ] action
|
||||
2choice ,
|
||||
'space' ,
|
||||
] seq* ;
|
||||
|
||||
: 'av-pairs' ( -- parser )
|
||||
'av-pair' ";" token list-of optional ;
|
||||
|
||||
PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
|
||||
|
||||
: 'cookie-value' ( -- parser )
|
||||
[
|
||||
'space' ,
|
||||
'attr' ,
|
||||
'space' ,
|
||||
"=" token hide ,
|
||||
'space' ,
|
||||
'value' ,
|
||||
'space' ,
|
||||
] seq* ;
|
||||
|
||||
PEG: (parse-cookie) ( string -- alist )
|
||||
'cookie-value' [ ";," member? ] satisfy list-of optional just ;
|
|
@ -2,9 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences arrays namespaces splitting
|
||||
vocabs.loader destructors assocs debugger continuations
|
||||
combinators tools.vocabs math
|
||||
combinators tools.vocabs tools.time math
|
||||
io
|
||||
io.server
|
||||
io.sockets
|
||||
io.sockets.secure
|
||||
io.encodings
|
||||
|
@ -12,8 +11,9 @@ io.encodings.utf8
|
|||
io.encodings.ascii
|
||||
io.encodings.binary
|
||||
io.streams.limited
|
||||
io.servers.connection
|
||||
io.timeouts
|
||||
fry logging calendar urls
|
||||
fry logging logging.insomniac calendar urls
|
||||
http
|
||||
http.server.responses
|
||||
html.elements
|
||||
|
@ -26,7 +26,9 @@ SYMBOL: responder-nesting
|
|||
|
||||
SYMBOL: main-responder
|
||||
|
||||
SYMBOL: development-mode
|
||||
SYMBOL: development?
|
||||
|
||||
SYMBOL: benchmark?
|
||||
|
||||
! path is a sequence of path component strings
|
||||
GENERIC: call-responder* ( path responder -- response )
|
||||
|
@ -55,32 +57,31 @@ main-responder global [ <404> <trivial-responder> or ] change-at
|
|||
|
||||
: <500> ( error -- response )
|
||||
500 "Internal server error" <trivial-response>
|
||||
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
|
||||
swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
|
||||
|
||||
: do-response ( response -- )
|
||||
[ write-response ]
|
||||
[ request get swap write-full-response ]
|
||||
[
|
||||
request get method>> "HEAD" = [ drop ] [
|
||||
'[
|
||||
,
|
||||
[ content-charset>> encode-output ]
|
||||
[ write-response-body ]
|
||||
bi
|
||||
]
|
||||
[
|
||||
utf8 [
|
||||
development-mode get
|
||||
[ http-error. ] [ drop "Response error" rethrow ] if
|
||||
] with-encoded-output
|
||||
] recover
|
||||
] if
|
||||
] bi ;
|
||||
[ \ do-response log-error ]
|
||||
[
|
||||
utf8 [
|
||||
development? get
|
||||
[ http-error. ] [ drop "Response error" write ] if
|
||||
] with-encoded-output
|
||||
] bi
|
||||
] recover ;
|
||||
|
||||
LOG: httpd-hit NOTICE
|
||||
|
||||
LOG: httpd-header NOTICE
|
||||
|
||||
: log-header ( headers name -- )
|
||||
tuck header 2array httpd-header ;
|
||||
|
||||
: log-request ( request -- )
|
||||
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi
|
||||
3array httpd-hit ;
|
||||
[ [ method>> ] [ url>> ] bi 2array httpd-hit ]
|
||||
[ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
|
||||
bi ;
|
||||
|
||||
: split-path ( string -- path )
|
||||
"/" split harvest ;
|
||||
|
@ -115,29 +116,39 @@ LOG: httpd-hit NOTICE
|
|||
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
|
||||
|
||||
: ?refresh-all ( -- )
|
||||
development-mode get-global
|
||||
[ global [ refresh-all ] bind ] when ;
|
||||
development? get-global [ global [ refresh-all ] bind ] when ;
|
||||
|
||||
: setup-limits ( -- )
|
||||
1 minutes timeouts
|
||||
64 1024 * limit-input ;
|
||||
LOG: httpd-benchmark DEBUG
|
||||
|
||||
: handle-client ( -- )
|
||||
: ?benchmark ( quot -- )
|
||||
benchmark? get [
|
||||
[ benchmark ] [ first ] bi request get url>> rot 3array
|
||||
httpd-benchmark
|
||||
] [ call ] if ; inline
|
||||
|
||||
TUPLE: http-server < threaded-server ;
|
||||
|
||||
M: http-server handle-client*
|
||||
drop
|
||||
[
|
||||
setup-limits
|
||||
ascii decode-input
|
||||
ascii encode-output
|
||||
64 1024 * limit-input
|
||||
?refresh-all
|
||||
read-request
|
||||
do-request
|
||||
do-response
|
||||
[ do-request ] ?benchmark
|
||||
[ do-response ] ?benchmark
|
||||
] with-destructors ;
|
||||
|
||||
: <http-server> ( -- server )
|
||||
http-server new-threaded-server
|
||||
"http.server" >>name
|
||||
"http" protocol-port >>insecure
|
||||
"https" protocol-port >>secure ;
|
||||
|
||||
: httpd ( port -- )
|
||||
dup integer? [ internet-server ] when
|
||||
"http.server" binary [ handle-client ] with-server ;
|
||||
<http-server>
|
||||
swap >>insecure
|
||||
f >>secure
|
||||
start-server ;
|
||||
|
||||
: httpd-main ( -- )
|
||||
8888 httpd ;
|
||||
|
||||
MAIN: httpd-main
|
||||
: http-insomniac ( -- )
|
||||
"http.server" { "httpd-hit" } schedule-insomniac ;
|
||||
|
|
|
@ -82,7 +82,7 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
"index.html" append-path dup exists? [ drop f ] unless ;
|
||||
|
||||
: serve-directory ( filename -- response )
|
||||
request get path>> "/" tail? [
|
||||
request get url>> path>> "/" tail? [
|
||||
dup
|
||||
find-index [ serve-file ] [ list-directory ] ?if
|
||||
] [
|
||||
|
|
|
@ -5,12 +5,11 @@ IN: io.encodings.ascii
|
|||
|
||||
<PRIVATE
|
||||
: encode-if< ( char stream encoding max -- )
|
||||
nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
|
||||
nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
|
||||
|
||||
: decode-if< ( stream encoding max -- character )
|
||||
nip swap stream-read1
|
||||
[ tuck > [ drop replacement-char ] unless ]
|
||||
[ drop f ] if* ;
|
||||
nip swap stream-read1 dup
|
||||
[ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: ascii
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
|
|||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors
|
||||
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||
io.streams.duplex io.ports ;
|
||||
io.streams.duplex io.ports debugger prettyprint inspector ;
|
||||
IN: io.launcher
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
@ -131,11 +131,16 @@ HOOK: run-process* io-backend ( process -- handle )
|
|||
run-detached
|
||||
dup detached>> [ dup wait-for-process drop ] unless ;
|
||||
|
||||
ERROR: process-failed code ;
|
||||
ERROR: process-failed process code ;
|
||||
|
||||
M: process-failed error.
|
||||
dup "Process exited with error code " write code>> . nl
|
||||
"Launch descriptor:" print nl
|
||||
process>> describe ;
|
||||
|
||||
: try-process ( desc -- )
|
||||
run-process wait-for-process dup zero?
|
||||
[ drop ] [ process-failed ] if ;
|
||||
run-process dup wait-for-process dup zero?
|
||||
[ 2drop ] [ process-failed ] if ;
|
||||
|
||||
HOOK: kill-process* io-backend ( handle -- )
|
||||
|
||||
|
|
|
@ -64,7 +64,3 @@ HELP: (wait-to-read)
|
|||
HELP: wait-to-read
|
||||
{ $values { "port" input-port } { "eof?" "a boolean" } }
|
||||
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ;
|
||||
|
||||
HELP: can-write?
|
||||
{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
|
||||
{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
|
||||
|
|
|
@ -98,11 +98,9 @@ TUPLE: output-port < buffered-port ;
|
|||
: <output-port> ( handle -- output-port )
|
||||
output-port <buffered-port> ;
|
||||
|
||||
: can-write? ( len buffer -- ? )
|
||||
[ buffer-fill + ] keep buffer-capacity <= ;
|
||||
|
||||
: wait-to-write ( len port -- )
|
||||
tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
|
||||
tuck buffer>> buffer-capacity <=
|
||||
[ drop ] [ stream-flush ] if ;
|
||||
|
||||
M: output-port stream-write1
|
||||
dup check-disposed
|
||||
|
|
|
@ -1,10 +0,0 @@
|
|||
USING: help help.syntax help.markup io ;
|
||||
IN: io.server
|
||||
|
||||
HELP: with-server
|
||||
{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } }
|
||||
{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ;
|
||||
|
||||
HELP: with-datagrams
|
||||
{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
|
||||
{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ;
|
|
@ -1,7 +0,0 @@
|
|||
IN: io.server.tests
|
||||
USING: tools.test io.server io.server.private kernel ;
|
||||
|
||||
{ 2 0 } [ [ ] server-loop ] must-infer-as
|
||||
{ 3 0 } [ [ ] with-connection ] must-infer-as
|
||||
{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
|
||||
{ 2 0 } [ [ ] with-datagrams ] must-infer-as
|
|
@ -1,76 +0,0 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.sockets io.sockets.secure io.files
|
||||
io.streams.duplex logging continuations destructors kernel math
|
||||
math.parser namespaces parser sequences strings prettyprint
|
||||
debugger quotations calendar threads concurrency.combinators
|
||||
assocs fry accessors ;
|
||||
IN: io.server
|
||||
|
||||
SYMBOL: servers
|
||||
|
||||
SYMBOL: remote-address
|
||||
|
||||
<PRIVATE
|
||||
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: with-connection ( client remote local quot -- )
|
||||
'[
|
||||
, [ remote-address set ] [ accepted-connection ] bi
|
||||
, local-address set
|
||||
@
|
||||
] with-stream ; inline
|
||||
|
||||
\ with-connection DEBUG add-error-logging
|
||||
|
||||
: accept-loop ( server quot -- )
|
||||
[
|
||||
[ [ accept ] [ addr>> ] bi ] dip
|
||||
'[ , , , , with-connection ] "Client" spawn drop
|
||||
] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( addrspec encoding quot -- )
|
||||
>r <server> dup servers get push r>
|
||||
'[ , accept-loop ] with-disposal ; inline
|
||||
|
||||
\ server-loop NOTICE add-error-logging
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: local-server ( port -- seq )
|
||||
"localhost" swap t resolve-host ;
|
||||
|
||||
: internet-server ( port -- seq )
|
||||
f swap t resolve-host ;
|
||||
|
||||
: secure-server ( port -- seq )
|
||||
internet-server [ <secure> ] map ;
|
||||
|
||||
: with-server ( seq service encoding quot -- )
|
||||
V{ } clone servers [
|
||||
'[ , [ , , server-loop ] with-logging ] parallel-each
|
||||
] with-variable ; inline
|
||||
|
||||
: stop-server ( -- )
|
||||
servers get dispose-each ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
LOG: received-datagram NOTICE
|
||||
|
||||
: datagram-loop ( quot datagram -- )
|
||||
[
|
||||
[ receive dup received-datagram [ swap call ] dip ] keep
|
||||
pick [ send ] [ 3drop ] if
|
||||
] 2keep datagram-loop ; inline
|
||||
|
||||
: spawn-datagrams ( quot addrspec -- )
|
||||
<datagram> [ datagram-loop ] with-disposal ; inline
|
||||
|
||||
\ spawn-datagrams NOTICE add-input-logging
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-datagrams ( seq service quot -- )
|
||||
'[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
|
|
@ -1 +0,0 @@
|
|||
TCP/IP and UDP/IP servers
|
|
@ -0,0 +1,2 @@
|
|||
USING: help help.syntax help.markup io ;
|
||||
IN: io.servers.connection
|
|
@ -0,0 +1,47 @@
|
|||
IN: io.servers.connection
|
||||
USING: tools.test io.servers.connection io.sockets namespaces
|
||||
io.servers.connection.private kernel accessors sequences
|
||||
concurrency.promises io.encodings.ascii io threads calendar ;
|
||||
|
||||
[ t ] [ <threaded-server> listen-on empty? ] unit-test
|
||||
|
||||
[ f ] [
|
||||
<threaded-server>
|
||||
25 internet-server >>insecure
|
||||
listen-on
|
||||
empty?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
|
||||
[ log-connection ] 2keep
|
||||
[ remote-address get = ] [ local-address get = ] bi*
|
||||
and
|
||||
] unit-test
|
||||
|
||||
[ ] [ <threaded-server> init-server drop ] unit-test
|
||||
|
||||
[ 10 ] [
|
||||
<threaded-server>
|
||||
10 >>max-connections
|
||||
init-server semaphore>> count>>
|
||||
] unit-test
|
||||
|
||||
[ ] [ <promise> "p" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
<threaded-server>
|
||||
5 >>max-connections
|
||||
1237 >>insecure
|
||||
[ "Hello world." write stop-server ] >>handler
|
||||
start-server
|
||||
t "p" get fulfill
|
||||
] in-thread
|
||||
] unit-test
|
||||
|
||||
[ ] [ 100 sleep ] unit-test
|
||||
|
||||
[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
|
||||
|
||||
[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test
|
|
@ -0,0 +1,131 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations destructors kernel math math.parser
|
||||
namespaces parser sequences strings prettyprint debugger
|
||||
quotations combinators combinators.lib logging calendar assocs
|
||||
fry accessors arrays io io.sockets io.encodings.ascii
|
||||
io.sockets.secure io.files io.streams.duplex io.timeouts
|
||||
io.encodings threads concurrency.combinators
|
||||
concurrency.semaphores ;
|
||||
IN: io.servers.connection
|
||||
|
||||
TUPLE: threaded-server
|
||||
name
|
||||
secure insecure
|
||||
secure-config
|
||||
sockets
|
||||
max-connections
|
||||
semaphore
|
||||
timeout
|
||||
encoding
|
||||
handler ;
|
||||
|
||||
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
|
||||
|
||||
: internet-server ( port -- addrspec ) f swap <inet> ;
|
||||
|
||||
: new-threaded-server ( class -- threaded-server )
|
||||
new
|
||||
"server" >>name
|
||||
ascii >>encoding
|
||||
1 minutes >>timeout
|
||||
V{ } clone >>sockets
|
||||
<secure-config> >>secure-config
|
||||
[ "No handler quotation" throw ] >>handler ; inline
|
||||
|
||||
: <threaded-server> ( -- threaded-server )
|
||||
threaded-server new-threaded-server ;
|
||||
|
||||
SYMBOL: remote-address
|
||||
|
||||
GENERIC: handle-client* ( server -- )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >insecure ( addrspec -- addrspec' )
|
||||
dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
|
||||
|
||||
: >secure ( addrspec -- addrspec' )
|
||||
>insecure
|
||||
dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
|
||||
|
||||
: listen-on ( threaded-server -- addrspecs )
|
||||
[ secure>> >secure ] [ insecure>> >insecure ] bi
|
||||
[ resolve-host ] bi@ append ;
|
||||
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: log-connection ( remote local -- )
|
||||
[ [ remote-address set ] [ local-address set ] bi* ]
|
||||
[ 2array accepted-connection ]
|
||||
2bi ;
|
||||
|
||||
M: threaded-server handle-client* handler>> call ;
|
||||
|
||||
: handle-client ( client remote local -- )
|
||||
'[
|
||||
, , log-connection
|
||||
threaded-server get
|
||||
[ timeout>> timeouts ] [ handle-client* ] bi
|
||||
] with-stream ;
|
||||
|
||||
: thread-name ( server-name addrspec -- string )
|
||||
unparse " connection from " swap 3append ;
|
||||
|
||||
: accept-connection ( server -- )
|
||||
[ accept ] [ addr>> ] bi
|
||||
[ '[ , , , handle-client ] ]
|
||||
[ drop threaded-server get name>> swap thread-name ] 2bi
|
||||
spawn drop ;
|
||||
|
||||
: accept-loop ( server -- )
|
||||
[
|
||||
threaded-server get semaphore>>
|
||||
[ [ accept-connection ] with-semaphore ]
|
||||
[ accept-connection ]
|
||||
if*
|
||||
] [ accept-loop ] bi ; inline
|
||||
|
||||
: start-accept-loop ( server -- )
|
||||
threaded-server get encoding>> <server>
|
||||
[ threaded-server get sockets>> push ]
|
||||
[ [ accept-loop ] with-disposal ]
|
||||
bi ;
|
||||
|
||||
\ start-accept-loop ERROR add-error-logging
|
||||
|
||||
: init-server ( threaded-server -- threaded-server )
|
||||
dup semaphore>> [
|
||||
dup max-connections>> [
|
||||
<semaphore> >>semaphore
|
||||
] when*
|
||||
] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: start-server ( threaded-server -- )
|
||||
init-server
|
||||
dup secure-config>> [
|
||||
dup threaded-server [
|
||||
dup name>> [
|
||||
listen-on [
|
||||
start-accept-loop
|
||||
] parallel-each
|
||||
] with-logging
|
||||
] with-variable
|
||||
] with-secure-context ;
|
||||
|
||||
: stop-server ( -- )
|
||||
threaded-server get [ f ] change-sockets drop dispose-each ;
|
||||
|
||||
GENERIC: port ( addrspec -- n )
|
||||
|
||||
M: integer port ;
|
||||
|
||||
M: object port port>> ;
|
||||
|
||||
: secure-port ( -- n )
|
||||
threaded-server get dup [ secure>> port ] when ;
|
||||
|
||||
: insecure-port ( -- n )
|
||||
threaded-server get dup [ insecure>> port ] when ;
|
|
@ -0,0 +1 @@
|
|||
Multi-threaded TCP/IP servers
|
|
@ -0,0 +1,21 @@
|
|||
IN: io.servers.datagram
|
||||
|
||||
<PRIVATE
|
||||
|
||||
LOG: received-datagram NOTICE
|
||||
|
||||
: datagram-loop ( quot datagram -- )
|
||||
[
|
||||
[ receive dup received-datagram [ swap call ] dip ] keep
|
||||
pick [ send ] [ 3drop ] if
|
||||
] 2keep datagram-loop ; inline
|
||||
|
||||
: spawn-datagrams ( quot addrspec -- )
|
||||
<datagram> [ datagram-loop ] with-disposal ; inline
|
||||
|
||||
\ spawn-datagrams NOTICE add-input-logging
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-datagrams ( seq service quot -- )
|
||||
'[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
|
|
@ -0,0 +1 @@
|
|||
Multi-threaded UDP/IP servers
|
|
@ -0,0 +1 @@
|
|||
network
|
|
@ -1 +1,4 @@
|
|||
! No unit tests here, until Windows SSL is implemented
|
||||
IN: io.sockets.secure.tests
|
||||
USING: accessors kernel io.sockets io.sockets.secure tools.test ;
|
||||
|
||||
[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel symbols namespaces continuations
|
||||
destructors io.sockets sequences inspector calendar ;
|
||||
destructors io.sockets sequences inspector calendar delegate ;
|
||||
IN: io.sockets.secure
|
||||
|
||||
SYMBOL: secure-socket-timeout
|
||||
|
@ -42,8 +42,10 @@ TUPLE: secure addrspec ;
|
|||
|
||||
C: <secure> secure
|
||||
|
||||
: resolve-secure-host ( host port passive? -- seq )
|
||||
resolve-host [ <secure> ] map ;
|
||||
CONSULT: inet secure addrspec>> ;
|
||||
|
||||
M: secure resolve-host ( secure -- seq )
|
||||
addrspec>> resolve-host [ <secure> ] map ;
|
||||
|
||||
HOOK: check-certificate secure-socket-backend ( host handle -- )
|
||||
|
||||
|
@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ;
|
|||
|
||||
M: secure-inet (client)
|
||||
[
|
||||
addrspec>>
|
||||
[ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
|
||||
host>> pick handle>> check-certificate
|
||||
[ resolve-host (client) [ |dispose ] dip ] keep
|
||||
addrspec>> host>> pick handle>> check-certificate
|
||||
] with-destructors ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
@ -27,7 +27,7 @@ $nl
|
|||
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
|
||||
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
|
||||
}
|
||||
"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
|
||||
"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
|
||||
{ $see-also "io.sockets.secure" } ;
|
||||
|
||||
ARTICLE: "network-packet" "Packet-oriented networking"
|
||||
|
@ -79,7 +79,7 @@ HELP: inet
|
|||
HELP: inet4
|
||||
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
|
||||
{ $notes
|
||||
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
|
||||
"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
|
||||
}
|
||||
{ $examples
|
||||
{ $code "\"127.0.0.1\" 8080 <inet4>" }
|
||||
|
@ -88,7 +88,7 @@ HELP: inet4
|
|||
HELP: inet6
|
||||
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
|
||||
{ $notes
|
||||
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
|
||||
"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." }
|
||||
{ $examples
|
||||
{ $code "\"::1\" 8080 <inet6>" }
|
||||
} ;
|
||||
|
@ -118,10 +118,10 @@ HELP: <server>
|
|||
}
|
||||
{ $notes
|
||||
"To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
|
||||
{ $code "f 1234 t resolve-host" }
|
||||
{ $code "f 1234 <inet> resolve-host" }
|
||||
"To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
|
||||
{ $code "\"localhost\" 1234 t resolve-host" }
|
||||
"Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
|
||||
{ $code "\"localhost\" 1234 <inet> resolve-host" }
|
||||
"Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this."
|
||||
$nl
|
||||
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
|
||||
{ $unchecked-example
|
||||
|
@ -148,9 +148,9 @@ HELP: <datagram>
|
|||
}
|
||||
{ $notes
|
||||
"To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
|
||||
{ $code "f 1234 t resolve-host" }
|
||||
{ $code "f 1234 <inet> resolve-host" }
|
||||
"To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
|
||||
{ $code "\"localhost\" 1234 t resolve-host" }
|
||||
{ $code "\"localhost\" 1234 <inet> resolve-host" }
|
||||
"Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
|
||||
"Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
|
||||
}
|
||||
|
@ -165,3 +165,7 @@ HELP: send
|
|||
{ $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } }
|
||||
{ $description "Sends a packet to the given address." }
|
||||
{ $errors "Throws an error if the packet could not be sent." } ;
|
||||
|
||||
HELP: resolve-host
|
||||
{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
|
||||
{ $description "Resolves host names to IP addresses." } ;
|
||||
|
|
|
@ -45,7 +45,7 @@ concurrency.promises threads io.streams.string ;
|
|||
[ "1:2:0:0:0:0:3:4" ]
|
||||
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
|
||||
[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
|
||||
|
||||
! Smoke-test UDP
|
||||
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
|
||||
|
|
|
@ -259,20 +259,26 @@ HOOK: (send) io-backend ( packet addrspec datagram -- )
|
|||
[ addrinfo>addrspec ] map
|
||||
sift ;
|
||||
|
||||
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
|
||||
: prepare-resolve-host ( addrspec -- host' serv' flags )
|
||||
#! If the port is a number, we resolve for 'http' then
|
||||
#! change it later. This is a workaround for a FreeBSD
|
||||
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
|
||||
#! we can convert a number to a string and pass that as the
|
||||
#! service name, but on FreeBSD this gives us an unknown
|
||||
#! service error.
|
||||
>r
|
||||
dup integer? [ port-override set "http" ] when
|
||||
r> AI_PASSIVE 0 ? ;
|
||||
[ host>> ]
|
||||
[ port>> dup integer? [ port-override set "http" ] when ] bi
|
||||
over 0 AI_PASSIVE ? ;
|
||||
|
||||
HOOK: addrinfo-error io-backend ( n -- )
|
||||
|
||||
: resolve-host ( host serv passive? -- seq )
|
||||
GENERIC: resolve-host ( addrspec -- seq )
|
||||
|
||||
TUPLE: inet host port ;
|
||||
|
||||
C: <inet> inet
|
||||
|
||||
M: inet resolve-host
|
||||
[
|
||||
prepare-resolve-host
|
||||
"addrinfo" <c-object>
|
||||
|
@ -284,17 +290,16 @@ HOOK: addrinfo-error io-backend ( n -- )
|
|||
freeaddrinfo
|
||||
] with-scope ;
|
||||
|
||||
M: f resolve-host drop { } ;
|
||||
|
||||
M: object resolve-host 1array ;
|
||||
|
||||
: host-name ( -- string )
|
||||
256 <byte-array> dup dup length gethostname
|
||||
zero? [ "gethostname failed" throw ] unless
|
||||
ascii alien>string ;
|
||||
|
||||
TUPLE: inet host port ;
|
||||
|
||||
C: <inet> inet
|
||||
|
||||
M: inet (client)
|
||||
[ host>> ] [ port>> ] bi f resolve-host (client) ;
|
||||
M: inet (client) resolve-host (client) ;
|
||||
|
||||
ERROR: invalid-inet-server addrspec ;
|
||||
|
||||
|
|
|
@ -30,3 +30,11 @@ namespaces tools.test strings kernel ;
|
|||
[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
|
||||
|
||||
[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
|
||||
|
||||
[ "he" CHAR: l ] [
|
||||
B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
|
||||
ascii <byte-reader> [
|
||||
5 limit-input
|
||||
"l" read-until
|
||||
] with-input-stream
|
||||
] unit-test
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math io destructors accessors sequences
|
||||
namespaces ;
|
||||
USING: kernel math io io.encodings destructors accessors
|
||||
sequences namespaces ;
|
||||
IN: io.streams.limited
|
||||
|
||||
TUPLE: limited-stream stream count limit ;
|
||||
|
@ -12,8 +12,13 @@ TUPLE: limited-stream stream count limit ;
|
|||
swap >>stream
|
||||
0 >>count ;
|
||||
|
||||
: limit-input ( limit -- )
|
||||
input-stream [ swap <limited-stream> ] change ;
|
||||
GENERIC# limit 1 ( stream limit -- stream' )
|
||||
|
||||
M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
|
||||
|
||||
M: object limit <limited-stream> ;
|
||||
|
||||
: limit-input ( limit -- ) input-stream [ swap limit ] change ;
|
||||
|
||||
ERROR: limit-exceeded ;
|
||||
|
||||
|
|
|
@ -31,7 +31,7 @@ USE: unix
|
|||
] when* ;
|
||||
|
||||
: redirect-fd ( oldfd fd -- )
|
||||
2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
|
||||
2dup = [ 2drop ] [ dup2 io-error ] if ;
|
||||
|
||||
: reset-fd ( fd -- )
|
||||
#! We drop the error code because on *BSD, fcntl of
|
||||
|
|
|
@ -9,12 +9,12 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
: with-test-context
|
||||
: with-test-context ( quot -- )
|
||||
<secure-config>
|
||||
"resource:extra/openssl/test/server.pem" >>key-file
|
||||
"resource:extra/openssl/test/dh1024.pem" >>dh-file
|
||||
"password" >>password
|
||||
swap with-secure-context ;
|
||||
swap with-secure-context ; inline
|
||||
|
||||
:: server-test ( quot -- )
|
||||
[
|
||||
|
@ -28,7 +28,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
] with-test-context
|
||||
] "SSL server test" spawn drop ;
|
||||
|
||||
: client-test
|
||||
: client-test ( -- string )
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
|
||||
] with-secure-context ;
|
||||
|
|
|
@ -118,13 +118,27 @@ M: secure (get-local-address) addrspec>> (get-local-address) ;
|
|||
dup dup handle>> SSL_connect check-connect-response dup
|
||||
[ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
|
||||
|
||||
: resume-session ( ssl-handle ssl-session -- )
|
||||
[ [ handle>> ] dip SSL_set_session ssl-error ]
|
||||
[ drop do-ssl-connect ]
|
||||
2bi ;
|
||||
|
||||
: begin-session ( ssl-handle addrspec -- )
|
||||
[ drop do-ssl-connect ]
|
||||
[ [ handle>> SSL_get1_session ] dip save-session ]
|
||||
2bi ;
|
||||
|
||||
: secure-connection ( ssl-handle addrspec -- )
|
||||
dup get-session [ resume-session ] [ begin-session ] ?if ;
|
||||
|
||||
M: secure establish-connection ( client-out remote -- )
|
||||
[ addrspec>> establish-connection ]
|
||||
addrspec>>
|
||||
[ establish-connection ]
|
||||
[
|
||||
drop handle>>
|
||||
[ [ do-ssl-connect ] with-timeout ]
|
||||
[ t >>connected drop ]
|
||||
bi
|
||||
[ handle>> ] dip
|
||||
[ [ secure-connection ] curry with-timeout ]
|
||||
[ drop t >>connected drop ]
|
||||
2bi
|
||||
] 2bi ;
|
||||
|
||||
M: secure (server) addrspec>> (server) ;
|
||||
|
|
|
@ -42,11 +42,9 @@ SYMBOL: log-service
|
|||
|
||||
<PRIVATE
|
||||
|
||||
PREDICATE: one-string-array < array
|
||||
[ length 1 = ] [ [ string? ] all? ] bi and ;
|
||||
|
||||
: stack>message ( obj -- inputs>message )
|
||||
dup one-string-array? [ first ] [
|
||||
dup array? [ dup length 1 = [ first ] when ] when
|
||||
dup string? [
|
||||
[
|
||||
string-limit off
|
||||
1 line-limit set
|
||||
|
@ -54,7 +52,7 @@ PREDICATE: one-string-array < array
|
|||
0 margin set
|
||||
unparse
|
||||
] with-scope
|
||||
] if ;
|
||||
] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue