steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Bruno Deferrari 2008-06-18 23:58:49 -03:00
parent 646a4dd925 ebb3423e4a
commit 757c9329f1
197 changed files with 3007 additions and 1926 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
core/assocs/assocs.factor
View File

@ -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
@ -150,6 +149,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
: push-at ( value key assoc -- )
[ ?push ] change-at ;
: zip ( keys values -- alist )
2array flip ; inline

2
core/bit-arrays/bit-arrays-tests.factor
View File

@ -38,7 +38,7 @@ IN: bit-arrays.tests
[ t ] [
100 [
drop 100 [ drop 2 random zero? ] map
drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all?
] unit-test

6
core/classes/algebra/algebra-tests.factor
View File

@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
10 [
[ ] [
20 [ drop random-op ] map >quotation
20 [ random-op ] [ ] replicate-as
[ infer effect-in [ random-class ] times ] keep
call
drop
@ -238,8 +238,8 @@ UNION: z1 b1 c1 ;
20 [
[ t ] [
20 [ drop random-boolean-op ] [ ] map-as dup .
[ infer effect-in [ drop random-boolean ] map dup . ] keep
20 [ random-boolean-op ] [ ] replicate-as dup .
[ infer effect-in [ random-boolean ] replicate dup . ] keep
[ >r [ ] each r> call ] 2keep

2
core/grouping/grouping-tests.factor
View File

@ -10,3 +10,5 @@ IN: grouping.tests
2 over set-length
>array
] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test

2
core/grouping/grouping.factor
View File

@ -56,7 +56,7 @@ M: clumps set-length
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < groups ;
TUPLE: sliced-clumps < clumps ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline

6
core/inference/backend/backend.factor
View File

@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ;
1 #drop node,
pop-d dup value-literal >r value-recursion r> ;
: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
: add-inputs ( seq stack -- n stack )
tuck [ length ] bi@ - dup 0 >
@ -162,7 +162,7 @@ TUPLE: too-many-r> ;
dup ensure-values
#>r
over 0 pick node-inputs
over [ drop pop-d ] map reverse [ push-r ] each
over [ pop-d ] replicate reverse [ push-r ] each
0 pick pick node-outputs
node,
drop ;
@ -171,7 +171,7 @@ TUPLE: too-many-r> ;
dup check-r>
#r>
0 pick pick node-inputs
over [ drop pop-r ] map reverse [ push-d ] each
over [ pop-r ] replicate reverse [ push-d ] each
over 0 pick node-outputs
node,
drop ;

2
core/inference/inference-docs.factor
View File

@ -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. }

102
core/io/encodings/encodings.factor
View File

@ -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 ;

5
core/optimizer/def-use/def-use.factor
View File

@ -13,7 +13,7 @@ SYMBOL: def-use
used-by empty? ;
: uses-values ( node seq -- )
[ def-use get [ ?push ] change-at ] with each ;
[ def-use get push-at ] with each ;
: defs-values ( seq -- )
#! If there is no value, set it to a new empty vector,
@ -132,5 +132,4 @@ M: #r> kill-node*
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
nest-def-use keys
def-use get [ [ t swap ?push ] change-at ] curry each ;
nest-def-use keys def-use get [ t -rot push-at ] curry each ;

66
core/optimizer/known-words/known-words.factor
View File

@ -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

10
core/parser/parser-docs.factor
View File

@ -117,14 +117,18 @@ $nl
{ $subsection parse-tokens } ;
ARTICLE: "parsing-words" "Parsing words"
"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
$nl
"Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:"
{ $code ": hello \"Hello world\" print ; parsing" }
"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser."
$nl
"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
$nl
"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later."
$nl
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
{ $link staging-violation }
{ $subsection staging-violation }
"Tools for implementing parsing words:"
{ $subsection "reading-ahead" }
{ $subsection "parsing-word-nest" }

13
core/sequences/sequences.factor
View File

@ -361,6 +361,12 @@ PRIVATE>
: map ( seq quot -- newseq )
over map-as ; inline
: replicate ( seq quot -- newseq )
[ drop ] prepose map ; inline
: replicate-as ( seq quot exemplar -- newseq )
>r [ drop ] prepose r> map-as ; inline
: change-each ( seq quot -- )
over map-into ; inline
@ -413,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

2
core/sorting/sorting-tests.factor
View File

@ -11,7 +11,7 @@ unit-test
[ t ] [
100 [
drop
100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
] all?
] unit-test

2
core/strings/strings-tests.factor
View File

@ -98,7 +98,7 @@ unit-test
[ ] [
[
4 [
100 [ drop "obdurak" clone ] map
100 [ "obdurak" clone ] replicate
gc
dup [
1234 0 rot set-string-nth

2
core/vectors/vectors-tests.factor
View File

@ -26,7 +26,7 @@ IN: vectors.tests
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
[ t ] [
100 [ drop 100 random ] map >vector
100 [ 100 random ] V{ } replicate-as
dup >array >vector =
] unit-test

4
extra/assocs/lib/lib-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: assocs.lib.tests
USING: assocs.lib tools.test vectors ;
{ 1 1 } [ [ ?push ] histogram ] must-infer-as

7
extra/assocs/lib/lib.factor
View File

@ -17,9 +17,6 @@ IN: assocs.lib
: replace-at ( assoc value key -- assoc )
>r >r dup r> 1vector r> rot set-at ;
: insert-at ( value key assoc -- )
[ ?push ] change-at ;
: peek-at* ( assoc key -- obj ? )
swap at* dup [ >r peek r> ] when ;
@ -32,7 +29,7 @@ IN: assocs.lib
: multi-assoc-each ( assoc quot -- )
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ;
: insert ( value variable -- ) namespace push-at ;
: generate-key ( assoc -- str )
>r 32 random-bits >hex r>
@ -44,4 +41,4 @@ IN: assocs.lib
: histogram ( assoc quot -- assoc' )
H{ } clone [
swap [ change-at ] 2curry assoc-each
] keep ;
] keep ; inline

20
extra/base64/base64-tests.factor
View File

@ -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

27
extra/base64/base64.factor
View File

@ -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* ;

2
extra/color-picker/color-picker.factor
View File

@ -24,7 +24,7 @@ M: color-preview model-changed
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ drop 0 0 0 255 <range> ] map
3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose>
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;

26
extra/combinators/lib/lib.factor
View File

@ -66,32 +66,6 @@ MACRO: napply ( n -- )
: short-circuit ( quots quot default -- quot )
1quotation -rot { } map>assoc <reversed> alist>quot ;
! MACRO: && ( quots -- ? )
! [ [ not ] append [ f ] ] t short-circuit ;
! MACRO: <-&& ( quots -- )
! [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
! [ nip ] append ;
! MACRO: <--&& ( quots -- )
! [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
! [ 2nip ] append ;
! or
! MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
! MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
! MACRO: 1|| ( quots -- ? )
! [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
! MACRO: 2|| ( quots -- ? )
! [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
! MACRO: 3|| ( quots -- ? )
! [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: 0&& ( quots -- quot )

10
extra/concurrency/distributed/distributed-tests.factor
View File

@ -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

22
extra/concurrency/distributed/distributed.factor
View File

@ -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 ;

2
extra/cords/cords.factor
View File

@ -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 ;

9
extra/db/queries/queries.factor
View File

@ -195,3 +195,12 @@ M: db <count-statement> ( tuple class groups -- statement )
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
: create-index ( index-name table-name columns -- )
[
>r >r "create index " % % r> " on " % % r> "(" %
"," join % ")" %
] "" make sql-command ;
: drop-index ( index-name -- )
[ "drop index " % % ] "" make sql-command ;

2
extra/db/sqlite/sqlite.factor
View File

@ -53,7 +53,7 @@ M: sqlite-result-set dispose ( result-set -- )
M: sqlite-statement low-level-bind ( statement -- )
[ statement-bind-params ] [ statement-handle ] bi
swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
[ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare

3
extra/db/tuples/tuples.factor
View File

@ -122,6 +122,9 @@ M: retryable execute-statement* ( statement type -- )
: ensure-table ( class -- )
[ create-table ] curry ignore-errors ;
: ensure-tables ( classes -- )
[ ensure-table ] each ;
: insert-db-assigned-statement ( tuple -- )
dup class
db get db-insert-statements [ <insert-db-assigned-statement> ] cache

14
extra/delegate/delegate.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint combinators.lib
math hashtables sets ;
sequences arrays vectors definitions prettyprint
math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )
@ -23,7 +23,15 @@ M: tuple-class group-words
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
[
nip
[
over second saver %
%
dup second restorer %
first ,
] [ ] make
] 3bi
define ;
: change-word-prop ( word prop quot -- )

4
extra/dns/dns.factor
View File

@ -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 )

48
extra/dns/server/server.factor
View File

@ -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

13
extra/dns/util/util.factor
View File

@ -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 ;

8
extra/editors/gvim/gvim.factor
View File

@ -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" ] }

4
extra/editors/vim/vim-docs.factor
View File

@ -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" } "." ;

14
extra/editors/vim/vim.factor
View File

@ -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

11
extra/eval-server/eval-server.factor
View File

@ -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
extra/eval-server/summary.txt
View File

@ -1 +0,0 @@
Listens for UDP packets on localhost:9998, evaluates them and sends back result

4
extra/eval-server/tags.txt
View File

@ -1,4 +0,0 @@
demos
network
tools
applications

45
extra/farkup/farkup.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.styles kernel memoize namespaces peg
sequences strings html.elements xml.entities xmode.code2html
splitting io.streams.string peg.parsers
USING: arrays io io.styles kernel memoize namespaces peg math
combinators sequences strings html.elements xml.entities
xmode.code2html splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
<PRIVATE
@ -67,13 +68,19 @@ MEMO: eq ( -- parser )
</pre>
] with-string-writer ;
: invalid-url "javascript:alert('Invalid URL in farkup');" ;
: check-url ( href -- href' )
CHAR: : over member? [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop "/" ] unless
] [
relative-link-prefix get prepend
] if ;
{
{ [ dup empty? ] [ drop invalid-url ] }
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop invalid-url ] unless
] }
[ relative-link-prefix get prepend ]
} cond ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
@ -82,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 )
[

18
extra/ftp/server/server.factor
View File

@ -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 ;

86
extra/furnace/actions/actions.factor
View File

@ -8,6 +8,7 @@ http.server
http.server.responses
furnace
furnace.flash
html.forms
html.elements
html.components
html.components
@ -20,75 +21,83 @@ 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 ;
CHLOE: validation-messages drop render-validation-messages ;
TUPLE: action rest init display validate submit ;
TUPLE: action rest authorize init display validate submit ;
: new-action ( class -- action )
new
[ ] >>init
[ <400> ] >>display
[ ] >>validate
[ <400> ] >>submit ;
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
: <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 )
'[
,
[ init>> call ]
[ drop flashed-variables restore-flash ]
[ display>> call ]
tri
, dup display>> [
{
[ init>> call ]
[ authorize>> call ]
[ drop restore-validation-errors ]
[ display>> call ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
: validation-failed ( -- * )
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
: (handle-post) ( action -- response )
[ validate>> call ] [ submit>> call ] bi ;
: param ( name -- value )
params get at ;
: revalidate-url-key "__u" ;
: check-url ( url -- ? )
request get url>>
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
: revalidate-url ( -- url/f )
revalidate-url-key param dup [ >url dup check-url swap and ] when ;
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 ;
@ -107,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 ;

32
extra/furnace/alloy/alloy.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences db.tuples alarms calendar db fry
furnace.cache
furnace.asides
furnace.flash
furnace.sessions
furnace.referrer
furnace.db
furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
'[
<asides>
<flash-scopes>
<sessions>
, , <db-persistence>
<check-form-submissions>
] call ;
: state-classes { session flash-scope aside permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables
user ensure-table ;
: start-expiring ( db params -- )
'[
, , [ state-classes [ expire-state ] each ] with-db
] 5 minutes every drop ;

66
extra/furnace/asides/asides.factor
View File

@ -2,37 +2,60 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces sequences arrays kernel
assocs assocs.lib hashtables math.parser urls combinators
furnace http http.server http.server.filters furnace.sessions
html.elements html.templates.chloe.syntax ;
html.elements html.templates.chloe.syntax db.types db.tuples
http http.server http.server.filters
furnace furnace.cache furnace.sessions furnace.redirection ;
IN: furnace.asides
TUPLE: asides < filter-responder ;
TUPLE: aside < server-state session method url post-data ;
C: <asides> asides
: <aside> ( id -- aside )
aside new-server-state ;
aside "ASIDES"
{
{ "session" "SESSION" BIG-INTEGER +not-null+ }
{ "method" "METHOD" { VARCHAR 10 } +not-null+ }
{ "url" "URL" URL +not-null+ }
{ "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
TUPLE: asides < server-state-manager ;
: <asides> ( responder -- responder' )
asides new-server-state-manager ;
: begin-aside* ( -- id )
request get
[ url>> ] [ post-data>> ] [ method>> ] tri 3array
asides sget set-at-unique
session-changed ;
f <aside>
session get id>> >>session
request get
[ method>> >>method ]
[ url>> >>url ]
[ post-data>> >>post-data ]
tri
[ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
: end-aside-post ( url post-data -- response )
: end-aside-post ( aside -- response )
request [
clone
swap >>post-data
swap >>url
over post-data>> >>post-data
over url>> >>url
] change
request get url>> path>> split-path
url>> path>> split-path
asides get responder>> call-responder ;
ERROR: end-aside-in-get-error ;
: get-aside ( id -- aside )
dup [ aside get-state ] when
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
: end-aside* ( url id -- response )
request get method>> "POST" = [ end-aside-in-get-error ] unless
asides sget at [
first3 {
{ "GET" [ drop <redirect> ] }
{ "HEAD" [ drop <redirect> ] }
post-request? [ end-aside-in-get-error ] unless
aside get-state [
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
@ -47,13 +70,12 @@ SYMBOL: aside-id
: end-aside ( default -- response )
aside-id [ f ] change end-aside* ;
: request-aside-id ( request -- aside-id )
aside-id-key swap request-params at string>number ;
M: asides call-responder*
dup asides set
aside-id-key request get request-params at aside-id set
call-next-method ;
M: asides init-session*
H{ } clone asides sset
request get request-aside-id aside-id set
call-next-method ;
M: asides link-attr ( tag -- )

6
extra/furnace/auth/auth-tests.factor Normal file
View File

@ -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

114
extra/furnace/auth/auth.factor
View File

@ -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 ;

46
extra/furnace/auth/basic/basic.factor
View File

@ -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
extra/furnace/auth/login/boilerplate.xml → extra/furnace/auth/boilerplate.xml
View File

24
extra/furnace/auth/features/deactivate-user/deactivate-user.factor Normal file
View File

@ -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? ;

4
extra/furnace/auth/features/edit-profile/edit-profile-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: furnace.auth.features.edit-profile.tests
USING: tools.test furnace.auth.features.edit-profile ;
\ allow-edit-profile must-infer

67
extra/furnace/auth/features/edit-profile/edit-profile.factor Normal file
View File

@ -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? ;

5
extra/furnace/auth/login/edit-profile.xml → extra/furnace/auth/features/edit-profile/edit-profile.xml
View File

@ -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>

2
extra/furnace/auth/login/recover-1.xml → extra/furnace/auth/features/recover-password/recover-1.xml
View File

@ -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>

0
extra/furnace/auth/login/recover-2.xml → extra/furnace/auth/features/recover-password/recover-2.xml
View File

2
extra/furnace/auth/login/recover-3.xml → extra/furnace/auth/features/recover-password/recover-3.xml
View File

@ -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>

2
extra/furnace/auth/login/recover-4.xml → extra/furnace/auth/features/recover-password/recover-4.xml
View File

@ -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>

4
extra/furnace/auth/features/recover-password/recover-password-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: furnace.auth.features.recover-password
USING: tools.test furnace.auth.features.recover-password ;
\ allow-password-recovery must-infer

124
extra/furnace/auth/features/recover-password/recover-password.factor Normal file
View File

@ -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
extra/furnace/auth/login/register.xml → extra/furnace/auth/features/registration/register.xml
View File

4
extra/furnace/auth/features/registration/registration-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: furnace.auth.features.registration.tests
USING: tools.test furnace.auth.features.registration ;
\ allow-registration must-infer

45
extra/furnace/auth/features/registration/registration.factor Normal file
View File

@ -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? ;

4
extra/furnace/auth/login/login-tests.factor
View File

@ -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

409
extra/furnace/auth/login/login.factor
View File

@ -1,85 +1,66 @@
! 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 ;
: users ( -- provider )
login get users>> ;
M: login-realm modify-form ( responder -- )
drop permit-id get realm get name>> permit-id-key hidden-form-field ;
: encode-password ( string salt -- bytes )
[ utf8 encode ] [ 4 >be ] bi* append
login get checksum>> checksum-bytes ;
: <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 ;
: >>encoded-password ( user string -- user )
32 random-bits [ encode-password ] keep
[ >>password ] [ >>salt ] bi* ; inline
: put-permit-cookie ( response -- response' )
<permit-cookie> put-cookie ;
: 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 ;
: 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
@ -88,13 +69,12 @@ M: user-saver dispose
: <login-action> ( -- action )
<page-action>
[
protected fget [
[ description>> "description" set-value ]
[ capabilities>> words>strings "capabilities" set-value ] bi
] when*
flashed-variables restore-flash
description get "description" set-value
capabilities get words>strings "capabilities" set-value
] >>init
{ login "login" } >>template
{ login-realm "login" } >>template
[
{
@ -105,284 +85,25 @@ M: user-saver dispose
"password" value
"username" value check-login
[ successful-login ] [ login-failed ] if*
] >>submit ;
] >>submit
<auth-boilerplate>
<secure-realm-only> ;
! ! ! 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 ;
! ! ! 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
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: show-login-page ( -- response )
M: login-realm login-required*
drop
begin-aside
URL" $login/login" { protected } <flash-redirect> ;
protected get description>> description set
protected get capabilities>> capabilities set
URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] bi@ subset? ;
M: protected call-responder* ( path responder -- response )
dup protected set
uid dup [
users get-user 2dup check-capabilities [
[ logged-in-user set ] [ save-user-after ] bi
call-next-method
] [
3drop show-login-page
] if
] [
3drop show-login-page
] if ;
M: login call-responder* ( path responder -- response )
dup login set
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> <protected>
"edit your profile" >>description
<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 ;

4
extra/furnace/auth/login/login.xml
View File

@ -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>

30
extra/furnace/auth/login/permits/permits.factor Normal file
View File

@ -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 ;

6
extra/furnace/auth/providers/assoc/assoc-tests.factor
View File

@ -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>

7
extra/furnace/auth/providers/db/db-tests.factor
View File

@ -1,20 +1,19 @@
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
"auth-test.db" temp-file sqlite-db [
init-users-table
user ensure-table
[ t ] [
"slava" <user>

2
extra/furnace/auth/providers/db/db.factor
View File

@ -18,8 +18,6 @@ user "USERS"
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
: init-users-table ( -- ) user ensure-table ;
SINGLETON: users-in-db
M: users-in-db get-user

21
extra/furnace/boilerplate/boilerplate.factor
View File

@ -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 |
[

36
extra/furnace/cache/cache.factor vendored Normal file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math.intervals
calendar alarms fry
random db db.tuples db.types
http.server.filters ;
IN: furnace.cache
TUPLE: server-state id expires ;
: new-server-state ( id class -- server-state )
new swap >>id ; inline
server-state f
{
{ "id" "ID" +random-id+ system-random-generator }
{ "expires" "EXPIRES" TIMESTAMP +not-null+ }
} define-persistent
: get-state ( id class -- state )
new-server-state select-tuple ;
: expire-state ( class -- )
new
-1.0/0.0 now [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;
: new-server-state-manager ( responder class -- responder' )
new
swap >>responder
20 minutes >>timeout ; inline
: touch-state ( state manager -- )
timeout>> from-now >>expires drop ;

3
extra/furnace/db/db.factor
View File

@ -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 ;

57
extra/furnace/flash/flash.factor
View File

@ -1,38 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs assocs.lib kernel sequences urls
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.sessions ;
furnace furnace.cache furnace.sessions furnace.redirection ;
IN: furnace.flash
TUPLE: flash-scope < server-state session namespace ;
: <flash-scope> ( id -- aside )
flash-scope new-server-state ;
flash-scope "FLASH_SCOPES" {
{ "session" "SESSION" BIG-INTEGER +not-null+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
} define-persistent
: flash-id-key "__f" ;
TUPLE: flash-scopes < filter-responder ;
TUPLE: flash-scopes < server-state-manager ;
C: <flash-scopes> flash-scopes
: <flash-scopes> ( responder -- responder' )
flash-scopes new-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
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
: request-flash-scope ( request -- flash-scope )
flash-id-key swap request-params at string>number get-flash-scope ;
M: flash-scopes call-responder*
flash-id-key
request get request-params at
flash-scopes sget at flash-scope set
call-next-method ;
M: flash-scopes init-session*
H{ } clone flash-scopes sset
dup flash-scopes set
request get request-flash-scope flash-scope set
call-next-method ;
: make-flash-scope ( seq -- id )
[ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
session-changed ;
f <flash-scope>
session get id>> >>session
swap [ dup get ] H{ } map>assoc >>namespace
[ flash-scopes get touch-state ] [ insert-tuple ] [ id>> ] tri ;
: <flash-redirect> ( url seq -- response )
make-flash-scope
[ clone ] dip flash-id-key set-query-param
[ clone ] dip
make-flash-scope flash-id-key set-query-param
<redirect> ;
: restore-flash ( seq -- )
[ flash-scope get key? ] filter [ [ fget ] keep set ] each ;
flash-scope get dup [
namespace>>
[ '[ , key? ] filter ]
[ '[ [ , at ] keep set ] each ]
bi
] [ 2drop ] if ;

89
extra/furnace/furnace.factor
View File

@ -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 ;
@ -84,6 +78,30 @@ M: object modify-form drop ;
] }
} case ;
: referrer ( -- referrer )
#! Typo is intentional, its in the HTTP spec!
"referer" request get header>> at >url ;
: user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
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 -- )
@ -97,15 +115,23 @@ SYMBOL: exit-continuation
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
CHLOE: atom
[ children>string ]
: a-url-path ( tag -- string )
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ] tri
<url>
swap >>query
swap >>path
adjust-url relative-to-request
add-atom-feed ;
[ "rest" optional-attr dup [ value ] when ] bi
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( tag -- url )
dup "value" optional-attr
[ value ] [
<url>
swap
[ a-url-path >>path ]
[ "query" optional-attr parse-query-attr >>query ]
bi
adjust-url relative-to-request
] ?if ;
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
@ -114,23 +140,11 @@ GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
: link-attrs ( tag -- )
#! Side-effects current namespace.
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
[
<a
dup link-attrs
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if
<url>
swap >>query
swap >>path
adjust-url relative-to-request =href
a>
] with-scope ;
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
CHLOE: a
[ a-start-tag ]
@ -147,22 +161,23 @@ 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 -- )
[
[
<form
"POST" =method
[ link-attrs ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
tri
{
[ link-attrs ]
[ "method" optional-attr "post" or =method ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
} cleave
form>
]
[ form-magic ] bi

41
extra/furnace/redirection/redirection.factor Normal file
View File

@ -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 ;

16
extra/furnace/referrer/referrer.factor Normal file
View File

@ -0,0 +1,16 @@
USING: accessors kernel
http.server http.server.filters http.server.responses
furnace ;
IN: furnace.referrer
TUPLE: referrer-check < filter-responder quot ;
C: <referrer-check> referrer-check
M: referrer-check call-responder*
referrer over quot>> call
[ call-next-method ]
[ 2drop 403 "Bad referrer" <trivial-response> ] if ;
: <check-form-submissions> ( responder -- responder' )
[ same-host? post-request? not or ] <referrer-check> ;

8
extra/furnace/sessions/sessions-tests.factor
View File

@ -1,9 +1,9 @@
IN: furnace.sessions.tests
USING: tools.test http furnace.sessions
furnace.actions http.server http.server.responses
math namespaces kernel accessors
math namespaces kernel accessors io.sockets io.servers.connection
prettyprint io.streams.string io.files splitting destructors
sequences db db.sqlite continuations urls math.parser
sequences db db.tuples db.sqlite continuations urls math.parser
furnace ;
: with-session
@ -54,7 +54,9 @@ M: foo call-responder*
"auth-test.db" temp-file sqlite-db [
<request> init-request
init-sessions-table
session ensure-table
"127.0.0.1" 1234 <inet4> remote-address set
[ ] [
<foo> <sessions>

94
extra/furnace/sessions/sessions.factor
View File

@ -1,40 +1,29 @@
! 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
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 ;
html.elements
furnace furnace.cache ;
IN: furnace.sessions
TUPLE: session id expires uid namespace changed? ;
TUPLE: session < server-state namespace user-agent client changed? ;
: <session> ( id -- session )
session new
swap >>id ;
session new-server-state ;
session "SESSIONS"
{
{ "id" "ID" +random-id+ system-random-generator }
{ "expires" "EXPIRES" TIMESTAMP +not-null+ }
{ "uid" "UID" { VARCHAR 255 } }
{ "namespace" "NAMESPACE" FACTOR-BLOB }
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
{ "user-agent" "USER_AGENT" TEXT +not-null+ }
{ "client" "CLIENT" TEXT +not-null+ }
} define-persistent
: get-session ( id -- session )
dup [ <session> select-tuple ] when ;
: init-sessions-table ( -- ) session ensure-table ;
: start-expiring-sessions ( db seq -- )
'[
, , [
session new
-1.0/0.0 now [a,b] >>expires
delete-tuples
] with-db
] 5 minutes every drop ;
dup [ session get-state ] when ;
GENERIC: init-session* ( responder -- )
@ -44,12 +33,11 @@ M: dispatcher init-session* default>> init-session* ;
M: filter-responder init-session* responder>> init-session* ;
TUPLE: sessions < filter-responder timeout domain ;
TUPLE: sessions < server-state-manager domain verify? ;
: <sessions> ( responder -- responder' )
sessions new
swap >>responder
20 minutes >>timeout ;
sessions new-server-state-manager
t >>verify? ;
: (session-changed) ( session -- )
t >>changed? drop ;
@ -69,24 +57,23 @@ TUPLE: sessions < filter-responder timeout domain ;
[ 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 ;
: cutoff-time ( -- time )
sessions get timeout>> from-now ;
: touch-session ( session -- )
cutoff-time >>expires drop ;
sessions get touch-state ;
: remote-host ( -- string )
{
[ request get "x-forwarded-for" header ]
[ remote-address get host>> ]
} 0|| ;
: empty-session ( -- session )
f <session>
H{ } clone >>namespace
remote-host >>client
user-agent >>user-agent
dup touch-session ;
: begin-session ( -- session )
@ -111,31 +98,29 @@ 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 [
dup
[ client>> remote-host = ]
[ user-agent>> user-agent = ]
bi and [ drop f ] unless
] when
] when ;
: request-session ( -- session/f )
request-session-id get-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 ;
@ -144,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 ;

19
extra/furnace/utilities/utilities.factor Normal file
View File

@ -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 ;

4
extra/gap-buffer/cursortree/cursortree.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
USING: assocs kernel gap-buffer generic trees trees.avl math
sequences quotations ;
IN: gap-buffer.cursortree
@ -21,7 +21,7 @@ TUPLE: right-cursor ;
: cursor-index ( cursor -- i ) cursor-i ;
: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ;
: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
: remove-cursor ( cursortree cursor -- )
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;

2
extra/help/lint/lint.factor
View File

@ -114,7 +114,7 @@ M: help-error error.
H{ } clone [
[
>r >r dup >link where dup
[ first r> at r> [ ?push ] change-at ]
[ first r> at r> push-at ]
[ r> r> 2drop 2drop ]
if
] 2curry each

23
extra/html/components/components-tests.factor
View File

@ -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

100
extra/html/components/components.factor
View File

@ -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

12
extra/html/elements/elements.factor
View File

@ -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
[

67
extra/html/forms/forms-tests.factor Normal file
View File

@ -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

106
extra/html/forms/forms.factor Normal file
View File

@ -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 ;

18
extra/html/templates/chloe/chloe-tests.factor
View File

@ -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
@ -151,16 +151,16 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[
"test10" test-template call-template
] 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

10
extra/html/templates/chloe/chloe.factor
View File

@ -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

4
extra/http/client/client-tests.factor
View File

@ -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"

10
extra/http/client/client.factor
View File

@ -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 ;

80
extra/http/http-tests.factor
View File

@ -1,13 +1,14 @@
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 ;
STRING: read-request-test-1
POST http://foo/bar HTTP/1.1
POST /bar HTTP/1.1
Some-Header: 1
Some-Header: 2
Content-Length: 4
@ -18,7 +19,7 @@ blah
[
TUPLE{ request
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
url: TUPLE{ url path: "/bar" }
method: "POST"
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
@ -49,14 +50,14 @@ read-request-test-1' 1array [
] unit-test
STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1
HEAD /bar HTTP/1.1
Host: www.sex.com
;
[
TUPLE{ request
url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
url: TUPLE{ url host: "www.sex.com" path: "/bar" }
method: "HEAD"
version: "1.1"
header: H{ { "host" "www.sex.com" } }
@ -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,16 +129,47 @@ 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.actions furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
USING: http.server http.server.static furnace.sessions furnace.alloy
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.dispatchers ;
http.server.responses http.server.redirection furnace.redirection
http.server.dispatchers db.tuples ;
: add-quit-action
<action>
@ -138,7 +181,7 @@ http.server.dispatchers ;
[ test-db drop delete-file ] ignore-errors
test-db [
init-sessions-table
init-furnace-tables
] with-db
[ ] [
@ -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

256
extra/http/http.factor
View File

@ -1,17 +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.server io.sockets.secure
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 => , ;
@ -19,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 )
{
@ -63,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
@ -135,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 ;
@ -142,35 +161,16 @@ cookies ;
request new
"1.1" >>version
<url>
"http" >>protocol
H{ } clone >>query
>>url
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 ;
@ -202,11 +202,10 @@ TUPLE: post-data raw content content-type ;
: extract-host ( request -- request )
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
ensure-port
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 ;
@ -214,28 +213,20 @@ TUPLE: post-data raw content content-type ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
: detect-protocol ( request -- request )
dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
: read-request ( -- request )
<request>
read-method
read-url
read-request-version
read-request-line
read-request-header
read-post-data
detect-protocol
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 =
@ -249,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 )
@ -274,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
@ -302,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 ]
@ -330,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 ]
@ -351,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 ;
@ -393,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 ;

166
extra/http/parsers/parsers.factor Normal file
View File

@ -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 ;

6
extra/http/server/cgi/cgi.factor
View File

@ -5,8 +5,6 @@ combinators arrays io.launcher io http.server.static http.server
http accessors sequences strings math.parser fry urls ;
IN: http.server.cgi
: post? ( -- ? ) request get method>> "POST" = ;
: cgi-variables ( script-path -- assoc )
#! This needs some work.
[
@ -34,7 +32,7 @@ IN: http.server.cgi
request get "user-agent" header "HTTP_USER_AGENT" set
request get "accept" header "HTTP_ACCEPT" set
post? [
post-request? [
request get post-data>> raw>>
[ "CONTENT_TYPE" set ]
[ length number>string "CONTENT_LENGTH" set ]
@ -53,7 +51,7 @@ IN: http.server.cgi
"CGI output follows" >>message
swap '[
, output-stream get swap <cgi-process> <process-stream> [
post? [ request get post-data>> raw>> write flush ] when
post-request? [ request get post-data>> raw>> write flush ] when
input-stream get swap (stream-copy)
] with-stream
] >>body ;

8
extra/http/server/redirection/redirection.factor
View File

@ -1,10 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces
USING: kernel accessors combinators namespaces strings
logging urls http http.server http.server.responses ;
IN: http.server.redirection
: relative-to-request ( url -- url' )
GENERIC: relative-to-request ( url -- url' )
M: string relative-to-request ;
M: url relative-to-request
request get url>>
clone
f >>query

115
extra/http/server/server.factor
View File

@ -2,27 +2,33 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
tools.vocabs math
combinators tools.vocabs tools.time math
io
io.server
io.sockets
io.sockets.secure
io.encodings
io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.servers.connection
io.timeouts
fry logging calendar
fry logging logging.insomniac calendar urls
http
http.server.responses
html.elements
html.streams ;
IN: http.server
: post-request? ( -- ? ) request get method>> "POST" = ;
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 )
@ -51,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" throw ] 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 ;
@ -88,38 +93,62 @@ LOG: httpd-hit NOTICE
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
: prepare-request ( request -- )
[
local-address get
[ secure? "https" "http" ? >>protocol ]
[ port>> '[ , or ] change-port ]
bi
] change-url drop ;
: valid-request? ( request -- ? )
url>> port>> local-address get port>> = ;
: do-request ( request -- response )
'[
,
[ init-request ]
[ log-request ]
[ dispatch-request ] tri
{
[ init-request ]
[ prepare-request ]
[ log-request ]
[ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
} cleave
] [ [ \ 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 ;

2
extra/http/server/static/static.factor
View File

@ -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
] [

7
extra/io/encodings/ascii/ascii.factor
View File

@ -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

2
extra/io/files/unique/unique.factor
View File

@ -15,7 +15,7 @@ IN: io.files.unique
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string )
[ drop random-ch ] "" map-as ;
[ random-ch ] "" replicate-as ;
: unique-length ( -- n ) 10 ; inline
: unique-retries ( -- n ) 10 ; inline

13
extra/io/launcher/launcher.factor
View File

@ -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 -- )

2
extra/io/pipes/pipes.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.ports io.streams.duplex
io splitting grouping sequences sequences.lib namespaces kernel
io splitting grouping sequences namespaces kernel
destructors math concurrency.combinators accessors
arrays continuations quotations ;
IN: io.pipes

3
extra/io/pools/pools.factor
View File

@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ;
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
connections>> [ delete-all ] [ dispose-each ] bi
connections>> delete-all
] [ drop ] if ;
: <pool> ( class -- pool )
@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn )
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;

4
extra/io/ports/ports-docs.factor
View File

@ -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." } ;

Some files were not shown because too many files have changed in this diff Show More