diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index c875475278..f56ac810d9 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) +: (assoc-each) ( assoc quot -- seq quot' ) + >r >alist r> [ first2 ] prepose ; inline + : assoc-find ( assoc quot -- key value ? ) - >r >alist r> [ first2 ] prepose find swap - [ first2 t ] [ drop f f f ] if ; inline + (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline : key? ( key assoc -- ? ) at* nip ; inline : assoc-each ( assoc quot -- ) - [ f ] compose assoc-find 3drop ; inline - -: (assoc>map) ( quot accum -- quot' ) - [ push ] curry compose ; inline + (assoc-each) each ; inline : assoc>map ( assoc quot exemplar -- seq ) - >r over assoc-size - [ (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 diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5900e5a844..7d43187f54 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors" { $subsection missing-effect } ; ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." +"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl "The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" { $subsection infer. } diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4a9f90cb32..942476616f 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -28,23 +28,62 @@ ERROR: encode-error ; ! Decoding - f decoder boa ; +>cr drop ; inline + +: cr- f >>cr drop ; inline + : >decoder< ( decoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline -: cr+ t swap set-decoder-cr ; inline +: fix-read1 ( stream char -- char ) + over cr>> [ + over cr- + dup CHAR: \n = [ + drop dup stream-read1 + ] when + ] when nip ; inline -: cr- f swap set-decoder-cr ; inline +M: decoder stream-read1 + dup >decoder< decode-char fix-read1 ; + +: fix-read ( stream string -- string ) + over cr>> [ + over cr- + "\n" ?head [ + over stream-read1 [ suffix ] when* + ] when + ] when nip ; inline + +: (read) ( n quot -- n string ) + over 0 [ + [ + >r call dup + [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if + ] 2curry find-integer + ] keep ; inline + +: finish-read ( n string -- string/f ) + { + { [ over 0 = ] [ 2drop f ] } + { [ over not ] [ nip ] } + [ swap head ] + } cond ; inline + +M: decoder stream-read + tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ; + +M: decoder stream-read-partial stream-read ; : line-ends/eof ( stream str -- str ) f like swap cr- ; inline : line-ends\r ( stream str -- str ) swap cr+ ; inline : line-ends\n ( stream str -- str ) - over decoder-cr over empty? and + over cr>> over empty? and [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline : handle-readln ( stream str ch -- str ) @@ -52,61 +91,30 @@ M: object f decoder boa ; { f [ line-ends/eof ] } { CHAR: \r [ line-ends\r ] } { CHAR: \n [ line-ends\n ] } - } case ; + } case ; inline -: fix-read ( stream string -- string ) - over decoder-cr [ - over cr- - "\n" ?head [ - over stream-read1 [ suffix ] when* - ] when - ] when nip ; - -: read-loop ( n stream -- string ) - SBUF" " clone [ - [ - >r nip stream-read1 dup - [ r> push f ] [ r> 2drop t ] if - ] 2curry find-integer drop - ] keep "" like f like ; - -M: decoder stream-read - tuck read-loop fix-read ; - -M: decoder stream-read-partial stream-read ; - -: (read-until) ( buf quot -- string/f sep/f ) +: ((read-until)) ( buf quot -- string/f sep/f ) ! quot: -- char stop? dup call [ >r drop "" like r> ] - [ pick push (read-until) ] if ; inline + [ pick push ((read-until)) ] if ; inline -M: decoder stream-read-until +: (read-until) ( seps stream -- string/f sep/f ) SBUF" " clone -rot >decoder< - [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry - (read-until) ; + [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry + ((read-until)) ; inline -: fix-read1 ( stream char -- char ) - over decoder-cr [ - over cr- - dup CHAR: \n = [ - drop dup stream-read1 - ] when - ] when nip ; +M: decoder stream-read-until (read-until) ; -M: decoder stream-read1 - dup >decoder< decode-char fix-read1 ; +M: decoder stream-readln "\r\n" over (read-until) handle-readln ; -M: decoder stream-readln ( stream -- str ) - "\r\n" over stream-read-until handle-readln ; - -M: decoder dispose decoder-stream dispose ; +M: decoder dispose stream>> dispose ; ! Encoding M: object encoder boa ; : >encoder< ( encoder -- stream encoding ) - [ stream>> ] [ code>> ] bi ; + [ stream>> ] [ code>> ] bi ; inline M: encoder stream-write1 >encoder< encode-char ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index d1dbefe26b..d69a2f94bc 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -2,14 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. IN: optimizer.known-words USING: alien arrays generic hashtables inference.dataflow -inference.class kernel assocs math math.private kernel.private -sequences words parser vectors strings sbufs io namespaces -assocs quotations sequences.private io.binary +inference.class kernel assocs math math.order math.private +kernel.private sequences words parser vectors strings sbufs io +namespaces assocs quotations sequences.private io.binary io.streams.string layouts splitting math.intervals math.floats.private classes.tuple classes.tuple.private classes classes.algebra optimizer.def-use optimizer.backend optimizer.pattern-match optimizer.inlining float-arrays -sequences.private combinators ; +sequences.private combinators byte-arrays byte-vectors ; { } [ [ @@ -59,15 +59,59 @@ sequences.private combinators ; node-in-d peek dup value? [ value-literal sequence? ] [ drop f ] if ; -: member-quot ( seq -- newquot ) - [ literalize [ t ] ] { } map>assoc - [ drop f ] suffix [ nip case ] curry ; +: expand-member ( #call quot -- ) + >r dup node-in-d peek value-literal r> call f splice-quot ; -: expand-member ( #call -- ) - dup node-in-d peek value-literal member-quot f splice-quot ; +: bit-member-n 256 ; inline + +: bit-member? ( seq -- ? ) + #! Can we use a fast byte array test here? + { + { [ dup length 8 < ] [ f ] } + { [ dup [ integer? not ] contains? ] [ f ] } + { [ dup [ 0 < ] contains? ] [ f ] } + { [ dup [ bit-member-n >= ] contains? ] [ f ] } + [ t ] + } cond nip ; + +: bit-member-seq ( seq -- flags ) + bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ; + +: exact-float? ( f -- ? ) + dup float? [ dup >integer >float = ] [ drop f ] if ; inline + +: bit-member-quot ( seq -- newquot ) + [ + [ drop ] % ! drop the sequence itself; we don't use it at run time + bit-member-seq , + [ + { + { [ over fixnum? ] [ ?nth 1 eq? ] } + { [ over bignum? ] [ ?nth 1 eq? ] } + { [ over exact-float? ] [ ?nth 1 eq? ] } + [ 2drop f ] + } cond + ] % + ] [ ] make ; + +: member-quot ( seq -- newquot ) + dup bit-member? [ + bit-member-quot + ] [ + [ literalize [ t ] ] { } map>assoc + [ drop f ] suffix [ nip case ] curry + ] if ; \ member? { - { [ dup literal-member? ] [ expand-member ] } + { [ dup literal-member? ] [ [ member-quot ] expand-member ] } +} define-optimizers + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; + +\ memq? { + { [ dup literal-member? ] [ [ memq-quot ] expand-member ] } } define-optimizers ! if the result of eq? is t and the second input is a literal, @@ -97,7 +141,7 @@ sequences.private combinators ; ] each \ push-all -{ { string sbuf } { array vector } } +{ { string sbuf } { array vector } { byte-array byte-vector } } "specializer" set-word-prop \ append diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index cb33552693..02a7191f0a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -419,10 +419,11 @@ PRIVATE> : interleave ( seq between quot -- ) [ (interleave) ] 2curry >r dup length swap r> 2each ; inline +: accumulator ( quot -- quot' vec ) + V{ } clone [ [ push ] curry compose ] keep ; inline + : unfold ( pred quot tail -- seq ) - V{ } clone [ - swap >r [ push ] curry compose r> while - ] keep { } like ; inline + swap accumulator >r swap while r> { } like ; inline : follow ( obj quot -- seq ) >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline diff --git a/extra/assocs/lib/lib-tests.factor b/extra/assocs/lib/lib-tests.factor new file mode 100644 index 0000000000..0bf8270088 --- /dev/null +++ b/extra/assocs/lib/lib-tests.factor @@ -0,0 +1,4 @@ +IN: assocs.lib.tests +USING: assocs.lib tools.test vectors ; + +{ 1 1 } [ [ ?push ] histogram ] must-infer-as diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 1c89c1eb16..14632df771 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -41,4 +41,4 @@ IN: assocs.lib : histogram ( assoc quot -- assoc' ) H{ } clone [ swap [ change-at ] 2curry assoc-each - ] keep ; + ] keep ; inline diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor index d867351f8b..86c58af505 100644 --- a/extra/base64/base64-tests.factor +++ b/extra/base64/base64-tests.factor @@ -1,8 +1,18 @@ USING: kernel tools.test base64 strings ; -[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> +[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string ] unit-test -[ "" ] [ "" >base64 base64> ] unit-test -[ "a" ] [ "a" >base64 base64> ] unit-test -[ "ab" ] [ "ab" >base64 base64> ] unit-test -[ "abc" ] [ "abc" >base64 base64> ] unit-test +[ "" ] [ "" >base64 base64> >string ] unit-test +[ "a" ] [ "a" >base64 base64> >string ] unit-test +[ "ab" ] [ "ab" >base64 base64> >string ] unit-test +[ "abc" ] [ "abc" >base64 base64> >string ] unit-test + +! From http://en.wikipedia.org/wiki/Base64 +[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] +[ + "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." + >base64 >string +] unit-test + +\ >base64 must-infer +\ base64> must-infer diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 600a8f4c3d..d48abc2014 100644 --- a/extra/base64/base64.factor +++ b/extra/base64/base64.factor @@ -1,11 +1,10 @@ -USING: kernel math sequences namespaces io.binary splitting -grouping strings hashtables ; +USING: kernel math sequences io.binary splitting grouping ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; + >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -20,28 +19,26 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ; + be> 4 [ -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 [ encode3 % ] each - dup empty? [ drop ] [ >base64-rem % ] if - ] "" make ; + dup length dup 3 mod - cut + [ 3 [ encode3 ] map concat ] + [ dup empty? [ drop "" ] [ >base64-rem ] if ] + bi* append ; : base64> ( base64 -- str ) #! input length must be a multiple of 4 - [ - [ 4 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end - ] SBUF" " make swap [ dup pop* ] times >string ; - + [ 4 [ decode4 ] map concat ] + [ [ CHAR: = = not ] count-end ] + bi head* ; diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index ca1da0deaa..dc20e7ad5c 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -1,9 +1,9 @@ IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files arrays io.sockets system combinators threads math sequences -concurrency.messaging continuations ; +concurrency.messaging continuations accessors prettyprint ; -: test-node +: test-node ( -- addrspec ) { { [ os unix? ] [ "distributed-concurrency-test" temp-file ] } { [ os windows? ] [ "127.0.0.1" 1238 ] } @@ -11,9 +11,9 @@ concurrency.messaging continuations ; [ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test -[ ] [ test-node dup 1array swap (start-node) ] unit-test +[ ] [ test-node dup (start-node) ] unit-test -[ ] [ 100 sleep ] unit-test +[ ] [ 1000 sleep ] unit-test [ ] [ [ @@ -30,4 +30,6 @@ concurrency.messaging continuations ; receive ] unit-test +[ ] [ 1000 sleep ] unit-test + [ ] [ test-node stop-node ] unit-test diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index c637f4baa3..9ae2627505 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io -io.server qualified arrays namespaces kernel io.encodings.binary -accessors ; +io.servers.connection io.encodings.binary +qualified arrays namespaces kernel accessors ; FROM: io.sockets => host-name with-client ; IN: concurrency.distributed @@ -10,21 +10,21 @@ SYMBOL: local-node : handle-node-client ( -- ) deserialize - [ first2 get-process send ] - [ stop-server ] if* ; + [ first2 get-process send ] [ stop-server ] if* ; -: (start-node) ( addrspecs addrspec -- ) +: (start-node) ( addrspec addrspec -- ) local-node set-global [ - "concurrency.distributed" - binary - [ handle-node-client ] with-server + + 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 ] bi - (start-node) ; + host-name over (start-node) ; TUPLE: remote-process id node ; diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor index f5cc89f8d5..a7f4246826 100644 --- a/extra/cords/cords.factor +++ b/extra/cords/cords.factor @@ -1,4 +1,4 @@ -! Copysecond (C) 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences sorting math math.order arrays combinators kernel ; diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 48380a0d57..214b45ce0c 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -424,6 +424,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED } 2cleave message boa ; +: ba->message ( ba -- message ) parse-message ; + +: with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : send-receive-udp ( ba server -- ba ) diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index de36d661aa..04b3ecfbee 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -1,15 +1,17 @@ -USING: kernel combinators sequences sets math - io.sockets unicode.case accessors +USING: kernel combinators sequences sets math threads namespaces continuations + debugger io io.sockets unicode.case accessors destructors combinators.cleave combinators.lib - newfx + newfx fry dns dns.util dns.misc ; IN: dns.server ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: records ( -- vector ) V{ } ; +SYMBOL: records-var + +: records ( -- records ) records-var get ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -50,9 +52,10 @@ IN: dns.server : rr->rdata-names ( rr -- names/f ) { - { [ dup type>> NS = ] [ rdata>> {1} ] } - { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } - { [ t ] [ drop f ] } + { [ dup type>> NS = ] [ rdata>> {1} ] } + { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] } + { [ dup type>> CNAME = ] [ rdata>> {1} ] } + { [ t ] [ drop f ] } } cond ; @@ -192,31 +195,14 @@ DEFER: query->rrs ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: (socket) ( -- vec ) V{ f } ; +: (handle-request) ( packet -- ) + [ [ find-answer ] with-message-bytes ] change-data respond ; -: socket ( -- socket ) (socket) 1st ; +: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ; -: init-socket-on-port ( port -- ) - f swap 0 (socket) as-mutate ; +: receive-loop ( socket -- ) + [ receive-packet handle-request ] [ receive-loop ] bi ; -: init-socket ( -- ) 53 init-socket-on-port ; +: loop ( addr-spec -- ) + [ '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: loop ( -- ) - socket receive - swap - parse-message - find-answer - message->ba - swap - socket send - loop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: start ( -- ) init-socket loop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: start diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5933216a3c..35af74b92a 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -16,4 +16,15 @@ MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 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 ; + diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor index 62150bdf49..041f3db675 100755 --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -3,14 +3,12 @@ namespaces sequences system combinators editors.vim editors.gvim.backend vocabs.loader ; IN: editors.gvim -TUPLE: gvim ; +SINGLETON: gvim M: gvim vim-command ( file line -- string ) - [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ; + [ gvim-path , swap , "+" swap number>string append , ] { } make ; -t vim-detach set-global ! don't block the ui - -T{ gvim } vim-editor set-global +gvim vim-editor set-global { { [ os unix? ] [ "editors.gvim.unix" ] } diff --git a/extra/editors/vim/vim-docs.factor b/extra/editors/vim/vim-docs.factor index 020117564d..cf42884084 100644 --- a/extra/editors/vim/vim-docs.factor +++ b/extra/editors/vim/vim-docs.factor @@ -11,7 +11,5 @@ $nl "USE: vim" "\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global" } -"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." -$nl -"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ; +"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ; diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor index 9ce256868b..bfbb8f15a5 100755 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -3,24 +3,20 @@ namespaces parser prettyprint sequences editors accessors ; IN: editors.vim SYMBOL: vim-path -SYMBOL: vim-detach SYMBOL: vim-editor -HOOK: vim-command vim-editor +HOOK: vim-command vim-editor ( file line -- array ) -TUPLE: vim ; +SINGLETON: vim -M: vim vim-command ( file line -- array ) +M: vim vim-command [ vim-path get , swap , "+" swap number>string append , ] { } make ; : vim-location ( file line -- ) - vim-command - 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 diff --git a/extra/eval-server/eval-server.factor b/extra/eval-server/eval-server.factor deleted file mode 100644 index 3bfae616a2..0000000000 --- a/extra/eval-server/eval-server.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: listener io.server strings parser byte-arrays ; -IN: eval-server - -: eval-server ( -- ) - 9998 local-server "eval-server" [ - >string eval>string >byte-array - ] with-datagrams ; - -MAIN: eval-server diff --git a/extra/eval-server/summary.txt b/extra/eval-server/summary.txt deleted file mode 100644 index b75930ac9f..0000000000 --- a/extra/eval-server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Listens for UDP packets on localhost:9998, evaluates them and sends back result diff --git a/extra/eval-server/tags.txt b/extra/eval-server/tags.txt deleted file mode 100644 index f628c95985..0000000000 --- a/extra/eval-server/tags.txt +++ /dev/null @@ -1,4 +0,0 @@ -demos -network -tools -applications diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index d5110de02d..321648136a 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -7,6 +7,7 @@ sequences.deep unicode.categories ; IN: farkup SYMBOL: relative-link-prefix +SYMBOL: disable-images? SYMBOL: link-no-follow? r , r> + " href=\"" , >r , r> "\"" , link-no-follow? get [ " nofollow=\"true\"" , ] when - "\">" , , "" , + ">" , , "" , ] { } make ; : make-image-link ( href alt -- seq ) - escape-link - [ - "\""" , ] - { } make ; + disable-images? get [ + 2drop "Images are not allowed" + ] [ + escape-link + [ + "\""" , + ] { } make + ] if ; MEMO: image-link ( -- parser ) [ diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index cce69dde0f..c71eadb72f 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.8-bit io.encodings io.encodings.binary io.encodings.utf8 io.files -io.server io.sockets kernel math.parser namespaces sequences +io.sockets kernel math.parser namespaces sequences ftp io.unix.launcher.parser unicode.case splitting assocs -classes io.server destructors calendar io.timeouts +classes io.servers.connection destructors calendar io.timeouts io.streams.duplex threads continuations math concurrency.promises byte-arrays ; IN: ftp.server @@ -305,7 +305,10 @@ ERROR: not-a-directory ; [ drop unrecognized-command t ] } case [ handle-client-loop ] when ; -: handle-client ( -- ) +TUPLE: ftp-server < threaded-server ; + +M: ftp-server handle-client* ( server -- ) + drop [ "" [ host-name client set @@ -313,9 +316,14 @@ ERROR: not-a-directory ; ] with-directory ] with-destructors ; +: ( 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 ; + start-server ; : ftpd-main ( -- ) 2100 ftpd ; diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 2b3144fd27..4b431c83bc 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -8,6 +8,7 @@ http.server http.server.responses furnace furnace.flash +html.forms html.elements html.components html.components @@ -20,10 +21,10 @@ SYMBOL: params SYMBOL: rest : render-validation-messages ( -- ) - validation-messages get + form get errors>> dup empty? [ drop ] [
    - [
  • message>> escape-string write
    • ] each + [
  • escape-string write
    • ] each
] if ; @@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ; : ( -- action ) action new-action ; -: flashed-variables ( -- seq ) - { validation-messages named-validation-messages } ; +: set-nested-form ( form name -- ) + dup empty? [ + drop form set + ] [ + dup length 1 = [ + first set-value + ] [ + unclip [ set-nested-form ] nest-form + ] if + ] if ; + +: restore-validation-errors ( -- ) + form fget [ + nested-forms fget set-nested-form + ] when* ; : handle-get ( action -- response ) '[ @@ -46,25 +60,12 @@ TUPLE: action rest authorize init display validate submit ; { [ init>> call ] [ authorize>> call ] - [ drop flashed-variables restore-flash ] + [ drop restore-validation-errors ] [ display>> call ] } cleave ] [ drop <400> ] if ] with-exit-continuation ; -: validation-failed ( -- * ) - post-request? [ f ] [ <400> ] if exit-with ; - -: (handle-post) ( action -- response ) - '[ - , dup submit>> [ - [ validate>> call ] - [ authorize>> call ] - [ submit>> call ] - tri - ] [ drop <400> ] if - ] with-exit-continuation ; - : param ( name -- value ) params get at ; @@ -74,24 +75,29 @@ TUPLE: action rest authorize init display validate submit ; revalidate-url-key param dup [ >url [ same-host? ] keep and ] when ; +: validation-failed ( -- * ) + post-request? revalidate-url and + [ + nested-forms-key param " " split harvest nested-forms set + { form nested-forms } + ] [ <400> ] if* + exit-with ; + : handle-post ( action -- response ) '[ - form-nesting-key params get at " " split - [ , (handle-post) ] - [ swap '[ , , nest-values ] ] reduce - call - ] with-exit-continuation - [ - revalidate-url - [ flashed-variables ] [ <403> ] if* - ] unless* ; + , dup submit>> [ + [ validate>> call ] + [ authorize>> call ] + [ submit>> call ] + tri + ] [ drop <400> ] if + ] with-exit-continuation ; : handle-rest ( path action -- assoc ) rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; : init-action ( path action -- ) - blank-values - init-validation + begin-form handle-rest request get request-params assoc-union params set ; @@ -110,8 +116,7 @@ M: action modify-form validation-failed? [ validation-failed ] when ; : validate-params ( validators -- ) - params get swap validate-values from-object - check-validation ; + params get swap validate-values check-validation ; : validate-integer-id ( -- ) { { "id" [ v-number ] } } validate-params ; diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor index 14ffbaba9d..28c34e6715 100644 --- a/extra/furnace/alloy/alloy.factor +++ b/extra/furnace/alloy/alloy.factor @@ -7,7 +7,8 @@ furnace.flash furnace.sessions furnace.referrer furnace.db -furnace.auth.providers ; +furnace.auth.providers +furnace.auth.login.permits ; IN: furnace.alloy : ( responder db params -- responder' ) @@ -19,7 +20,7 @@ IN: furnace.alloy ] call ; -: state-classes { session flash-scope aside } ; inline +: state-classes { session flash-scope aside permit } ; inline : init-furnace-tables ( -- ) state-classes ensure-tables diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index 15d1c1df0b..9f1411188c 100644 --- a/extra/furnace/asides/asides.factor +++ b/extra/furnace/asides/asides.factor @@ -4,7 +4,7 @@ USING: accessors namespaces sequences arrays kernel assocs assocs.lib hashtables math.parser urls combinators html.elements html.templates.chloe.syntax db.types db.tuples http http.server http.server.filters -furnace furnace.cache furnace.sessions ; +furnace furnace.cache furnace.sessions furnace.redirection ; IN: furnace.asides TUPLE: aside < server-state session method url post-data ; diff --git a/extra/furnace/auth/auth-tests.factor b/extra/furnace/auth/auth-tests.factor new file mode 100644 index 0000000000..220a8cd04c --- /dev/null +++ b/extra/furnace/auth/auth-tests.factor @@ -0,0 +1,6 @@ +USING: furnace.auth tools.test ; +IN: furnace.auth.tests + +\ logged-in-username must-infer +\ must-infer +\ new-realm must-infer diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index f78cea3835..ae042f05bd 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -1,15 +1,25 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets +destructors combinators fry +io.encodings.utf8 io.encodings.string io.binary random +checksums checksums.sha2 +html.forms http.server http.server.filters http.server.dispatchers -furnace.sessions -furnace.auth.providers ; +furnace +furnace.actions +furnace.redirection +furnace.boilerplate +furnace.auth.providers +furnace.auth.providers.db ; IN: furnace.auth SYMBOL: logged-in-user +: logged-in? ( -- ? ) logged-in-user get >boolean ; + GENERIC: init-user-profile ( responder -- ) M: object init-user-profile drop ; @@ -20,6 +30,9 @@ M: dispatcher init-user-profile M: filter-responder init-user-profile responder>> init-user-profile ; +: have-capability? ( capability -- ? ) + logged-in-user get capabilities>> member? ; + : profile ( -- assoc ) logged-in-user get profile>> ; : user-changed ( -- ) @@ -41,3 +54,100 @@ SYMBOL: capabilities V{ } clone capabilities set-global : define-capability ( word -- ) capabilities get adjoin ; + +TUPLE: realm < dispatcher name users checksum secure ; + +GENERIC: login-required* ( realm -- response ) + +GENERIC: logged-in-username ( realm -- username ) + +: login-required ( -- * ) realm get login-required* exit-with ; + +: new-realm ( responder name class -- realm ) + new-dispatcher + swap >>name + swap >>default + users-in-db >>users + sha-256 >>checksum + t >>secure ; inline + +: users ( -- provider ) + realm get users>> ; + +TUPLE: user-saver user ; + +C: user-saver + +M: user-saver dispose + user>> dup changed?>> [ users update-user ] [ drop ] if ; + +: save-user-after ( user -- ) + &dispose drop ; + +: init-user ( user -- ) + [ [ logged-in-user set ] [ save-user-after ] bi ] when* ; + +M: realm call-responder* ( path responder -- response ) + dup realm set + dup logged-in-username dup [ users get-user ] when init-user + call-next-method ; + +: encode-password ( string salt -- bytes ) + [ utf8 encode ] [ 4 >be ] bi* append + realm get checksum>> checksum-bytes ; + +: >>encoded-password ( user string -- user ) + 32 random-bits [ encode-password ] keep + [ >>password ] [ >>salt ] bi* ; inline + +: valid-login? ( password user -- ? ) + [ salt>> encode-password ] [ password>> ] bi = ; + +: check-login ( password username -- user/f ) + users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ; + +: if-secure-realm ( quot -- ) + realm get secure>> [ if-secure ] [ call ] if ; inline + +TUPLE: secure-realm-only < filter-responder ; + +C: secure-realm-only + +M: secure-realm-only call-responder* + '[ , , call-next-method ] if-secure-realm ; + +TUPLE: protected < filter-responder description capabilities ; + +: ( responder -- protected ) + protected new + swap >>responder ; + +: check-capabilities ( responder user/f -- ? ) + { + { [ dup not ] [ 2drop f ] } + { [ dup deleted>> 1 = ] [ 2drop f ] } + [ [ capabilities>> ] bi@ subset? ] + } cond ; + +M: protected call-responder* ( path responder -- response ) + '[ + , , + dup protected set + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop realm get login-required* ] if + ] if-secure-realm ; + +: ( responder -- responder' ) + { realm "boilerplate" } >>template ; + +: password-mismatch ( -- * ) + "passwords do not match" validation-error + validation-failed ; + +: same-password-twice ( -- ) + "new-password" value "verify-password" value = + [ password-mismatch ] unless ; + +: user-exists ( -- * ) + "username taken" validation-error + validation-failed ; diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor index c8d542c219..e478f70dcc 100755 --- a/extra/furnace/auth/basic/basic.factor +++ b/extra/furnace/auth/basic/basic.factor @@ -1,41 +1,29 @@ ! Copyright (c) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors quotations assocs kernel splitting -base64 html.elements io combinators sequences -http http.server.filters http.server.responses http.server -furnace.auth.providers furnace.auth.login ; +USING: accessors kernel splitting base64 namespaces strings +http http.server.responses furnace.auth ; IN: furnace.auth.basic -TUPLE: basic-auth < filter-responder realm provider ; +TUPLE: basic-auth-realm < realm ; -C: basic-auth +: ( responder name -- realm ) + basic-auth-realm new-realm ; -: authorization-ok? ( provider header -- ? ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. +: parse-basic-auth ( header -- username/f password/f ) dup [ " " split1 swap "Basic" = [ - base64> ":" split1 spin check-login - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; + base64> >string ":" split1 + ] [ drop f f ] if + ] [ drop f f ] if ; : <401> ( realm -- response ) - 401 "Unauthorized" - "Basic realm=\"" rot "\"" 3append - "WWW-Authenticate" set-header - [ - - "Username or Password is invalid" write - - ] >>body ; + 401 "Invalid username or password" + [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ; -: logged-in? ( request responder -- ? ) - provider>> swap "authorization" header authorization-ok? ; +M: basic-auth-realm login-required* ( realm -- response ) + name>> <401> ; -M: basic-auth call-responder* ( request path responder -- response ) - pick over logged-in? - [ call-next-method ] [ 2nip realm>> <401> ] if ; +M: basic-auth-realm logged-in-username ( realm -- uid ) + drop + request get "authorization" header parse-basic-auth + dup [ over check-login swap and ] [ 2drop f ] if ; diff --git a/extra/furnace/auth/login/boilerplate.xml b/extra/furnace/auth/boilerplate.xml similarity index 100% rename from extra/furnace/auth/login/boilerplate.xml rename to extra/furnace/auth/boilerplate.xml diff --git a/extra/furnace/auth/features/deactivate-user/deactivate-user.factor b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor new file mode 100644 index 0000000000..cf6a56c2d4 --- /dev/null +++ b/extra/furnace/auth/features/deactivate-user/deactivate-user.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs namespaces accessors db db.tuples urls +http.server.dispatchers +furnace.asides furnace.actions furnace.auth furnace.auth.providers ; +IN: furnace.auth.features.deactivate-user + +: ( -- action ) + + [ + logged-in-user get + 1 >>deleted + t >>changed? + drop + URL" $realm" end-aside + ] >>submit ; + +: allow-deactivation ( realm -- realm ) + + "delete your profile" >>description + "deactivate-user" add-responder ; + +: allow-deactivation? ( -- ? ) + realm get responders>> "deactivate-user" swap key? ; diff --git a/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor new file mode 100644 index 0000000000..d0fdf22c27 --- /dev/null +++ b/extra/furnace/auth/features/edit-profile/edit-profile-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.auth.features.edit-profile.tests +USING: tools.test furnace.auth.features.edit-profile ; + +\ allow-edit-profile must-infer diff --git a/extra/furnace/auth/features/edit-profile/edit-profile.factor b/extra/furnace/auth/features/edit-profile/edit-profile.factor new file mode 100644 index 0000000000..e03fca99a5 --- /dev/null +++ b/extra/furnace/auth/features/edit-profile/edit-profile.factor @@ -0,0 +1,67 @@ +! Copyright (c) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors namespaces sequences assocs +validators urls +html.forms +http.server.dispatchers +furnace.auth +furnace.asides +furnace.actions ; +IN: furnace.auth.features.edit-profile + +: ( -- 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 + + + "edit your profile" >>description ; + +: allow-edit-profile ( login -- login ) + "edit-profile" add-responder ; + +: allow-edit-profile? ( -- ? ) + realm get responders>> "edit-profile" swap key? ; diff --git a/extra/furnace/auth/login/edit-profile.xml b/extra/furnace/auth/features/edit-profile/edit-profile.xml similarity index 86% rename from extra/furnace/auth/login/edit-profile.xml rename to extra/furnace/auth/features/edit-profile/edit-profile.xml index 6beaf5de6d..a9d7994e97 100644 --- a/extra/furnace/auth/login/edit-profile.xml +++ b/extra/furnace/auth/features/edit-profile/edit-profile.xml @@ -4,7 +4,7 @@ Edit Profile - + @@ -67,4 +67,7 @@ + + Delete User + diff --git a/extra/furnace/auth/login/recover-1.xml b/extra/furnace/auth/features/recover-password/recover-1.xml similarity index 94% rename from extra/furnace/auth/login/recover-1.xml rename to extra/furnace/auth/features/recover-password/recover-1.xml index 21fbe6fd39..46e52d5319 100644 --- a/extra/furnace/auth/login/recover-1.xml +++ b/extra/furnace/auth/features/recover-password/recover-1.xml @@ -6,7 +6,7 @@

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.

- +
diff --git a/extra/furnace/auth/login/recover-2.xml b/extra/furnace/auth/features/recover-password/recover-2.xml similarity index 100% rename from extra/furnace/auth/login/recover-2.xml rename to extra/furnace/auth/features/recover-password/recover-2.xml diff --git a/extra/furnace/auth/login/recover-3.xml b/extra/furnace/auth/features/recover-password/recover-3.xml similarity index 94% rename from extra/furnace/auth/login/recover-3.xml rename to extra/furnace/auth/features/recover-password/recover-3.xml index 2e412d1f18..a71118ea31 100644 --- a/extra/furnace/auth/login/recover-3.xml +++ b/extra/furnace/auth/features/recover-password/recover-3.xml @@ -6,7 +6,7 @@

Choose a new password for your account.

- +
diff --git a/extra/furnace/auth/login/recover-4.xml b/extra/furnace/auth/features/recover-password/recover-4.xml similarity index 60% rename from extra/furnace/auth/login/recover-4.xml rename to extra/furnace/auth/features/recover-password/recover-4.xml index f5d02fa858..d71a01bc25 100755 --- a/extra/furnace/auth/login/recover-4.xml +++ b/extra/furnace/auth/features/recover-password/recover-4.xml @@ -4,6 +4,6 @@ Recover lost password: step 4 of 4 -

Your password has been reset. You may now log in.

+

Your password has been reset. You may now proceed.

diff --git a/extra/furnace/auth/features/recover-password/recover-password-tests.factor b/extra/furnace/auth/features/recover-password/recover-password-tests.factor new file mode 100644 index 0000000000..b589c52624 --- /dev/null +++ b/extra/furnace/auth/features/recover-password/recover-password-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.auth.features.recover-password +USING: tools.test furnace.auth.features.recover-password ; + +\ allow-password-recovery must-infer diff --git a/extra/furnace/auth/features/recover-password/recover-password.factor b/extra/furnace/auth/features/recover-password/recover-password.factor new file mode 100644 index 0000000000..93b3a7ad73 --- /dev/null +++ b/extra/furnace/auth/features/recover-password/recover-password.factor @@ -0,0 +1,124 @@ +! Copyright (c) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces accessors kernel assocs arrays io.sockets threads +fry urls smtp validators html.forms present +http http.server.responses http.server.redirection +http.server.dispatchers +furnace furnace.actions furnace.auth furnace.auth.providers +furnace.redirection ; +IN: furnace.auth.features.recover-password + +SYMBOL: lost-password-from + +: current-host ( -- string ) + request get url>> host>> host-name or ; + +: new-password-url ( user -- url ) + URL" recover-3" clone + swap + [ username>> "username" set-query-param ] + [ ticket>> "ticket" set-query-param ] + bi + adjust-url relative-to-request ; + +: password-email ( user -- email ) + + [ "[ " % 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 ; + +: ( -- 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" + ] >>submit ; + +: ( -- action ) + + { realm "features/recover-password/recover-2" } >>template ; + +: ( -- 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" + ] [ + <403> + ] if* + ] >>submit ; + +: ( -- action ) + + { realm "features/recover-password/recover-4" } >>template ; + +: allow-password-recovery ( login -- login ) + + "recover-password" add-responder + + "recover-2" add-responder + + "recover-3" add-responder + + "recover-4" add-responder ; + +: allow-password-recovery? ( -- ? ) + realm get responders>> "recover-password" swap key? ; diff --git a/extra/furnace/auth/login/register.xml b/extra/furnace/auth/features/registration/register.xml similarity index 100% rename from extra/furnace/auth/login/register.xml rename to extra/furnace/auth/features/registration/register.xml diff --git a/extra/furnace/auth/features/registration/registration-tests.factor b/extra/furnace/auth/features/registration/registration-tests.factor new file mode 100644 index 0000000000..e770f35586 --- /dev/null +++ b/extra/furnace/auth/features/registration/registration-tests.factor @@ -0,0 +1,4 @@ +IN: furnace.auth.features.registration.tests +USING: tools.test furnace.auth.features.registration ; + +\ allow-registration must-infer diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor new file mode 100644 index 0000000000..20a48d07d2 --- /dev/null +++ b/extra/furnace/auth/features/registration/registration.factor @@ -0,0 +1,45 @@ +! Copyright (c) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel namespaces validators html.forms urls +http.server.dispatchers +furnace furnace.auth furnace.auth.providers furnace.actions +furnace.redirection ; +IN: furnace.auth.features.registration + +: ( -- 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 + "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" + ] >>submit + ; + +: allow-registration ( login -- login ) + "register" add-responder ; + +: allow-registration? ( -- ? ) + realm get responders>> "register" swap key? ; diff --git a/extra/furnace/auth/login/login-tests.factor b/extra/furnace/auth/login/login-tests.factor index 5095ebdb85..64f7bd3b96 100755 --- a/extra/furnace/auth/login/login-tests.factor +++ b/extra/furnace/auth/login/login-tests.factor @@ -1,6 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer -\ allow-registration must-infer -\ allow-password-recovery must-infer +\ must-infer diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index a1d2bf47c3..68161382c1 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -1,99 +1,71 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors quotations assocs kernel splitting -combinators sequences namespaces hashtables sets -fry arrays threads qualified random validators words -io -io.sockets -io.encodings.utf8 -io.encodings.string -io.binary -continuations -destructors -checksums -checksums.sha2 -validators -html.components -html.elements -urls -http -http.server -http.server.dispatchers -http.server.filters -http.server.responses +USING: kernel accessors namespaces sequences math.parser +calendar validators urls html.forms +http http.server http.server.dispatchers furnace furnace.auth -furnace.auth.providers -furnace.auth.providers.db -furnace.actions -furnace.asides furnace.flash +furnace.asides +furnace.actions furnace.sessions -furnace.boilerplate ; -QUALIFIED: smtp +furnace.utilities +furnace.redirection +furnace.auth.login.permits ; IN: furnace.auth.login -: word>string ( word -- string ) - [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; +SYMBOL: permit-id -: words>strings ( seq -- seq' ) - [ word>string ] map ; +: permit-id-key ( realm -- string ) + [ >hex 2 CHAR: 0 pad-left ] { } map-as concat + "__p_" prepend ; -: string>word ( string -- word ) - ":" split1 swap lookup ; +: client-permit-id ( realm -- id/f ) + permit-id-key client-state dup [ string>number ] when ; -: strings>words ( seq -- seq' ) - [ string>word ] map ; +TUPLE: login-realm < realm timeout domain ; -TUPLE: login < dispatcher users checksum ; +M: login-realm call-responder* + [ name>> client-permit-id permit-id set ] + [ call-next-method ] + bi ; -TUPLE: protected < filter-responder description capabilities ; +M: login-realm logged-in-username + drop permit-id get dup [ get-permit-uid ] when ; -: ( responder -- protected ) - protected new - swap >>responder ; +M: login-realm modify-form ( responder -- ) + drop permit-id get realm get name>> permit-id-key hidden-form-field ; -: users ( -- provider ) - login get users>> ; +: ( -- cookie ) + permit-id get realm get name>> permit-id-key + "$login-realm" resolve-base-path >>path + realm get + [ timeout>> from-now >>expires ] + [ domain>> >>domain ] + [ secure>> >>secure ] + tri ; -: encode-password ( string salt -- bytes ) - [ utf8 encode ] [ 4 >be ] bi* append - login get checksum>> checksum-bytes ; +: put-permit-cookie ( response -- response' ) + put-cookie ; -: >>encoded-password ( user string -- user ) - 32 random-bits [ encode-password ] keep - [ >>password ] [ >>salt ] bi* ; inline - -: valid-login? ( password user -- ? ) - [ salt>> encode-password ] [ password>> ] bi = ; - -: check-login ( password username -- user/f ) - users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ; - -! Destructor -TUPLE: user-saver user ; - -C: user-saver - -M: user-saver dispose - user>> dup changed?>> [ users update-user ] [ drop ] if ; - -: save-user-after ( user -- ) - &dispose drop ; - -! ! ! Login : successful-login ( user -- response ) - username>> set-uid URL" $login" end-aside ; + [ username>> make-permit permit-id set ] [ init-user ] bi + URL" $realm" end-aside + put-permit-cookie ; -: login-failed ( -- * ) - "invalid username or password" validation-error - validation-failed ; +: logout ( -- ) + permit-id get [ delete-permit ] when* + URL" $realm" end-aside ; SYMBOL: description SYMBOL: capabilities : flashed-variables { description capabilities } ; +: login-failed ( -- * ) + "invalid username or password" validation-error + validation-failed ; + : ( -- action ) [ @@ -102,7 +74,7 @@ SYMBOL: capabilities capabilities get words>strings "capabilities" set-value ] >>init - { login "login" } >>template + { login-realm "login" } >>template [ { @@ -113,288 +85,25 @@ SYMBOL: capabilities "password" value "username" value check-login [ successful-login ] [ login-failed ] if* - ] >>submit ; - -! ! ! New user registration - -: user-exists ( -- * ) - "username taken" validation-error - validation-failed ; - -: password-mismatch ( -- * ) - "passwords do not match" validation-error - validation-failed ; - -: same-password-twice ( -- ) - "new-password" value "verify-password" value = - [ password-mismatch ] unless ; - -: ( -- action ) - - { login "register" } >>template - - [ - { - { "username" [ v-username ] } - { "realname" [ [ v-one-line ] v-optional ] } - { "new-password" [ v-password ] } - { "verify-password" [ v-password ] } - { "email" [ [ v-email ] v-optional ] } - { "captcha" [ v-captcha ] } - } validate-params - - same-password-twice - ] >>validate - - [ - "username" value - "realname" value >>realname - "new-password" value >>encoded-password - "email" value >>email - H{ } clone >>profile - - users new-user [ user-exists ] unless* - - login get init-user-profile - - successful-login - ] >>submit ; - -! ! ! Editing user profile - -: ( -- action ) - - [ - logged-in-user get - [ username>> "username" set-value ] - [ realname>> "realname" set-value ] - [ email>> "email" set-value ] - tri - ] >>init - - { login "edit-profile" } >>template - - [ - uid "username" set-value - - { - { "realname" [ [ v-one-line ] v-optional ] } - { "password" [ ] } - { "new-password" [ [ v-password ] v-optional ] } - { "verify-password" [ [ v-password ] v-optional ] } - { "email" [ [ v-email ] v-optional ] } - } validate-params - - { "password" "new-password" "verify-password" } - [ value empty? not ] contains? [ - "password" value uid check-login - [ "incorrect password" validation-error ] unless - - same-password-twice - ] when - ] >>validate - - [ - logged-in-user get - - "new-password" value dup empty? - [ drop ] [ >>encoded-password ] if - - "realname" value >>realname - "email" value >>email - - t >>changed? - - drop - - URL" $login" end-aside ] >>submit + + ; - - "edit your profile" >>description ; - -! ! ! Password recovery - -SYMBOL: lost-password-from - -: current-host ( -- string ) - request get url>> host>> host-name or ; - -: new-password-url ( user -- url ) - "recover-3" - swap [ - [ username>> "username" set ] - [ ticket>> "ticket" set ] - bi - ] H{ } make-assoc - derive-url ; - -: password-email ( user -- email ) - smtp: - [ "[ " % current-host % " ] password recovery" % ] "" make >>subject - lost-password-from get >>from - over email>> 1array >>to - [ - "This e-mail was sent by the application server on " % current-host % "\n" % - "because somebody, maybe you, clicked on a ``recover password'' link in the\n" % - "login form, and requested a new password for the user named ``" % - over username>> % "''.\n" % - "\n" % - "If you believe that this request was legitimate, you may click the below link in\n" % - "your browser to set a new password for your account:\n" % - "\n" % - swap new-password-url % - "\n\n" % - "Love,\n" % - "\n" % - " FactorBot\n" % - ] "" make >>body ; - -: send-password-email ( user -- ) - '[ , password-email smtp:send-email ] - "E-mail send thread" spawn drop ; - -: ( -- action ) - - { login "recover-1" } >>template - - [ - { - { "username" [ v-username ] } - { "email" [ v-email ] } - { "captcha" [ v-captcha ] } - } validate-params - ] >>validate - - [ - "email" value "username" value - users issue-ticket [ - send-password-email - ] when* - - URL" $login/recover-2" - ] >>submit ; - -: ( -- action ) - - { login "recover-2" } >>template ; - -: ( -- action ) - - [ - { - { "username" [ v-username ] } - { "ticket" [ v-required ] } - } validate-params - ] >>init - - { login "recover-3" } >>template - - [ - { - { "username" [ v-username ] } - { "ticket" [ v-required ] } - { "new-password" [ v-password ] } - { "verify-password" [ v-password ] } - } validate-params - - same-password-twice - ] >>validate - - [ - "ticket" value - "username" value - users claim-ticket [ - "new-password" value >>encoded-password - users update-user - - URL" $login/recover-4" - ] [ - <403> - ] if* - ] >>submit ; - -: ( -- action ) - - { login "recover-4" } >>template ; - -! ! ! Logout : ( -- action ) - [ - f set-uid - URL" $login" end-aside - ] >>submit ; + [ logout ] >>submit + + "logout" >>description ; -! ! ! Authentication logic -: show-login-page ( -- response ) +M: login-realm login-required* + drop begin-aside protected get description>> description set protected get capabilities>> capabilities set - URL" $login/login" flashed-variables ; + URL" $realm/login" >secure-url flashed-variables ; -: login-required ( -- * ) - show-login-page exit-with ; - -: have-capability? ( capability -- ? ) - logged-in-user get capabilities>> member? ; - -: check-capabilities ( responder user/f -- ? ) - dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ; - -M: protected call-responder* ( path responder -- response ) - dup protected set - dup logged-in-user get check-capabilities - [ call-next-method ] [ 2drop show-login-page ] if ; - -: init-user ( -- ) - uid [ - users get-user - [ logged-in-user set ] - [ save-user-after ] bi - ] when* ; - -M: login call-responder* ( path responder -- response ) - dup login set - init-user - call-next-method ; - -: ( responder -- responder' ) - - { login "boilerplate" } >>template ; - -: ( responder -- auth ) - login new-dispatcher - swap >>default - "login" add-responder - "logout" add-responder - users-in-db >>users - sha-256 >>checksum ; - -! ! ! Configuration - -: allow-edit-profile ( login -- login ) - "edit-profile" add-responder ; - -: allow-registration ( login -- login ) - - "register" add-responder ; - -: allow-password-recovery ( login -- login ) - - "recover-password" add-responder - - "recover-2" add-responder - - "recover-3" add-responder - - "recover-4" add-responder ; - -: allow-edit-profile? ( -- ? ) - login get responders>> "edit-profile" swap key? ; - -: allow-registration? ( -- ? ) - login get responders>> "register" swap key? ; - -: allow-password-recovery? ( -- ? ) - login get responders>> "recover-password" swap key? ; +: ( responder name -- auth ) + login-realm new-realm + "login" add-responder + "logout" add-responder + 20 minutes >>timeout ; diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index a7ac92bf44..81f9520e76 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -43,11 +43,11 @@

- + Register | - + Recover Password

diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor new file mode 100644 index 0000000000..49cf98e0e3 --- /dev/null +++ b/extra/furnace/auth/login/permits/permits.factor @@ -0,0 +1,30 @@ +USING: accessors namespaces combinators.lib kernel +db.tuples db.types +furnace.auth furnace.sessions furnace.cache ; +IN: furnace.auth.login.permits + +TUPLE: permit < server-state session uid ; + +permit "PERMITS" { + { "session" "SESSION" BIG-INTEGER +not-null+ } + { "uid" "UID" { VARCHAR 255 } +not-null+ } +} define-persistent + +: touch-permit ( permit -- ) + realm get touch-state ; + +: get-permit-uid ( id -- uid ) + permit get-state { + [ ] + [ session>> session get id>> = ] + [ [ touch-permit ] [ uid>> ] bi ] + } 1&& ; + +: make-permit ( uid -- id ) + permit new + swap >>uid + session get id>> >>session + [ touch-permit ] [ insert-tuple ] [ id>> ] tri ; + +: delete-permit ( id -- ) + permit new-server-state delete-tuples ; diff --git a/extra/furnace/auth/providers/assoc/assoc-tests.factor b/extra/furnace/auth/providers/assoc/assoc-tests.factor index 8f9eeaa7a5..8fe1dd4dd4 100755 --- a/extra/furnace/auth/providers/assoc/assoc-tests.factor +++ b/extra/furnace/auth/providers/assoc/assoc-tests.factor @@ -1,11 +1,11 @@ IN: furnace.auth.providers.assoc.tests -USING: furnace.actions furnace.auth.providers +USING: furnace.actions furnace.auth furnace.auth.providers furnace.auth.providers.assoc furnace.auth.login tools.test namespaces accessors kernel ; - + "Test" >>users -login set +realm set [ t ] [ "slava" diff --git a/extra/furnace/auth/providers/db/db-tests.factor b/extra/furnace/auth/providers/db/db-tests.factor index e5914c7ab3..fac5c23e4a 100755 --- a/extra/furnace/auth/providers/db/db-tests.factor +++ b/extra/furnace/auth/providers/db/db-tests.factor @@ -1,14 +1,13 @@ IN: furnace.auth.providers.db.tests USING: furnace.actions +furnace.auth furnace.auth.login furnace.auth.providers furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files accessors kernel ; - - users-in-db >>users -login set + "test" realm set [ "auth-test.db" temp-file delete-file ] ignore-errors diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index 7c5b7a0c81..0e2a673d9b 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,19 +1,32 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces -html.templates html.templates.chloe +USING: accessors kernel math.order namespaces combinators.lib +html.forms +html.templates +html.templates.chloe locals http.server http.server.filters furnace ; IN: furnace.boilerplate -TUPLE: boilerplate < filter-responder template ; +TUPLE: boilerplate < filter-responder template init ; -: ( responder -- boilerplate ) f boilerplate boa ; +: ( 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 | [ diff --git a/extra/furnace/db/db.factor b/extra/furnace/db/db.factor index 8487b4b3fc..b4a4386015 100755 --- a/extra/furnace/db/db.factor +++ b/extra/furnace/db/db.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors continuations namespaces destructors -db db.pools io.pools http.server http.server.filters -furnace.sessions ; +db db.pools io.pools http.server http.server.filters ; IN: furnace.db TUPLE: db-persistence < filter-responder pool ; diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor index 43e0d293a5..2149e4fcd7 100644 --- a/extra/furnace/flash/flash.factor +++ b/extra/furnace/flash/flash.factor @@ -3,7 +3,7 @@ USING: namespaces assocs assocs.lib kernel sequences accessors urls db.types db.tuples math.parser fry http http.server http.server.filters http.server.redirection -furnace furnace.cache furnace.sessions ; +furnace furnace.cache furnace.sessions furnace.redirection ; IN: furnace.flash TUPLE: flash-scope < server-state session namespace ; @@ -25,7 +25,9 @@ TUPLE: flash-scopes < server-state-manager ; SYMBOL: flash-scope -: fget ( key -- value ) flash-scope get at ; +: fget ( key -- value ) + flash-scope get dup + [ namespace>> at ] [ 2drop f ] if ; : get-flash-scope ( id -- flash-scope ) dup [ flash-scope get-state ] when diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 2645146fbf..90b529e385 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -10,6 +10,7 @@ xml.entities xml.writer html.components html.elements +html.forms html.templates html.templates.chloe html.templates.chloe.syntax @@ -30,7 +31,7 @@ IN: furnace : base-path ( string -- pair ) dup responder-nesting get - [ second class word-name = ] with find nip + [ second class superclasses [ word-name = ] with contains? ] with find nip [ first ] [ "No such responder: " swap append throw ] ?if ; : resolve-base-path ( string -- string' ) @@ -62,13 +63,6 @@ M: url adjust-url M: string adjust-url ; -: ( url -- response ) - adjust-url request get method>> { - { "GET" [ ] } - { "HEAD" [ ] } - { "POST" [ ] } - } case ; - GENERIC: modify-form ( responder -- ) M: object modify-form drop ; @@ -95,6 +89,19 @@ M: object modify-form drop ; request get url>> [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; +: cookie-client-state ( key request -- value/f ) + swap get-cookie dup [ value>> ] when ; + +: post-client-state ( key request -- value/f ) + request-params at ; + +: client-state ( key -- value/f ) + request get dup method>> { + { "GET" [ cookie-client-state ] } + { "HEAD" [ cookie-client-state ] } + { "POST" [ post-client-state ] } + } case ; + SYMBOL: exit-continuation : exit-with ( value -- ) @@ -109,7 +116,8 @@ SYMBOL: exit-continuation [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; : a-url-path ( tag -- string ) - [ "href" required-attr ] [ "rest" optional-attr value ] bi + [ "href" required-attr ] + [ "rest" optional-attr dup [ value ] when ] bi [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; : a-url ( tag -- url ) @@ -153,11 +161,11 @@ CHLOE: a input/> ] [ 2drop ] if ; -: form-nesting-key "__n" ; +: nested-forms-key "__n" ; : form-magic ( tag -- ) [ modify-form ] each-responder - nested-values get " " join f like form-nesting-key hidden-form-field + nested-forms get " " join f like nested-forms-key hidden-form-field "for" optional-attr [ "," split [ hidden render ] each ] when* ; : form-start-tag ( tag -- ) diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor new file mode 100644 index 0000000000..88d621b573 --- /dev/null +++ b/extra/furnace/redirection/redirection.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors combinators namespaces fry +io.servers.connection +http http.server http.server.redirection http.server.filters +furnace ; +IN: furnace.redirection + +: ( url -- response ) + adjust-url request get method>> { + { "GET" [ ] } + { "HEAD" [ ] } + { "POST" [ ] } + } case ; + +: >secure-url ( url -- url' ) + clone + "https" >>protocol + secure-port >>port ; + +: ( url -- response ) + >secure-url ; + +TUPLE: redirect-responder to ; + +: ( url -- responder ) + redirect-responder boa ; + +M: redirect-responder call-responder* nip to>> ; + +TUPLE: secure-only < filter-responder ; + +C: secure-only + +: if-secure ( quot -- ) + >r request get url>> protocol>> "http" = + [ request get url>> ] + r> if ; inline + +M: secure-only call-responder* + '[ , , call-next-method ] if-secure ; diff --git a/extra/furnace/sessions/sessions-tests.factor b/extra/furnace/sessions/sessions-tests.factor index e959cae76a..98d1bbdfc9 100755 --- a/extra/furnace/sessions/sessions-tests.factor +++ b/extra/furnace/sessions/sessions-tests.factor @@ -1,7 +1,7 @@ IN: furnace.sessions.tests USING: tools.test http furnace.sessions furnace.actions http.server http.server.responses -math namespaces kernel accessors io.sockets io.server +math namespaces kernel accessors io.sockets io.servers.connection prettyprint io.streams.string io.files splitting destructors sequences db db.tuples db.sqlite continuations urls math.parser furnace ; @@ -65,7 +65,7 @@ M: foo call-responder* [ [ ] [ - empty-session + empty-session 123 >>id session set ] unit-test diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index ab971d24d0..6e50417ea1 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,22 +1,22 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math.intervals math.parser namespaces -random accessors quotations hashtables sequences continuations -fry calendar combinators destructors alarms io.server +strings random accessors quotations hashtables sequences continuations +fry calendar combinators combinators.lib destructors alarms +io.servers.connection db db.tuples db.types http http.server http.server.dispatchers http.server.filters html.elements furnace furnace.cache ; IN: furnace.sessions -TUPLE: session < server-state uid namespace user-agent client changed? ; +TUPLE: session < server-state namespace user-agent client changed? ; : ( id -- session ) session new-server-state ; session "SESSIONS" { - { "uid" "UID" { VARCHAR 255 } } { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ } { "user-agent" "USER_AGENT" TEXT +not-null+ } { "client" "CLIENT" TEXT +not-null+ } @@ -57,19 +57,17 @@ TUPLE: sessions < server-state-manager domain verify? ; [ namespace>> swap change-at ] keep (session-changed) ; inline -: uid ( -- uid ) - session get uid>> ; - -: set-uid ( uid -- ) - session get [ (>>uid) ] [ (session-changed) ] bi ; - : init-session ( session -- ) session [ sessions get init-session* ] with-variable ; : touch-session ( session -- ) sessions get touch-state ; -: remote-host ( -- string ) remote-address get host>> ; +: remote-host ( -- string ) + { + [ request get "x-forwarded-for" header ] + [ remote-address get host>> ] + } 0|| ; : empty-session ( -- session ) f @@ -100,20 +98,6 @@ M: session-saver dispose : session-id-key "__s" ; -: cookie-session-id ( request -- id/f ) - session-id-key get-cookie - dup [ value>> string>number ] when ; - -: post-session-id ( request -- id/f ) - session-id-key swap request-params at string>number ; - -: request-session-id ( -- id/f ) - request get dup method>> { - { "GET" [ cookie-session-id ] } - { "HEAD" [ cookie-session-id ] } - { "POST" [ post-session-id ] } - } case ; - : verify-session ( session -- session ) sessions get verify?>> [ dup [ @@ -125,16 +109,18 @@ M: session-saver dispose ] when ; : request-session ( -- session/f ) - request-session-id get-session verify-session ; + session-id-key + client-state dup string? [ string>number ] when + get-session verify-session ; -: ( id -- cookie ) - session-id-key +: ( -- cookie ) + session get id>> session-id-key "$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 put-cookie ; + put-cookie ; M: sessions modify-form ( responder -- ) drop session get id>> session-id-key hidden-form-field ; @@ -143,6 +129,3 @@ M: sessions call-responder* ( path responder -- response ) sessions set request-session [ begin-session ] unless* existing-session put-session-cookie ; - -: logout-all-sessions ( uid -- ) - session new swap >>uid delete-tuples ; diff --git a/extra/furnace/utilities/utilities.factor b/extra/furnace/utilities/utilities.factor new file mode 100644 index 0000000000..20c05d459f --- /dev/null +++ b/extra/furnace/utilities/utilities.factor @@ -0,0 +1,19 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: words kernel sequences splitting ; +IN: furnace.utilities + +: word>string ( word -- string ) + [ word-vocabulary ] [ word-name ] bi ":" swap 3append ; + +: words>strings ( seq -- seq' ) + [ word>string ] map ; + +ERROR: no-such-word name vocab ; + +: string>word ( string -- word ) + ":" split1 swap 2dup lookup dup + [ 2nip ] [ drop no-such-word ] if ; + +: strings>words ( seq -- seq' ) + [ string>word ] map ; diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 2ae120b527..5779371078 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -1,9 +1,9 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.elements html.components namespaces ; +html.elements html.components html.forms namespaces ; -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test @@ -63,7 +63,7 @@ TUPLE: color red green blue ; ] with-null-writer ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "new york" "city1" set-value ] unit-test @@ -101,7 +101,7 @@ TUPLE: color red green blue ; ] with-null-writer ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ t "delivery" set-value ] unit-test @@ -156,7 +156,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ ] [ "-foo\n-bar" "farkup" set-value ] unit-test [ "
  • foo
  • bar
" ] [ - [ "farkup" farkup render ] with-string-writer + [ "farkup" T{ farkup } render ] with-string-writer ] unit-test [ ] [ { 1 2 3 } "object" set-value ] unit-test @@ -167,12 +167,19 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; = ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "factor" [ "concatenative" "model" set-value - ] nest-values + ] nest-form ] unit-test -[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test +[ + H{ + { + "factor" + T{ form f V{ } H{ { "model" "concatenative" } } } + } + } +] [ values ] unit-test diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 42d89811c1..b6b7f22b1d 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -1,82 +1,26 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces io math.parser assocs classes -classes.tuple words arrays sequences sequences.lib splitting -mirrors hashtables combinators continuations math strings -fry locals calendar calendar.format xml.entities validators -html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html urls present ; +classes.tuple words arrays sequences splitting mirrors +hashtables combinators continuations math strings inspector +fry locals calendar calendar.format xml.entities +validators urls present +xmode.code2html lcs.diff2html farkup +html.elements html.streams html.forms ; IN: html.components -SYMBOL: values - -: value ( name -- value ) values get at ; - -: set-value ( value name -- ) values get set-at ; - -: blank-values ( -- ) H{ } clone values set ; - -: prepare-value ( name object -- value name object ) - [ [ value ] keep ] dip ; inline - -: from-object ( object -- ) - dup assoc? [ ] unless - values get swap update ; - -: deposit-values ( destination names -- ) - [ dup value ] H{ } map>assoc update ; - -: deposit-slots ( destination names -- ) - [ ] 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* ; > 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 diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index 5fc4bd19ae..35e01227b5 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -5,7 +5,7 @@ USING: io kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects -urls math math.parser combinators present ; +urls math math.parser combinators present fry ; IN: html.elements @@ -70,7 +70,7 @@ SYMBOL: html : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry + dup swap '[ , write-html ] (( -- )) html-word ; : ( str -- foo> ) ">" append ; @@ -93,14 +93,14 @@ SYMBOL: html : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup [ write-html ] curry (( -- )) html-word ; + dup '[ , write-html ] (( -- )) html-word ; : ( str -- ) "<" swap "/>" 3append ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup swap [ write-html ] curry + dup swap '[ , write-html ] (( -- )) html-word ; : foo/> ( str -- str/> ) "/>" append ; @@ -134,7 +134,7 @@ SYMBOL: html : define-attribute-word ( name -- ) dup "=" prepend swap - [ write-attr ] curry (( string -- )) html-word ; + '[ , write-attr ] (( string -- )) html-word ; ! Define some closed HTML tags [ diff --git a/extra/html/forms/forms-tests.factor b/extra/html/forms/forms-tests.factor new file mode 100644 index 0000000000..d2dc3ed3a3 --- /dev/null +++ b/extra/html/forms/forms-tests.factor @@ -0,0 +1,67 @@ +IN: html.forms.tests +USING: kernel sequences tools.test assocs html.forms validators accessors +namespaces ; + +: with-validation ( quot -- messages ) + [ + begin-form + call + ] with-scope ; inline + +[ 14 ] [ + [ + "14" [ v-number 13 v-min-value 100 v-max-value ] validate + ] with-validation +] unit-test + +[ t ] [ + [ + "140" [ v-number 13 v-min-value 100 v-max-value ] validate + [ validation-error? ] + [ value>> "140" = ] + bi and + ] with-validation +] unit-test + +TUPLE: person name age ; + +person { + { "name" [ ] } + { "age" [ v-number 13 v-min-value 100 v-max-value ] } +} define-validators + +[ t t ] [ + [ + { { "age" "" } } + { { "age" [ v-required ] } } + validate-values + validation-failed? + "age" value + [ validation-error? ] + [ message>> "required" = ] + bi and + ] with-validation +] unit-test + +[ H{ { "a" 123 } } f ] [ + [ + H{ + { "a" "123" } + { "b" "c" } + { "c" "d" } + } + H{ + { "a" [ v-integer ] } + } validate-values + values + validation-failed? + ] with-validation +] unit-test + +[ t "foo" ] [ + [ + "foo" validation-error + validation-failed? + form get errors>> first + ] with-validation +] unit-test diff --git a/extra/html/forms/forms.factor b/extra/html/forms/forms.factor new file mode 100644 index 0000000000..0da3fcb0b3 --- /dev/null +++ b/extra/html/forms/forms.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors strings namespaces assocs hashtables +mirrors math fry sequences sequences.lib words continuations ; +IN: html.forms + +TUPLE: form errors values validation-failed ; + +:
( -- form ) + form 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 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 set + call + form get + ] with-scope + ] dip set-value ; inline + +TUPLE: validation-error value message ; + +C: 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 ) + [ ] 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 ; diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 433aedbc9a..4048836cfe 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -1,7 +1,7 @@ USING: html.templates html.templates.chloe tools.test io.streams.string kernel sequences ascii boxes -namespaces xml html.components -splitting unicode.categories furnace ; +namespaces xml html.components html.forms +splitting unicode.categories furnace accessors ; IN: html.templates.chloe.tests [ f ] [ f parse-query-attr ] unit-test @@ -9,13 +9,13 @@ IN: html.templates.chloe.tests [ f ] [ "" parse-query-attr ] unit-test [ H{ { "a" "b" } } ] [ - blank-values + begin-form "b" "a" set-value "a" parse-query-attr ] unit-test [ H{ { "a" "b" } { "c" "d" } } ] [ - blank-values + begin-form "b" "a" set-value "d" "c" set-value "a,c" parse-query-attr @@ -69,7 +69,7 @@ IN: html.templates.chloe.tests ] run-template ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ "A label" "label" set-value ] unit-test @@ -157,10 +157,10 @@ TUPLE: person first-name last-name ; ] run-template ] unit-test -[ ] [ blank-values ] unit-test +[ ] [ begin-form ] unit-test [ ] [ - H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value + H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } >>values "person" set-value ] unit-test [ "
RBaxterUnknown
" ] [ @@ -170,7 +170,7 @@ TUPLE: person first-name last-name ; ] unit-test [ ] [ - blank-values + begin-form { "a" "b" } "choices" set-value "true" "b" set-value ] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 08d6b873fc..103020ee0f 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -5,6 +5,7 @@ classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string unicode.case tuple-syntax mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities +html.forms html.elements html.components html.templates @@ -76,7 +77,7 @@ CHLOE: each [ with-each-value ] (bind-tag) ; CHLOE: bind-each [ with-each-object ] (bind-tag) ; -CHLOE: bind [ with-values ] (bind-tag) ; +CHLOE: bind [ with-form ] (bind-tag) ; : error-message-tag ( tag -- ) children>string render-error ; @@ -86,11 +87,10 @@ CHLOE: comment drop ; CHLOE: call-next-template drop call-next-template ; : attr>word ( value -- word/f ) - dup ":" split1 swap lookup - [ ] [ "No such word: " swap append throw ] ?if ; + ":" split1 swap lookup ; : if-satisfied? ( tag -- ? ) - [ "code" optional-attr [ attr>word execute ] [ t ] if* ] + [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ] [ "value" optional-attr [ value ] [ t ] if* ] bi and ; @@ -98,12 +98,12 @@ CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; CHLOE-SINGLETON: label CHLOE-SINGLETON: link -CHLOE-SINGLETON: farkup CHLOE-SINGLETON: inspector CHLOE-SINGLETON: comparison CHLOE-SINGLETON: html CHLOE-SINGLETON: hidden +CHLOE-TUPLE: farkup CHLOE-TUPLE: field CHLOE-TUPLE: textarea CHLOE-TUPLE: password diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index daf4ad88d3..28a605174a 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -14,7 +14,7 @@ tuple-syntax namespaces urls ; method: "GET" version: "1.1" cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } + header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } ] [ "http://www.apple.com/index.html" @@ -27,7 +27,7 @@ tuple-syntax namespaces urls ; method: "GET" version: "1.1" cookies: V{ } - header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } } + header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } } ] [ "https://www.amazon.com/index.html" diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 56957b021c..0b9224f171 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -79,13 +79,9 @@ ERROR: download-failed response body ; M: download-failed error. "HTTP download failed:" print nl - [ - response>> - write-response-code - write-response-message nl - drop - ] - [ body>> write ] bi ; + [ response>> write-response-line nl drop ] + [ body>> write ] + bi ; : check-response ( response data -- response data ) over code>> success? [ download-failed ] unless ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index bc206f08b7..522d0c1845 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,7 +1,8 @@ USING: http tools.test multiline tuple-syntax io.streams.string io.encodings.utf8 io.encodings.string kernel arrays splitting sequences -assocs io.sockets db db.sqlite continuations urls hashtables ; +assocs io.sockets db db.sqlite continuations urls hashtables +accessors ; IN: http.tests : lf>crlf "\n" split "\r\n" join ; @@ -73,10 +74,21 @@ GET nested HTTP/1.0 ; -[ read-request-test-3 [ read-request ] with-string-reader ] +[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ] [ "Bad request: URL" = ] must-fail-with +STRING: read-request-test-4 +GET /blah HTTP/1.0 +Host: "www.amazon.com" +; + +[ "www.amazon.com" ] +[ + read-request-test-4 lf>crlf [ read-request ] with-string-reader + "host" header +] unit-test + STRING: read-response-test-1 HTTP/1.1 404 not found Content-Type: text/html; charset=UTF-8 @@ -117,15 +129,46 @@ read-response-test-1' 1array [ [ t ] [ "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" - dup parse-cookies unparse-cookies = + dup parse-set-cookie first unparse-set-cookie = +] unit-test + +[ t ] [ + "a=" + dup parse-set-cookie first unparse-set-cookie = +] unit-test + +STRING: read-response-test-2 +HTTP/1.1 200 Content follows +Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456 + + +; + +[ 2 ] [ + read-response-test-2 lf>crlf + [ read-response ] with-string-reader + cookies>> length +] unit-test + +STRING: read-response-test-3 +HTTP/1.1 200 Content follows +Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes + + +; + +[ 1 ] [ + read-response-test-3 lf>crlf + [ read-response ] with-string-reader + cookies>> length ] unit-test ! Live-fire exercise USING: http.server http.server.static furnace.sessions furnace.alloy -furnace.actions furnace.auth.login furnace.db http.client -io.server io.files io io.encodings.ascii +furnace.actions furnace.auth furnace.auth.login furnace.db http.client +io.servers.connection io.files io io.encodings.ascii accessors namespaces threads -http.server.responses http.server.redirection +http.server.responses http.server.redirection furnace.redirection http.server.dispatchers db.tuples ; : add-quit-action @@ -176,7 +219,7 @@ test-db [ [ - + "Test" "" add-responder add-quit-action @@ -206,7 +249,7 @@ test-db [ [ [ [ "Hi" write ] "text/plain" ] >>display - + "Test" "" add-responder add-quit-action @@ -223,7 +266,8 @@ test-db [ [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test -USING: html.components html.elements xml xml.utilities validators +USING: html.components html.elements html.forms +xml xml.utilities validators furnace furnace.flash ; SYMBOL: a @@ -275,3 +319,7 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test + +! Test cloning +[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test +[ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 521c18c703..4001301cb1 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,16 +1,18 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel combinators math namespaces - -assocs sequences splitting sorting sets debugger +assocs assocs.lib sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present -io io.encodings.iana io.encodings.binary io.encodings.8-bit +io io.encodings io.encodings.iana io.encodings.binary +io.encodings.8-bit unicode.case unicode.categories qualified -urls html.templates xml xml.data xml.writer ; +urls html.templates xml xml.data xml.writer + +http.parsers ; EXCLUDE: fry => , ; @@ -18,40 +20,20 @@ IN: http : crlf ( -- ) "\r\n" write ; -: add-header ( value key assoc -- ) - [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; - -: header-line ( line -- ) - dup first blank? [ - [ blank? ] left-trim - "last-header" get - "header" get - add-header - ] [ - ":" split1 dup [ - [ blank? ] left-trim - swap >lower dup "last-header" set - "header" get add-header - ] [ - 2drop - ] if - ] if ; - -: read-lf ( -- bytes ) - "\n" read-until CHAR: \n assert= ; - : read-crlf ( -- bytes ) "\r" read-until [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; -: (read-header) ( -- ) - read-crlf dup - empty? [ drop ] [ header-line (read-header) ] if ; +: (read-header) ( -- alist ) + [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ; + +: process-header ( alist -- assoc ) + f swap [ [ swap or dup ] dip swap ] assoc-map nip + [ ?push ] histogram [ "; " join ] assoc-map + >hashtable ; : read-header ( -- assoc ) - H{ } clone [ - "header" [ (read-header) ] with-variable - ] keep ; + (read-header) process-header ; : header-value>string ( value -- string ) { @@ -62,69 +44,100 @@ IN: http : check-header-string ( str -- str ) #! http://en.wikipedia.org/wiki/HTTP_Header_Injection - dup "\r\n" intersect empty? + dup "\r\n\"" intersect empty? [ "Header injection attack" throw ] unless ; : write-header ( assoc -- ) >alist sort-keys [ - swap - check-header-string write ": " write - header-value>string check-header-string write crlf + [ check-header-string write ": " write ] + [ header-value>string check-header-string write crlf ] bi* ] assoc-each crlf ; -TUPLE: cookie name value path domain expires max-age http-only ; +TUPLE: cookie name value version comment path domain expires max-age http-only secure ; : ( 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 ] } [ dup , nip ] } case - ] each - + ] assoc-each drop ] { } make ; -: (unparse-cookie) ( key value -- ) +: parse-cookie ( string -- seq ) + [ + f swap + (parse-cookie) + [ + swap { + { "$version" [ >>version ] } + { "$domain" [ >>domain ] } + { "$path" [ >>path ] } + [ dup , nip ] + } case + ] assoc-each + drop + ] { } make ; + +: check-cookie-string ( string -- string' ) + dup "=;'\"\r\n" intersect empty? + [ "Bad cookie name or value" throw ] unless ; + +: unparse-cookie-value ( key value -- ) { { f [ drop ] } - { t [ , ] } + { t [ check-cookie-string , ] } [ { { [ dup timestamp? ] [ timestamp>cookie-string ] } { [ dup duration? ] [ dt>seconds number>string ] } + { [ dup real? ] [ number>string ] } [ ] } cond - "=" swap 3append , + check-cookie-string "=" swap check-cookie-string 3append , ] } case ; -: unparse-cookie ( cookie -- strings ) +: (unparse-cookie) ( cookie -- strings ) [ - dup name>> >lower over value>> (unparse-cookie) - "path" over path>> (unparse-cookie) - "domain" over domain>> (unparse-cookie) - "expires" over expires>> (unparse-cookie) - "max-age" over max-age>> (unparse-cookie) - "httponly" over http-only>> (unparse-cookie) + dup name>> check-cookie-string >lower + over value>> unparse-cookie-value + "$path" over path>> unparse-cookie-value + "$domain" over domain>> unparse-cookie-value drop ] { } make ; -: unparse-cookies ( cookies -- string ) - [ unparse-cookie ] map concat "; " join ; +: unparse-cookie ( cookies -- string ) + [ (unparse-cookie) ] map concat "; " join ; + +: unparse-set-cookie ( cookie -- string ) + [ + dup name>> check-cookie-string >lower + over value>> unparse-cookie-value + "path" over path>> unparse-cookie-value + "domain" over domain>> unparse-cookie-value + "expires" over expires>> unparse-cookie-value + "max-age" over max-age>> unparse-cookie-value + "httponly" over http-only>> unparse-cookie-value + "secure" over secure>> unparse-cookie-value + drop + ] { } make "; " join ; TUPLE: request method @@ -134,6 +147,13 @@ header post-data cookies ; +: check-url ( string -- url ) + >url dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline + +: read-request-line ( request -- request ) + read-crlf parse-request-line first3 + [ >>method ] [ check-url >>url ] [ >>version ] tri* ; + : set-header ( request/response value key -- request/response ) pick header>> set-at ; @@ -146,29 +166,11 @@ cookies ; H{ } clone >>header V{ } clone >>cookies "close" "connection" set-header - "Factor http.client vocabulary" "user-agent" set-header ; - -: read-method ( request -- request ) - " " read-until [ "Bad request: method" throw ] unless - >>method ; + "Factor http.client" "user-agent" set-header ; : check-absolute ( url -- url ) dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline -: read-url ( request -- request ) - " " read-until [ - dup empty? [ drop read-url ] [ >url check-absolute >>url ] if - ] [ "Bad request: URL" throw ] if ; - -: parse-version ( string -- version ) - "HTTP/" ?head [ "Bad request: version" throw ] unless - dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ; - -: read-request-version ( request -- request ) - read-crlf [ CHAR: \s = ] left-trim - parse-version - >>version ; - : read-request-header ( request -- request ) read-header >>header ; @@ -203,7 +205,7 @@ TUPLE: post-data raw content content-type ; drop ; : extract-cookies ( request -- request ) - dup "cookie" header [ parse-cookies >>cookies ] when* ; + dup "cookie" header [ parse-cookie >>cookies ] when* ; : parse-content-type-attributes ( string -- attributes ) " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ; @@ -213,22 +215,18 @@ TUPLE: post-data raw content content-type ; : read-request ( -- request ) - read-method - read-url - read-request-version + read-request-line read-request-header read-post-data extract-host extract-cookies ; -: write-method ( request -- request ) - dup method>> write bl ; - -: write-request-url ( request -- request ) - dup url>> relative-url present write bl ; - -: write-version ( request -- request ) - "HTTP/" write dup request-version write crlf ; +: write-request-line ( request -- request ) + dup + [ method>> write bl ] + [ url>> relative-url present write bl ] + [ "HTTP/" write version>> write crlf ] + tri ; : url-host ( url -- string ) [ host>> ] [ port>> ] bi dup "http" protocol-port = @@ -242,7 +240,7 @@ TUPLE: post-data raw content content-type ; [ content-type>> "content-type" pick set-at ] bi ] when* - over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* + over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when* write-header ; GENERIC: >post-data ( object -- post-data ) @@ -267,9 +265,7 @@ M: f >post-data ; : write-request ( request -- ) unparse-post-data - write-method - write-request-url - write-version + write-request-line write-request-header write-post-data flush @@ -295,26 +291,22 @@ body ; H{ } clone >>header "close" "connection" set-header now timestamp>http-string "date" set-header + "Factor http.server" "server" set-header latin1 >>content-charset V{ } clone >>cookies ; -: read-response-version ( response -- response ) - " \t" read-until - [ "Bad response: version" throw ] unless - parse-version - >>version ; +M: response clone + call-next-method + [ clone ] change-header + [ clone ] change-cookies ; -: read-response-code ( response -- response ) - " \t" read-until [ "Bad response: code" throw ] unless - string>number [ "Bad response: code" throw ] unless* - >>code ; - -: read-response-message ( response -- response ) - read-crlf >>message ; +: read-response-line ( response -- response ) + read-crlf parse-response-line first3 + [ >>version ] [ >>code ] [ >>message ] tri* ; : read-response-header ( response -- response ) read-header >>header - dup "set-cookie" header parse-cookies >>cookies + dup "set-cookie" header parse-set-cookie >>cookies dup "content-type" header [ parse-content-type [ >>content-type ] @@ -323,20 +315,15 @@ body ; : read-response ( -- response ) - read-response-version - read-response-code - read-response-message + read-response-line read-response-header ; -: write-response-version ( response -- response ) - "HTTP/" write - dup version>> write bl ; - -: write-response-code ( response -- response ) - dup code>> number>string write bl ; - -: write-response-message ( response -- response ) - dup message>> write crlf ; +: write-response-line ( response -- response ) + dup + [ "HTTP/" write version>> write bl ] + [ code>> present write bl ] + [ message>> write crlf ] + tri ; : unparse-content-type ( request -- content-type ) [ content-type>> "application/octet-stream" or ] @@ -344,26 +331,40 @@ body ; bi [ "; charset=" swap 3append ] when* ; +: ensure-domain ( cookie -- cookie ) + [ + request get url>> + host>> dup "localhost" = + [ drop ] [ or ] if + ] change-domain ; + : write-response-header ( response -- response ) - dup header>> clone - over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when* + #! We send one set-cookie header per cookie, because that's + #! what Firefox expects. + dup header>> >alist >vector over unparse-content-type "content-type" pick set-at + over cookies>> [ + ensure-domain unparse-set-cookie + "set-cookie" swap 2array over push + ] each write-header ; : write-response-body ( response -- response ) dup body>> call-template ; M: response write-response ( respose -- ) - write-response-version - write-response-code - write-response-message + write-response-line write-response-header flush drop ; M: response write-full-response ( request response -- ) dup write-response - swap method>> "HEAD" = [ write-response-body ] unless ; + swap method>> "HEAD" = [ + [ content-charset>> encode-output ] + [ write-response-body ] + bi + ] unless ; : get-cookie ( request/response name -- cookie/f ) [ cookies>> ] dip '[ , _ name>> = ] find nip ; @@ -386,9 +387,7 @@ body ; "1.1" >>version ; M: raw-response write-response ( respose -- ) - write-response-version - write-response-code - write-response-message + write-response-line write-response-body drop ; diff --git a/extra/http/parsers/parsers.factor b/extra/http/parsers/parsers.factor new file mode 100644 index 0000000000..33bfa4b202 --- /dev/null +++ b/extra/http/parsers/parsers.factor @@ -0,0 +1,166 @@ +USING: math math.order math.parser kernel combinators.lib +sequences sequences.deep peg peg.parsers assocs arrays +hashtables strings unicode.case namespaces ascii ; +IN: http.parsers + +: except ( quot -- parser ) + [ not ] compose satisfy ; inline + +: except-these ( quots -- parser ) + [ 1|| ] curry except ; inline + +: ctl? ( ch -- ? ) + { [ 0 31 between? ] [ 127 = ] } 1|| ; + +: tspecial? ( ch -- ? ) + "()<>@,;:\\\"/[]?={} \t" member? ; + +: 'token' ( -- parser ) + { [ ctl? ] [ tspecial? ] } except-these repeat1 ; + +: case-insensitive ( parser -- parser' ) + [ flatten >string >lower ] action ; + +: case-sensitive ( parser -- parser' ) + [ flatten >string ] action ; + +: 'space' ( -- parser ) + [ " \t" member? ] satisfy repeat0 hide ; + +: one-of ( strings -- parser ) + [ token ] map choice ; + +: 'http-method' ( -- parser ) + { "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ; + +: 'url' ( -- parser ) + [ " \t\r\n" member? ] except repeat1 case-sensitive ; + +: 'http-version' ( -- parser ) + [ + "HTTP" token hide , + 'space' , + "/" token hide , + 'space' , + "1" token , + "." token , + { "0" "1" } one-of , + ] seq* [ concat >string ] action ; + +PEG: parse-request-line ( string -- triple ) + #! Triple is { method url version } + [ + 'space' , + 'http-method' , + 'space' , + 'url' , + 'space' , + 'http-version' , + 'space' , + ] seq* just ; + +: 'text' ( -- parser ) + [ ctl? ] except ; + +: 'response-code' ( -- parser ) + [ digit? ] satisfy 3 exactly-n [ string>number ] action ; + +: 'response-message' ( -- parser ) + 'text' repeat0 case-sensitive ; + +PEG: parse-response-line ( string -- triple ) + #! Triple is { version code message } + [ + 'space' , + 'http-version' , + 'space' , + 'response-code' , + 'space' , + 'response-message' , + ] seq* just ; + +: 'crlf' ( -- parser ) + "\r\n" token ; + +: 'lws' ( -- parser ) + [ " \t" member? ] satisfy repeat1 ; + +: 'qdtext' ( -- parser ) + { [ CHAR: " = ] [ ctl? ] } except-these ; + +: 'quoted-char' ( -- parser ) + "\\" token hide any-char 2seq ; + +: 'quoted-string' ( -- parser ) + 'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ; + +: 'ctext' ( -- parser ) + { [ ctl? ] [ "()" member? ] } except-these ; + +: 'comment' ( -- parser ) + 'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ; + +: 'field-name' ( -- parser ) + 'token' case-insensitive ; + +: 'field-content' ( -- parser ) + 'quoted-string' case-sensitive + 'text' repeat0 case-sensitive + 2choice ; + +PEG: parse-header-line ( string -- pair ) + #! Pair is either { name value } or { f value }. If f, its a + #! continuation of the previous header line. + [ + 'field-name' , + 'space' , + ":" token hide , + 'space' , + 'field-content' , + ] seq* + [ + 'lws' [ drop f ] action , + 'field-content' , + ] seq* + 2choice ; + +: 'word' ( -- parser ) + 'token' 'quoted-string' 2choice ; + +: 'value' ( -- parser ) + 'quoted-string' + [ ";" member? ] except repeat0 + 2choice case-sensitive ; + +: 'attr' ( -- parser ) + 'token' case-insensitive ; + +: 'av-pair' ( -- parser ) + [ + 'space' , + 'attr' , + 'space' , + [ "=" token , 'space' , 'value' , ] seq* [ peek ] action + epsilon [ drop f ] action + 2choice , + 'space' , + ] seq* ; + +: 'av-pairs' ( -- parser ) + 'av-pair' ";" token list-of optional ; + +PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ; + +: 'cookie-value' ( -- parser ) + [ + 'space' , + 'attr' , + 'space' , + "=" token hide , + 'space' , + 'value' , + 'space' , + ] seq* ; + +PEG: (parse-cookie) ( string -- alist ) + 'cookie-value' [ ";," member? ] satisfy list-of optional just ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 4ad44554f5..21ab074907 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,9 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -combinators tools.vocabs math +combinators tools.vocabs tools.time math io -io.server io.sockets io.sockets.secure io.encodings @@ -12,8 +11,9 @@ io.encodings.utf8 io.encodings.ascii io.encodings.binary io.streams.limited +io.servers.connection io.timeouts -fry logging calendar urls +fry logging logging.insomniac calendar urls http http.server.responses html.elements @@ -26,7 +26,9 @@ SYMBOL: responder-nesting SYMBOL: main-responder -SYMBOL: development-mode +SYMBOL: development? + +SYMBOL: benchmark? ! path is a sequence of path component strings GENERIC: call-responder* ( path responder -- response ) @@ -55,32 +57,31 @@ main-responder global [ <404> or ] change-at : <500> ( error -- response ) 500 "Internal server error" - swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; + swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) - [ write-response ] + [ request get swap write-full-response ] [ - request get method>> "HEAD" = [ drop ] [ - '[ - , - [ content-charset>> encode-output ] - [ write-response-body ] - bi - ] - [ - utf8 [ - development-mode get - [ http-error. ] [ drop "Response error" rethrow ] if - ] with-encoded-output - ] recover - ] if - ] bi ; + [ \ do-response log-error ] + [ + utf8 [ + development? get + [ http-error. ] [ drop "Response error" write ] if + ] with-encoded-output + ] bi + ] recover ; LOG: httpd-hit NOTICE +LOG: httpd-header NOTICE + +: log-header ( headers name -- ) + tuck header 2array httpd-header ; + : log-request ( request -- ) - [ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi - 3array httpd-hit ; + [ [ method>> ] [ url>> ] bi 2array httpd-hit ] + [ { "user-agent" "x-forwarded-for" } [ log-header ] with each ] + bi ; : split-path ( string -- path ) "/" split harvest ; @@ -115,29 +116,39 @@ LOG: httpd-hit NOTICE ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; : ?refresh-all ( -- ) - development-mode get-global - [ global [ refresh-all ] bind ] when ; + development? get-global [ global [ refresh-all ] bind ] when ; -: setup-limits ( -- ) - 1 minutes timeouts - 64 1024 * limit-input ; +LOG: httpd-benchmark DEBUG -: handle-client ( -- ) +: ?benchmark ( quot -- ) + benchmark? get [ + [ benchmark ] [ first ] bi request get url>> rot 3array + httpd-benchmark + ] [ call ] if ; inline + +TUPLE: http-server < threaded-server ; + +M: http-server handle-client* + drop [ - setup-limits - ascii decode-input - ascii encode-output + 64 1024 * limit-input ?refresh-all read-request - do-request - do-response + [ do-request ] ?benchmark + [ do-response ] ?benchmark ] with-destructors ; +: ( -- server ) + http-server new-threaded-server + "http.server" >>name + "http" protocol-port >>insecure + "https" protocol-port >>secure ; + : httpd ( port -- ) - dup integer? [ internet-server ] when - "http.server" binary [ handle-client ] with-server ; + + swap >>insecure + f >>secure + start-server ; -: httpd-main ( -- ) - 8888 httpd ; - -MAIN: httpd-main +: http-insomniac ( -- ) + "http.server" { "httpd-hit" } schedule-insomniac ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 9d76c82e4a..83fcf6f4a9 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -82,7 +82,7 @@ TUPLE: file-responder root hook special allow-listings ; "index.html" append-path dup exists? [ drop f ] unless ; : serve-directory ( filename -- response ) - request get path>> "/" tail? [ + request get url>> path>> "/" tail? [ dup find-index [ serve-file ] [ list-directory ] ?if ] [ diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 9ff120c5fa..08dc8d07d9 100755 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -5,12 +5,11 @@ IN: io.encodings.ascii [ drop replacement-char ] unless ] - [ drop f ] if* ; + nip swap stream-read1 dup + [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline PRIVATE> SINGLETON: ascii diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 131cadfaf0..bd90072039 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.ports ; +io.streams.duplex io.ports debugger prettyprint inspector ; IN: io.launcher TUPLE: process < identity-tuple @@ -131,11 +131,16 @@ HOOK: run-process* io-backend ( process -- handle ) run-detached dup detached>> [ dup wait-for-process drop ] unless ; -ERROR: process-failed code ; +ERROR: process-failed process code ; + +M: process-failed error. + dup "Process exited with error code " write code>> . nl + "Launch descriptor:" print nl + process>> describe ; : try-process ( desc -- ) - run-process wait-for-process dup zero? - [ drop ] [ process-failed ] if ; + run-process dup wait-for-process dup zero? + [ 2drop ] [ process-failed ] if ; HOOK: kill-process* io-backend ( handle -- ) diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor index 7420cac115..47485193cf 100755 --- a/extra/io/ports/ports-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -64,7 +64,3 @@ HELP: (wait-to-read) HELP: wait-to-read { $values { "port" input-port } { "eof?" "a boolean" } } { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ; - -HELP: can-write? -{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } } -{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ; diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index b761ecaf5b..f54cd2e9b3 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -98,11 +98,9 @@ TUPLE: output-port < buffered-port ; : ( handle -- output-port ) output-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 diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor deleted file mode 100755 index 50f38cb146..0000000000 --- a/extra/io/server/server-docs.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: help help.syntax help.markup io ; -IN: io.server - -HELP: with-server -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } } -{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ; - -HELP: with-datagrams -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ; diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor deleted file mode 100755 index 965a70718b..0000000000 --- a/extra/io/server/server-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -IN: io.server.tests -USING: tools.test io.server io.server.private kernel ; - -{ 2 0 } [ [ ] server-loop ] must-infer-as -{ 3 0 } [ [ ] with-connection ] must-infer-as -{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as -{ 2 0 } [ [ ] with-datagrams ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor deleted file mode 100755 index c855fba6be..0000000000 --- a/extra/io/server/server.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.sockets.secure io.files -io.streams.duplex logging continuations destructors kernel math -math.parser namespaces parser sequences strings prettyprint -debugger quotations calendar threads concurrency.combinators -assocs fry accessors ; -IN: io.server - -SYMBOL: servers - -SYMBOL: remote-address - -> ] bi ] dip - '[ , , , , with-connection ] "Client" spawn drop - ] 2keep accept-loop ; inline - -: server-loop ( addrspec encoding quot -- ) - >r 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 [ ] 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 ; - - [ datagram-loop ] with-disposal ; inline - -\ spawn-datagrams NOTICE add-input-logging - -PRIVATE> - -: with-datagrams ( seq service quot -- ) - '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/server/summary.txt b/extra/io/server/summary.txt deleted file mode 100644 index e791b704eb..0000000000 --- a/extra/io/server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -TCP/IP and UDP/IP servers diff --git a/extra/eval-server/authors.txt b/extra/io/servers/connection/authors.txt similarity index 100% rename from extra/eval-server/authors.txt rename to extra/io/servers/connection/authors.txt diff --git a/extra/io/servers/connection/connection-docs.factor b/extra/io/servers/connection/connection-docs.factor new file mode 100755 index 0000000000..b033ec287c --- /dev/null +++ b/extra/io/servers/connection/connection-docs.factor @@ -0,0 +1,2 @@ +USING: help help.syntax help.markup io ; +IN: io.servers.connection diff --git a/extra/io/servers/connection/connection-tests.factor b/extra/io/servers/connection/connection-tests.factor new file mode 100755 index 0000000000..bb87d67917 --- /dev/null +++ b/extra/io/servers/connection/connection-tests.factor @@ -0,0 +1,47 @@ +IN: io.servers.connection +USING: tools.test io.servers.connection io.sockets namespaces +io.servers.connection.private kernel accessors sequences +concurrency.promises io.encodings.ascii io threads calendar ; + +[ t ] [ listen-on empty? ] unit-test + +[ f ] [ + + 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 + +[ ] [ init-server drop ] unit-test + +[ 10 ] [ + + 10 >>max-connections + init-server semaphore>> count>> +] unit-test + +[ ] [ "p" set ] unit-test + +[ ] [ + [ + + 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 ascii drop contents ] unit-test + +[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor new file mode 100755 index 0000000000..b062322142 --- /dev/null +++ b/extra/io/servers/connection/connection.factor @@ -0,0 +1,131 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations destructors kernel math math.parser +namespaces parser sequences strings prettyprint debugger +quotations combinators combinators.lib logging calendar assocs +fry accessors arrays io io.sockets io.encodings.ascii +io.sockets.secure io.files io.streams.duplex io.timeouts +io.encodings threads concurrency.combinators +concurrency.semaphores ; +IN: io.servers.connection + +TUPLE: threaded-server +name +secure insecure +secure-config +sockets +max-connections +semaphore +timeout +encoding +handler ; + +: local-server ( port -- addrspec ) "localhost" swap ; + +: internet-server ( port -- addrspec ) f swap ; + +: new-threaded-server ( class -- threaded-server ) + new + "server" >>name + ascii >>encoding + 1 minutes >>timeout + V{ } clone >>sockets + >>secure-config + [ "No handler quotation" throw ] >>handler ; inline + +: ( -- threaded-server ) + threaded-server new-threaded-server ; + +SYMBOL: remote-address + +GENERIC: handle-client* ( server -- ) + +insecure ( addrspec -- addrspec' ) + dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ; + +: >secure ( addrspec -- addrspec' ) + >insecure + dup { [ secure? ] [ not ] } 1|| [ ] 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>> + [ 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 + ] 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 ; diff --git a/extra/io/servers/connection/summary.txt b/extra/io/servers/connection/summary.txt new file mode 100644 index 0000000000..8269ecfc38 --- /dev/null +++ b/extra/io/servers/connection/summary.txt @@ -0,0 +1 @@ +Multi-threaded TCP/IP servers diff --git a/extra/io/server/tags.txt b/extra/io/servers/connection/tags.txt similarity index 100% rename from extra/io/server/tags.txt rename to extra/io/servers/connection/tags.txt diff --git a/extra/io/server/authors.txt b/extra/io/servers/packet/authors.txt similarity index 100% rename from extra/io/server/authors.txt rename to extra/io/servers/packet/authors.txt diff --git a/extra/io/servers/packet/datagram.factor b/extra/io/servers/packet/datagram.factor new file mode 100644 index 0000000000..03596ee43c --- /dev/null +++ b/extra/io/servers/packet/datagram.factor @@ -0,0 +1,21 @@ +IN: io.servers.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 diff --git a/extra/io/servers/packet/summary.txt b/extra/io/servers/packet/summary.txt new file mode 100644 index 0000000000..29247a2937 --- /dev/null +++ b/extra/io/servers/packet/summary.txt @@ -0,0 +1 @@ +Multi-threaded UDP/IP servers diff --git a/extra/io/servers/packet/tags.txt b/extra/io/servers/packet/tags.txt new file mode 100644 index 0000000000..992ae12982 --- /dev/null +++ b/extra/io/servers/packet/tags.txt @@ -0,0 +1 @@ +network diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor index 9b9436a8db..78de43d379 100644 --- a/extra/io/sockets/secure/secure-tests.factor +++ b/extra/io/sockets/secure/secure-tests.factor @@ -1 +1,4 @@ -! No unit tests here, until Windows SSL is implemented +IN: io.sockets.secure.tests +USING: accessors kernel io.sockets io.sockets.secure tools.test ; + +[ "hello" 24 ] [ "hello" 24 [ host>> ] [ port>> ] bi ] unit-test diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor index 448a5cdda0..10aec22ee5 100644 --- a/extra/io/sockets/secure/secure.factor +++ b/extra/io/sockets/secure/secure.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel symbols namespaces continuations -destructors io.sockets sequences inspector calendar ; +destructors io.sockets sequences inspector calendar delegate ; IN: io.sockets.secure SYMBOL: secure-socket-timeout @@ -42,8 +42,10 @@ TUPLE: secure addrspec ; C: secure -: resolve-secure-host ( host port passive? -- seq ) - resolve-host [ ] map ; +CONSULT: inet secure addrspec>> ; + +M: secure resolve-host ( secure -- seq ) + addrspec>> resolve-host [ ] map ; HOOK: check-certificate secure-socket-backend ( host handle -- ) @@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ; M: secure-inet (client) [ - addrspec>> - [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep - host>> pick handle>> check-certificate + [ resolve-host (client) [ |dispose ] dip ] keep + addrspec>> host>> pick handle>> check-certificate ] with-destructors ; PRIVATE> diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 78cddd5d3b..6aa46ccdbc 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -27,7 +27,7 @@ $nl { { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" } { { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" } } -"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link } " 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 } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface." { $see-also "io.sockets.secure" } ; ARTICLE: "network-packet" "Packet-oriented networking" @@ -79,7 +79,7 @@ HELP: inet HELP: inet4 { $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } { $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 " } @@ -88,7 +88,7 @@ HELP: inet4 HELP: inet6 { $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } { $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 " } } ; @@ -118,10 +118,10 @@ HELP: } { $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 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 resolve-host" } + "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this." $nl "To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:" { $unchecked-example @@ -148,9 +148,9 @@ HELP: } { $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 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 resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly." "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding" } @@ -165,3 +165,7 @@ HELP: send { $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } } { $description "Sends a packet to the given address." } { $errors "Throws an error if the packet could not be sent." } ; + +HELP: resolve-host +{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } } +{ $description "Resolves host names to IP addresses." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index 8264bec032..4b95a31512 100755 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -45,7 +45,7 @@ concurrency.promises threads io.streams.string ; [ "1:2:0:0:0:0:3:4" ] [ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test -[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test +[ t ] [ "localhost" 80 resolve-host length 1 >= ] unit-test ! Smoke-test UDP [ ] [ "127.0.0.1" 0 "datagram1" set ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 4efd30c65e..a9278c8357 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -259,20 +259,26 @@ HOOK: (send) io-backend ( packet addrspec datagram -- ) [ addrinfo>addrspec ] map sift ; -: prepare-resolve-host ( host serv passive? -- host' serv' flags ) +: prepare-resolve-host ( addrspec -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then #! change it later. This is a workaround for a FreeBSD #! getaddrinfo() limitation -- on Windows, Linux and Mac, #! we can convert a number to a string and pass that as the #! service name, but on FreeBSD this gives us an unknown #! service error. - >r - dup integer? [ port-override set "http" ] when - r> AI_PASSIVE 0 ? ; + [ host>> ] + [ port>> dup integer? [ port-override set "http" ] when ] bi + over 0 AI_PASSIVE ? ; HOOK: addrinfo-error io-backend ( n -- ) -: resolve-host ( host serv passive? -- seq ) +GENERIC: resolve-host ( addrspec -- seq ) + +TUPLE: inet host port ; + +C: inet + +M: inet resolve-host [ prepare-resolve-host "addrinfo" @@ -284,17 +290,16 @@ HOOK: addrinfo-error io-backend ( n -- ) freeaddrinfo ] with-scope ; +M: f resolve-host drop { } ; + +M: object resolve-host 1array ; + : host-name ( -- string ) 256 dup dup length gethostname zero? [ "gethostname failed" throw ] unless ascii alien>string ; -TUPLE: inet host port ; - -C: inet - -M: inet (client) - [ host>> ] [ port>> ] bi f resolve-host (client) ; +M: inet (client) resolve-host (client) ; ERROR: invalid-inet-server addrspec ; diff --git a/extra/io/streams/limited/limited-tests.factor b/extra/io/streams/limited/limited-tests.factor index d160a3f756..eb5b921260 100644 --- a/extra/io/streams/limited/limited-tests.factor +++ b/extra/io/streams/limited/limited-tests.factor @@ -30,3 +30,11 @@ namespaces tools.test strings kernel ; [ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test [ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with + +[ "he" CHAR: l ] [ + B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } + ascii [ + 5 limit-input + "l" read-until + ] with-input-stream +] unit-test diff --git a/extra/io/streams/limited/limited.factor b/extra/io/streams/limited/limited.factor index 669240d28b..e89b31a884 100644 --- a/extra/io/streams/limited/limited.factor +++ b/extra/io/streams/limited/limited.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math io destructors accessors sequences -namespaces ; +USING: kernel math io io.encodings destructors accessors +sequences namespaces ; IN: io.streams.limited TUPLE: limited-stream stream count limit ; @@ -12,8 +12,13 @@ TUPLE: limited-stream stream count limit ; swap >>stream 0 >>count ; -: limit-input ( limit -- ) - input-stream [ swap ] change ; +GENERIC# limit 1 ( stream limit -- stream' ) + +M: decoder limit [ clone ] dip [ limit ] curry change-stream ; + +M: object limit ; + +: limit-input ( limit -- ) input-stream [ swap limit ] change ; ERROR: limit-exceeded ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 7f6b3396a1..365e51749d 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -31,7 +31,7 @@ USE: unix ] when* ; : redirect-fd ( oldfd fd -- ) - 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ; + 2dup = [ 2drop ] [ dup2 io-error ] if ; : reset-fd ( fd -- ) #! We drop the error code because on *BSD, fcntl of diff --git a/extra/io/unix/sockets/secure/secure-tests.factor b/extra/io/unix/sockets/secure/secure-tests.factor index cbda002354..dee5c32349 100644 --- a/extra/io/unix/sockets/secure/secure-tests.factor +++ b/extra/io/unix/sockets/secure/secure-tests.factor @@ -9,12 +9,12 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; [ ] [ "port" set ] unit-test -: with-test-context +: with-test-context ( quot -- ) "resource:extra/openssl/test/server.pem" >>key-file "resource:extra/openssl/test/dh1024.pem" >>dh-file "password" >>password - swap with-secure-context ; + swap with-secure-context ; inline :: server-test ( quot -- ) [ @@ -28,7 +28,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ; ] with-test-context ] "SSL server test" spawn drop ; -: client-test +: client-test ( -- string ) [ "127.0.0.1" "port" get ?promise ascii drop contents ] with-secure-context ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 946e0e7be5..a0acbebb3a 100755 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -118,13 +118,27 @@ M: secure (get-local-address) addrspec>> (get-local-address) ; dup dup handle>> SSL_connect check-connect-response dup [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ; +: resume-session ( ssl-handle ssl-session -- ) + [ [ handle>> ] dip SSL_set_session ssl-error ] + [ drop do-ssl-connect ] + 2bi ; + +: begin-session ( ssl-handle addrspec -- ) + [ drop do-ssl-connect ] + [ [ handle>> SSL_get1_session ] dip save-session ] + 2bi ; + +: secure-connection ( ssl-handle addrspec -- ) + dup get-session [ resume-session ] [ begin-session ] ?if ; + M: secure establish-connection ( client-out remote -- ) - [ addrspec>> establish-connection ] + addrspec>> + [ establish-connection ] [ - drop handle>> - [ [ do-ssl-connect ] with-timeout ] - [ t >>connected drop ] - bi + [ handle>> ] dip + [ [ secure-connection ] curry with-timeout ] + [ drop t >>connected drop ] + 2bi ] 2bi ; M: secure (server) addrspec>> (server) ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index f46fcf6c53..5168e7fcd2 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -42,11 +42,9 @@ SYMBOL: log-service message ( obj -- inputs>message ) - dup one-string-array? [ first ] [ + dup array? [ dup length 1 = [ first ] when ] when + dup string? [ [ string-limit off 1 line-limit set @@ -54,7 +52,7 @@ PREDICATE: one-string-array < array 0 margin set unparse ] with-scope - ] if ; + ] unless ; PRIVATE> diff --git a/extra/math/quadratic/quadratic.factor b/extra/math/quadratic/quadratic.factor index 2253582623..60929b92cb 100644 --- a/extra/math/quadratic/quadratic.factor +++ b/extra/math/quadratic/quadratic.factor @@ -3,13 +3,13 @@ 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 @@ -17,4 +17,4 @@ IN: math.quadratic : qeval ( x c b a -- y ) #! Evaluate ax^2 + bx + c - >r pick * r> roll sq * + + ; + [ pick * ] dip roll sq * + + ; diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index be30dfe370..37c738cd6a 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -1,11 +1,12 @@ -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 @@ -189,4 +190,9 @@ METHOD: as-mutate { object object assoc } set-at ; ! 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 diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 3218d67b5c..dced2e5c0c 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -1,12 +1,8 @@ ! 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 @@ -24,11 +20,47 @@ 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 @@ -55,8 +87,9 @@ IN: openssl.libssl } ; 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 @@ -64,7 +97,7 @@ 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 ( ) ; @@ -94,42 +127,50 @@ FUNCTION: ssl-method TLSv1_server_method ( ) ; 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-pointer ssl, int fd ) ; +FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ; -FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ; +FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ; -FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ; +FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ; -FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ; +FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ; -FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ; +FUNCTION: void SSL_set_connect_state ( SSL* ssl ) ; -FUNCTION: int SSL_connect ( ssl-pointer ssl ) ; +FUNCTION: void SSL_set_accept_state ( SSL* ssl ) ; -FUNCTION: int SSL_accept ( ssl-pointer ssl ) ; +FUNCTION: int SSL_connect ( SSL* ssl ) ; -FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ; +FUNCTION: int SSL_accept ( SSL* ssl ) ; -FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ; +FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num ) ; -FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num ) ; + +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: void SSL_free ( ssl-pointer ssl ) ; +FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, char* sid_ctx, uint len ) ; -FUNCTION: int SSL_want ( ssl-pointer ssl ) ; +FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ; + +FUNCTION: void SSL_free ( SSL* ssl ) ; + +FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ; + +FUNCTION: int SSL_want ( SSL* ssl ) ; : SSL_NOTHING 1 ; inline : SSL_WRITING 2 ; inline @@ -140,55 +181,55 @@ FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ; 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 ( ) ; @@ -198,6 +239,23 @@ 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 ! =============================================== diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index b2dbda7d2e..6d750bd8e0 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -2,8 +2,8 @@ ! 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 ; @@ -48,7 +48,13 @@ SYMBOL: ssl-initialized? [ 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>> [ @@ -133,12 +139,20 @@ M: rsa dispose* handle>> RSA_free ; ] bi SSL_CTX_set_tmp_rsa ssl-error ; +: ( config ctx -- context ) + openssl-context new + swap >>handle + swap >>config + V{ } clone >>aliens + H{ } clone >>sessions ; + M: openssl ( 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 |dispose { + [ set-session-cache ] [ load-certificate-chain ] [ set-default-password ] [ use-private-key-file ] @@ -152,8 +166,9 @@ M: openssl ( config -- context ) 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 ; @@ -204,4 +219,11 @@ M: openssl check-certificate ( host ssl -- ) 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 diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 443b9fc61d..da44c12e8f 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -24,11 +24,9 @@ MEMO: just ( parser -- parser ) : 1token ( ch -- parser ) 1string token ; -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) ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b420574a3b..54c25778de 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,6 +1,6 @@ ! 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 ; @@ -563,11 +563,24 @@ PRIVATE> #! to fix boxes so this isn't needed... box-parser boa next-id f 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 diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ed4c337a92..56488818ab 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -201,9 +201,6 @@ USE: continuations >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 diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 824651030d..a6a8bb2cca 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -1,6 +1,6 @@ ! 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 diff --git a/extra/tangle/sandbox/sandbox.factor b/extra/tangle/sandbox/sandbox.factor index b6e110ada5..b44acb7617 100644 --- a/extra/tangle/sandbox/sandbox.factor +++ b/extra/tangle/sandbox/sandbox.factor @@ -12,7 +12,7 @@ IN: tangle.sandbox ] with-tangle ; : new-sandbox ( -- ) - development-mode on + development? on delete-db sandbox-db f [ make-sandbox ] [ ] bi main-responder set ; diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index d4b1a34e76..4ba38ad06a 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,11 +1,15 @@ -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 ; +: ( port -- ) + + "tty-server" >>name + utf8 >>encoding + swap local-server >>insecure + [ listener ] >>handler + start-server ; -: default-tty-server ( -- ) 9999 tty-server ; +: tty-server ( -- ) 9999 ; -MAIN: default-tty-server +MAIN: tty-server diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor index 7d4325cbb6..bd24323f20 100644 --- a/extra/validators/validators-tests.factor +++ b/extra/validators/validators-tests.factor @@ -2,14 +2,6 @@ IN: validators.tests 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 @@ -60,59 +52,3 @@ namespaces assocs ; [ "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 diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor index aeb2dc2f80..37c0216740 100644 --- a/extra/validators/validators.factor +++ b/extra/validators/validators.factor @@ -1,8 +1,8 @@ ! 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 @@ -107,53 +107,3 @@ 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 ( string -- ) - (validation-message) ; - -: validation-message-for ( string name -- ) - [ ] dip (validation-message-for) ; - -TUPLE: validation-error message value ; - -C: validation-error - -: validation-error ( message -- ) - f (validation-message) ; - -: validation-error-for ( message value name -- ) - [ ] 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 ; diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml index 965f059abd..e809c0e7f5 100644 --- a/extra/webapps/blogs/blogs-common.xml +++ b/extra/webapps/blogs/blogs-common.xml @@ -12,13 +12,13 @@ | My Posts | New Post - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 38bf065e56..10e0ab54c0 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -1,14 +1,16 @@ ! 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 db.types db.tuples calendar -present http.server.dispatchers +urls validators db db.types db.tuples calendar present namespaces +html.forms +html.components +http.server.dispatchers furnace furnace.actions +furnace.redirection furnace.auth furnace.auth.login furnace.boilerplate -furnace.sessions furnace.syndication ; IN: webapps.blogs @@ -116,6 +118,7 @@ M: comment entity-url : ( -- action ) + "author" >>rest [ validate-author ] >>init [ "Recent Posts by " "author" value append ] >>title [ list-posts ] >>entries @@ -123,6 +126,7 @@ M: comment entity-url : ( -- action ) + "id" >>rest [ validate-integer-id "id" value post "post" set-value ] >>init [ "post" value feed-entry-title ] >>title [ "post" value entity-url ] >>url @@ -140,7 +144,7 @@ M: comment entity-url "id" value "new-comment" [ "parent" set-value - ] nest-values + ] nest-form ] >>init { blogs "view-post" } >>template ; @@ -156,13 +160,13 @@ M: comment entity-url [ validate-post - uid "author" set-value + logged-in-user get username>> "author" set-value ] >>validate [ f - dup { "title" "content" } deposit-slots - uid >>author + dup { "title" "content" } to-object + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit @@ -173,7 +177,8 @@ M: comment entity-url "make a new blog post" >>description ; : authorize-author ( author -- ) - uid = can-administer-blogs? have-capability? or + logged-in-user get username>> = + can-administer-blogs? have-capability? or [ login-required ] unless ; : do-post-action ( -- ) @@ -193,7 +198,7 @@ M: comment entity-url [ "id" value - dup { "title" "author" "date" "content" } deposit-slots + dup { "title" "author" "date" "content" } to-object [ update-tuple ] [ entity-url ] bi ] >>submit @@ -249,13 +254,13 @@ M: comment entity-url [ validate-comment - uid "author" set-value + logged-in-user get username>> "author" set-value ] >>validate [ "parent" value f "content" value >>content - uid >>author + logged-in-user get username>> >>author now >>date [ insert-tuple ] [ entity-url ] bi ] >>submit diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml index 55bdd2e806..d8d4df10b2 100644 --- a/extra/webapps/blogs/view-post.xml +++ b/extra/webapps/blogs/view-post.xml @@ -37,7 +37,7 @@

- +

Delete Comment diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index da646fb76f..a14d6d9823 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -1,6 +1,6 @@ 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 diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor deleted file mode 100644 index fa598c0948..0000000000 --- a/extra/webapps/factor-website/factor-website.factor +++ /dev/null @@ -1,70 +0,0 @@ -! 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.tuples db.sqlite smtp -http.server -http.server.dispatchers -furnace.alloy -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-furnace-tables - - { - post comment - paste annotation - blog posting - todo - short-url - article revision - } ensure-tables - ] with-db ; - -TUPLE: factor-website < dispatcher ; - -: ( -- responder ) - factor-website new-dispatcher - "blogs" add-responder - "todo" add-responder - "pastebin" add-responder - "planet" add-responder - "wiki" add-responder - "wee-url" add-responder - "user-admin" add-responder - - users-in-db >>users - allow-registration - allow-password-recovery - allow-edit-profile - - { factor-website "page" } >>template - test-db ; - -: init-factor-website ( -- ) - "factorcode.org" 25 smtp-server set-global - "todo@factorcode.org" lost-password-from set-global - init-factor-db - main-responder set-global ; - -: start-factor-website ( -- ) - test-db start-expiring - test-db start-update-task - 8812 httpd ; diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index 47f7666b22..b95f3f7b64 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -11,13 +11,13 @@ Pastes | New Paste - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index d381adafcd..3aeb21420f 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -4,6 +4,7 @@ USING: namespaces assocs sorting sequences kernel accessors 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 @@ -11,6 +12,7 @@ http.server.dispatchers http.server.redirection furnace furnace.actions +furnace.redirection furnace.auth furnace.auth.login furnace.boilerplate @@ -126,7 +128,7 @@ M: annotation entity-url "parent" set-value mode-names "modes" set-value "factor" "mode" set-value - ] nest-values + ] nest-form ] >>init { pastebin "paste" } >>template ; @@ -149,7 +151,7 @@ M: annotation entity-url : deposit-entity-slots ( tuple -- ) now >>date - { "summary" "author" "mode" "contents" } deposit-slots ; + { "summary" "author" "mode" "contents" } to-object ; : ( -- action ) @@ -160,11 +162,12 @@ M: annotation entity-url { pastebin "new-paste" } >>template - [ mode-names "modes" set-value ] >>validate + [ + mode-names "modes" set-value + validate-entity + ] >>validate [ - validate-entity - f [ deposit-entity-slots ] [ insert-tuple ] @@ -196,6 +199,7 @@ M: annotation entity-url : ( -- action ) [ + mode-names "modes" set-value { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index 34ee73da67..6c0affd17f 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -9,12 +9,12 @@ | Atom Feed | Admin - - - | Edit Profile + + + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 90b2411fc1..ca74b7e642 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -3,13 +3,14 @@ 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 @@ -130,7 +131,7 @@ posting "POSTINGS" } validate-params ; : deposit-blog-slots ( blog -- ) - { "name" "www-url" "feed-url" } deposit-slots ; + { "name" "www-url" "feed-url" } to-object ; : ( -- action ) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 0770765754..0fb7e7dc89 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -2,15 +2,16 @@ ! 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 @@ -31,7 +32,7 @@ todo "TODO" : ( id -- todo ) todo new swap >>id - uid >>uid ; + logged-in-user get username>> >>uid ; : ( -- action ) @@ -62,7 +63,7 @@ todo "TODO" [ f - dup { "summary" "priority" "description" } deposit-slots + dup { "summary" "priority" "description" } to-object [ insert-tuple ] [ id>> view-todo-url ] bi ] >>submit ; @@ -82,7 +83,7 @@ todo "TODO" [ f - dup { "id" "summary" "priority" "description" } deposit-slots + dup { "id" "summary" "priority" "description" } to-object [ update-tuple ] [ id>> view-todo-url ] bi ] >>submit ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index e087fbfcfc..f7500cdad2 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -8,11 +8,11 @@ List Items | Add Item - - | Edit Profile + + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml index 0c55f8ca76..252667462b 100644 --- a/extra/webapps/user-admin/edit-user.xml +++ b/extra/webapps/user-admin/edit-user.xml @@ -50,11 +50,11 @@

- +

- Delete + Delete diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 19153e1354..2137abbc2d 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -2,6 +2,7 @@ ! 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 @@ -10,8 +11,9 @@ furnace.auth.providers 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 @@ -26,10 +28,19 @@ TUPLE: user-admin < dispatcher ; : 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 ; : ( -- action ) @@ -42,14 +53,13 @@ TUPLE: user-admin < dispatcher ; [ 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 @@ -74,14 +84,16 @@ TUPLE: user-admin < dispatcher ; : validate-username ( -- ) { { "username" [ v-username ] } } validate-params ; +: select-capabilities ( seq -- ) + [ t swap word>string set-value ] each ; + : ( -- action ) [ validate-username "username" value select-tuple - [ from-object ] - [ capabilities>> [ "true" swap word>string set-value ] each ] bi + [ from-object ] [ capabilities>> select-capabilities ] bi init-capabilities ] >>init @@ -89,14 +101,17 @@ TUPLE: user-admin < dispatcher ; { user-admin "edit-user" } >>template [ + "username" value 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" @@ -124,11 +139,7 @@ TUPLE: user-admin < dispatcher ; [ validate-username - - [ select-tuple 1 >>deleted update-tuple ] - [ logout-all-sessions ] - bi - + "username" value delete-tuples URL" $user-admin" ] >>submit ; diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 9cb9ef0a0a..2141fdc1d9 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -6,11 +6,11 @@ List Users | Add User - - | Edit Profile + + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index 29c4a60bef..27187c4352 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -3,8 +3,8 @@ ! 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 ; diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 97a051cd96..0e1af75a8f 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -16,7 +16,7 @@ - Rollback + Rollback diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 4c6d1a5b5c..0abd36a7cd 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -14,13 +14,13 @@ | All Articles | Recent Changes - + - - | Edit Profile + + | Edit Profile - | Logout + | Logout @@ -28,6 +28,23 @@

- + + + + + + + +
+ +

+ + + +

+ + + +
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 8dd62c8761..77ee242668 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,11 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order present -html.components syndication +syndication +html.components html.forms http.server http.server.dispatchers furnace furnace.actions +furnace.redirection furnace.auth furnace.auth.login furnace.boilerplate @@ -77,6 +79,10 @@ M: revision feed-entry-url id>> revision-url ; [ "Front Page" view-url ] >>display ; +: latest-revision ( title -- revision/f ) +
select-tuple + dup [ revision>> select-tuple ] when ; + : ( -- action ) @@ -87,8 +93,8 @@ M: revision feed-entry-url id>> revision-url ; ] >>init [ - "title" value dup
select-tuple [ - revision>> select-tuple from-object + "title" value dup latest-revision [ + from-object { wiki "view" } ] [ edit-url @@ -231,8 +237,8 @@ M: revision feed-entry-url id>> revision-url ; "old-id" "new-id" [ value 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 @@ -279,6 +285,11 @@ M: revision feed-entry-url id>> revision-url ; { wiki "page-common" } >>template ; +: init-sidebar ( -- ) + "Sidebar" latest-revision [ + "sidebar" [ from-object ] nest-form + ] when* ; + : ( -- dispatcher ) wiki new-dispatcher "" add-responder @@ -296,4 +307,5 @@ M: revision feed-entry-url id>> revision-url ; "changes.atom" add-responder "delete" add-responder + [ init-sidebar ] >>init { wiki "wiki-common" } >>template ; diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor new file mode 100644 index 0000000000..6d65f10783 --- /dev/null +++ b/extra/websites/concatenative/concatenative.factor @@ -0,0 +1,104 @@ +! 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 ; + +: ( -- responder ) + factor-website new-dispatcher + "blogs" add-responder + "todo" add-responder + "pastebin" add-responder + "planet" add-responder + "wiki" add-responder + "wee-url" add-responder + "user-admin" add-responder + URL" /wiki/view/Front Page" "" add-responder + "Factor website" + "Factor website" >>name + allow-registration + allow-password-recovery + allow-edit-profile + allow-deactivation + + { factor-website "page" } >>template + test-db ; + +SYMBOL: key-password +SYMBOL: key-file +SYMBOL: dh-file + +: common-configuration ( -- ) + "concatenative.org" 25 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 + 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 ; + +: ( -- config ) + + key-file get >>key-file + dh-file get >>dh-file + key-password get >>password ; + +: ( -- threaded-server ) + + >>secure-config + 8080 >>insecure + 8431 >>secure ; + +: start-website ( -- ) + test-db start-expiring + test-db start-update-task + http-insomniac + start-server ; diff --git a/extra/webapps/factor-website/page.css b/extra/websites/concatenative/page.css similarity index 100% rename from extra/webapps/factor-website/page.css rename to extra/websites/concatenative/page.css diff --git a/extra/webapps/factor-website/page.xml b/extra/websites/concatenative/page.xml similarity index 88% rename from extra/webapps/factor-website/page.xml rename to extra/websites/concatenative/page.xml index 32e1223c58..464a3d9c5d 100644 --- a/extra/webapps/factor-website/page.xml +++ b/extra/websites/concatenative/page.xml @@ -12,7 +12,7 @@ - + diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 8c6025f726..98276caf83 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -5,7 +5,7 @@ IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; -r diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor index 5cf3675941..8039db0ac9 100755 --- a/extra/xmode/loader/loader.factor +++ b/extra/xmode/loader/loader.factor @@ -7,15 +7,15 @@ IN: xmode.loader ! Based on org.gjt.sp.jedit.XModeHandler ! RULES and its children -number swap set-rule-set-terminate-char ; RULE: SEQ seq-rule diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor index 175c8ed22f..b3adf5cb60 100644 --- a/extra/xmode/loader/syntax/syntax.factor +++ b/extra/xmode/loader/syntax/syntax.factor @@ -75,7 +75,7 @@ SYMBOL: ignore-case? [ parse-literal-matcher swap set-rule-end ] , ; ! SPAN's children - tag-handler-word get tag-handlers get >alist [ >r dup name-tag r> case ] curry - (( tag -- )) define-declared ; parsing + define ; parsing