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
: 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
[ t ] [
100 [
- drop 100 [ drop 2 random zero? ] map
+ drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all?
] unit-test
\r
10 [\r
[ ] [\r
- 20 [ drop random-op ] map >quotation\r
+ 20 [ random-op ] [ ] replicate-as\r
[ infer effect-in [ random-class ] times ] keep\r
call\r
drop\r
\r
20 [\r
[ t ] [\r
- 20 [ drop random-boolean-op ] [ ] map-as dup .\r
- [ infer effect-in [ drop random-boolean ] map dup . ] keep\r
+ 20 [ random-boolean-op ] [ ] replicate-as dup .\r
+ [ infer effect-in [ random-boolean ] replicate dup . ] keep\r
\r
[ >r [ ] each r> call ] 2keep\r
\r
2 over set-length
>array
] unit-test
+
+[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
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
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 >
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 ;
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 ;
{ $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. }
! Decoding
-<PRIVATE
-
M: object <decoder> f decoder boa ;
-: >decoder< ( decoder -- stream encoding )
- [ stream>> ] [ code>> ] bi ;
-
-: cr+ t swap set-decoder-cr ; inline
+<PRIVATE
-: cr- f swap set-decoder-cr ; inline
+: cr+ t >>cr drop ; inline
-: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
+: cr- f >>cr drop ; inline
-: line-ends\r ( stream str -- str ) swap cr+ ; inline
+: >decoder< ( decoder -- stream encoding )
+ [ stream>> ] [ code>> ] bi ; inline
-: line-ends\n ( stream str -- str )
- over decoder-cr over empty? and
- [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
+: fix-read1 ( stream char -- char )
+ over cr>> [
+ over cr-
+ dup CHAR: \n = [
+ drop dup stream-read1
+ ] when
+ ] when nip ; inline
-: handle-readln ( stream str ch -- str )
- {
- { f [ line-ends/eof ] }
- { CHAR: \r [ line-ends\r ] }
- { CHAR: \n [ line-ends\n ] }
- } case ;
+M: decoder stream-read1
+ dup >decoder< decode-char fix-read1 ;
: fix-read ( stream string -- string )
- over decoder-cr [
+ over cr>> [
over cr-
"\n" ?head [
over stream-read1 [ suffix ] when*
] when
- ] when nip ;
+ ] when nip ; inline
-: read-loop ( n stream -- string )
- SBUF" " clone [
+: (read) ( n quot -- n string )
+ over 0 <string> [
[
- >r nip stream-read1 dup
- [ r> push f ] [ r> 2drop t ] if
- ] 2curry find-integer drop
- ] keep "" like f like ;
+ >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 read-loop fix-read ;
+ tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
M: decoder stream-read-partial stream-read ;
-: (read-until) ( buf quot -- string/f sep/f )
+: 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 cr>> over empty? and
+ [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
+
+: handle-readln ( stream str ch -- str )
+ {
+ { f [ line-ends/eof ] }
+ { CHAR: \r [ line-ends\r ] }
+ { CHAR: \n [ line-ends\n ] }
+ } case ; inline
+
+: ((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-read1
- dup >decoder< decode-char fix-read1 ;
+M: decoder stream-read-until (read-until) ;
-M: decoder stream-readln ( stream -- str )
- "\r\n" over stream-read-until handle-readln ;
+M: decoder stream-readln "\r\n" over (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 ;
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,
#! 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 ;
! 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> } [
[
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 ;
+
+: 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 ;
-: expand-member ( #call -- )
- dup node-in-d peek value-literal member-quot f splice-quot ;
+: 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,
] each
\ push-all
-{ { string sbuf } { array vector } }
+{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
\ append
{ $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" }
: 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
: 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
[ 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
[ ] [
[
4 [
- 100 [ drop "obdurak" clone ] map
+ 100 [ "obdurak" clone ] replicate
gc
dup [
1234 0 rot set-string-nth
[ 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
--- /dev/null
+IN: assocs.lib.tests
+USING: assocs.lib tools.test vectors ;
+
+{ 1 1 } [ [ ?push ] histogram ] must-infer-as
: 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 ;
: 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>
: histogram ( assoc quot -- assoc' )
H{ } clone [
swap [ change-at ] 2curry assoc-each
- ] keep ;
+ ] keep ; inline
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
-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 ;
} 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* ;
[ [ 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 ;
: 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 )
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> ] }
[ ] [ [ "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
[ ] [
[
receive
] unit-test
+[ ] [ 1000 sleep ] unit-test
+
[ ] [ test-node stop-node ] unit-test
! 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
: 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 ;
-! 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 ;
] { { } { } { } } 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 ;
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
: 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
! 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 )
: 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 -- )
}
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 )
-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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: (socket) ( -- vec ) V{ f } ;
-
-: socket ( -- socket ) (socket) 1st ;
-
-: init-socket-on-port ( port -- )
- f swap <inet4> <datagram> 0 (socket) as-mutate ;
+: (handle-request) ( packet -- )
+ [ [ find-answer ] with-message-bytes ] change-data respond ;
-: init-socket ( -- ) 53 init-socket-on-port ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
-: loop ( -- )
- socket receive
- swap
- parse-message
- find-answer
- message->ba
- swap
- socket send
- loop ;
+: receive-loop ( socket -- )
+ [ receive-packet handle-request ] [ receive-loop ] bi ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start ( -- ) init-socket loop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: loop ( addr-spec -- )
+ [ <datagram> '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
-MAIN: start
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: longer? ( seq seq -- ? ) [ length ] bi@ > ;
\ No newline at end of file
+: 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 ;
+
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" ] }
"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" } "." ;
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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
+++ /dev/null
-Listens for UDP packets on localhost:9998, evaluates them and sends back result
+++ /dev/null
-demos
-network
-tools
-applications
! 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
</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 ;
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 )
[
! 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
[ 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
] 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 ;
http.server.responses\r
furnace\r
furnace.flash\r
+html.forms\r
html.elements\r
html.components\r
html.components\r
SYMBOL: rest\r
\r
: render-validation-messages ( -- )\r
- validation-messages get\r
+ form get errors>>\r
dup empty? [ drop ] [\r
<ul "errors" =class ul>\r
- [ <li> message>> escape-string write </li> ] each\r
+ [ <li> escape-string write </li> ] each\r
</ul>\r
] if ;\r
\r
CHLOE: validation-messages drop render-validation-messages ;\r
\r
-TUPLE: action rest init display validate submit ;\r
+TUPLE: action rest authorize init display validate submit ;\r
\r
: new-action ( class -- action )\r
- new\r
- [ ] >>init\r
- [ <400> ] >>display\r
- [ ] >>validate\r
- [ <400> ] >>submit ;\r
+ new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
\r
: <action> ( -- action )\r
action new-action ;\r
\r
-: flashed-variables ( -- seq )\r
- { validation-messages named-validation-messages } ;\r
+: set-nested-form ( form name -- )\r
+ dup empty? [\r
+ drop form set\r
+ ] [\r
+ dup length 1 = [\r
+ first set-value\r
+ ] [\r
+ unclip [ set-nested-form ] nest-form\r
+ ] if\r
+ ] if ;\r
+\r
+: restore-validation-errors ( -- )\r
+ form fget [\r
+ nested-forms fget set-nested-form\r
+ ] when* ;\r
\r
: handle-get ( action -- response )\r
'[\r
- ,\r
- [ init>> call ]\r
- [ drop flashed-variables restore-flash ]\r
- [ display>> call ]\r
- tri\r
+ , dup display>> [\r
+ {\r
+ [ init>> call ]\r
+ [ authorize>> call ]\r
+ [ drop restore-validation-errors ]\r
+ [ display>> call ]\r
+ } cleave\r
+ ] [ drop <400> ] if\r
] with-exit-continuation ;\r
\r
-: validation-failed ( -- * )\r
- request get method>> "POST" = [ f ] [ <400> ] if exit-with ;\r
-\r
-: (handle-post) ( action -- response )\r
- [ validate>> call ] [ submit>> call ] bi ;\r
-\r
: param ( name -- value )\r
params get at ;\r
\r
: revalidate-url-key "__u" ;\r
\r
-: check-url ( url -- ? )\r
- request get url>>\r
- [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;\r
-\r
: revalidate-url ( -- url/f )\r
- revalidate-url-key param dup [ >url dup check-url swap and ] when ;\r
+ revalidate-url-key param\r
+ dup [ >url [ same-host? ] keep and ] when ;\r
+\r
+: validation-failed ( -- * )\r
+ post-request? revalidate-url and\r
+ [\r
+ nested-forms-key param " " split harvest nested-forms set\r
+ { form nested-forms } <flash-redirect>\r
+ ] [ <400> ] if*\r
+ exit-with ;\r
\r
: handle-post ( action -- response )\r
'[\r
- form-nesting-key params get at " " split\r
- [ , (handle-post) ]\r
- [ swap '[ , , nest-values ] ] reduce\r
- call\r
- ] with-exit-continuation\r
- [\r
- revalidate-url\r
- [ flashed-variables <flash-redirect> ] [ <403> ] if*\r
- ] unless* ;\r
+ , dup submit>> [\r
+ [ validate>> call ]\r
+ [ authorize>> call ]\r
+ [ submit>> call ]\r
+ tri\r
+ ] [ drop <400> ] if\r
+ ] with-exit-continuation ;\r
\r
: handle-rest ( path action -- assoc )\r
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
\r
: init-action ( path action -- )\r
- blank-values\r
- init-validation\r
+ begin-form\r
handle-rest\r
request get request-params assoc-union params set ;\r
\r
validation-failed? [ validation-failed ] when ;\r
\r
: validate-params ( validators -- )\r
- params get swap validate-values from-object\r
- check-validation ;\r
+ params get swap validate-values check-validation ;\r
\r
: validate-integer-id ( -- )\r
{ { "id" [ v-number ] } } validate-params ;\r
--- /dev/null
+! 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 ;
! 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 ;
: 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 -- )
--- /dev/null
+USING: furnace.auth tools.test ;
+IN: furnace.auth.tests
+
+\ logged-in-username must-infer
+\ <protected> must-infer
+\ new-realm must-infer
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs namespaces kernel sequences sets\r
+destructors combinators fry\r
+io.encodings.utf8 io.encodings.string io.binary random\r
+checksums checksums.sha2\r
+html.forms\r
http.server\r
http.server.filters\r
http.server.dispatchers\r
-furnace.sessions\r
-furnace.auth.providers ;\r
+furnace\r
+furnace.actions\r
+furnace.redirection\r
+furnace.boilerplate\r
+furnace.auth.providers\r
+furnace.auth.providers.db ;\r
IN: furnace.auth\r
\r
SYMBOL: logged-in-user\r
\r
+: logged-in? ( -- ? ) logged-in-user get >boolean ;\r
+\r
GENERIC: init-user-profile ( responder -- )\r
\r
M: object init-user-profile drop ;\r
M: filter-responder init-user-profile\r
responder>> init-user-profile ;\r
\r
+: have-capability? ( capability -- ? )\r
+ logged-in-user get capabilities>> member? ;\r
+\r
: profile ( -- assoc ) logged-in-user get profile>> ;\r
\r
: user-changed ( -- )\r
V{ } clone capabilities set-global\r
\r
: define-capability ( word -- ) capabilities get adjoin ;\r
+\r
+TUPLE: realm < dispatcher name users checksum secure ;\r
+\r
+GENERIC: login-required* ( realm -- response )\r
+\r
+GENERIC: logged-in-username ( realm -- username )\r
+\r
+: login-required ( -- * ) realm get login-required* exit-with ;\r
+\r
+: new-realm ( responder name class -- realm )\r
+ new-dispatcher\r
+ swap >>name\r
+ swap >>default\r
+ users-in-db >>users\r
+ sha-256 >>checksum\r
+ t >>secure ; inline\r
+\r
+: users ( -- provider )\r
+ realm get users>> ;\r
+\r
+TUPLE: user-saver user ;\r
+\r
+C: <user-saver> user-saver\r
+\r
+M: user-saver dispose\r
+ user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
+\r
+: save-user-after ( user -- )\r
+ <user-saver> &dispose drop ;\r
+\r
+: init-user ( user -- )\r
+ [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;\r
+\r
+M: realm call-responder* ( path responder -- response )\r
+ dup realm set\r
+ dup logged-in-username dup [ users get-user ] when init-user\r
+ call-next-method ;\r
+\r
+: encode-password ( string salt -- bytes )\r
+ [ utf8 encode ] [ 4 >be ] bi* append\r
+ realm get checksum>> checksum-bytes ;\r
+\r
+: >>encoded-password ( user string -- user )\r
+ 32 random-bits [ encode-password ] keep\r
+ [ >>password ] [ >>salt ] bi* ; inline\r
+\r
+: valid-login? ( password user -- ? )\r
+ [ salt>> encode-password ] [ password>> ] bi = ;\r
+\r
+: check-login ( password username -- user/f )\r
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
+\r
+: if-secure-realm ( quot -- )\r
+ realm get secure>> [ if-secure ] [ call ] if ; inline\r
+\r
+TUPLE: secure-realm-only < filter-responder ;\r
+\r
+C: <secure-realm-only> secure-realm-only\r
+\r
+M: secure-realm-only call-responder*\r
+ '[ , , call-next-method ] if-secure-realm ;\r
+\r
+TUPLE: protected < filter-responder description capabilities ;\r
+\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
+\r
+: check-capabilities ( responder user/f -- ? )\r
+ {\r
+ { [ dup not ] [ 2drop f ] }\r
+ { [ dup deleted>> 1 = ] [ 2drop f ] }\r
+ [ [ capabilities>> ] bi@ subset? ]\r
+ } cond ;\r
+\r
+M: protected call-responder* ( path responder -- response )\r
+ '[\r
+ , ,\r
+ dup protected set\r
+ dup logged-in-user get check-capabilities\r
+ [ call-next-method ] [ 2drop realm get login-required* ] if\r
+ ] if-secure-realm ;\r
+\r
+: <auth-boilerplate> ( responder -- responder' )\r
+ <boilerplate> { realm "boilerplate" } >>template ;\r
+\r
+: password-mismatch ( -- * )\r
+ "passwords do not match" validation-error\r
+ validation-failed ;\r
+\r
+: same-password-twice ( -- )\r
+ "new-password" value "verify-password" value =\r
+ [ password-mismatch ] unless ;\r
+\r
+: user-exists ( -- * )\r
+ "username taken" validation-error\r
+ validation-failed ;\r
! Copyright (c) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-base64 html.elements io combinators sequences\r
-http http.server.filters http.server.responses http.server\r
-furnace.auth.providers furnace.auth.login ;\r
+USING: accessors kernel splitting base64 namespaces strings\r
+http http.server.responses furnace.auth ;\r
IN: furnace.auth.basic\r
\r
-TUPLE: basic-auth < filter-responder realm provider ;\r
+TUPLE: basic-auth-realm < realm ;\r
\r
-C: <basic-auth> basic-auth\r
+: <basic-auth-realm> ( responder name -- realm )\r
+ basic-auth-realm new-realm ;\r
\r
-: authorization-ok? ( provider header -- ? )\r
- #! Given the realm and the 'Authorization' header,\r
- #! authenticate the user.\r
+: parse-basic-auth ( header -- username/f password/f )\r
dup [\r
" " split1 swap "Basic" = [\r
- base64> ":" split1 spin check-login\r
- ] [\r
- 2drop f\r
- ] if\r
- ] [\r
- 2drop f\r
- ] if ;\r
+ base64> >string ":" split1\r
+ ] [ drop f f ] if\r
+ ] [ drop f f ] if ;\r
\r
: <401> ( realm -- response )\r
- 401 "Unauthorized" <trivial-response>\r
- "Basic realm=\"" rot "\"" 3append\r
- "WWW-Authenticate" set-header\r
- [\r
- <html> <body>\r
- "Username or Password is invalid" write\r
- </body> </html>\r
- ] >>body ;\r
+ 401 "Invalid username or password" <trivial-response>\r
+ [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;\r
\r
-: logged-in? ( request responder -- ? )\r
- provider>> swap "authorization" header authorization-ok? ;\r
+M: basic-auth-realm login-required* ( realm -- response )\r
+ name>> <401> ;\r
\r
-M: basic-auth call-responder* ( request path responder -- response )\r
- pick over logged-in?\r
- [ call-next-method ] [ 2nip realm>> <401> ] if ;\r
+M: basic-auth-realm logged-in-username ( realm -- uid )\r
+ drop\r
+ request get "authorization" header parse-basic-auth\r
+ dup [ over check-login swap and ] [ 2drop f ] if ;\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+! 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? ;
--- /dev/null
+IN: furnace.auth.features.edit-profile.tests
+USING: tools.test furnace.auth.features.edit-profile ;
+
+\ allow-edit-profile must-infer
--- /dev/null
+! 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? ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Profile</t:title>
+
+ <t:form t:action="$realm/edit-profile">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:label t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Current password:</th>
+ <td><t:password t:name="password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you don't want to change your current password, leave this field blank.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you are changing your password, enter it twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Update" />
+ <t:validation-messages />
+ </p>
+
+ </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>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 1 of 4</t:title>
+
+ <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="$realm/recover-password">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <input type="submit" value="Recover password" />
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 2 of 4</t:title>
+
+ <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 3 of 4</t:title>
+
+ <p>Choose a new password for your account.</p>
+
+ <t:form t:action="$realm/recover-3">
+
+ <table>
+
+ <t:hidden t:name="username" />
+ <t:hidden t:name="ticket" />
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify password:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Set password" />
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>\r
+\r
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
+\r
+ <t:title>Recover lost password: step 4 of 4</t:title>\r
+\r
+ <p>Your password has been reset. You may now <t:a t:href="$realm">proceed</t:a>.</p>\r
+\r
+</t:chloe>\r
--- /dev/null
+IN: furnace.auth.features.recover-password
+USING: tools.test furnace.auth.features.recover-password ;
+
+\ allow-password-recovery must-infer
--- /dev/null
+! 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? ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User Registration</t:title>
+
+ <t:form t:action="register">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Register" />
+ <t:validation-messages />
+
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+IN: furnace.auth.features.registration.tests
+USING: tools.test furnace.auth.features.registration ;
+
+\ allow-registration must-infer
--- /dev/null
+! 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? ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Edit Profile</t:title>
-
- <t:form t:action="$login/edit-profile">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:label t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Current password:</th>
- <td><t:password t:name="password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you don't want to change your current password, leave this field blank.</td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you are changing your password, enter it twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Update" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
IN: furnace.auth.login.tests\r
USING: tools.test furnace.auth.login ;\r
\r
-\ <login> must-infer\r
-\ allow-registration must-infer\r
-\ allow-password-recovery must-infer\r
+\ <login-realm> must-infer\r
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-combinators sequences namespaces hashtables sets\r
-fry arrays threads qualified random validators words\r
-io\r
-io.sockets\r
-io.encodings.utf8\r
-io.encodings.string\r
-io.binary\r
-continuations\r
-destructors\r
-checksums\r
-checksums.sha2\r
-validators\r
-html.components\r
-html.elements\r
-urls\r
-http\r
-http.server\r
-http.server.dispatchers\r
-http.server.filters\r
-http.server.responses\r
+USING: kernel accessors namespaces sequences math.parser\r
+calendar validators urls html.forms\r
+http http.server http.server.dispatchers\r
furnace\r
furnace.auth\r
-furnace.auth.providers\r
-furnace.auth.providers.db\r
-furnace.actions\r
-furnace.asides\r
furnace.flash\r
+furnace.asides\r
+furnace.actions\r
furnace.sessions\r
-furnace.boilerplate ;\r
-QUALIFIED: smtp\r
+furnace.utilities\r
+furnace.redirection\r
+furnace.auth.login.permits ;\r
IN: furnace.auth.login\r
\r
-: word>string ( word -- string )\r
- [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;\r
-\r
-: words>strings ( seq -- seq' )\r
- [ word>string ] map ;\r
-\r
-: string>word ( string -- word )\r
- ":" split1 swap lookup ;\r
+SYMBOL: permit-id\r
\r
-: strings>words ( seq -- seq' )\r
- [ string>word ] map ;\r
+: permit-id-key ( realm -- string )\r
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat\r
+ "__p_" prepend ;\r
\r
-TUPLE: login < dispatcher users checksum ;\r
+: client-permit-id ( realm -- id/f )\r
+ permit-id-key client-state dup [ string>number ] when ;\r
\r
-TUPLE: protected < filter-responder description capabilities ;\r
+TUPLE: login-realm < realm timeout domain ;\r
\r
-: users ( -- provider )\r
- login get users>> ;\r
+M: login-realm call-responder*\r
+ [ name>> client-permit-id permit-id set ]\r
+ [ call-next-method ]\r
+ bi ;\r
\r
-: encode-password ( string salt -- bytes )\r
- [ utf8 encode ] [ 4 >be ] bi* append\r
- login get checksum>> checksum-bytes ;\r
+M: login-realm logged-in-username\r
+ drop permit-id get dup [ get-permit-uid ] when ;\r
\r
-: >>encoded-password ( user string -- user )\r
- 32 random-bits [ encode-password ] keep\r
- [ >>password ] [ >>salt ] bi* ; inline\r
+M: login-realm modify-form ( responder -- )\r
+ drop permit-id get realm get name>> permit-id-key hidden-form-field ;\r
\r
-: valid-login? ( password user -- ? )\r
- [ salt>> encode-password ] [ password>> ] bi = ;\r
+: <permit-cookie> ( -- cookie )\r
+ permit-id get realm get name>> permit-id-key <cookie>\r
+ "$login-realm" resolve-base-path >>path\r
+ realm get\r
+ [ timeout>> from-now >>expires ]\r
+ [ domain>> >>domain ]\r
+ [ secure>> >>secure ]\r
+ tri ;\r
\r
-: check-login ( password username -- user/f )\r
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
+: put-permit-cookie ( response -- response' )\r
+ <permit-cookie> put-cookie ;\r
\r
-! Destructor\r
-TUPLE: user-saver user ;\r
-\r
-C: <user-saver> user-saver\r
+: successful-login ( user -- response )\r
+ [ username>> make-permit permit-id set ] [ init-user ] bi\r
+ URL" $realm" end-aside\r
+ put-permit-cookie ;\r
\r
-M: user-saver dispose\r
- user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
+: logout ( -- )\r
+ permit-id get [ delete-permit ] when*\r
+ URL" $realm" end-aside ;\r
\r
-: save-user-after ( user -- )\r
- <user-saver> &dispose drop ;\r
+SYMBOL: description\r
+SYMBOL: capabilities\r
\r
-! ! ! Login\r
-: successful-login ( user -- response )\r
- username>> set-uid URL" $login" end-aside ;\r
+: flashed-variables { description capabilities } ;\r
\r
: login-failed ( -- * )\r
"invalid username or password" validation-error\r
: <login-action> ( -- action )\r
<page-action>\r
[\r
- protected fget [\r
- [ description>> "description" set-value ]\r
- [ capabilities>> words>strings "capabilities" set-value ] bi\r
- ] when*\r
+ flashed-variables restore-flash\r
+ description get "description" set-value\r
+ capabilities get words>strings "capabilities" set-value\r
] >>init\r
\r
- { login "login" } >>template\r
+ { login-realm "login" } >>template\r
\r
[\r
{\r
"password" value\r
"username" value check-login\r
[ successful-login ] [ login-failed ] if*\r
- ] >>submit ;\r
-\r
-! ! ! New user registration\r
-\r
-: user-exists ( -- * )\r
- "username taken" validation-error\r
- validation-failed ;\r
-\r
-: password-mismatch ( -- * )\r
- "passwords do not match" validation-error\r
- validation-failed ;\r
-\r
-: same-password-twice ( -- )\r
- "new-password" value "verify-password" value =\r
- [ password-mismatch ] unless ;\r
-\r
-: <register-action> ( -- action )\r
- <page-action>\r
- { login "register" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- { "email" [ [ v-email ] v-optional ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "username" value <user>\r
- "realname" value >>realname\r
- "new-password" value >>encoded-password\r
- "email" value >>email\r
- H{ } clone >>profile\r
-\r
- users new-user [ user-exists ] unless*\r
-\r
- login get init-user-profile\r
-\r
- successful-login\r
- ] >>submit ;\r
-\r
-! ! ! Editing user profile\r
-\r
-: <edit-profile-action> ( -- action )\r
- <page-action>\r
- [\r
- logged-in-user get\r
- [ username>> "username" set-value ]\r
- [ realname>> "realname" set-value ]\r
- [ email>> "email" set-value ]\r
- tri\r
- ] >>init\r
-\r
- { login "edit-profile" } >>template\r
-\r
- [\r
- uid "username" set-value\r
-\r
- {\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "password" [ ] }\r
- { "new-password" [ [ v-password ] v-optional ] }\r
- { "verify-password" [ [ v-password ] v-optional ] } \r
- { "email" [ [ v-email ] v-optional ] }\r
- } validate-params\r
-\r
- { "password" "new-password" "verify-password" }\r
- [ value empty? not ] contains? [\r
- "password" value uid check-login\r
- [ "incorrect password" validation-error ] unless\r
-\r
- same-password-twice\r
- ] when\r
- ] >>validate\r
-\r
- [\r
- logged-in-user get\r
-\r
- "new-password" value dup empty?\r
- [ drop ] [ >>encoded-password ] if\r
-\r
- "realname" value >>realname\r
- "email" value >>email\r
-\r
- t >>changed?\r
-\r
- drop\r
-\r
- URL" $login" end-aside\r
- ] >>submit ;\r
-\r
-! ! ! Password recovery\r
+ ] >>submit\r
+ <auth-boilerplate>\r
+ <secure-realm-only> ;\r
\r
-SYMBOL: lost-password-from\r
-\r
-: current-host ( -- string )\r
- request get url>> host>> host-name or ;\r
-\r
-: new-password-url ( user -- url )\r
- "recover-3"\r
- swap [\r
- [ username>> "username" set ]\r
- [ ticket>> "ticket" set ]\r
- bi\r
- ] H{ } make-assoc\r
- derive-url ;\r
-\r
-: password-email ( user -- email )\r
- smtp:<email>\r
- [ "[ " % current-host % " ] password recovery" % ] "" make >>subject\r
- lost-password-from get >>from\r
- over email>> 1array >>to\r
- [\r
- "This e-mail was sent by the application server on " % current-host % "\n" %\r
- "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %\r
- "login form, and requested a new password for the user named ``" %\r
- over username>> % "''.\n" %\r
- "\n" %\r
- "If you believe that this request was legitimate, you may click the below link in\n" %\r
- "your browser to set a new password for your account:\n" %\r
- "\n" %\r
- swap new-password-url %\r
- "\n\n" %\r
- "Love,\n" %\r
- "\n" %\r
- " FactorBot\n" %\r
- ] "" make >>body ;\r
-\r
-: send-password-email ( user -- )\r
- '[ , password-email smtp:send-email ]\r
- "E-mail send thread" spawn drop ;\r
-\r
-: <recover-action-1> ( -- action )\r
- <page-action>\r
- { login "recover-1" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "email" [ v-email ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
- ] >>validate\r
-\r
- [\r
- "email" value "username" value\r
- users issue-ticket [\r
- send-password-email\r
- ] when*\r
-\r
- URL" $login/recover-2" <redirect>\r
- ] >>submit ;\r
-\r
-: <recover-action-2> ( -- action )\r
- <page-action>\r
- { login "recover-2" } >>template ;\r
-\r
-: <recover-action-3> ( -- action )\r
- <page-action>\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- } validate-params\r
- ] >>init\r
-\r
- { login "recover-3" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "ticket" value\r
- "username" value\r
- users claim-ticket [\r
- "new-password" value >>encoded-password\r
- users update-user\r
-\r
- URL" $login/recover-4" <redirect>\r
- ] [\r
- <403>\r
- ] if*\r
- ] >>submit ;\r
-\r
-: <recover-action-4> ( -- action )\r
- <page-action>\r
- { login "recover-4" } >>template ;\r
-\r
-! ! ! Logout\r
: <logout-action> ( -- action )\r
<action>\r
- [\r
- f set-uid\r
- URL" $login" end-aside\r
- ] >>submit ;\r
-\r
-! ! ! Authentication logic\r
-: <protected> ( responder -- protected )\r
- protected new\r
- swap >>responder ;\r
+ [ logout ] >>submit\r
+ <protected>\r
+ "logout" >>description ;\r
\r
-: show-login-page ( -- response )\r
+M: login-realm login-required*\r
+ drop\r
begin-aside\r
- URL" $login/login" { protected } <flash-redirect> ;\r
-\r
-: check-capabilities ( responder user -- ? )\r
- [ capabilities>> ] bi@ subset? ;\r
-\r
-M: protected call-responder* ( path responder -- response )\r
- dup protected set\r
- uid dup [\r
- users get-user 2dup check-capabilities [\r
- [ logged-in-user set ] [ save-user-after ] bi\r
- call-next-method\r
- ] [\r
- 3drop show-login-page\r
- ] if\r
- ] [\r
- 3drop show-login-page\r
- ] if ;\r
-\r
-M: login call-responder* ( path responder -- response )\r
- dup login set\r
- call-next-method ;\r
-\r
-: <login-boilerplate> ( responder -- responder' )\r
- <boilerplate>\r
- { login "boilerplate" } >>template ;\r
-\r
-: <login> ( responder -- auth )\r
- login new-dispatcher\r
- swap >>default\r
- <login-action> <login-boilerplate> "login" add-responder\r
- <logout-action> <login-boilerplate> "logout" add-responder\r
- users-in-db >>users\r
- sha-256 >>checksum ;\r
-\r
-! ! ! Configuration\r
-\r
-: allow-edit-profile ( login -- login )\r
- <edit-profile-action> <protected>\r
- "edit your profile" >>description\r
- <login-boilerplate>\r
- "edit-profile" add-responder ;\r
-\r
-: allow-registration ( login -- login )\r
- <register-action> <login-boilerplate>\r
- "register" add-responder ;\r
-\r
-: allow-password-recovery ( login -- login )\r
- <recover-action-1> <login-boilerplate>\r
- "recover-password" add-responder\r
- <recover-action-2> <login-boilerplate>\r
- "recover-2" add-responder\r
- <recover-action-3> <login-boilerplate>\r
- "recover-3" add-responder\r
- <recover-action-4> <login-boilerplate>\r
- "recover-4" add-responder ;\r
-\r
-: allow-edit-profile? ( -- ? )\r
- login get responders>> "edit-profile" swap key? ;\r
-\r
-: allow-registration? ( -- ? )\r
- login get responders>> "register" swap key? ;\r
-\r
-: allow-password-recovery? ( -- ? )\r
- login get responders>> "recover-password" swap key? ;\r
+ protected get description>> description set\r
+ protected get capabilities>> capabilities set\r
+ URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;\r
+\r
+: <login-realm> ( responder name -- auth )\r
+ login-realm new-realm\r
+ <login-action> "login" add-responder\r
+ <logout-action> "logout" add-responder\r
+ 20 minutes >>timeout ;\r
</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>
--- /dev/null
+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 ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 1 of 4</t:title>
-
- <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">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
- </tr>
-
- </table>
-
- <input type="submit" value="Recover password" />
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 2 of 4</t:title>
-
- <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 3 of 4</t:title>
-
- <p>Choose a new password for your account.</p>
-
- <t:form t:action="new-password">
-
- <table>
-
- <t:hidden t:name="username" />
- <t:hidden t:name="ticket" />
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify password:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Set password" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>\r
-\r
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
-\r
- <t:title>Recover lost password: step 4 of 4</t:title>\r
-\r
- <p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>\r
-\r
-</t:chloe>\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New User Registration</t:title>
-
- <t:form t:action="register">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
-
- </table>
-
- <p>
-
- <input type="submit" value="Register" />
- <t:validation-messages />
-
- </p>
-
- </t:form>
-
-</t:chloe>
IN: furnace.auth.providers.assoc.tests\r
-USING: furnace.actions furnace.auth.providers \r
+USING: furnace.actions furnace.auth furnace.auth.providers \r
furnace.auth.providers.assoc furnace.auth.login\r
tools.test namespaces accessors kernel ;\r
\r
-<action> <login>\r
+<action> "Test" <login-realm>\r
<users-in-memory> >>users\r
-login set\r
+realm set\r
\r
[ t ] [\r
"slava" <user>\r
IN: furnace.auth.providers.db.tests\r
USING: furnace.actions\r
+furnace.auth\r
furnace.auth.login\r
furnace.auth.providers\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
io.files accessors kernel ;\r
\r
-<action> <login>\r
- users-in-db >>users\r
-login set\r
+<action> "test" <login-realm> realm set\r
\r
[ "auth-test.db" temp-file delete-file ] ignore-errors\r
\r
"auth-test.db" temp-file sqlite-db [\r
\r
- init-users-table\r
+ user ensure-table\r
\r
[ t ] [\r
"slava" <user>\r
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
-: init-users-table ( -- ) user ensure-table ;
-
SINGLETON: users-in-db
M: users-in-db get-user
! 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 |
[
--- /dev/null
+! 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 ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors continuations namespaces destructors\r
-db db.pools io.pools http.server http.server.filters\r
-furnace.sessions ;\r
+db db.pools io.pools http.server http.server.filters ;\r
IN: furnace.db\r
\r
TUPLE: db-persistence < filter-responder pool ;\r
! 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 ;
-M: flash-scopes call-responder*
- flash-id-key
- request get request-params at
- flash-scopes sget at flash-scope set
- call-next-method ;
+: 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 init-session*
- H{ } clone flash-scopes sset
+M: flash-scopes call-responder*
+ 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 ;
xml.writer
html.components
html.elements
+html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
: 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' )
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 ;
] }
} 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 -- )
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 ;
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 ]
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
--- /dev/null
+! 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 ;
--- /dev/null
+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> ;
IN: furnace.sessions.tests\r
USING: tools.test http furnace.sessions\r
furnace.actions http.server http.server.responses\r
-math namespaces kernel accessors\r
+math namespaces kernel accessors io.sockets io.servers.connection\r
prettyprint io.streams.string io.files splitting destructors\r
-sequences db db.sqlite continuations urls math.parser\r
+sequences db db.tuples db.sqlite continuations urls math.parser\r
furnace ;\r
\r
: with-session\r
"auth-test.db" temp-file sqlite-db [\r
\r
<request> init-request\r
- init-sessions-table\r
+ session ensure-table\r
+\r
+ "127.0.0.1" 1234 <inet4> remote-address set\r
\r
[ ] [\r
<foo> <sessions>\r
! 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 -- )
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 ;
[ 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 )
: 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 ;
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;
-
-: logout-all-sessions ( uid -- )
- session new swap >>uid delete-tuples ;
--- /dev/null
+! 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 ;
! 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
: 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 ;
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
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
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "new york" "city1" set-value ] unit-test
] with-null-writer
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ t "delivery" set-value ] unit-test
[ ] [ "-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
=
] 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
! 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
[ 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
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
: 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 ;
: 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 ;
: 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 ;
: define-attribute-word ( name -- )
dup "=" prepend swap
- [ write-attr ] curry (( string -- )) html-word ;
+ '[ , write-attr ] (( string -- )) html-word ;
! Define some closed HTML tags
[
--- /dev/null
+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
--- /dev/null
+! 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 ;
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
[ 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
] run-template
] unit-test
-[ ] [ blank-values ] unit-test
+[ ] [ begin-form ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
[ ] [ 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>" ] [
] unit-test
[ ] [
- blank-values
+ begin-form
{ "a" "b" } "choices" set-value
"true" "b" set-value
] unit-test
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
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 ;
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 ;
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
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"
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"
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 ;
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
[
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" } }
] 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" } }
;
-[ 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
[ 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>
[ test-db drop delete-file ] ignore-errors
test-db [
- init-sessions-table
+ init-furnace-tables
] with-db
[ ] [
[
<dispatcher>
<action> <protected>
- <login>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
- <login>
+ "Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
[ "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
[ 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
! 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 => , ;
: 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 )
{
: 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 ;
+: parse-cookie ( string -- seq )
+ [
+ f swap
+ (parse-cookie)
+ [
+ swap {
+ { "$version" [ >>version ] }
+ { "$domain" [ >>domain ] }
+ { "$path" [ >>path ] }
+ [ <cookie> dup , nip ]
+ } case
+ ] assoc-each
drop
] { } make ;
-: (unparse-cookie) ( key value -- )
+: 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
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 ;
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 ;
: 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 ;
: 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 =
[ 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 )
: write-request ( request -- )
unparse-post-data
- write-method
- write-request-url
- write-version
+ write-request-line
write-request-header
write-post-data
flush
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 ]
: 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 ]
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 ;
"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 ;
--- /dev/null
+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 ;
http accessors sequences strings math.parser fry urls ;\r
IN: http.server.cgi\r
\r
-: post? ( -- ? ) request get method>> "POST" = ;\r
-\r
: cgi-variables ( script-path -- assoc )\r
#! This needs some work.\r
[\r
request get "user-agent" header "HTTP_USER_AGENT" set\r
request get "accept" header "HTTP_ACCEPT" set\r
\r
- post? [\r
+ post-request? [\r
request get post-data>> raw>>\r
[ "CONTENT_TYPE" set ]\r
[ length number>string "CONTENT_LENGTH" set ]\r
"CGI output follows" >>message\r
swap '[\r
, output-stream get swap <cgi-process> <process-stream> [\r
- post? [ request get post-data>> raw>> write flush ] when\r
+ post-request? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
] >>body ;\r
! 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
! 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 )
: <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 ;
: 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 ;
+
+LOG: httpd-benchmark DEBUG
+
+: ?benchmark ( quot -- )
+ benchmark? get [
+ [ benchmark ] [ first ] bi request get url>> rot 3array
+ httpd-benchmark
+ ] [ call ] if ; inline
-: setup-limits ( -- )
- 1 minutes timeouts
- 64 1024 * limit-input ;
+TUPLE: http-server < threaded-server ;
-: handle-client ( -- )
+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 ;
-: httpd ( port -- )
- dup integer? [ internet-server ] when
- "http.server" binary [ handle-client ] with-server ;
+: <http-server> ( -- server )
+ http-server new-threaded-server
+ "http.server" >>name
+ "http" protocol-port >>insecure
+ "https" protocol-port >>secure ;
-: httpd-main ( -- )
- 8888 httpd ;
+: httpd ( port -- )
+ <http-server>
+ swap >>insecure
+ f >>secure
+ start-server ;
-MAIN: httpd-main
+: http-insomniac ( -- )
+ "http.server" { "httpd-hit" } schedule-insomniac ;
"index.html" append-path dup exists? [ drop f ] unless ;\r
\r
: serve-directory ( filename -- response )\r
- request get path>> "/" tail? [\r
+ request get url>> path>> "/" tail? [\r
dup\r
find-index [ serve-file ] [ list-directory ] ?if\r
] [\r
<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
[ 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
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
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 -- )
! 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
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
- connections>> [ delete-all ] [ dispose-each ] bi
+ connections>> delete-all
] [ drop ] if ;
: <pool> ( class -- pool )
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
+ dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;
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." } ;
: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
-: can-write? ( len buffer -- ? )
- [ buffer-fill + ] keep buffer-capacity <= ;
-
: wait-to-write ( len port -- )
- tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
+ tuck buffer>> buffer-capacity <=
+ [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
dup check-disposed
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help help.syntax help.markup io ;
-IN: io.server
-
-HELP: with-server
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } }
-{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ;
-
-HELP: with-datagrams
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
-{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ;
+++ /dev/null
-IN: io.server.tests
-USING: tools.test io.server io.server.private kernel ;
-
-{ 2 0 } [ [ ] server-loop ] must-infer-as
-{ 2 0 } [ [ ] with-connection ] must-infer-as
-{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
-{ 2 0 } [ [ ] with-datagrams ] must-infer-as
+++ /dev/null
-! Copyright (C) 2003, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.sockets io.sockets.secure io.files
-io.streams.duplex logging continuations destructors kernel math
-math.parser namespaces parser sequences strings prettyprint
-debugger quotations calendar threads concurrency.combinators
-assocs fry ;
-IN: io.server
-
-SYMBOL: servers
-
-SYMBOL: remote-address
-
-<PRIVATE
-
-LOG: accepted-connection NOTICE
-
-: with-connection ( client remote quot -- )
- '[
- , [ remote-address set ] [ accepted-connection ] bi
- @
- ] with-stream ; inline
-
-\ with-connection DEBUG add-error-logging
-
-: accept-loop ( server quot -- )
- [
- >r accept r> '[ , , , with-connection ] "Client" spawn drop
- ] 2keep accept-loop ; inline
-
-: server-loop ( addrspec encoding quot -- )
- >r <server> dup servers get push r>
- '[ , accept-loop ] with-disposal ; inline
-
-\ server-loop NOTICE add-error-logging
-
-PRIVATE>
-
-: local-server ( port -- seq )
- "localhost" swap t resolve-host ;
-
-: internet-server ( port -- seq )
- f swap t resolve-host ;
-
-: secure-server ( port -- seq )
- internet-server [ <secure> ] map ;
-
-: with-server ( seq service encoding quot -- )
- V{ } clone servers [
- '[ , [ , , server-loop ] with-logging ] parallel-each
- ] with-variable ; inline
-
-: stop-server ( -- )
- servers get dispose-each ;
-
-<PRIVATE
-
-LOG: received-datagram NOTICE
-
-: datagram-loop ( quot datagram -- )
- [
- [ receive dup received-datagram >r swap call r> ] keep
- pick [ send ] [ 3drop ] if
- ] 2keep datagram-loop ; inline
-
-: spawn-datagrams ( quot addrspec -- )
- <datagram> [ datagram-loop ] with-disposal ; inline
-
-\ spawn-datagrams NOTICE add-input-logging
-
-PRIVATE>
-
-: with-datagrams ( seq service quot -- )
- '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
+++ /dev/null
-TCP/IP and UDP/IP servers
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help help.syntax help.markup io ;
+IN: io.servers.connection
--- /dev/null
+IN: io.servers.connection
+USING: tools.test io.servers.connection io.sockets namespaces
+io.servers.connection.private kernel accessors sequences
+concurrency.promises io.encodings.ascii io threads calendar ;
+
+[ t ] [ <threaded-server> listen-on empty? ] unit-test
+
+[ f ] [
+ <threaded-server>
+ 25 internet-server >>insecure
+ listen-on
+ empty?
+] unit-test
+
+[ t ] [
+ T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
+ [ log-connection ] 2keep
+ [ remote-address get = ] [ local-address get = ] bi*
+ and
+] unit-test
+
+[ ] [ <threaded-server> init-server drop ] unit-test
+
+[ 10 ] [
+ <threaded-server>
+ 10 >>max-connections
+ init-server semaphore>> count>>
+] unit-test
+
+[ ] [ <promise> "p" set ] unit-test
+
+[ ] [
+ [
+ <threaded-server>
+ 5 >>max-connections
+ 1237 >>insecure
+ [ "Hello world." write stop-server ] >>handler
+ start-server
+ t "p" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
+
+[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test
--- /dev/null
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations destructors kernel math math.parser
+namespaces parser sequences strings prettyprint debugger
+quotations combinators combinators.lib logging calendar assocs
+fry accessors arrays io io.sockets io.encodings.ascii
+io.sockets.secure io.files io.streams.duplex io.timeouts
+io.encodings threads concurrency.combinators
+concurrency.semaphores ;
+IN: io.servers.connection
+
+TUPLE: threaded-server
+name
+secure insecure
+secure-config
+sockets
+max-connections
+semaphore
+timeout
+encoding
+handler ;
+
+: local-server ( port -- addrspec ) "localhost" swap <inet> ;
+
+: internet-server ( port -- addrspec ) f swap <inet> ;
+
+: new-threaded-server ( class -- threaded-server )
+ new
+ "server" >>name
+ ascii >>encoding
+ 1 minutes >>timeout
+ V{ } clone >>sockets
+ <secure-config> >>secure-config
+ [ "No handler quotation" throw ] >>handler ; inline
+
+: <threaded-server> ( -- threaded-server )
+ threaded-server new-threaded-server ;
+
+SYMBOL: remote-address
+
+GENERIC: handle-client* ( server -- )
+
+<PRIVATE
+
+: >insecure ( addrspec -- addrspec' )
+ dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
+
+: >secure ( addrspec -- addrspec' )
+ >insecure
+ dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
+
+: listen-on ( threaded-server -- addrspecs )
+ [ secure>> >secure ] [ insecure>> >insecure ] bi
+ [ resolve-host ] bi@ append ;
+
+LOG: accepted-connection NOTICE
+
+: log-connection ( remote local -- )
+ [ [ remote-address set ] [ local-address set ] bi* ]
+ [ 2array accepted-connection ]
+ 2bi ;
+
+M: threaded-server handle-client* handler>> call ;
+
+: handle-client ( client remote local -- )
+ '[
+ , , log-connection
+ threaded-server get
+ [ timeout>> timeouts ] [ handle-client* ] bi
+ ] with-stream ;
+
+: thread-name ( server-name addrspec -- string )
+ unparse " connection from " swap 3append ;
+
+: accept-connection ( server -- )
+ [ accept ] [ addr>> ] bi
+ [ '[ , , , handle-client ] ]
+ [ drop threaded-server get name>> swap thread-name ] 2bi
+ spawn drop ;
+
+: accept-loop ( server -- )
+ [
+ threaded-server get semaphore>>
+ [ [ accept-connection ] with-semaphore ]
+ [ accept-connection ]
+ if*
+ ] [ accept-loop ] bi ; inline
+
+: start-accept-loop ( server -- )
+ threaded-server get encoding>> <server>
+ [ threaded-server get sockets>> push ]
+ [ [ accept-loop ] with-disposal ]
+ bi ;
+
+\ start-accept-loop ERROR add-error-logging
+
+: init-server ( threaded-server -- threaded-server )
+ dup semaphore>> [
+ dup max-connections>> [
+ <semaphore> >>semaphore
+ ] when*
+ ] unless ;
+
+PRIVATE>
+
+: start-server ( threaded-server -- )
+ init-server
+ dup secure-config>> [
+ dup threaded-server [
+ dup name>> [
+ listen-on [
+ start-accept-loop
+ ] parallel-each
+ ] with-logging
+ ] with-variable
+ ] with-secure-context ;
+
+: stop-server ( -- )
+ threaded-server get [ f ] change-sockets drop dispose-each ;
+
+GENERIC: port ( addrspec -- n )
+
+M: integer port ;
+
+M: object port port>> ;
+
+: secure-port ( -- n )
+ threaded-server get dup [ secure>> port ] when ;
+
+: insecure-port ( -- n )
+ threaded-server get dup [ insecure>> port ] when ;
--- /dev/null
+Multi-threaded TCP/IP servers
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: io.servers.datagram
+
+<PRIVATE
+
+LOG: received-datagram NOTICE
+
+: datagram-loop ( quot datagram -- )
+ [
+ [ receive dup received-datagram [ swap call ] dip ] keep
+ pick [ send ] [ 3drop ] if
+ ] 2keep datagram-loop ; inline
+
+: spawn-datagrams ( quot addrspec -- )
+ <datagram> [ datagram-loop ] with-disposal ; inline
+
+\ spawn-datagrams NOTICE add-input-logging
+
+PRIVATE>
+
+: with-datagrams ( seq service quot -- )
+ '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
--- /dev/null
+Multi-threaded UDP/IP servers
-! No unit tests here, until Windows SSL is implemented
+IN: io.sockets.secure.tests
+USING: accessors kernel io.sockets io.sockets.secure tools.test ;
+
+[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
-destructors io.sockets sequences inspector calendar ;
+destructors io.sockets sequences inspector calendar delegate ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
C: <secure> secure
-: resolve-secure-host ( host port passive? -- seq )
- resolve-host [ <secure> ] map ;
+CONSULT: inet secure addrspec>> ;
+
+M: secure resolve-host ( secure -- seq )
+ addrspec>> resolve-host [ <secure> ] map ;
HOOK: check-certificate secure-socket-backend ( host handle -- )
M: secure-inet (client)
[
- addrspec>>
- [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
- host>> pick handle>> check-certificate
+ [ resolve-host (client) [ |dispose ] dip ] keep
+ addrspec>> host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE>
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
}
-"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
+"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
{ $see-also "io.sockets.secure" } ;
ARTICLE: "network-packet" "Packet-oriented networking"
HELP: inet4
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
{ $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
+"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
}
{ $examples
{ $code "\"127.0.0.1\" 8080 <inet4>" }
HELP: inet6
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
{ $notes
-"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
+"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." }
{ $examples
{ $code "\"::1\" 8080 <inet6>" }
} ;
}
{ $notes
"To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "f 1234 t resolve-host" }
+ { $code "f 1234 <inet> resolve-host" }
"To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "\"localhost\" 1234 t resolve-host" }
- "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
+ { $code "\"localhost\" 1234 <inet> resolve-host" }
+ "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this."
$nl
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
{ $unchecked-example
}
{ $notes
"To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "f 1234 t resolve-host" }
+ { $code "f 1234 <inet> resolve-host" }
"To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
- { $code "\"localhost\" 1234 t resolve-host" }
+ { $code "\"localhost\" 1234 <inet> resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
"Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
}
{ $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } }
{ $description "Sends a packet to the given address." }
{ $errors "Throws an error if the packet could not be sent." } ;
+
+HELP: resolve-host
+{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
+{ $description "Resolves host names to IP addresses." } ;
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
-[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
+[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
[ addrinfo>addrspec ] map
sift ;
-: prepare-resolve-host ( host serv passive? -- host' serv' flags )
+: prepare-resolve-host ( addrspec -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
- >r
- dup integer? [ port-override set "http" ] when
- r> AI_PASSIVE 0 ? ;
+ [ host>> ]
+ [ port>> dup integer? [ port-override set "http" ] when ] bi
+ over 0 AI_PASSIVE ? ;
HOOK: addrinfo-error io-backend ( n -- )
-: resolve-host ( host serv passive? -- seq )
+GENERIC: resolve-host ( addrspec -- seq )
+
+TUPLE: inet host port ;
+
+C: <inet> inet
+
+M: inet resolve-host
[
prepare-resolve-host
"addrinfo" <c-object>
freeaddrinfo
] with-scope ;
+M: f resolve-host drop { } ;
+
+M: object resolve-host 1array ;
+
: host-name ( -- string )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;
-TUPLE: inet host port ;
-
-C: <inet> inet
-
-M: inet (client)
- [ host>> ] [ port>> ] bi f resolve-host (client) ;
+M: inet (client) resolve-host (client) ;
ERROR: invalid-inet-server addrspec ;
accessors delegate delegate.protocols ;
IN: io.streams.duplex
-! We ensure that the stream can only be closed once, to preserve
-! integrity of duplex I/O ports.
-
TUPLE: duplex-stream in out ;
C: <duplex-stream> duplex-stream
[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
+
+[ "he" CHAR: l ] [
+ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
+ ascii <byte-reader> [
+ 5 limit-input
+ "l" read-until
+ ] with-input-stream
+] unit-test
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io destructors accessors sequences
-namespaces ;
+USING: kernel math io io.encodings destructors accessors
+sequences namespaces ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit ;
swap >>stream
0 >>count ;
-: limit-input ( limit -- )
- input-stream [ swap <limited-stream> ] change ;
+GENERIC# limit 1 ( stream limit -- stream' )
+
+M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
+
+M: object limit <limited-stream> ;
+
+: limit-input ( limit -- ) input-stream [ swap limit ] change ;
ERROR: limit-exceeded ;
GENERIC: add-input-callback ( thread fd mx -- )
-: add-callback ( thread fd assoc -- )
- [ ?push ] change-at ;
-
-M: mx add-input-callback reads>> add-callback ;
+M: mx add-input-callback reads>> push-at ;
GENERIC: add-output-callback ( thread fd mx -- )
-M: mx add-output-callback writes>> add-callback ;
+M: mx add-output-callback writes>> push-at ;
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
] when* ;
: redirect-fd ( oldfd fd -- )
- 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
+ 2dup = [ 2drop ] [ dup2 io-error ] if ;
: reset-fd ( fd -- )
#! We drop the error code because on *BSD, fcntl of
[ ] [ <promise> "port" set ] unit-test
-: with-test-context
+: with-test-context ( quot -- )
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >>password
- swap with-secure-context ;
+ swap with-secure-context ; inline
:: server-test ( quot -- )
[
] with-test-context
] "SSL server test" spawn drop ;
-: client-test
+: client-test ( -- string )
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context ;
dup dup handle>> SSL_connect check-connect-response dup
[ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
+: resume-session ( ssl-handle ssl-session -- )
+ [ [ handle>> ] dip SSL_set_session ssl-error ]
+ [ drop do-ssl-connect ]
+ 2bi ;
+
+: begin-session ( ssl-handle addrspec -- )
+ [ drop do-ssl-connect ]
+ [ [ handle>> SSL_get1_session ] dip save-session ]
+ 2bi ;
+
+: secure-connection ( ssl-handle addrspec -- )
+ dup get-session [ resume-session ] [ begin-session ] ?if ;
+
M: secure establish-connection ( client-out remote -- )
- [ addrspec>> establish-connection ]
+ addrspec>>
+ [ establish-connection ]
[
- drop handle>>
- [ [ do-ssl-connect ] with-timeout ]
- [ t >>connected drop ]
- bi
+ [ handle>> ] dip
+ [ [ secure-connection ] curry with-timeout ]
+ [ drop t >>connected drop ]
+ 2bi
] 2bi ;
M: secure (server) addrspec>> (server) ;
! Computing a basis
: graded ( seq -- seq )
- dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map
+ dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
+\ lcs must-infer
+\ diff must-infer
+\ levenshtein must-infer
+
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
[ 1- ] change-i [ 1- ] change-j ;\r
\r
: inserted? ( state -- ? )\r
- [ j>> 0 > ]\r
- [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;\r
+ {\r
+ [ j>> 0 > ]\r
+ [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]\r
+ } 1&& ;\r
\r
: do-insert ( state -- state )\r
dup new-nth insert boa , [ 1- ] change-j ;\r
\r
: deleted? ( state -- ? )\r
- [ i>> 0 > ]\r
- [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;\r
+ {\r
+ [ i>> 0 > ]\r
+ [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]\r
+ } 1&& ;\r
\r
: do-delete ( state -- state )\r
dup old-nth delete boa , [ 1- ] change-i ;\r
\r
<PRIVATE\r
\r
-PREDICATE: one-string-array < array\r
- [ length 1 = ] [ [ string? ] all? ] bi and ;\r
-\r
: stack>message ( obj -- inputs>message )\r
- dup one-string-array? [ first ] [\r
+ dup array? [ dup length 1 = [ first ] when ] when\r
+ dup string? [\r
[\r
string-limit off\r
1 line-limit set\r
0 margin set\r
unparse\r
] with-scope\r
- ] if ;\r
+ ] unless ;\r
\r
PRIVATE>\r
\r
USING: kernel math math.functions ;
IN: math.quadratic
-: monic ( c b a -- c' b' ) tuck / >r / r> ;
+: monic ( c b a -- c' b' ) tuck [ / ] 2bi@ ;
: discriminant ( c b -- b d ) tuck sq 4 / swap - sqrt ;
-: critical ( b d -- -b/2 d ) >r -2 / r> ;
+: critical ( b d -- -b/2 d ) [ -2 / ] dip ;
-: +- ( x y -- x+y x-y ) [ + ] 2keep - ;
+: +- ( x y -- x+y x-y ) [ + ] [ - ] 2bi ;
: quadratic ( c b a -- alpha beta )
#! Solve a quadratic equation ax^2 + bx + c = 0
: qeval ( x c b a -- y )
#! Evaluate ax^2 + bx + c
- >r pick * r> roll sq * + + ;
+ [ pick * ] dip roll sq * + + ;
-USING: kernel sequences assocs qualified circular ;
+USING: kernel sequences assocs qualified circular sets ;
USING: math multi-methods ;
QUALIFIED: sequences
QUALIFIED: assocs
QUALIFIED: circular
+QUALIFIED: sets
IN: newfx
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
-! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
+! indicate that this is the main objective of the word, as a side effect.
+
+: adjoin ( seq elt -- seq ) over sets:adjoin ;
+: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
+: adjoined ( set elt -- ) swap sets:adjoin ;
+: adjoined-on ( elt set -- ) sets:adjoin ;
\ No newline at end of file
! Copyright (C) 2007 Elie CHAFTARI
+! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-!
-! export LD_LIBRARY_PATH=/opt/local/lib
-
USING: alien alien.syntax combinators kernel system namespaces
-assocs parser sequences words quotations ;
+assocs parser sequences words quotations math.bitfields ;
IN: openssl.libssl
: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline
: SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline
-: SSL_CTRL_NEED_TMP_RSA 1 ; inline
-: SSL_CTRL_SET_TMP_RSA 2 ; inline
-: SSL_CTRL_SET_TMP_DH 3 ; inline
-: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
-: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
+: SSL_CTRL_NEED_TMP_RSA 1 ; inline
+: SSL_CTRL_SET_TMP_RSA 2 ; inline
+: SSL_CTRL_SET_TMP_DH 3 ; inline
+: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
+: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
+
+: SSL_CTRL_GET_SESSION_REUSED 6 ; inline
+: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 ; inline
+: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 ; inline
+: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 ; inline
+: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 ; inline
+: SSL_CTRL_GET_FLAGS 11 ; inline
+: SSL_CTRL_EXTRA_CHAIN_CERT 12 ; inline
+
+: SSL_CTRL_SET_MSG_CALLBACK 13 ; inline
+: SSL_CTRL_SET_MSG_CALLBACK_ARG 14 ; inline
+
+: SSL_CTRL_SESS_NUMBER 20 ; inline
+: SSL_CTRL_SESS_CONNECT 21 ; inline
+: SSL_CTRL_SESS_CONNECT_GOOD 22 ; inline
+: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23 ; inline
+: SSL_CTRL_SESS_ACCEPT 24 ; inline
+: SSL_CTRL_SESS_ACCEPT_GOOD 25 ; inline
+: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26 ; inline
+: SSL_CTRL_SESS_HIT 27 ; inline
+: SSL_CTRL_SESS_CB_HIT 28 ; inline
+: SSL_CTRL_SESS_MISSES 29 ; inline
+: SSL_CTRL_SESS_TIMEOUTS 30 ; inline
+: SSL_CTRL_SESS_CACHE_FULL 31 ; inline
+: SSL_CTRL_OPTIONS 32 ; inline
+: SSL_CTRL_MODE 33 ; inline
+
+: SSL_CTRL_GET_READ_AHEAD 40 ; inline
+: SSL_CTRL_SET_READ_AHEAD 41 ; inline
+: SSL_CTRL_SET_SESS_CACHE_SIZE 42 ; inline
+: SSL_CTRL_GET_SESS_CACHE_SIZE 43 ; inline
+: SSL_CTRL_SET_SESS_CACHE_MODE 44 ; inline
+: SSL_CTRL_GET_SESS_CACHE_MODE 45 ; inline
+
+: SSL_CTRL_GET_MAX_CERT_LIST 50 ; inline
+: SSL_CTRL_SET_MAX_CERT_LIST 51 ; inline
: SSL_ERROR_NONE 0 ; inline
: SSL_ERROR_SSL 1 ; inline
} ;
TYPEDEF: void* ssl-method
-TYPEDEF: void* ssl-ctx
-TYPEDEF: void* ssl-pointer
+TYPEDEF: void* SSL_CTX*
+TYPEDEF: void* SSL_SESSION*
+TYPEDEF: void* SSL*
LIBRARY: libssl
! ssl.h
! ===============================================
-FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ;
+FUNCTION: char* SSL_get_version ( SSL* ssl ) ;
! Maps OpenSSL errors to strings
FUNCTION: void SSL_load_error_strings ( ) ;
FUNCTION: ssl-method TLSv1_method ( ) ;
! Creates the context
-FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ;
+FUNCTION: SSL_CTX* SSL_CTX_new ( ssl-method method ) ;
! Load the certificates and private keys into the SSL_CTX
-FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx,
+FUNCTION: int SSL_CTX_use_certificate_chain_file ( SSL_CTX* ctx,
char* file ) ; ! PEM type
-FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ;
+FUNCTION: SSL* SSL_new ( SSL_CTX* ctx ) ;
+
+FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ;
-FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ;
+FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ;
-FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ;
+FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ;
-FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ;
+FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ;
-FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_set_connect_state ( SSL* ssl ) ;
-FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_set_accept_state ( SSL* ssl ) ;
-FUNCTION: int SSL_connect ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_connect ( SSL* ssl ) ;
-FUNCTION: int SSL_accept ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_accept ( SSL* ssl ) ;
-FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
+FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num ) ;
-FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
+FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num ) ;
-FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_shutdown ( SSL* ssl ) ;
: SSL_SENT_SHUTDOWN 1 ;
: SSL_RECEIVED_SHUTDOWN 2 ;
-FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ;
+
+FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, char* sid_ctx, uint len ) ;
+
+FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ;
+
+FUNCTION: void SSL_free ( SSL* ssl ) ;
-FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
+FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ;
-FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
+FUNCTION: int SSL_want ( SSL* ssl ) ;
: SSL_NOTHING 1 ; inline
: SSL_WRITING 2 ; inline
FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ;
-FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ;
+FUNCTION: void SSL_CTX_free ( SSL_CTX* ctx ) ;
FUNCTION: void RAND_seed ( void* buf, int num ) ;
-FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ;
+FUNCTION: int SSL_set_cipher_list ( SSL* ssl, char* str ) ;
-FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ;
+FUNCTION: int SSL_use_RSAPrivateKey_file ( SSL* ssl, char* str ) ;
-FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ;
+FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( SSL_CTX* ctx, int type ) ;
-FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
+FUNCTION: int SSL_use_certificate_file ( SSL* ssl,
char* str, int type ) ;
-FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
+FUNCTION: int SSL_CTX_load_verify_locations ( SSL_CTX* ctx, char* CAfile,
char* CApath ) ;
-FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ;
+FUNCTION: int SSL_CTX_set_default_verify_paths ( SSL_CTX* ctx ) ;
: SSL_VERIFY_NONE 0 ; inline
: SSL_VERIFY_PEER 1 ; inline
: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
: SSL_VERIFY_CLIENT_ONCE 4 ; inline
-FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ;
+FUNCTION: void SSL_CTX_set_verify ( SSL_CTX* ctx, int mode, void* callback ) ;
-FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
+FUNCTION: void SSL_CTX_set_client_CA_list ( SSL_CTX* ctx, SSL* list ) ;
-FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
+FUNCTION: SSL* SSL_load_client_CA_file ( char* file ) ;
! Used to manipulate settings of the SSL_CTX and SSL objects.
! This function should never be called directly
-FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ;
+FUNCTION: long SSL_CTX_ctrl ( SSL_CTX* ctx, int cmd, long larg, void* parg ) ;
-FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ;
+FUNCTION: void SSL_CTX_set_default_passwd_cb ( SSL_CTX* ctx, void* cb ) ;
-FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx,
+FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( SSL_CTX* ctx,
void* u ) ;
-FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file,
+FUNCTION: int SSL_CTX_use_PrivateKey_file ( SSL_CTX* ctx, char* file,
int type ) ;
-! Sets the maximum depth for the allowed ctx certificate chain verification
-FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ;
+! Sets the maximum depth for the allowed ctx certificate chain verification
+FUNCTION: void SSL_CTX_set_verify_depth ( SSL_CTX* ctx, int depth ) ;
! Sets DH parameters to be used to be dh.
! The key is inherited by all ssl objects created from ctx
-FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ;
+FUNCTION: void SSL_CTX_set_tmp_dh_callback ( SSL_CTX* ctx, void* dh ) ;
-FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
+FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
+: SSL_CTX_set_session_cache_mode ( ctx mode -- n )
+ >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ;
+
+: SSL_SESS_CACHE_OFF HEX: 0000 ; inline
+: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline
+: SSL_SESS_CACHE_SERVER HEX: 0002 ; inline
+
+: SSL_SESS_CACHE_BOTH ( -- n )
+ { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
+
+: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 ; inline
+: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 ; inline
+: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 ; inline
+
+: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
+ { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
+
! ===============================================
! x509.h
! ===============================================
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
-continuations destructors debugger inspector splitting
-locals unicode.case
+continuations destructors debugger inspector splitting assocs
+random math.parser locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
io.timeouts ;
[ f ssl-initialized? set-global ] "openssl" add-init-hook
-TUPLE: openssl-context < secure-context aliens ;
+TUPLE: openssl-context < secure-context aliens sessions ;
+
+: set-session-cache ( ctx -- )
+ handle>>
+ [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
+ [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
+ bi ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
+: <openssl-context> ( config ctx -- context )
+ openssl-context new
+ swap >>handle
+ swap >>config
+ V{ } clone >>aliens
+ H{ } clone >>sessions ;
+
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
- dup ssl-error f V{ } clone openssl-context boa |dispose
+ dup ssl-error <openssl-context> |dispose
{
+ [ set-session-cache ]
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
M: openssl-context dispose*
[ aliens>> [ free ] each ]
+ [ sessions>> values [ SSL_SESSION_free ] each ]
[ handle>> SSL_CTX_free ]
- bi ;
+ tri ;
TUPLE: ssl-handle file handle connected disposed ;
2bi
] [ 2drop ] if ;
+: get-session ( addrspec -- session/f )
+ current-secure-context sessions>> at
+ dup expired? [ drop f ] when ;
+
+: save-session ( session addrspec -- )
+ current-secure-context sessions>> set-at ;
+
openssl secure-socket-backend set-global
: 1token ( ch -- parser ) 1string token ;
-<PRIVATE
: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
-PRIVATE>
: list-of ( items separator -- parser )
hide f (list-of) ;
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings fry namespaces math assocs shuffle
+USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order
unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
#! to fix boxes so this isn't needed...
box-parser boa next-id f <parser> over set-delegate [ ] action ;
+ERROR: parse-failed input word ;
+
+M: parse-failed error.
+ "The " write dup word>> pprint " word could not parse the following input:" print nl
+ input>> . ;
+
: PEG:
- (:) [
+ (:)
+ [let | def [ ] word [ ] |
[
- call compile [ compiled-parse ] curry
- [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
- append define
- ] with-compilation-unit
- ] 2curry over push-all ; parsing
+ [
+ [let | compiled-def [ def call compile ] |
+ [
+ dup compiled-def compiled-parse
+ [ ast>> ] [ word parse-failed ] ?if
+ ]
+ word swap define
+ ]
+ ] with-compilation-unit
+ ] over push-all
+ ] ; parsing
[ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
] each
-[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test
+[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
[ ] [ "1" get >vector "2" set ] unit-test
[ t ] [
: partial-sum-infimum ( seq -- seq )
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
-: generate ( n quot -- seq )
- [ drop ] prepose map ; inline
-
: map-infimum ( seq quot -- min )
[ min ] compose 0 swap reduce ; inline
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+ 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
PRIVATE>
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
-[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
[ find drop [ head-slice ] when* ] curry
[ dup ] prepose keep like ;
-: replicate ( seq quot -- newseq )
- #! quot: ( -- obj )
- [ drop ] prepose map ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
-: accumulator ( quot -- quot vec )
- V{ } clone [ [ push ] curry compose ] keep ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq
: short ( seq n -- seq n' )
over length min ; inline
-<PRIVATE
-:: insert ( seq quot n -- )
- n zero? [
- n n 1- [ seq nth quot call ] bi@ >= [
- n n 1- seq exchange
- seq quot n 1- insert
- ] unless
- ] unless ; inline
-PRIVATE>
-
-: insertion-sort ( seq quot -- )
- ! quot is a transformation on elements
- over length [ insert ] 2with each ; inline
-
: if-seq ( seq quot1 quot2 -- )
[ f like ] 2dip if* ; inline
! Copyright (C) 2007 Elie CHAFTARI
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel prettyprint io io.timeouts io.server
+USING: combinators kernel prettyprint io io.timeouts
sequences namespaces io.sockets continuations calendar
io.encodings.ascii io.streams.duplex destructors ;
IN: smtp.server
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+IN: sorting.insertion
+USING: sorting.insertion sequences kernel tools.test ;
+
+[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
--- /dev/null
+USING: locals sequences kernel math ;
+IN: sorting.insertion
+
+<PRIVATE
+:: insert ( seq quot n -- )
+ n zero? [
+ n n 1- [ seq nth quot call ] bi@ >= [
+ n n 1- seq exchange
+ seq quot n 1- insert
+ ] unless
+ ] unless ; inline
+PRIVATE>
+
+: insertion-sort ( seq quot -- )
+ ! quot is a transformation on elements
+ over length [ insert ] with with each ; inline
--- /dev/null
+Insertion sort
--- /dev/null
+collections
] if next ;\r
\r
: expect-string ( string -- )\r
- dup [ drop get-char next ] map 2dup =\r
+ dup [ get-char next ] replicate 2dup =\r
[ 2drop ] [ expected ] if ;\r
\r
: init-parser ( -- )\r
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
-[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
+[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
alphanumeric-chars random ;
: random-alphanumeric-string ( length -- str )
- [ drop random-alphanumeric-char ] map "" like ;
-
+ [ random-alphanumeric-char ] "" replicate-as ;
] with-tangle ;
: new-sandbox ( -- )
- development-mode on
+ development? on
delete-db sandbox-db f <tangle>
[ make-sandbox ] [ <tangle-dispatcher> ] bi
main-responder set ;
-USING: listener io.server io.encodings.utf8 ;
+USING: listener io.servers.connection io.encodings.utf8
+accessors kernel ;
IN: tty-server
-: tty-server ( port -- )
- local-server
- "tty-server"
- utf8 [ listener ] with-server ;
+: <tty-server> ( port -- )
+ <threaded-server>
+ "tty-server" >>name
+ utf8 >>encoding
+ swap local-server >>insecure
+ [ listener ] >>handler
+ start-server ;
-: default-tty-server ( -- ) 9999 tty-server ;
+: tty-server ( -- ) 9999 <tty-server> ;
-MAIN: default-tty-server
+MAIN: tty-server
! gadgets gets left-over space.
TUPLE: frame ;
-: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ;
+: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
: @center 1 1 ;
: @left 0 1 ;
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
- [ (extend)? ]
- [ "Other_Grapheme_Extend" property? ] or? ;
+ { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
: grapheme-class ( ch -- class )
{
} cond ;
: init-grapheme-table ( -- table )
- graphemes [ drop graphemes f <array> ] map ;
+ graphemes [ graphemes f <array> ] replicate ;
SYMBOL: table
HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;\r
\r
: illegal? ( char -- ? )\r
- [ "Noncharacter_Code_Point" property? ]\r
- [ category "Cs" = ] or? ;\r
+ { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;\r
\r
: derive-weight ( char -- weights )\r
first dup illegal?\r
USING: assocs math kernel sequences io.files hashtables
quotations splitting grouping arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii values interval-maps ascii sets assocs.lib
+io.encodings.ascii values interval-maps ascii sets
combinators.lib combinators locals math.ranges sorting ;
IN: unicode.data
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
- second [ empty? ] [ first ] or? ;
+ second { [ empty? ] [ first ] } 1|| ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
:: fill-ranges ( table -- table )
name-map >alist sort-values keys
- [ [ "first>" tail? ] [ "last>" tail? ] or? ] filter
+ [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
2 group [
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
[ swap table ?set-nth ] curry each
: properties>intervals ( properties -- assoc[str,interval] )
dup values prune [ f ] H{ } map>assoc
- [ [ insert-at ] curry assoc-each ] keep
+ [ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ;
: load-properties ( -- assoc )
USING: sequences namespaces unicode.data kernel math arrays
-locals combinators.lib sequences.lib combinators.lib ;
+locals combinators.lib sorting.insertion combinators.lib ;
IN: unicode.normalize
! Conjoining Jamo behavior
GENERIC: >url ( obj -- url )
+M: f >url drop <url> ;
+
M: url >url ;
M: string >url
USING: kernel sequences tools.test validators accessors
namespaces assocs ;
-: with-validation ( quot -- messages )
- [
- init-validation
- call
- validation-messages get
- named-validation-messages get >alist append
- ] with-scope ; inline
-
[ "" v-one-line ] must-fail
[ "hello world" ] [ "hello world" v-one-line ] unit-test
[ "hello\nworld" v-one-line ] must-fail
[ "4561_2612_1234_5467" v-credit-card ] must-fail
[ "4561-2621-1234-5467" v-credit-card ] must-fail
-
-
-[ 14 V{ } ] [
- [
- "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
- ] with-validation
-] unit-test
-
-[ f t ] [
- [
- "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
- ] with-validation first
- [ first "age" = ]
- [ second validation-error? ]
- [ second value>> "140" = ]
- tri and and
-] unit-test
-
-TUPLE: person name age ;
-
-person {
- { "name" [ ] }
- { "age" [ v-number 13 v-min-value 100 v-max-value ] }
-} define-validators
-
-[ t t ] [
- [
- { { "age" "" } } required-values
- validation-failed?
- ] with-validation first
- [ first "age" = ]
- [ second validation-error? ]
- [ second message>> "required" = ]
- tri and and
-] unit-test
-
-[ H{ { "a" 123 } } f V{ } ] [
- [
- H{
- { "a" "123" }
- { "b" "c" }
- { "c" "d" }
- }
- H{
- { "a" [ v-integer ] }
- } validate-values
- validation-failed?
- ] with-validation
-] unit-test
-
-[ t "foo" ] [
- [
- "foo" validation-error
- validation-failed?
- ] with-validation first message>>
-] unit-test
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences sequences.lib math
-namespaces sets math.parser math.ranges assocs regexp fry
-unicode.categories arrays hashtables words combinators mirrors
+namespaces sets math.parser math.ranges assocs regexp
+unicode.categories arrays hashtables words
classes quotations xmode.catalog ;
IN: validators
] [
"invalid credit card number format" throw
] if ;
-
-SYMBOL: validation-messages
-SYMBOL: named-validation-messages
-
-: init-validation ( -- )
- V{ } clone validation-messages set
- H{ } clone named-validation-messages set ;
-
-: (validation-message) ( obj -- )
- validation-messages get push ;
-
-: (validation-message-for) ( obj name -- )
- named-validation-messages get set-at ;
-
-TUPLE: validation-message message ;
-
-C: <validation-message> validation-message
-
-: validation-message ( string -- )
- <validation-message> (validation-message) ;
-
-: validation-message-for ( string name -- )
- [ <validation-message> ] dip (validation-message-for) ;
-
-TUPLE: validation-error message value ;
-
-C: <validation-error> validation-error
-
-: validation-error ( message -- )
- f <validation-error> (validation-message) ;
-
-: validation-error-for ( message value name -- )
- [ <validation-error> ] dip (validation-message-for) ;
-
-: validation-failed? ( -- ? )
- validation-messages get [ validation-error? ] contains?
- named-validation-messages get [ nip validation-error? ] assoc-contains?
- or ;
-
-: define-validators ( class validators -- )
- >hashtable "validators" set-word-prop ;
-
-: validate ( value name quot -- result )
- '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
-
-: required-values ( assoc -- )
- [ swap [ v-required ] validate drop ] assoc-each ;
-
-: validate-values ( assoc validators -- assoc' )
- swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;
| <t:a t:href="$blogs/by">My Posts</t:a>
| <t:a t:href="$blogs/new-post">New Post</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser
-urls validators html.components db.types db.tuples calendar
+urls validators db db.types db.tuples calendar present namespaces
+html.forms
+html.components
http.server.dispatchers
-furnace furnace.actions furnace.auth.login furnace.boilerplate
-furnace.sessions furnace.syndication ;
+furnace
+furnace.actions
+furnace.redirection
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.syndication ;
IN: webapps.blogs
TUPLE: blogs < dispatcher ;
+SYMBOL: can-administer-blogs?
+
+can-administer-blogs? define-capability
+
: view-post-url ( id -- url )
- number>string "$blogs/post/" prepend >url ;
+ present "$blogs/post/" prepend >url ;
: view-comment-url ( parent id -- url )
[ view-post-url ] dip >>anchor ;
: list-posts-url ( -- url )
- URL" $blogs/" ;
+ "$blogs/" >url ;
-: user-posts-url ( author -- url )
+: posts-by-url ( author -- url )
"$blogs/by/" prepend >url ;
TUPLE: entity id author date content ;
TUPLE: post < entity title comments ;
M: post feed-entry-title
- [ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
+ [ author>> ] [ title>> ] bi ": " swap 3append ;
M: post entity-url
id>> view-post-url ;
: <post> ( id -- post ) \ post new swap >>id ;
-: init-posts-table ( -- ) \ post ensure-table ;
-
TUPLE: comment < entity parent ;
comment "COMMENTS" {
swap >>id
swap >>parent ;
-: init-comments-table ( -- ) comment ensure-table ;
-
: post ( id -- post )
[ <post> select-tuple ] [ f <comment> select-tuples ] bi
>>comments ;
[ [ date>> ] compare invert-comparison ] sort ;
: validate-author ( -- )
- { { "author" [ [ v-username ] v-optional ] } } validate-params ;
+ { { "author" [ v-username ] } } validate-params ;
: list-posts ( -- posts )
f <post> "author" value >>author
- select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
+ select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
reverse-chronological-order ;
: <list-posts-action> ( -- action )
<page-action>
- [
- list-posts "posts" set-value
- ] >>init
-
+ [ list-posts "posts" set-value ] >>init
{ blogs "list-posts" } >>template ;
: <list-posts-feed-action> ( -- action )
[ list-posts ] >>entries
[ list-posts-url ] >>url ;
-: <user-posts-action> ( -- action )
+: <posts-by-action> ( -- action )
<page-action>
+
"author" >>rest
+
[
validate-author
list-posts "posts" set-value
] >>init
- { blogs "user-posts" } >>template ;
-: <user-posts-feed-action> ( -- action )
+ { blogs "posts-by" } >>template ;
+
+: <posts-by-feed-action> ( -- action )
<feed-action>
+ "author" >>rest
[ validate-author ] >>init
[ "Recent Posts by " "author" value append ] >>title
[ list-posts ] >>entries
- [ "author" value user-posts-url ] >>url ;
+ [ "author" value posts-by-url ] >>url ;
: <post-feed-action> ( -- action )
<feed-action>
+ "id" >>rest
[ validate-integer-id "id" value post "post" set-value ] >>init
[ "post" value feed-entry-title ] >>title
[ "post" value entity-url ] >>url
: <view-post-action> ( -- action )
<page-action>
+
"id" >>rest
[
"id" value
"new-comment" [
"parent" set-value
- ] nest-values
+ ] nest-form
] >>init
{ blogs "view-post" } >>template ;
: <new-post-action> ( -- action )
<page-action>
+
[
validate-post
- uid "author" set-value
+ logged-in-user get username>> "author" set-value
] >>validate
[
f <post>
- dup { "title" "content" } deposit-slots
- uid >>author
+ dup { "title" "content" } to-object
+ logged-in-user get username>> >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
- { blogs "new-post" } >>template ;
+ { blogs "new-post" } >>template
+
+ <protected>
+ "make a new blog post" >>description ;
+
+: authorize-author ( author -- )
+ logged-in-user get username>> =
+ can-administer-blogs? have-capability? or
+ [ login-required ] unless ;
+
+: do-post-action ( -- )
+ validate-integer-id
+ "id" value <post> select-tuple from-object ;
: <edit-post-action> ( -- action )
<page-action>
- [
- validate-integer-id
- "id" value <post> select-tuple from-object
- ] >>init
- [
- validate-integer-id
- validate-post
- ] >>validate
+ "id" >>rest
+
+ [ do-post-action ] >>init
+
+ [ do-post-action validate-post ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
[
- "id" value <post> select-tuple
- dup { "title" "content" } deposit-slots
+ "id" value <post>
+ dup { "title" "author" "date" "content" } to-object
[ update-tuple ] [ entity-url <redirect> ] bi
] >>submit
- { blogs "edit-post" } >>template ;
-
+ { blogs "edit-post" } >>template
+
+ <protected>
+ "edit a blog post" >>description ;
+
+: delete-post ( id -- )
+ [ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
+
: <delete-post-action> ( -- action )
<action>
+
+ [ do-post-action ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
[
- validate-integer-id
- { { "author" [ v-username ] } } validate-params
- ] >>validate
+ [ "id" value delete-post ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
+
+: <delete-author-action> ( -- action )
+ <action>
+
+ [ validate-author ] >>validate
+
+ [ "author" value authorize-author ] >>authorize
+
[
- "id" value <post> delete-tuples
- "author" value user-posts-url <redirect>
- ] >>submit ;
+ [
+ f <post> "author" value >>author select-tuples [ id>> delete-post ] each
+ f f <comment> "author" value >>author delete-tuples
+ ] with-transaction
+ "author" value posts-by-url <redirect>
+ ] >>submit
+
+ <protected>
+ "delete a blog post" >>description ;
: validate-comment ( -- )
{
[
validate-comment
- uid "author" set-value
+ logged-in-user get username>> "author" set-value
] >>validate
[
"parent" value f <comment>
"content" value >>content
- uid >>author
+ logged-in-user get username>> >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
- ] >>submit ;
-
+ ] >>submit
+
+ <protected>
+ "make a comment" >>description ;
+
: <delete-comment-action> ( -- action )
<action>
+
[
validate-integer-id
{ { "parent" [ v-integer ] } } validate-params
] >>validate
+
+ [
+ "parent" value <post> select-tuple
+ author>> authorize-author
+ ] >>authorize
+
[
f "id" value <comment> delete-tuples
"parent" value view-post-url <redirect>
- ] >>submit ;
-
+ ] >>submit
+
+ <protected>
+ "delete a comment" >>description ;
+
: <blogs> ( -- dispatcher )
blogs new-dispatcher
<list-posts-action> "" add-responder
<list-posts-feed-action> "posts.atom" add-responder
- <user-posts-action> "by" add-responder
- <user-posts-feed-action> "by.atom" add-responder
+ <posts-by-action> "by" add-responder
+ <posts-by-feed-action> "by.atom" add-responder
<view-post-action> "post" add-responder
<post-feed-action> "post.atom" add-responder
- <new-post-action> <protected>
- "make a new blog post" >>description
- "new-post" add-responder
- <edit-post-action> <protected>
- "edit a blog post" >>description
- "edit-post" add-responder
- <delete-post-action> <protected>
- "delete a blog post" >>description
- "delete-post" add-responder
- <new-comment-action> <protected>
- "make a comment" >>description
- "new-comment" add-responder
- <delete-comment-action> <protected>
- "delete a comment" >>description
- "delete-comment" add-responder
+ <new-post-action> "new-post" add-responder
+ <edit-post-action> "edit-post" add-responder
+ <delete-post-action> "delete-post" add-responder
+ <new-comment-action> "new-comment" add-responder
+ <delete-comment-action> "delete-comment" add-responder
<boilerplate>
{ blogs "blogs-common" } >>template ;
<div class="posting-footer">
Post by
- <t:a t:href="$blogs/" t:query="author">
+ <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
- <t:a t:href="$blogs/post" t:for="id">View Post</t:a>
+ <t:a t:href="$blogs/post" t:rest="id">View Post</t:a>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div>
<t:bind-each t:name="posts">
<h2 class="post-title">
- <t:a t:href="$blogs/post" t:query="id">
+ <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="title" />
</t:a>
</h2>
<div class="posting-footer">
Post by
- <t:a t:href="$blogs/by" t:query="author">
+ <t:a t:href="$blogs/by" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
- <t:a t:href="$blogs/post" t:query="id">
+ <t:a t:href="$blogs/post" t:rest="id">
<t:label t:name="comments" />
comments.
</t:a>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:atom t:href="$blogs/by" t:rest="author">
+ Recent Posts by <t:label t:name="author" />
+ </t:atom>
+
+ <t:title>
+ Recent Posts by <t:label t:name="author" />
+ </t:title>
+
+ <t:bind-each t:name="posts">
+
+ <h2 class="post-title">
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:farkup t:name="content" />
+ </p>
+
+ <div class="posting-footer">
+ Post by
+ <t:a t:href="$blogs/by" t:rest="author">
+ <t:label t:name="author" />
+ </t:a>
+ on
+ <t:label t:name="date" />
+ |
+ <t:a t:href="$blogs/post" t:rest="id">
+ <t:label t:name="comments" />
+ comments.
+ </t:a>
+ </div>
+
+ </t:bind-each>
+
+</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:atom t:href="$blogs/by" t:query="author">
- Recent Posts by <t:label t:name="author" />
- </t:atom>
-
- <t:title>
- Recent Posts by <t:label t:name="author" />
- </t:title>
-
- <t:bind-each t:name="posts">
-
- <h2 class="post-title">
- <t:a t:href="$blogs/post" t:query="id">
- <t:label t:name="title" />
- </t:a>
- </h2>
-
- <p class="posting-body">
- <t:farkup t:name="content" />
- </p>
-
- <div class="posting-footer">
- Post by
- <t:a t:href="$blogs/by" t:query="author">
- <t:label t:name="author" />
- </t:a>
- on
- <t:label t:name="date" />
- |
- <t:a t:href="$blogs/post" t:query="id">
- <t:label t:name="comments" />
- comments.
- </t:a>
- </div>
-
- </t:bind-each>
-
-</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:href="$blogs/post.atom" t:query="id">
+ <t:atom t:href="$blogs/post.atom" t:rest="id">
<t:label t:name="author" />: <t:label t:name="title" />
</t:atom>
- <t:atom t:href="$blogs/by.atom" t:query="author">
+ <t:atom t:href="$blogs/by.atom" t:rest="author">
Recent Posts by <t:label t:name="author" />
</t:atom>
<div class="posting-footer">
Post by
- <t:a t:href="$blogs/" t:query="author">
+ <t:a t:href="$blogs/" t:rest="author">
<t:label t:name="author" />
</t:a>
on
<t:label t:name="date" />
|
- <t:a t:href="$blogs/edit-post" t:query="id">Edit Post</t:a>
+ <t:a t:href="$blogs/edit-post" t:rest="id">Edit Post</t:a>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
</div>
<hr/>
<p class="comment-header">
- Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
+ <a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
</p>
<p class="posting-body">
- <t:farkup t:name="content" />
+ <t:farkup t:name="content" t:no-follow="true" t:disable-images="true" />
</p>
<t:button t:action="$blogs/delete-comment" t:for="id,parent" class="link-button link">Delete Comment</t:button>
USING: math kernel accessors http.server http.server.dispatchers
-furnace furnace.actions furnace.sessions
-html.components html.templates.chloe
+furnace furnace.actions furnace.sessions furnace.redirection
+html.components html.forms html.templates.chloe
fry urls ;
IN: webapps.counter
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs io.files io.sockets
-io.server
-namespaces db db.sqlite smtp
-http.server
-http.server.dispatchers
-furnace.db
-furnace.asides
-furnace.flash
-furnace.sessions
-furnace.auth.login
-furnace.auth.providers.db
-furnace.boilerplate
-webapps.blogs
-webapps.pastebin
-webapps.planet
-webapps.todo
-webapps.wiki
-webapps.wee-url
-webapps.user-admin ;
-IN: webapps.factor-website
-
-: test-db ( -- db params ) "resource:test.db" sqlite-db ;
-
-: init-factor-db ( -- )
- test-db [
- init-users-table
- init-sessions-table
-
- init-pastes-table
- init-annotations-table
-
- init-blog-table
- init-postings-table
-
- init-todo-table
-
- init-articles-table
- init-revisions-table
-
- init-postings-table
- init-comments-table
-
- init-short-url-table
- ] with-db ;
-
-TUPLE: factor-website < dispatcher ;
-
-: <factor-website> ( -- responder )
- factor-website new-dispatcher
- <blogs> "blogs" add-responder
- <todo-list> "todo" add-responder
- <pastebin> "pastebin" add-responder
- <planet-factor> "planet" add-responder
- <wiki> "wiki" add-responder
- <wee-url> "wee-url" add-responder
- <user-admin> "user-admin" add-responder
- <login>
- users-in-db >>users
- allow-registration
- allow-password-recovery
- allow-edit-profile
- <boilerplate>
- { factor-website "page" } >>template
- <asides> <flash-scopes> <sessions>
- test-db <db-persistence> ;
-
-: init-factor-website ( -- )
- "factorcode.org" 25 <inet> smtp-server set-global
- "todo@factorcode.org" lost-password-from set-global
-
- init-factor-db
-
- <factor-website> main-responder set-global ;
-
-: start-factor-website ( -- )
- test-db start-expiring-sessions
- test-db start-update-task
- 8812 httpd ;
+++ /dev/null
-body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
-}
-
-.link-button {
- padding: 0px;
- background: none;
- border: none;
-}
-
-a, .link {
- color: #222;
- border-bottom:1px dotted #666;
- text-decoration:none;
-}
-
-a:hover, .link:hover {
- border-bottom:1px solid #66a;
-}
-
-.error { color: #a00; }
-
-.errors li { color: #a00; }
-
-.field-label {
- text-align: right;
-}
-
-.inline {
- display: inline;
-}
-
-.navbar {
- background-color: #eee;
- padding: 5px;
- border: 1px solid #ccc;
-}
-
-.big-field-label {
- vertical-align: top;
-}
-
-.description {
- padding: 5px;
- color: #000;
-}
-
-.description pre {
- border: 1px dashed #ccc;
- background-color: #f5f5f5;
-}
-
-.description p:first-child {
- margin-top: 0px;
-}
-
-.description p:last-child {
- margin-bottom: 0px;
-}
-
-.description table, .description td {
- border-color: #666;
- border-style: solid;
-}
-
-.description table {
- border-width: 0 0 1px 1px;
- border-spacing: 0;
- border-collapse: collapse;
-}
-
-.description td {
- margin: 0;
- padding: 4px;
- border-width: 1px 1px 0 0;
-}
-
+++ /dev/null
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-
- <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <head>
- <t:write-title />
-
- <t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
-
- <t:style t:include="resource:extra/webapps/factor-website/page.css" />
-
- <t:write-style />
-
- <t:write-atom />
- </head>
-
- <body>
- <t:call-next-template />
- </body>
-
- </t:chloe>
-
-</html>
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
hashtables sequences.lib db.types db.tuples db combinators
calendar calendar.format math.parser syndication urls xml.writer
xmode.catalog validators
+html.forms
html.components
html.templates.chloe
http.server
http.server.redirection
furnace
furnace.actions
+furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
TUPLE: pastebin < dispatcher ;
+SYMBOL: can-delete-pastes?
+
+can-delete-pastes? define-capability
+
! ! !
! DOMAIN MODEL
! ! !
"parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
- ] nest-values
+ ] nest-form
] >>init
{ pastebin "paste" } >>template ;
: deposit-entity-slots ( tuple -- )
now >>date
- { "summary" "author" "mode" "contents" } deposit-slots ;
+ { "summary" "author" "mode" "contents" } to-object ;
: <new-paste-action> ( -- action )
<page-action>
{ pastebin "new-paste" } >>template
- [ mode-names "modes" set-value ] >>validate
-
[
+ mode-names "modes" set-value
validate-entity
+ ] >>validate
+ [
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
: <delete-paste-action> ( -- action )
<action>
+
[ validate-integer-id ] >>validate
[
- "id" value <paste> delete-tuples
- "id" value f <annotation> delete-tuples
+ [
+ "id" value <paste> delete-tuples
+ "id" value f <annotation> delete-tuples
+ ] with-transaction
URL" $pastebin/list" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete pastes" >>description
+ { can-delete-pastes? } >>capabilities ;
! ! !
! ANNOTATIONS
: <new-annotation-action> ( -- action )
<action>
[
+ mode-names "modes" set-value
{ { "parent" [ v-integer ] } } validate-params
validate-entity
] >>validate
: <delete-annotation-action> ( -- action )
<action>
+
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
[ delete-tuples ]
[ parent>> paste-url <redirect> ]
bi
- ] >>submit ;
-
-SYMBOL: can-delete-pastes?
+ ] >>submit
-can-delete-pastes? define-capability
+ <protected>
+ "delete annotations" >>description
+ { can-delete-pastes? } >>capabilities ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
- <delete-paste-action> <protected>
- "delete pastes" >>description
- { can-delete-pastes? } >>capabilities "delete-paste" add-responder
+ <delete-paste-action> "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
- <delete-annotation-action> <protected>
- "delete annotations" >>description
- { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
+ <delete-annotation-action> "delete-annotation" add-responder
<boilerplate>
{ pastebin "pastebin-common" } >>template ;
-
-: init-pastes-table ( -- ) \ paste ensure-table ;
-
-: init-annotations-table ( -- ) annotation ensure-table ;
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:code="furnace.sessions:uid">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth:logged-in?">
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
+syndication urls xml.writer validators
+html.forms
html.components
-syndication urls xml.writer
-validators
http.server
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.boilerplate
furnace.auth.login
furnace.auth
TUPLE: planet-factor < dispatcher ;
+SYMBOL: can-administer-planet-factor?
+
+can-administer-planet-factor? define-capability
+
TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
- { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
- { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
+ { "www-url" "WWWURL" URL +not-null+ }
+ { "feed-url" "FEEDURL" URL +not-null+ }
} define-persistent
TUPLE: posting < entry id ;
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
- { "url" "LINK" { VARCHAR 256 } +not-null+ }
+ { "url" "LINK" URL +not-null+ }
{ "description" "DESCRIPTION" TEXT +not-null+ }
{ "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
-: init-blog-table ( -- ) blog ensure-table ;
-
-: init-postings-table ( -- ) posting ensure-table ;
-
: <blog> ( id -- todo )
blog new
swap >>id ;
} validate-params ;
: deposit-blog-slots ( blog -- )
- { "name" "www-url" "feed-url" } deposit-slots ;
+ { "name" "www-url" "feed-url" } to-object ;
: <new-blog-action> ( -- action )
<page-action>
+
{ planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
]
tri
] >>submit ;
-
+
: <edit-blog-action> ( -- action )
<page-action>
+
[
validate-integer-id
"id" value <blog> select-tuple from-object
<update-action> "update" add-responder
<new-blog-action> "new-blog" add-responder
<edit-blog-action> "edit-blog" add-responder
- <delete-blog-action> "delete-blog" add-responder ;
-
-SYMBOL: can-administer-planet-factor?
-
-can-administer-planet-factor? define-capability
+ <delete-blog-action> "delete-blog" add-responder
+ <protected>
+ "administer Planet Factor" >>description
+ { can-administer-planet-factor? } >>capabilities ;
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
<planet-feed-action> "feed.xml" add-responder
- <planet-factor-admin> <protected>
- "administer Planet Factor" >>description
- { can-administer-planet-factor? } >>capabilities
- "admin" add-responder
+ <planet-factor-admin> "admin" add-responder
<boilerplate>
{ planet-factor "planet-common" } >>template ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces
db db.types db.tuples validators hashtables urls
+html.forms
html.components
html.templates.chloe
http.server
http.server.dispatchers
furnace
-furnace.sessions
furnace.boilerplate
furnace.auth
furnace.actions
+furnace.redirection
furnace.db
furnace.auth.login ;
IN: webapps.todo
{ "description" "DESCRIPTION" { VARCHAR 256 } }
} define-persistent
-: init-todo-table ( -- ) todo ensure-table ;
-
: <todo> ( id -- todo )
todo new
swap >>id
- uid >>uid ;
+ logged-in-user get username>> >>uid ;
: <view-action> ( -- action )
<page-action>
[
f <todo>
- dup { "summary" "priority" "description" } deposit-slots
+ dup { "summary" "priority" "description" } to-object
[ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
[
f <todo>
- dup { "id" "summary" "priority" "description" } deposit-slots
+ dup { "id" "summary" "priority" "description" } to-object
[ update-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
<t:a t:href="$todo-list/list">List Items</t:a>
| <t:a t:href="$todo-list/new">Add Item</t:a>
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
</table>
<p>
- <button type="submit" class="link-button link">Update</button>
+ <button type="submit" >Update</button>
<t:validation-messages />
</p>
</t:form>
- <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
+ <t:button t:action="$user-admin/delete" t:for="username">Delete</t:button>
</t:chloe>
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls
+html.forms
html.elements
html.components
furnace
furnace.auth.providers.db
furnace.auth.login
furnace.auth
-furnace.sessions
furnace.actions
+furnace.redirection
+furnace.utilities
http.server
http.server.dispatchers ;
IN: webapps.user-admin
: init-capabilities ( -- )
capabilities get words>strings "capabilities" set-value ;
-: selected-capabilities ( -- seq )
+: validate-capabilities ( -- )
"capabilities" value
- [ param empty? not ] filter
- [ string>word ] map ;
+ [ [ param empty? not ] keep set-value ] each ;
+
+: selected-capabilities ( -- seq )
+ "capabilities" value [ value ] filter [ string>word ] map ;
+
+: validate-user ( -- )
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params ;
: <new-user-action> ( -- action )
<page-action>
[
init-capabilities
+ validate-capabilities
+
+ validate-user
{
- { "username" [ v-username ] }
- { "realname" [ v-one-line ] }
{ "new-password" [ v-password ] }
{ "verify-password" [ v-password ] }
- { "email" [ [ v-email ] v-optional ] }
- { "capabilities" [ ] }
} validate-params
same-password-twice
: validate-username ( -- )
{ { "username" [ v-username ] } } validate-params ;
+: select-capabilities ( seq -- )
+ [ t swap word>string set-value ] each ;
+
: <edit-user-action> ( -- action )
<page-action>
[
validate-username
"username" value <user> select-tuple
- [ from-object ]
- [ capabilities>> [ "true" swap word>string set-value ] each ] bi
+ [ from-object ] [ capabilities>> select-capabilities ] bi
init-capabilities
] >>init
{ user-admin "edit-user" } >>template
[
+ "username" value <user> select-tuple
+ [ from-object ] [ capabilities>> select-capabilities ] bi
+
init-capabilities
+ validate-capabilities
+
+ validate-user
{
- { "username" [ v-username ] }
- { "realname" [ v-one-line ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
- { "email" [ [ v-email ] v-optional ] }
} validate-params
"new-password" "verify-password"
<action>
[
validate-username
-
- [ <user> select-tuple 1 >>deleted update-tuple ]
- [ logout-all-sessions ]
- bi
-
+ "username" value <user> delete-tuples
URL" $user-admin" <redirect>
] >>submit ;
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
! See http://factorcode.org/license.txt for BSD license.
USING: math.ranges sequences random accessors combinators.lib
kernel namespaces fry db.types db.tuples urls validators
-html.components http http.server.dispatchers furnace
-furnace.actions furnace.boilerplate ;
+html.components html.forms http http.server.dispatchers furnace
+furnace.actions furnace.boilerplate furnace.redirection ;
IN: webapps.wee-url
TUPLE: wee-url < dispatcher ;
{ "url" "URL" TEXT +not-null+ }
} define-persistent
-: init-short-url-table ( -- )
- short-url ensure-table ;
-
: letter-bank ( -- seq )
CHAR: a CHAR: z [a,b]
CHAR: A CHAR: Z [a,b]
3append ; foldable
: random-url ( -- string )
- 1 6 [a,b] random [ drop letter-bank random ] "" map-as ;
+ 1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
: insert-short-url ( short-url -- short-url )
'[ , dup random-url >>short insert-tuple ] 10 retry ;
<ul>
<t:bind-each t:name="articles">
<li>
- <t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
+ <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title"/></t:a>
</li>
</t:bind-each>
</ul>
<t:title>Recent Changes</t:title>
- <ul>
- <t:bind-each t:name="changes">
- <li>
- <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
- on
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
- by
- <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
- </li>
- </t:bind-each>
- </ul>
+ <div class="revisions">
+
+ <table>
+
+ <tr>
+ <th>Article</th>
+ <th>Date</th>
+ <th>By</th>
+ </tr>
+
+ <t:bind-each t:name="changes">
+ <tr>
+ <td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
+ <td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
+ <td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
+ </tr>
+ </t:bind-each>
+
+ </table>
+
+ </div>
</t:chloe>
<tr>
<th class="field-label">Old revision:</th>
<t:bind t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
<tr>
<th class="field-label">New revision:</th>
<t:bind t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
</t:bind>
</tr>
</table>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:href="$wiki/revisions.atom" t:query="title">
+ <t:atom t:href="$wiki/revisions.atom" t:rest="title">
Revisions of <t:label t:name="title" />
</t:atom>
<t:call-next-template />
<div class="navbar">
- <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
- | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
- | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ <t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:rest="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:rest="title">Edit</t:a>
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</div>
<table>
<tr>
<th>Revision</th>
- <th>Author</th>
+ <th>By</th>
<th>Rollback</th>
</tr>
<t:bind-each t:name="revisions">
<tr>
- <td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
- <td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
- <td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
+ <td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
+ <td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
+ <td> <t:button t:action="$wiki/rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
</tr>
</t:bind-each>
</table>
<h2>View Differences</h2>
- <form action="diff" method="get">
+ <t:form t:action="$wiki/diff" t:method="get">
<table>
<tr>
<th class="field-label">Old revision:</th>
</table>
<input type="submit" value="View" />
- </form>
+ </t:form>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:href="$wiki/user-edits.atom" t:query="author">
+ <t:atom t:href="$wiki/user-edits.atom" t:rest="author">
Edits by <t:label t:name="author" />
</t:atom>
<ul>
<t:bind-each t:name="user-edits">
<li>
- <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
+ <t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
on
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
</li>
</t:bind-each>
</ul>
<t:farkup t:name="content" />
</div>
- <p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</em></p>
+ <p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</em></p>
</t:chloe>
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
- <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth:logged-in?">
- <t:if t:code="furnace.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
+ | <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
<h1><t:write-title /></h1>
- <t:call-next-template />
+ <table width="100%">
+ <tr>
+ <td> <t:call-next-template /> </td>
+ <t:if t:value="sidebar">
+ <td valign="top">
+ <t:bind t:name="sidebar">
+ <h2>
+ <t:a t:href="$wiki/view" t:query="title">
+ <t:label t:name="title" />
+ </t:a>
+ </h2>
+
+ <t:farkup t:name="content" />
+ </t:bind>
+ </td>
+ </t:if>
+ </tr>
+ </table>
</t:chloe>
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
-namespaces splitting sequences sorting math.order
-html.components syndication
+namespaces splitting sequences sorting math.order present
+syndication
+html.components html.forms
http.server
http.server.dispatchers
furnace
furnace.actions
+furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate
db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
-: view-url ( title -- url )
- "$wiki/view/" prepend >url ;
+: wiki-url ( rest path -- url )
+ [ "$wiki/" % % "/" % % ] "" make
+ <url> swap >>path ;
-: edit-url ( title -- url )
- "$wiki/edit" >url swap "title" set-query-param ;
+: view-url ( title -- url ) "view" wiki-url ;
-: revisions-url ( title -- url )
- "$wiki/revisions" >url swap "title" set-query-param ;
+: edit-url ( title -- url ) "edit" wiki-url ;
-: revision-url ( id -- url )
- "$wiki/revision" >url swap "id" set-query-param ;
+: revisions-url ( title -- url ) "revisions" wiki-url ;
-: user-edits-url ( author -- url )
- "$wiki/user-edits" >url swap "author" set-query-param ;
+: revision-url ( id -- url ) "revision" wiki-url ;
+
+: user-edits-url ( author -- url ) "user-edits" wiki-url ;
TUPLE: wiki < dispatcher ;
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
TUPLE: article title revision ;
article "ARTICLES" {
{ "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
- ! { "AUTHOR" INTEGER +not-null+ } ! uid
- ! { "PROTECTED" BOOLEAN +not-null+ }
{ "revision" "REVISION" INTEGER +not-null+ } ! revision id
} define-persistent
: <article> ( title -- article ) article new swap >>title ;
-: init-articles-table ( -- ) article ensure-table ;
-
TUPLE: revision id title author date content ;
revision "REVISIONS" {
: <revision> ( id -- revision )
revision new swap >>id ;
-: init-revisions-table ( -- ) revision ensure-table ;
-
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
<action>
[ "Front Page" view-url <redirect> ] >>display ;
+: latest-revision ( title -- revision/f )
+ <article> select-tuple
+ dup [ revision>> <revision> select-tuple ] when ;
+
: <view-article-action> ( -- action )
<action>
+
"title" >>rest
[
validate-title
- "view?title=" relative-link-prefix set
] >>init
[
- "title" value dup <article> select-tuple [
- revision>> <revision> select-tuple from-object
+ "title" value dup latest-revision [
+ from-object
{ wiki "view" } <chloe-content>
] [
edit-url <redirect>
: <view-revision-action> ( -- action )
<page-action>
+
+ "id" >>rest
+
[
validate-integer-id
"id" value <revision>
select-tuple from-object
- "view?title=" relative-link-prefix set
+ URL" $wiki/view/" adjust-url present relative-link-prefix set
] >>init
{ wiki "view" } >>template ;
+: amend-article ( revision article -- )
+ swap id>> >>revision update-tuple ;
+
+: add-article ( revision -- )
+ [ title>> ] [ id>> ] bi article boa insert-tuple ;
+
: add-revision ( revision -- )
[ insert-tuple ]
[
- dup title>> <article> select-tuple [
- swap id>> >>revision update-tuple
- ] [
- [ title>> ] [ id>> ] bi article boa insert-tuple
- ] if*
+ dup title>> <article> select-tuple
+ [ amend-article ] [ add-article ] if*
] bi ;
: <edit-article-action> ( -- action )
<page-action>
+
+ "title" >>rest
+
[
validate-title
"title" value <article> select-tuple [
] >>init
{ wiki "edit" } >>template
-
+
[
validate-title
{ { "content" [ v-required ] } } validate-params
logged-in-user get username>> >>author
"content" value >>content
[ add-revision ] [ title>> view-url <redirect> ] bi
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "edit wiki articles" >>description ;
: list-revisions ( -- seq )
f <revision> "title" value >>title select-tuples
: <list-revisions-action> ( -- action )
<page-action>
+
+ "title" >>rest
+
[
validate-title
list-revisions "revisions" set-value
] >>init
+
{ wiki "revisions" } >>template ;
: <list-revisions-feed-action> ( -- action )
<feed-action>
+
+ "title" >>rest
+
[ validate-title ] >>init
+
[ "Revisions of " "title" value append ] >>title
+
[ "title" value revisions-url ] >>url
+
[ list-revisions ] >>entries ;
: <rollback-action> ( -- action )
<action>
+
[ validate-integer-id ] >>validate
[
] >>submit ;
: list-changes ( -- seq )
- "id" value <revision> select-tuples
+ f <revision> select-tuples
reverse-chronological-order ;
: <list-changes-action> ( -- action )
<page-action>
[ list-changes "changes" set-value ] >>init
-
{ wiki "changes" } >>template ;
: <list-changes-feed-action> ( -- action )
: <delete-action> ( -- action )
<action>
+
[ validate-title ] >>validate
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
URL" $wiki" <redirect>
- ] >>submit ;
+ ] >>submit
+
+ <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities ;
: <diff-action> ( -- action )
<page-action>
"old-id" "new-id"
[ value <revision> select-tuple ] bi@
[
- [ [ title>> "title" set-value ] [ "old" set-value ] bi ]
- [ "new" set-value ] bi*
+ [ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ]
+ [ "new" [ from-object ] nest-form ] bi*
]
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
: <list-articles-action> ( -- action )
<page-action>
+
[
f <article> select-tuples
[ [ title>> ] compare ] sort
: <user-edits-action> ( -- action )
<page-action>
+
+ "author" >>rest
+
[
validate-author
list-user-edits "user-edits" set-value
] >>init
+
{ wiki "user-edits" } >>template ;
: <user-edits-feed-action> ( -- action )
<feed-action>
+ "author" >>rest
[ validate-author ] >>init
[ "Edits by " "author" value append ] >>title
[ "author" value user-edits-url ] >>url
[ list-user-edits ] >>entries ;
-SYMBOL: can-delete-wiki-articles?
-
-can-delete-wiki-articles? define-capability
-
: <article-boilerplate> ( responder -- responder' )
<boilerplate>
{ wiki "page-common" } >>template ;
+: init-sidebar ( -- )
+ "Sidebar" latest-revision [
+ "sidebar" [ from-object ] nest-form
+ ] when* ;
+
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<main-article-action> <article-boilerplate> "" add-responder
<list-revisions-action> <article-boilerplate> "revisions" add-responder
<list-revisions-feed-action> "revisions.atom" add-responder
<diff-action> <article-boilerplate> "diff" add-responder
- <edit-article-action> <article-boilerplate> <protected>
- "edit wiki articles" >>description
- "edit" add-responder
+ <edit-article-action> <article-boilerplate> "edit" add-responder
<rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
<user-edits-feed-action> "user-edits.atom" add-responder
<list-changes-feed-action> "changes.atom" add-responder
- <delete-action> <protected>
- "delete wiki articles" >>description
- { can-delete-wiki-articles? } >>capabilities
- "delete" add-responder
+ <delete-action> "delete" add-responder
<boilerplate>
+ [ init-sidebar ] >>init
{ wiki "wiki-common" } >>template ;
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences assocs io.files io.sockets
+io.sockets.secure io.servers.connection
+namespaces db db.tuples db.sqlite smtp urls
+logging.insomniac
+http.server
+http.server.dispatchers
+http.server.redirection
+furnace.alloy
+furnace.auth.login
+furnace.auth.providers.db
+furnace.auth.features.edit-profile
+furnace.auth.features.recover-password
+furnace.auth.features.registration
+furnace.auth.features.deactivate-user
+furnace.boilerplate
+furnace.redirection
+webapps.blogs
+webapps.pastebin
+webapps.planet
+webapps.todo
+webapps.wiki
+webapps.wee-url
+webapps.user-admin ;
+IN: websites.concatenative
+
+: test-db ( -- db params ) "resource:test.db" sqlite-db ;
+
+: init-factor-db ( -- )
+ test-db [
+ init-furnace-tables
+
+ {
+ post comment
+ paste annotation
+ blog posting
+ todo
+ short-url
+ article revision
+ } ensure-tables
+ ] with-db ;
+
+TUPLE: factor-website < dispatcher ;
+
+: <factor-website> ( -- responder )
+ factor-website new-dispatcher
+ <blogs> "blogs" add-responder
+ <todo-list> "todo" add-responder
+ <pastebin> "pastebin" add-responder
+ <planet-factor> "planet" add-responder
+ <wiki> "wiki" add-responder
+ <wee-url> "wee-url" add-responder
+ <user-admin> "user-admin" add-responder
+ URL" /wiki/view/Front Page" <redirect-responder> "" add-responder
+ "Factor website" <login-realm>
+ "Factor website" >>name
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ allow-deactivation
+ <boilerplate>
+ { factor-website "page" } >>template
+ test-db <alloy> ;
+
+SYMBOL: key-password
+SYMBOL: key-file
+SYMBOL: dh-file
+
+: common-configuration ( -- )
+ "concatenative.org" 25 <inet> smtp-server set-global
+ "noreply@concatenative.org" lost-password-from set-global
+ "website@concatenative.org" insomniac-sender set-global
+ "slava@factorcode.org" insomniac-recipients set-global
+ <factor-website> main-responder set-global
+ init-factor-db ;
+
+: init-testing ( -- )
+ "resource:extra/openssl/test/dh1024.pem" dh-file set-global
+ "resource:extra/openssl/test/server.pem" key-file set-global
+ "password" key-password set-global
+ common-configuration ;
+
+: init-production ( -- )
+ "/home/slava/cert/host.pem" key-file set-global
+ common-configuration ;
+
+: <factor-secure-config> ( -- config )
+ <secure-config>
+ key-file get >>key-file
+ dh-file get >>dh-file
+ key-password get >>password ;
+
+: <factor-website-server> ( -- threaded-server )
+ <http-server>
+ <factor-secure-config> >>secure-config
+ 8080 >>insecure
+ 8431 >>secure ;
+
+: start-website ( -- )
+ test-db start-expiring
+ test-db start-update-task
+ http-insomniac
+ <factor-website-server> start-server ;
--- /dev/null
+body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+}
+
+.link-button {
+ padding: 0px;
+ background: none;
+ border: none;
+}
+
+a, .link {
+ color: #222;
+ border-bottom:1px dotted #666;
+ text-decoration:none;
+}
+
+a:hover, .link:hover {
+ border-bottom:1px solid #66a;
+}
+
+.error { color: #a00; }
+
+.errors li { color: #a00; }
+
+.field-label {
+ text-align: right;
+}
+
+.inline {
+ display: inline;
+}
+
+.navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+}
+
+.big-field-label {
+ vertical-align: top;
+}
+
+.description {
+ padding: 5px;
+ color: #000;
+}
+
+.description pre {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+}
+
+.description p:first-child {
+ margin-top: 0px;
+}
+
+.description p:last-child {
+ margin-bottom: 0px;
+}
+
+.description table, .description td {
+ border-color: #666;
+ border-style: solid;
+}
+
+.description table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.description td {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <head>
+ <t:write-title />
+
+ <t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
+
+ <t:style t:include="resource:extra/websites/concatenative/page.css" />
+
+ <t:write-style />
+
+ <t:write-atom />
+ </head>
+
+ <body>
+ <t:call-next-template />
+ </body>
+
+ </t:chloe>
+
+</html>
USING: alien alien.c-types windows.com.syntax windows.ole32\r
-windows.types continuations kernel alien.syntax ;\r
+windows.types continuations kernel alien.syntax libc ;\r
IN: windows.com\r
\r
LIBRARY: ole32\r
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;\r
\r
: com-query-interface ( interface iid -- interface' )\r
- f <void*>\r
- [ IUnknown::QueryInterface ole32-error ] keep\r
- *void* ;\r
+ "void*" heap-size [\r
+ [ IUnknown::QueryInterface ole32-error ] keep *void*\r
+ ] with-malloc ;\r
\r
: com-add-ref ( interface -- interface )\r
[ IUnknown::AddRef drop ] keep ; inline\r
USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
-sequences.lib namespaces windows.ole32 libc
+sequences.lib namespaces windows.ole32 libc vocabs
assocs accessors arrays sequences quotations combinators
-math combinators.lib words compiler.units destructors ;
+math combinators.lib words compiler.units destructors fry
+math.parser ;
IN: windows.com.wrapper
-TUPLE: com-wrapper vtbls freed? ;
+TUPLE: com-wrapper vtbls disposed ;
<PRIVATE
[ H{ } +wrapped-objects+ set-global ]
unless
+SYMBOL: +vtbl-counter+
++vtbl-counter+ get-global
+[ 0 +vtbl-counter+ set-global ]
+unless
+
+"windows.com.wrapper.callbacks" create-vocab drop
+
+: (next-vtbl-counter) ( -- n )
+ +vtbl-counter+ [ 1+ dup ] change ;
+
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
[ "invalid COM wrapping pointer" throw ] unless ;
[ +wrapped-objects+ get-global delete-at ] keep
free ;
-: (make-query-interface) ( interfaces -- quot )
+: (query-interface-cases) ( interfaces -- cases )
[
- [ swap 16 memory>byte-array ] %
+ [ find-com-interface-definition family-tree [ iid>> ] map ] dip
+ 1quotation [ 2array ] curry map
+ ] map-index concat
+ [ drop f ] suffix ;
+
+: (make-query-interface) ( interfaces -- quot )
+ (query-interface-cases)
+ '[
+ swap 16 memory>byte-array
+ , case
[
- >r find-com-interface-definition family-tree
- r> 1quotation [ >r iid>> r> 2array ] curry map
- ] map-index concat
- [ drop f ] suffix ,
- \ case ,
- "void*" heap-size
- [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
- curry ,
- [ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
- \ if* ,
- ] [ ] make ;
+ "void*" heap-size * rot <displaced-alien> com-add-ref
+ 0 rot set-void*-nth S_OK
+ ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
+ ] ;
: (make-add-ref) ( interfaces -- quot )
- length "void*" heap-size * [ swap <displaced-alien>
+ length "void*" heap-size * '[
+ , swap <displaced-alien>
0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep
- ] curry ;
+ ] ;
: (make-release) ( interfaces -- quot )
- length "void*" heap-size * [ over <displaced-alien>
+ length "void*" heap-size * '[
+ , over <displaced-alien>
0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
- ] curry ;
+ ] ;
: (make-iunknown-methods) ( interfaces -- quots )
[ (make-query-interface) ]
: (thunk) ( n -- quot )
dup 0 =
[ drop [ ] ]
- [ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
+ [ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
if ;
-: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
- [ [ swap 2array ] curry map swap ] keep
- [ com-unwrap ] compose [ swap 2array ] curry map append ;
+: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
+ [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
+ [ '[ , [ swap 2array ] curry map ] ] bi bi*
+ swap append ;
-: compile-alien-callback ( return parameters abi quot -- alien )
+: compile-alien-callback ( word return parameters abi quot -- alien )
[ alien-callback ] 4 ncurry
- [ gensym [ swap (( -- alien )) define-declared ] keep ]
+ [ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit
execute ;
-: (make-vtbl) ( interface-name quots iunknown-methods n -- )
+: (byte-array-to-malloced-buffer) ( byte-array -- alien )
+ [ byte-length malloc ] [ over byte-array>memory ] bi ;
+
+: (callback-word) ( function-name interface-name counter -- word )
+ [ "::" rot 3append "-callback-" ] dip number>string 3append
+ "windows.com.wrapper.callbacks" create ;
+
+: (finish-thunk) ( param-count thunk quot -- thunked-quot )
+ [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
+ dip compose ;
+
+: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
(thunk) (thunked-quots)
- swap find-com-interface-definition family-tree-functions [
- [ return>> ] [ parameters>> [ first ] map ] bi
- dup length 1- roll [
- first dup empty?
- [ 2drop [ ] ]
- [ swap [ ndip ] 2curry ]
- if
- ] [ second ] bi compose
+ swap [ find-com-interface-definition family-tree-functions ]
+ keep (next-vtbl-counter) '[
+ swap [
+ [ name>> , , (callback-word) ]
+ [ return>> ] [
+ parameters>>
+ [ [ first ] map ]
+ [ length ] bi
+ ] tri
+ ] [
+ first2 (finish-thunk)
+ ] bi*
"stdcall" swap compile-alien-callback
- ] 2map >c-void*-array [ byte-length malloc ] keep
- over byte-array>memory ;
+ ] 2map >c-void*-array
+ (byte-array-to-malloced-buffer) ;
: (make-vtbls) ( implementations -- vtbls )
dup [ first ] map (make-iunknown-methods)
: <com-wrapper> ( implementations -- wrapper )
(make-vtbls) f com-wrapper boa ;
-M: com-wrapper dispose
- t >>freed?
+M: com-wrapper dispose*
vtbls>> [ free ] each ;
: com-wrap ( object wrapper -- wrapped-object )
- dup (malloc-wrapped-object) >r vtbls>> r>
+ [ vtbls>> ] [ (malloc-wrapped-object) ] bi
[ [ set-void*-nth ] curry each-index ] keep
[ +wrapped-objects+ get-global set-at ] keep ;
TUPLE: mode file file-name-glob first-line-glob ;
-<TAGS: parse-mode-tag
+<TAGS: parse-mode-tag ( modes tag -- )
TAG: MODE
"NAME" over at >r
! Based on org.gjt.sp.jedit.XModeHandler
! RULES and its children
-<TAGS: parse-rule-tag
+<TAGS: parse-rule-tag ( rule-set tag -- )
-TAG: PROPS ( rule-set tag -- )
+TAG: PROPS
parse-props-tag swap set-rule-set-props ;
-TAG: IMPORT ( rule-set tag -- )
+TAG: IMPORT
"DELEGATE" swap at swap import-rule-set ;
-TAG: TERMINATE ( rule-set tag -- )
+TAG: TERMINATE
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ;
RULE: SEQ seq-rule
[ parse-literal-matcher swap set-rule-end ] , ;
! SPAN's children
-<TAGS: parse-begin/end-tag
+<TAGS: parse-begin/end-tag ( rule tag -- )
TAG: BEGIN
! XXX
rule-set-imports push ;
: inverted-index ( hashes key index -- )
- [ swapd [ ?push ] change-at ] 2curry each ;
+ [ swapd push-at ] 2curry each ;
: ?push-all ( seq1 seq2 -- seq1+seq2 )
[
: (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
: TAG:
- f set-word
scan parse-definition
(TAG:) ; parsing
: TAGS>
tag-handler-word get
tag-handlers get >alist [ >r dup name-tag r> case ] curry
- (( tag -- )) define-declared ; parsing
+ define ; parsing
projects / factor.git / commitdiff