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

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

db4
Doug Coleman 2008-06-18 12:04:43 -05:00
parent e92980b9ad ebb3423e4a
commit 21b47bdc3c
137 changed files with 2269 additions and 1460 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
core/assocs/assocs.factor
View File

@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
: (assoc-each) ( assoc quot -- seq quot' )
>r >alist r> [ first2 ] prepose ; inline
: assoc-find ( assoc quot -- key value ? )
>r >alist r> [ first2 ] prepose find swap
[ first2 t ] [ drop f f f ] if ; inline
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
: assoc-each ( assoc quot -- )
[ f ] compose assoc-find 3drop ; inline
: (assoc>map) ( quot accum -- quot' )
[ push ] curry compose ; inline
(assoc-each) each ; inline
: assoc>map ( assoc quot exemplar -- seq )
>r over assoc-size
<vector> [ (assoc>map) assoc-each ] keep
r> like ; inline
>r accumulator >r assoc-each r> r> like ; inline
: assoc-map-as ( assoc quot exemplar -- newassoc )
>r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline
: assoc-map ( assoc quot -- newassoc )
over >r [ 2array ] compose V{ } assoc>map r> assoc-like ;
inline
over assoc-map-as ; inline
: assoc-push-if ( key value quot accum -- )
>r 2keep r> roll

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

@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors"
{ $subsection missing-effect } ;
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
$nl
"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
{ $subsection infer. }

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

@ -28,23 +28,62 @@ ERROR: encode-error ;
! Decoding
<PRIVATE
M: object <decoder> f decoder boa ;
<PRIVATE
: cr+ t >>cr drop ; inline
: cr- f >>cr drop ; inline
: >decoder< ( decoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
[ stream>> ] [ code>> ] bi ; inline
: cr+ t swap set-decoder-cr ; inline
: fix-read1 ( stream char -- char )
over cr>> [
over cr-
dup CHAR: \n = [
drop dup stream-read1
] when
] when nip ; inline
: cr- f swap set-decoder-cr ; inline
M: decoder stream-read1
dup >decoder< decode-char fix-read1 ;
: fix-read ( stream string -- string )
over cr>> [
over cr-
"\n" ?head [
over stream-read1 [ suffix ] when*
] when
] when nip ; inline
: (read) ( n quot -- n string )
over 0 <string> [
[
>r call dup
[ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
] 2curry find-integer
] keep ; inline
: finish-read ( n string -- string/f )
{
{ [ over 0 = ] [ 2drop f ] }
{ [ over not ] [ nip ] }
[ swap head ]
} cond ; inline
M: decoder stream-read
tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
M: decoder stream-read-partial stream-read ;
: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
: line-ends\r ( stream str -- str ) swap cr+ ; inline
: line-ends\n ( stream str -- str )
over decoder-cr over empty? and
over cr>> over empty? and
[ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
: handle-readln ( stream str ch -- str )
@ -52,61 +91,30 @@ M: object <decoder> f decoder boa ;
{ f [ line-ends/eof ] }
{ CHAR: \r [ line-ends\r ] }
{ CHAR: \n [ line-ends\n ] }
} case ;
} case ; inline
: fix-read ( stream string -- string )
over decoder-cr [
over cr-
"\n" ?head [
over stream-read1 [ suffix ] when*
] when
] when nip ;
: read-loop ( n stream -- string )
SBUF" " clone [
[
>r nip stream-read1 dup
[ r> push f ] [ r> 2drop t ] if
] 2curry find-integer drop
] keep "" like f like ;
M: decoder stream-read
tuck read-loop fix-read ;
M: decoder stream-read-partial stream-read ;
: (read-until) ( buf quot -- string/f sep/f )
: ((read-until)) ( buf quot -- string/f sep/f )
! quot: -- char stop?
dup call
[ >r drop "" like r> ]
[ pick push (read-until) ] if ; inline
[ pick push ((read-until)) ] if ; inline
M: decoder stream-read-until
: (read-until) ( seps stream -- string/f sep/f )
SBUF" " clone -rot >decoder<
[ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
(read-until) ;
[ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
((read-until)) ; inline
: fix-read1 ( stream char -- char )
over decoder-cr [
over cr-
dup CHAR: \n = [
drop dup stream-read1
] when
] when nip ;
M: decoder stream-read-until (read-until) ;
M: decoder stream-read1
dup >decoder< decode-char fix-read1 ;
M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
M: decoder stream-readln ( stream -- str )
"\r\n" over stream-read-until handle-readln ;
M: decoder dispose decoder-stream dispose ;
M: decoder dispose stream>> dispose ;
! Encoding
M: object <encoder> encoder boa ;
: >encoder< ( encoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
[ stream>> ] [ code>> ] bi ; inline
M: encoder stream-write1
>encoder< encode-char ;

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

@ -2,14 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.private kernel.private
sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary
inference.class kernel assocs math math.order math.private
kernel.private sequences words parser vectors strings sbufs io
namespaces assocs quotations sequences.private io.binary
io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining float-arrays
sequences.private combinators ;
sequences.private combinators byte-arrays byte-vectors ;
{ <tuple> <tuple-boa> } [
[
@ -59,15 +59,59 @@ sequences.private combinators ;
node-in-d peek dup value?
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
[ literalize [ t ] ] { } map>assoc
[ drop f ] suffix [ nip case ] curry ;
: expand-member ( #call quot -- )
>r dup node-in-d peek value-literal r> call f splice-quot ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ;
: bit-member-n 256 ; inline
: bit-member? ( seq -- ? )
#! Can we use a fast byte array test here?
{
{ [ dup length 8 < ] [ f ] }
{ [ dup [ integer? not ] contains? ] [ f ] }
{ [ dup [ 0 < ] contains? ] [ f ] }
{ [ dup [ bit-member-n >= ] contains? ] [ f ] }
[ t ]
} cond nip ;
: bit-member-seq ( seq -- flags )
bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
: exact-float? ( f -- ? )
dup float? [ dup >integer >float = ] [ drop f ] if ; inline
: bit-member-quot ( seq -- newquot )
[
[ drop ] % ! drop the sequence itself; we don't use it at run time
bit-member-seq ,
[
{
{ [ over fixnum? ] [ ?nth 1 eq? ] }
{ [ over bignum? ] [ ?nth 1 eq? ] }
{ [ over exact-float? ] [ ?nth 1 eq? ] }
[ 2drop f ]
} cond
] %
] [ ] make ;
: member-quot ( seq -- newquot )
dup bit-member? [
bit-member-quot
] [
[ literalize [ t ] ] { } map>assoc
[ drop f ] suffix [ nip case ] curry
] if ;
\ member? {
{ [ dup literal-member? ] [ expand-member ] }
{ [ dup literal-member? ] [ [ member-quot ] expand-member ] }
} define-optimizers
: memq-quot ( seq -- newquot )
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
[ drop f ] suffix [ nip cond ] curry ;
\ memq? {
{ [ dup literal-member? ] [ [ memq-quot ] expand-member ] }
} define-optimizers
! if the result of eq? is t and the second input is a literal,
@ -97,7 +141,7 @@ sequences.private combinators ;
] each
\ push-all
{ { string sbuf } { array vector } }
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
\ append

7
core/sequences/sequences.factor
View File

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

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

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

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

@ -41,4 +41,4 @@ IN: assocs.lib
: histogram ( assoc quot -- assoc' )
H{ } clone [
swap [ change-at ] 2curry assoc-each
] keep ;
] keep ; inline

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

@ -1,8 +1,18 @@
USING: kernel tools.test base64 strings ;
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
] unit-test
[ "" ] [ "" >base64 base64> ] unit-test
[ "a" ] [ "a" >base64 base64> ] unit-test
[ "ab" ] [ "ab" >base64 base64> ] unit-test
[ "abc" ] [ "abc" >base64 base64> ] unit-test
[ "" ] [ "" >base64 base64> >string ] unit-test
[ "a" ] [ "a" >base64 base64> >string ] unit-test
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
>base64 >string
] unit-test
\ >base64 must-infer
\ base64> must-infer

27
extra/base64/base64.factor
View File

@ -1,11 +1,10 @@
USING: kernel math sequences namespaces io.binary splitting
grouping strings hashtables ;
USING: kernel math sequences io.binary splitting grouping ;
IN: base64
<PRIVATE
: count-end ( seq quot -- count )
>r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ;
>r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@ -20,28 +19,26 @@ IN: base64
} nth ;
: encode3 ( seq -- seq )
be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ;
be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
: decode4 ( str -- str )
[ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ;
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: >base64-rem ( str -- str )
[ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ;
[ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
PRIVATE>
: >base64 ( seq -- base64 )
#! cut string into two pieces, convert 3 bytes at a time
#! pad string with = when not enough bits
dup length dup 3 mod - cut swap
[
3 <groups> [ encode3 % ] each
dup empty? [ drop ] [ >base64-rem % ] if
] "" make ;
dup length dup 3 mod - cut
[ 3 <groups> [ encode3 ] map concat ]
[ dup empty? [ drop "" ] [ >base64-rem ] if ]
bi* append ;
: base64> ( base64 -- str )
#! input length must be a multiple of 4
[
[ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end
] SBUF" " make swap [ dup pop* ] times >string ;
[ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = not ] count-end ]
bi head* ;

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

@ -1,9 +1,9 @@
IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
arrays io.sockets system combinators threads math sequences
concurrency.messaging continuations ;
concurrency.messaging continuations accessors prettyprint ;
: test-node
: test-node ( -- addrspec )
{
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
{ [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
@ -11,9 +11,9 @@ concurrency.messaging continuations ;
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
[ ] [ test-node dup 1array swap (start-node) ] unit-test
[ ] [ test-node dup (start-node) ] unit-test
[ ] [ 100 sleep ] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [
[
@ -30,4 +30,6 @@ concurrency.messaging continuations ;
receive
] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [ test-node stop-node ] unit-test

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

@ -1,8 +1,8 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
io.server qualified arrays namespaces kernel io.encodings.binary
accessors ;
io.servers.connection io.encodings.binary
qualified arrays namespaces kernel accessors ;
FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed
@ -10,21 +10,21 @@ SYMBOL: local-node
: handle-node-client ( -- )
deserialize
[ first2 get-process send ]
[ stop-server ] if* ;
[ first2 get-process send ] [ stop-server ] if* ;
: (start-node) ( addrspecs addrspec -- )
: (start-node) ( addrspec addrspec -- )
local-node set-global
[
"concurrency.distributed"
binary
[ handle-node-client ] with-server
<threaded-server>
swap >>insecure
binary >>encoding
"concurrency.distributed" >>name
[ handle-node-client ] >>handler
start-server
] curry "Distributed concurrency server" spawn drop ;
: start-node ( port -- )
[ internet-server ]
[ host-name swap <inet> ] bi
(start-node) ;
host-name over <inet> (start-node) ;
TUPLE: remote-process id node ;

2
extra/cords/cords.factor
View File

@ -1,4 +1,4 @@
! Copysecond (C) 2008 Slava Pestov.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting math math.order
arrays combinators kernel ;

4
extra/dns/dns.factor
View File

@ -424,6 +424,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
}
2cleave message boa ;
: ba->message ( ba -- message ) parse-message ;
: with-message-bytes ( ba quot -- ) >r ba->message r> call message->ba ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: send-receive-udp ( ba server -- ba )

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

@ -1,15 +1,17 @@
USING: kernel combinators sequences sets math
io.sockets unicode.case accessors
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
combinators.cleave combinators.lib
newfx
newfx fry
dns dns.util dns.misc ;
IN: dns.server
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: records ( -- vector ) V{ } ;
SYMBOL: records-var
: records ( -- records ) records-var get ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -50,9 +52,10 @@ IN: dns.server
: rr->rdata-names ( rr -- names/f )
{
{ [ dup type>> NS = ] [ rdata>> {1} ] }
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
{ [ t ] [ drop f ] }
{ [ dup type>> NS = ] [ rdata>> {1} ] }
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
{ [ dup type>> CNAME = ] [ rdata>> {1} ] }
{ [ t ] [ drop f ] }
}
cond ;
@ -192,31 +195,14 @@ DEFER: query->rrs
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (socket) ( -- vec ) V{ f } ;
: (handle-request) ( packet -- )
[ [ find-answer ] with-message-bytes ] change-data respond ;
: socket ( -- socket ) (socket) 1st ;
: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
: init-socket-on-port ( port -- )
f swap <inet4> <datagram> 0 (socket) as-mutate ;
: receive-loop ( socket -- )
[ receive-packet handle-request ] [ receive-loop ] bi ;
: init-socket ( -- ) 53 init-socket-on-port ;
: loop ( addr-spec -- )
[ <datagram> '[ , [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: loop ( -- )
socket receive
swap
parse-message
find-answer
message->ba
swap
socket send
loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start ( -- ) init-socket loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: start

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

@ -16,4 +16,15 @@ MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: longer? ( seq seq -- ? ) [ length ] bi@ > ;
: longer? ( seq seq -- ? ) [ length ] bi@ > ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: io.sockets accessors ;
TUPLE: packet data addr socket ;
: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;

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

@ -3,14 +3,12 @@ namespaces sequences system combinators
editors.vim editors.gvim.backend vocabs.loader ;
IN: editors.gvim
TUPLE: gvim ;
SINGLETON: gvim
M: gvim vim-command ( file line -- string )
[ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
[ gvim-path , swap , "+" swap number>string append , ] { } make ;
t vim-detach set-global ! don't block the ui
T{ gvim } vim-editor set-global
gvim vim-editor set-global
{
{ [ os unix? ] [ "editors.gvim.unix" ] }

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

@ -11,7 +11,5 @@ $nl
"USE: vim"
"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
}
"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
$nl
"If you are running the terminal version of Vim, you want it to block Factor until exiting, but for GVim the opposite is desired, so that one can work in Factor and GVim concurrently. The " { $link vim-detach } " global variable can be set to " { $link t } " to detach the Vim process. The default is " { $link f } "." ;
"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ;

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

@ -3,24 +3,20 @@ namespaces parser prettyprint sequences editors accessors ;
IN: editors.vim
SYMBOL: vim-path
SYMBOL: vim-detach
SYMBOL: vim-editor
HOOK: vim-command vim-editor
HOOK: vim-command vim-editor ( file line -- array )
TUPLE: vim ;
SINGLETON: vim
M: vim vim-command ( file line -- array )
M: vim vim-command
[
vim-path get , swap , "+" swap number>string append ,
] { } make ;
: vim-location ( file line -- )
vim-command
<process> swap >>command
vim-detach get-global [ t >>detached ] when
try-process ;
vim-command try-process ;
"vim" vim-path set-global
[ vim-location ] edit-hook set-global
T{ vim } vim-editor set-global
vim vim-editor set-global

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

@ -1,11 +0,0 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: listener io.server strings parser byte-arrays ;
IN: eval-server
: eval-server ( -- )
9998 local-server "eval-server" [
>string eval>string >byte-array
] with-datagrams ;
MAIN: eval-server

1
extra/eval-server/summary.txt
View File

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

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

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

21
extra/farkup/farkup.factor
View File

@ -7,6 +7,7 @@ sequences.deep unicode.categories ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
<PRIVATE
@ -88,18 +89,22 @@ MEMO: eq ( -- parser )
escape-link
[
"<a" ,
" href=\"" , >r , r>
" href=\"" , >r , r> "\"" ,
link-no-follow? get [ " nofollow=\"true\"" , ] when
"\">" , , "</a>" ,
">" , , "</a>" ,
] { } make ;
: make-image-link ( href alt -- seq )
escape-link
[
"<img src=\"" , swap , "\"" ,
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
"/>" , ]
{ } make ;
disable-images? get [
2drop "<strong>Images are not allowed</strong>"
] [
escape-link
[
"<img src=\"" , swap , "\"" ,
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
"/>" ,
] { } make
] if ;
MEMO: image-link ( -- parser )
[

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

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.encodings io.encodings.binary io.encodings.utf8 io.files
io.server io.sockets kernel math.parser namespaces sequences
io.sockets kernel math.parser namespaces sequences
ftp io.unix.launcher.parser unicode.case splitting assocs
classes io.server destructors calendar io.timeouts
classes io.servers.connection destructors calendar io.timeouts
io.streams.duplex threads continuations math
concurrency.promises byte-arrays ;
IN: ftp.server
@ -305,7 +305,10 @@ ERROR: not-a-directory ;
[ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
: handle-client ( -- )
TUPLE: ftp-server < threaded-server ;
M: ftp-server handle-client* ( server -- )
drop
[
"" [
host-name <ftp-client> client set
@ -313,9 +316,14 @@ ERROR: not-a-directory ;
] with-directory
] with-destructors ;
: <ftp-server> ( port -- server )
ftp-server new-threaded-server
swap >>insecure
"ftp.server" >>name
latin1 >>encoding ;
: ftpd ( port -- )
internet-server "ftp.server"
latin1 [ handle-client ] with-server ;
<ftp-server> start-server ;
: ftpd-main ( -- ) 2100 ftpd ;

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

@ -8,6 +8,7 @@ http.server
http.server.responses
furnace
furnace.flash
html.forms
html.elements
html.components
html.components
@ -20,10 +21,10 @@ SYMBOL: params
SYMBOL: rest
: render-validation-messages ( -- )
validation-messages get
form get errors>>
dup empty? [ drop ] [
<ul "errors" =class ul>
[ <li> message>> escape-string write </li> ] each
[ <li> escape-string write </li> ] each
</ul>
] if ;
@ -37,8 +38,21 @@ TUPLE: action rest authorize init display validate submit ;
: <action> ( -- action )
action new-action ;
: flashed-variables ( -- seq )
{ validation-messages named-validation-messages } ;
: set-nested-form ( form name -- )
dup empty? [
drop form set
] [
dup length 1 = [
first set-value
] [
unclip [ set-nested-form ] nest-form
] if
] if ;
: restore-validation-errors ( -- )
form fget [
nested-forms fget set-nested-form
] when* ;
: handle-get ( action -- response )
'[
@ -46,25 +60,12 @@ TUPLE: action rest authorize init display validate submit ;
{
[ init>> call ]
[ authorize>> call ]
[ drop flashed-variables restore-flash ]
[ drop restore-validation-errors ]
[ display>> call ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
: validation-failed ( -- * )
post-request? [ f ] [ <400> ] if exit-with ;
: (handle-post) ( action -- response )
'[
, dup submit>> [
[ validate>> call ]
[ authorize>> call ]
[ submit>> call ]
tri
] [ drop <400> ] if
] with-exit-continuation ;
: param ( name -- value )
params get at ;
@ -74,24 +75,29 @@ TUPLE: action rest authorize init display validate submit ;
revalidate-url-key param
dup [ >url [ same-host? ] keep and ] when ;
: validation-failed ( -- * )
post-request? revalidate-url and
[
nested-forms-key param " " split harvest nested-forms set
{ form nested-forms } <flash-redirect>
] [ <400> ] if*
exit-with ;
: handle-post ( action -- response )
'[
form-nesting-key params get at " " split
[ , (handle-post) ]
[ swap '[ , , nest-values ] ] reduce
call
] with-exit-continuation
[
revalidate-url
[ flashed-variables <flash-redirect> ] [ <403> ] if*
] unless* ;
, dup submit>> [
[ validate>> call ]
[ authorize>> call ]
[ submit>> call ]
tri
] [ drop <400> ] if
] with-exit-continuation ;
: handle-rest ( path action -- assoc )
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
: init-action ( path action -- )
blank-values
init-validation
begin-form
handle-rest
request get request-params assoc-union params set ;
@ -110,8 +116,7 @@ M: action modify-form
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values from-object
check-validation ;
params get swap validate-values check-validation ;
: validate-integer-id ( -- )
{ { "id" [ v-number ] } } validate-params ;

5
extra/furnace/alloy/alloy.factor
View File

@ -7,7 +7,8 @@ furnace.flash
furnace.sessions
furnace.referrer
furnace.db
furnace.auth.providers ;
furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
@ -19,7 +20,7 @@ IN: furnace.alloy
<check-form-submissions>
] call ;
: state-classes { session flash-scope aside } ; inline
: state-classes { session flash-scope aside permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables

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

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

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

@ -0,0 +1,6 @@
USING: furnace.auth tools.test ;
IN: furnace.auth.tests
\ logged-in-username must-infer
\ <protected> must-infer
\ new-realm must-infer

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

@ -1,15 +1,25 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry
io.encodings.utf8 io.encodings.string io.binary random
checksums checksums.sha2
html.forms
http.server
http.server.filters
http.server.dispatchers
furnace.sessions
furnace.auth.providers ;
furnace
furnace.actions
furnace.redirection
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db ;
IN: furnace.auth
SYMBOL: logged-in-user
: logged-in? ( -- ? ) logged-in-user get >boolean ;
GENERIC: init-user-profile ( responder -- )
M: object init-user-profile drop ;
@ -20,6 +30,9 @@ M: dispatcher init-user-profile
M: filter-responder init-user-profile
responder>> init-user-profile ;
: have-capability? ( capability -- ? )
logged-in-user get capabilities>> member? ;
: profile ( -- assoc ) logged-in-user get profile>> ;
: user-changed ( -- )
@ -41,3 +54,100 @@ SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get adjoin ;
TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( realm -- response )
GENERIC: logged-in-username ( realm -- username )
: login-required ( -- * ) realm get login-required* exit-with ;
: new-realm ( responder name class -- realm )
new-dispatcher
swap >>name
swap >>default
users-in-db >>users
sha-256 >>checksum
t >>secure ; inline
: users ( -- provider )
realm get users>> ;
TUPLE: user-saver user ;
C: <user-saver> user-saver
M: user-saver dispose
user>> dup changed?>> [ users update-user ] [ drop ] if ;
: save-user-after ( user -- )
<user-saver> &dispose drop ;
: init-user ( user -- )
[ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
M: realm call-responder* ( path responder -- response )
dup realm set
dup logged-in-username dup [ users get-user ] when init-user
call-next-method ;
: encode-password ( string salt -- bytes )
[ utf8 encode ] [ 4 >be ] bi* append
realm get checksum>> checksum-bytes ;
: >>encoded-password ( user string -- user )
32 random-bits [ encode-password ] keep
[ >>password ] [ >>salt ] bi* ; inline
: valid-login? ( password user -- ? )
[ salt>> encode-password ] [ password>> ] bi = ;
: check-login ( password username -- user/f )
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
: if-secure-realm ( quot -- )
realm get secure>> [ if-secure ] [ call ] if ; inline
TUPLE: secure-realm-only < filter-responder ;
C: <secure-realm-only> secure-realm-only
M: secure-realm-only call-responder*
'[ , , call-next-method ] if-secure-realm ;
TUPLE: protected < filter-responder description capabilities ;
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: check-capabilities ( responder user/f -- ? )
{
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ [ capabilities>> ] bi@ subset? ]
} cond ;
M: protected call-responder* ( path responder -- response )
'[
, ,
dup protected set
dup logged-in-user get check-capabilities
[ call-next-method ] [ 2drop realm get login-required* ] if
] if-secure-realm ;
: <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ;
: password-mismatch ( -- * )
"passwords do not match" validation-error
validation-failed ;
: same-password-twice ( -- )
"new-password" value "verify-password" value =
[ password-mismatch ] unless ;
: user-exists ( -- * )
"username taken" validation-error
validation-failed ;

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

@ -1,41 +1,29 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators sequences
http http.server.filters http.server.responses http.server
furnace.auth.providers furnace.auth.login ;
USING: accessors kernel splitting base64 namespaces strings
http http.server.responses furnace.auth ;
IN: furnace.auth.basic
TUPLE: basic-auth < filter-responder realm provider ;
TUPLE: basic-auth-realm < realm ;
C: <basic-auth> basic-auth
: <basic-auth-realm> ( responder name -- realm )
basic-auth-realm new-realm ;
: authorization-ok? ( provider header -- ? )
#! Given the realm and the 'Authorization' header,
#! authenticate the user.
: parse-basic-auth ( header -- username/f password/f )
dup [
" " split1 swap "Basic" = [
base64> ":" split1 spin check-login
] [
2drop f
] if
] [
2drop f
] if ;
base64> >string ":" split1
] [ drop f f ] if
] [ drop f f ] if ;
: <401> ( realm -- response )
401 "Unauthorized" <trivial-response>
"Basic realm=\"" rot "\"" 3append
"WWW-Authenticate" set-header
[
<html> <body>
"Username or Password is invalid" write
</body> </html>
] >>body ;
401 "Invalid username or password" <trivial-response>
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
: logged-in? ( request responder -- ? )
provider>> swap "authorization" header authorization-ok? ;
M: basic-auth-realm login-required* ( realm -- response )
name>> <401> ;
M: basic-auth call-responder* ( request path responder -- response )
pick over logged-in?
[ call-next-method ] [ 2nip realm>> <401> ] if ;
M: basic-auth-realm logged-in-username ( realm -- uid )
drop
request get "authorization" header parse-basic-auth
dup [ over check-login swap and ] [ 2drop f ] if ;

0
extra/furnace/auth/login/boilerplate.xml → extra/furnace/auth/boilerplate.xml
View File

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

@ -0,0 +1,24 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs namespaces accessors db db.tuples urls
http.server.dispatchers
furnace.asides furnace.actions furnace.auth furnace.auth.providers ;
IN: furnace.auth.features.deactivate-user
: <deactivate-user-action> ( -- action )
<action>
[
logged-in-user get
1 >>deleted
t >>changed?
drop
URL" $realm" end-aside
] >>submit ;
: allow-deactivation ( realm -- realm )
<deactivate-user-action> <protected>
"delete your profile" >>description
"deactivate-user" add-responder ;
: allow-deactivation? ( -- ? )
realm get responders>> "deactivate-user" swap key? ;

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

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

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

@ -0,0 +1,67 @@
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces sequences assocs
validators urls
html.forms
http.server.dispatchers
furnace.auth
furnace.asides
furnace.actions ;
IN: furnace.auth.features.edit-profile
: <edit-profile-action> ( -- action )
<page-action>
[
logged-in-user get
[ username>> "username" set-value ]
[ realname>> "realname" set-value ]
[ email>> "email" set-value ]
tri
] >>init
{ realm "features/edit-profile/edit-profile" } >>template
[
logged-in-user get username>> "username" set-value
{
{ "realname" [ [ v-one-line ] v-optional ] }
{ "password" [ ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
} validate-params
{ "password" "new-password" "verify-password" }
[ value empty? not ] contains? [
"password" value logged-in-user get username>> check-login
[ "incorrect password" validation-error ] unless
same-password-twice
] when
] >>validate
[
logged-in-user get
"new-password" value dup empty?
[ drop ] [ >>encoded-password ] if
"realname" value >>realname
"email" value >>email
t >>changed?
drop
URL" $login" end-aside
] >>submit
<protected>
"edit your profile" >>description ;
: allow-edit-profile ( login -- login )
<edit-profile-action> <auth-boilerplate> "edit-profile" add-responder ;
: allow-edit-profile? ( -- ? )
realm get responders>> "edit-profile" swap key? ;

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

@ -4,7 +4,7 @@
<t:title>Edit Profile</t:title>
<t:form t:action="$login/edit-profile">
<t:form t:action="$realm/edit-profile">
<table>
@ -67,4 +67,7 @@
</t:form>
<t:if t:code="furnace.auth.features.deactivate-user:allow-deactivation?">
<t:button t:action="$realm/deactivate-user">Delete User</t:button>
</t:if>
</t:chloe>

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

@ -6,7 +6,7 @@
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<t:form t:action="recover-password">
<t:form t:action="$realm/recover-password">
<table>

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

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

@ -6,7 +6,7 @@
<p>Choose a new password for your account.</p>
<t:form t:action="new-password">
<t:form t:action="$realm/recover-3">
<table>

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

@ -4,6 +4,6 @@
<t:title>Recover lost password: step 4 of 4</t:title>
<p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>
<p>Your password has been reset. You may now <t:a t:href="$realm">proceed</t:a>.</p>
</t:chloe>

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

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

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

@ -0,0 +1,124 @@
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors kernel assocs arrays io.sockets threads
fry urls smtp validators html.forms present
http http.server.responses http.server.redirection
http.server.dispatchers
furnace furnace.actions furnace.auth furnace.auth.providers
furnace.redirection ;
IN: furnace.auth.features.recover-password
SYMBOL: lost-password-from
: current-host ( -- string )
request get url>> host>> host-name or ;
: new-password-url ( user -- url )
URL" recover-3" clone
swap
[ username>> "username" set-query-param ]
[ ticket>> "ticket" set-query-param ]
bi
adjust-url relative-to-request ;
: password-email ( user -- email )
<email>
[ "[ " % current-host % " ] password recovery" % ] "" make >>subject
lost-password-from get >>from
over email>> 1array >>to
[
"This e-mail was sent by the application server on " % current-host % "\n" %
"because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
"login form, and requested a new password for the user named ``" %
over username>> % "''.\n" %
"\n" %
"If you believe that this request was legitimate, you may click the below link in\n" %
"your browser to set a new password for your account:\n" %
"\n" %
swap new-password-url present %
"\n\n" %
"Love,\n" %
"\n" %
" FactorBot\n" %
] "" make >>body ;
: send-password-email ( user -- )
'[ , password-email send-email ]
"E-mail send thread" spawn drop ;
: <recover-action-1> ( -- action )
<page-action>
{ realm "features/recover-password/recover-1" } >>template
[
{
{ "username" [ v-username ] }
{ "email" [ v-email ] }
{ "captcha" [ v-captcha ] }
} validate-params
] >>validate
[
"email" value "username" value
users issue-ticket [
send-password-email
] when*
URL" $realm/recover-2" <redirect>
] >>submit ;
: <recover-action-2> ( -- action )
<page-action>
{ realm "features/recover-password/recover-2" } >>template ;
: <recover-action-3> ( -- action )
<page-action>
[
{
{ "username" [ v-username ] }
{ "ticket" [ v-required ] }
} validate-params
] >>init
{ realm "features/recover-password/recover-3" } >>template
[
{
{ "username" [ v-username ] }
{ "ticket" [ v-required ] }
{ "new-password" [ v-password ] }
{ "verify-password" [ v-password ] }
} validate-params
same-password-twice
] >>validate
[
"ticket" value
"username" value
users claim-ticket [
"new-password" value >>encoded-password
users update-user
URL" $realm/recover-4" <redirect>
] [
<403>
] if*
] >>submit ;
: <recover-action-4> ( -- action )
<page-action>
{ realm "features/recover-password/recover-4" } >>template ;
: allow-password-recovery ( login -- login )
<recover-action-1> <auth-boilerplate>
"recover-password" add-responder
<recover-action-2> <auth-boilerplate>
"recover-2" add-responder
<recover-action-3> <auth-boilerplate>
"recover-3" add-responder
<recover-action-4> <auth-boilerplate>
"recover-4" add-responder ;
: allow-password-recovery? ( -- ? )
realm get responders>> "recover-password" swap key? ;

0
extra/furnace/auth/login/register.xml → extra/furnace/auth/features/registration/register.xml
View File

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

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

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

@ -0,0 +1,45 @@
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces validators html.forms urls
http.server.dispatchers
furnace furnace.auth furnace.auth.providers furnace.actions
furnace.redirection ;
IN: furnace.auth.features.registration
: <register-action> ( -- action )
<page-action>
{ realm "features/registration/register" } >>template
[
{
{ "username" [ v-username ] }
{ "realname" [ [ v-one-line ] v-optional ] }
{ "new-password" [ v-password ] }
{ "verify-password" [ v-password ] }
{ "email" [ [ v-email ] v-optional ] }
{ "captcha" [ v-captcha ] }
} validate-params
same-password-twice
] >>validate
[
"username" value <user>
"realname" value >>realname
"new-password" value >>encoded-password
"email" value >>email
H{ } clone >>profile
users new-user [ user-exists ] unless*
realm get init-user-profile
URL" $realm" <redirect>
] >>submit
<auth-boilerplate> ;
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
: allow-registration? ( -- ? )
realm get responders>> "register" swap key? ;

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

@ -1,6 +1,4 @@
IN: furnace.auth.login.tests
USING: tools.test furnace.auth.login ;
\ <login> must-infer
\ allow-registration must-infer
\ allow-password-recovery must-infer
\ <login-realm> must-infer

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

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

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

@ -43,11 +43,11 @@
</t:form>
<p>
<t:if t:code="furnace.auth.login:allow-registration?">
<t:if t:code="furnace.auth.features.registration:allow-registration?">
<t:a t:href="register">Register</t:a>
</t:if>
|
<t:if t:code="furnace.auth.login:allow-password-recovery?">
<t:if t:code="furnace.auth.features.recover-password:allow-password-recovery?">
<t:a t:href="recover-password">Recover Password</t:a>
</t:if>
</p>

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

@ -0,0 +1,30 @@
USING: accessors namespaces combinators.lib kernel
db.tuples db.types
furnace.auth furnace.sessions furnace.cache ;
IN: furnace.auth.login.permits
TUPLE: permit < server-state session uid ;
permit "PERMITS" {
{ "session" "SESSION" BIG-INTEGER +not-null+ }
{ "uid" "UID" { VARCHAR 255 } +not-null+ }
} define-persistent
: touch-permit ( permit -- )
realm get touch-state ;
: get-permit-uid ( id -- uid )
permit get-state {
[ ]
[ session>> session get id>> = ]
[ [ touch-permit ] [ uid>> ] bi ]
} 1&& ;
: make-permit ( uid -- id )
permit new
swap >>uid
session get id>> >>session
[ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
: delete-permit ( id -- )
permit new-server-state delete-tuples ;

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

@ -1,11 +1,11 @@
IN: furnace.auth.providers.assoc.tests
USING: furnace.actions furnace.auth.providers
USING: furnace.actions furnace.auth furnace.auth.providers
furnace.auth.providers.assoc furnace.auth.login
tools.test namespaces accessors kernel ;
<action> <login>
<action> "Test" <login-realm>
<users-in-memory> >>users
login set
realm set
[ t ] [
"slava" <user>

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

@ -1,14 +1,13 @@
IN: furnace.auth.providers.db.tests
USING: furnace.actions
furnace.auth
furnace.auth.login
furnace.auth.providers
furnace.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ;
<action> <login>
users-in-db >>users
login set
<action> "test" <login-realm> realm set
[ "auth-test.db" temp-file delete-file ] ignore-errors

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

@ -1,19 +1,32 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces
html.templates html.templates.chloe
USING: accessors kernel math.order namespaces combinators.lib
html.forms
html.templates
html.templates.chloe
locals
http.server
http.server.filters
furnace ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template ;
TUPLE: boilerplate < filter-responder template init ;
: <boilerplate> ( responder -- boilerplate ) f boilerplate boa ;
: <boilerplate> ( responder -- boilerplate )
boilerplate new
swap >>responder
[ ] >>init ;
: wrap-boilerplate? ( response -- ? )
{
[ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
[ content-type>> "text/html" = ]
} 1&& ;
M:: boilerplate call-responder* ( path responder -- )
begin-form
path responder call-next-method
responder init>> call
dup content-type>> "text/html" = [
clone [| body |
[

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

@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors continuations namespaces destructors
db db.pools io.pools http.server http.server.filters
furnace.sessions ;
db db.pools io.pools http.server http.server.filters ;
IN: furnace.db
TUPLE: db-persistence < filter-responder pool ;

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

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

30
extra/furnace/furnace.factor
View File

@ -10,6 +10,7 @@ xml.entities
xml.writer
html.components
html.elements
html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
@ -30,7 +31,7 @@ IN: furnace
: base-path ( string -- pair )
dup responder-nesting get
[ second class word-name = ] with find nip
[ second class superclasses [ word-name = ] with contains? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
@ -62,13 +63,6 @@ M: url adjust-url
M: string adjust-url ;
: <redirect> ( url -- response )
adjust-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
{ "HEAD" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
} case ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
@ -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 -- )

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

@ -0,0 +1,41 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry
io.servers.connection
http http.server http.server.redirection http.server.filters
furnace ;
IN: furnace.redirection
: <redirect> ( url -- response )
adjust-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
{ "HEAD" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
} case ;
: >secure-url ( url -- url' )
clone
"https" >>protocol
secure-port >>port ;
: <secure-redirect> ( url -- response )
>secure-url <redirect> ;
TUPLE: redirect-responder to ;
: <redirect-responder> ( url -- responder )
redirect-responder boa ;
M: redirect-responder call-responder* nip to>> <redirect> ;
TUPLE: secure-only < filter-responder ;
C: <secure-only> secure-only
: if-secure ( quot -- )
>r request get url>> protocol>> "http" =
[ request get url>> <secure-redirect> ]
r> if ; inline
M: secure-only call-responder*
'[ , , call-next-method ] if-secure ;

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

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

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

@ -1,22 +1,22 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
random accessors quotations hashtables sequences continuations
fry calendar combinators destructors alarms io.server
strings random accessors quotations hashtables sequences continuations
fry calendar combinators combinators.lib destructors alarms
io.servers.connection
db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
furnace furnace.cache ;
IN: furnace.sessions
TUPLE: session < server-state uid namespace user-agent client changed? ;
TUPLE: session < server-state namespace user-agent client changed? ;
: <session> ( id -- session )
session new-server-state ;
session "SESSIONS"
{
{ "uid" "UID" { VARCHAR 255 } }
{ "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
{ "user-agent" "USER_AGENT" TEXT +not-null+ }
{ "client" "CLIENT" TEXT +not-null+ }
@ -57,19 +57,17 @@ TUPLE: sessions < server-state-manager domain verify? ;
[ namespace>> swap change-at ] keep
(session-changed) ; inline
: uid ( -- uid )
session get uid>> ;
: set-uid ( uid -- )
session get [ (>>uid) ] [ (session-changed) ] bi ;
: init-session ( session -- )
session [ sessions get init-session* ] with-variable ;
: touch-session ( session -- )
sessions get touch-state ;
: remote-host ( -- string ) remote-address get host>> ;
: remote-host ( -- string )
{
[ request get "x-forwarded-for" header ]
[ remote-address get host>> ]
} 0|| ;
: empty-session ( -- session )
f <session>
@ -100,20 +98,6 @@ M: session-saver dispose
: session-id-key "__s" ;
: cookie-session-id ( request -- id/f )
session-id-key get-cookie
dup [ value>> string>number ] when ;
: post-session-id ( request -- id/f )
session-id-key swap request-params at string>number ;
: request-session-id ( -- id/f )
request get dup method>> {
{ "GET" [ cookie-session-id ] }
{ "HEAD" [ cookie-session-id ] }
{ "POST" [ post-session-id ] }
} case ;
: verify-session ( session -- session )
sessions get verify?>> [
dup [
@ -125,16 +109,18 @@ M: session-saver dispose
] when ;
: request-session ( -- session/f )
request-session-id get-session verify-session ;
session-id-key
client-state dup string? [ string>number ] when
get-session verify-session ;
: <session-cookie> ( id -- cookie )
session-id-key <cookie>
: <session-cookie> ( -- cookie )
session get id>> session-id-key <cookie>
"$sessions" resolve-base-path >>path
sessions get timeout>> from-now >>expires
sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ;
<session-cookie> put-cookie ;
M: sessions modify-form ( responder -- )
drop session get id>> session-id-key hidden-form-field ;
@ -143,6 +129,3 @@ M: sessions call-responder* ( path responder -- response )
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;
: logout-all-sessions ( uid -- )
session new swap >>uid delete-tuples ;

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

@ -0,0 +1,19 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences splitting ;
IN: furnace.utilities
: word>string ( word -- string )
[ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
: words>strings ( seq -- seq' )
[ word>string ] map ;
ERROR: no-such-word name vocab ;
: string>word ( string -- word )
":" split1 swap 2dup lookup dup
[ 2nip ] [ drop no-such-word ] if ;
: strings>words ( seq -- seq' )
[ string>word ] map ;

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

@ -1,9 +1,9 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.elements html.components namespaces ;
html.elements html.components html.forms namespaces ;
[ ] [ blank-values ] unit-test
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
@ -63,7 +63,7 @@ TUPLE: color red green blue ;
] with-null-writer
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ begin-form ] unit-test
[ ] [ "new york" "city1" set-value ] unit-test
@ -101,7 +101,7 @@ TUPLE: color red green blue ;
] with-null-writer
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ begin-form ] unit-test
[ ] [ t "delivery" set-value ] unit-test
@ -156,7 +156,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
[ "farkup" farkup render ] with-string-writer
[ "farkup" T{ farkup } render ] with-string-writer
] unit-test
[ ] [ { 1 2 3 } "object" set-value ] unit-test
@ -167,12 +167,19 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
=
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ begin-form ] unit-test
[ ] [
"factor" [
"concatenative" "model" set-value
] nest-values
] nest-form
] unit-test
[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
[
H{
{
"factor"
T{ form f V{ } H{ { "model" "concatenative" } } }
}
}
] [ values ] unit-test

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

@ -1,82 +1,26 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences sequences.lib splitting
mirrors hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
html.elements html.streams xmode.code2html farkup inspector
lcs.diff2html urls present ;
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector
fry locals calendar calendar.format xml.entities
validators urls present
xmode.code2html lcs.diff2html farkup
html.elements html.streams html.forms ;
IN: html.components
SYMBOL: values
: value ( name -- value ) values get at ;
: set-value ( value name -- ) values get set-at ;
: blank-values ( -- ) H{ } clone values set ;
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
: from-object ( object -- )
dup assoc? [ <mirror> ] unless
values get swap update ;
: deposit-values ( destination names -- )
[ dup value ] H{ } map>assoc update ;
: deposit-slots ( destination names -- )
[ <mirror> ] dip deposit-values ;
: with-each-value ( name quot -- )
[ value ] dip '[
[
values [ clone ] change
1+ "index" set-value
"value" set-value
@
] with-scope
] each-index ; inline
: with-each-object ( name quot -- )
[ value ] dip '[
[
blank-values
1+ "index" set-value
from-object
@
] with-scope
] each-index ; inline
SYMBOL: nested-values
: with-values ( name quot -- )
'[
,
[ nested-values [ swap prefix ] change ]
[ value blank-values from-object ]
bi
@
] with-scope ; inline
: nest-values ( name quot -- )
swap [
[
H{ } clone [ values set call ] keep
] with-scope
] dip set-value ; inline
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
over named-validation-messages get at [
[ value>> ] [ message>> ] bi
[ -rot render* ] dip
render-error
] [
prepare-value render*
] if* ;
prepare-value
[
dup validation-error?
[ [ message>> ] [ value>> ] bi ]
[ f swap ]
if
] 2dip
render*
[ render-error ] when* ;
<PRIVATE
@ -200,10 +144,20 @@ M: code render*
[ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
! Farkup component
SINGLETON: farkup
TUPLE: farkup no-follow disable-images ;
: string>boolean ( string -- boolean )
{
{ "true" [ t ] }
{ "false" [ f ] }
} case ;
M: farkup render*
2drop string-lines "\n" join convert-farkup write ;
[
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
[ disable-images>> [ string>boolean disable-images? set ] when* ] bi
drop string-lines "\n" join convert-farkup write
] with-scope ;
! Inspector component
SINGLETON: inspector

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

@ -5,7 +5,7 @@
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators present ;
urls math math.parser combinators present fry ;
IN: html.elements
@ -70,7 +70,7 @@ SYMBOL: html
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
dup <foo> swap [ <foo> write-html ] curry
dup <foo> swap '[ , <foo> write-html ]
(( -- )) html-word ;
: <foo ( str -- <str ) "<" prepend ;
@ -78,7 +78,7 @@ SYMBOL: html
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
<foo dup [ write-html ] curry
<foo dup '[ , write-html ]
(( -- )) html-word ;
: foo> ( str -- foo> ) ">" append ;
@ -93,14 +93,14 @@ SYMBOL: html
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup [ write-html ] curry (( -- )) html-word ;
</foo> dup '[ , write-html ] (( -- )) html-word ;
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
dup <foo/> swap [ <foo/> write-html ] curry
dup <foo/> swap '[ , <foo/> write-html ]
(( -- )) html-word ;
: foo/> ( str -- str/> ) "/>" append ;
@ -134,7 +134,7 @@ SYMBOL: html
: define-attribute-word ( name -- )
dup "=" prepend swap
[ write-attr ] curry (( string -- )) html-word ;
'[ , write-attr ] (( string -- )) html-word ;
! Define some closed HTML tags
[

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

@ -0,0 +1,67 @@
IN: html.forms.tests
USING: kernel sequences tools.test assocs html.forms validators accessors
namespaces ;
: with-validation ( quot -- messages )
[
begin-form
call
] with-scope ; inline
[ 14 ] [
[
"14" [ v-number 13 v-min-value 100 v-max-value ] validate
] with-validation
] unit-test
[ t ] [
[
"140" [ v-number 13 v-min-value 100 v-max-value ] validate
[ validation-error? ]
[ value>> "140" = ]
bi and
] with-validation
] unit-test
TUPLE: person name age ;
person {
{ "name" [ ] }
{ "age" [ v-number 13 v-min-value 100 v-max-value ] }
} define-validators
[ t t ] [
[
{ { "age" "" } }
{ { "age" [ v-required ] } }
validate-values
validation-failed?
"age" value
[ validation-error? ]
[ message>> "required" = ]
bi and
] with-validation
] unit-test
[ H{ { "a" 123 } } f ] [
[
H{
{ "a" "123" }
{ "b" "c" }
{ "c" "d" }
}
H{
{ "a" [ v-integer ] }
} validate-values
values
validation-failed?
] with-validation
] unit-test
[ t "foo" ] [
[
"foo" validation-error
validation-failed?
form get errors>> first
] with-validation
] unit-test

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

@ -0,0 +1,106 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables
mirrors math fry sequences sequences.lib words continuations ;
IN: html.forms
TUPLE: form errors values validation-failed ;
: <form> ( -- form )
form new
V{ } clone >>errors
H{ } clone >>values ;
M: form clone
call-next-method
[ clone ] change-errors
[ clone ] change-values ;
: check-value-name ( name -- name )
dup string? [ "Value name not a string" throw ] unless ;
: values ( -- assoc )
form get values>> ;
: value ( name -- value )
check-value-name values at ;
: set-value ( value name -- )
check-value-name values set-at ;
: begin-form ( -- ) <form> form set ;
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
: from-object ( object -- )
[ values ] [ make-mirror ] bi* update ;
: to-object ( destination names -- )
[ make-mirror ] [ values extract-keys ] bi* update ;
: with-each-value ( name quot -- )
[ value ] dip '[
[
form [ clone ] change
1+ "index" set-value
"value" set-value
@
] with-scope
] each-index ; inline
: with-each-object ( name quot -- )
[ value ] dip '[
[
begin-form
1+ "index" set-value
from-object
@
] with-scope
] each-index ; inline
SYMBOL: nested-forms
: with-form ( name quot -- )
'[
,
[ nested-forms [ swap prefix ] change ]
[ value form set ]
bi
@
] with-scope ; inline
: nest-form ( name quot -- )
swap [
[
<form> form set
call
form get
] with-scope
] dip set-value ; inline
TUPLE: validation-error value message ;
C: <validation-error> validation-error
: validation-error ( message -- )
form get
t >>validation-failed
errors>> push ;
: validation-failed? ( -- ? )
form get validation-failed>> ;
: define-validators ( class validators -- )
>hashtable "validators" set-word-prop ;
: validate ( value quot -- result )
[ <validation-error> ] recover ; inline
: validate-value ( name value quot -- )
validate
dup validation-error? [ form get t >>validation-failed drop ] when
swap set-value ;
: validate-values ( assoc validators -- assoc' )
swap '[ dup , at _ validate-value ] assoc-each ;

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

@ -1,7 +1,7 @@
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
namespaces xml html.components
splitting unicode.categories furnace ;
namespaces xml html.components html.forms
splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
@ -9,13 +9,13 @@ IN: html.templates.chloe.tests
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
blank-values
begin-form
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
blank-values
begin-form
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
@ -69,7 +69,7 @@ IN: html.templates.chloe.tests
] run-template
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ begin-form ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
@ -157,10 +157,10 @@ TUPLE: person first-name last-name ;
] run-template
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ begin-form ] unit-test
[ ] [
H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
<form> H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } >>values "person" set-value
] unit-test
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
@ -170,7 +170,7 @@ TUPLE: person first-name last-name ;
] unit-test
[ ] [
blank-values
begin-form
{ "a" "b" } "choices" set-value
"true" "b" set-value
] unit-test

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

@ -5,6 +5,7 @@ classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
html.forms
html.elements
html.components
html.templates
@ -76,7 +77,7 @@ CHLOE: each [ with-each-value ] (bind-tag) ;
CHLOE: bind-each [ with-each-object ] (bind-tag) ;
CHLOE: bind [ with-values ] (bind-tag) ;
CHLOE: bind [ with-form ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
@ -86,11 +87,10 @@ CHLOE: comment drop ;
CHLOE: call-next-template drop call-next-template ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
":" split1 swap lookup ;
: if-satisfied? ( tag -- ? )
[ "code" optional-attr [ attr>word execute ] [ t ] if* ]
[ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
[ "value" optional-attr [ value ] [ t ] if* ]
bi and ;
@ -98,12 +98,12 @@ CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
CHLOE-SINGLETON: farkup
CHLOE-SINGLETON: inspector
CHLOE-SINGLETON: comparison
CHLOE-SINGLETON: html
CHLOE-SINGLETON: hidden
CHLOE-TUPLE: farkup
CHLOE-TUPLE: field
CHLOE-TUPLE: textarea
CHLOE-TUPLE: password

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

@ -14,7 +14,7 @@ tuple-syntax namespaces urls ;
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
}
] [
"http://www.apple.com/index.html"
@ -27,7 +27,7 @@ tuple-syntax namespaces urls ;
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
}
] [
"https://www.amazon.com/index.html"

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

@ -79,13 +79,9 @@ ERROR: download-failed response body ;
M: download-failed error.
"HTTP download failed:" print nl
[
response>>
write-response-code
write-response-message nl
drop
]
[ body>> write ] bi ;
[ response>> write-response-line nl drop ]
[ body>> write ]
bi ;
: check-response ( response data -- response data )
over code>> success? [ download-failed ] unless ;

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

@ -1,7 +1,8 @@
USING: http tools.test multiline tuple-syntax
io.streams.string io.encodings.utf8 io.encodings.string
kernel arrays splitting sequences
assocs io.sockets db db.sqlite continuations urls hashtables ;
assocs io.sockets db db.sqlite continuations urls hashtables
accessors ;
IN: http.tests
: lf>crlf "\n" split "\r\n" join ;
@ -73,10 +74,21 @@ GET nested HTTP/1.0
;
[ read-request-test-3 [ read-request ] with-string-reader ]
[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ]
[ "Bad request: URL" = ]
must-fail-with
STRING: read-request-test-4
GET /blah HTTP/1.0
Host: "www.amazon.com"
;
[ "www.amazon.com" ]
[
read-request-test-4 lf>crlf [ read-request ] with-string-reader
"host" header
] unit-test
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF-8
@ -117,15 +129,46 @@ read-response-test-1' 1array [
[ t ] [
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
dup parse-cookies unparse-cookies =
dup parse-set-cookie first unparse-set-cookie =
] unit-test
[ t ] [
"a="
dup parse-set-cookie first unparse-set-cookie =
] unit-test
STRING: read-response-test-2
HTTP/1.1 200 Content follows
Set-Cookie: oo="bar; a=b"; httponly=yes; sid=123456
;
[ 2 ] [
read-response-test-2 lf>crlf
[ read-response ] with-string-reader
cookies>> length
] unit-test
STRING: read-response-test-3
HTTP/1.1 200 Content follows
Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes
;
[ 1 ] [
read-response-test-3 lf>crlf
[ read-response ] with-string-reader
cookies>> length
] unit-test
! Live-fire exercise
USING: http.server http.server.static furnace.sessions furnace.alloy
furnace.actions furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
furnace.actions furnace.auth furnace.auth.login furnace.db http.client
io.servers.connection io.files io io.encodings.ascii
accessors namespaces threads
http.server.responses http.server.redirection
http.server.responses http.server.redirection furnace.redirection
http.server.dispatchers db.tuples ;
: add-quit-action
@ -176,7 +219,7 @@ test-db [
[
<dispatcher>
<action> <protected>
<login>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
@ -206,7 +249,7 @@ test-db [
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
<login>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
@ -223,7 +266,8 @@ test-db [
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
USING: html.components html.elements xml xml.utilities validators
USING: html.components html.elements html.forms
xml xml.utilities validators
furnace furnace.flash ;
SYMBOL: a
@ -275,3 +319,7 @@ SYMBOL: a
[ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test

249
extra/http/http.factor
View File

@ -1,16 +1,18 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators math namespaces
assocs sequences splitting sorting sets debugger
assocs assocs.lib sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
io io.encodings.iana io.encodings.binary io.encodings.8-bit
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit
unicode.case unicode.categories qualified
urls html.templates xml xml.data xml.writer ;
urls html.templates xml xml.data xml.writer
http.parsers ;
EXCLUDE: fry => , ;
@ -18,40 +20,20 @@ IN: http
: crlf ( -- ) "\r\n" write ;
: add-header ( value key assoc -- )
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
: header-line ( line -- )
dup first blank? [
[ blank? ] left-trim
"last-header" get
"header" get
add-header
] [
":" split1 dup [
[ blank? ] left-trim
swap >lower dup "last-header" set
"header" get add-header
] [
2drop
] if
] if ;
: read-lf ( -- bytes )
"\n" read-until CHAR: \n assert= ;
: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: (read-header) ( -- )
read-crlf dup
empty? [ drop ] [ header-line (read-header) ] if ;
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
: process-header ( alist -- assoc )
f swap [ [ swap or dup ] dip swap ] assoc-map nip
[ ?push ] histogram [ "; " join ] assoc-map
>hashtable ;
: read-header ( -- assoc )
H{ } clone [
"header" [ (read-header) ] with-variable
] keep ;
(read-header) process-header ;
: header-value>string ( value -- string )
{
@ -62,69 +44,100 @@ IN: http
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
dup "\r\n" intersect empty?
dup "\r\n\"" intersect empty?
[ "Header injection attack" throw ] unless ;
: write-header ( assoc -- )
>alist sort-keys [
swap
check-header-string write ": " write
header-value>string check-header-string write crlf
[ check-header-string write ": " write ]
[ header-value>string check-header-string write crlf ] bi*
] assoc-each crlf ;
TUPLE: cookie name value path domain expires max-age http-only ;
TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
: <cookie> ( value name -- cookie )
cookie new
swap >>name
swap >>value ;
: parse-cookies ( string -- seq )
: parse-set-cookie ( string -- seq )
[
f swap
";" split [
[ blank? ] trim "=" split1 swap >lower {
(parse-set-cookie)
[
swap {
{ "version" [ >>version ] }
{ "comment" [ >>comment ] }
{ "expires" [ cookie-string>timestamp >>expires ] }
{ "max-age" [ string>number seconds >>max-age ] }
{ "domain" [ >>domain ] }
{ "path" [ >>path ] }
{ "httponly" [ drop t >>http-only ] }
{ "" [ drop ] }
{ "secure" [ drop t >>secure ] }
[ <cookie> dup , nip ]
} case
] each
] assoc-each
drop
] { } make ;
: (unparse-cookie) ( key value -- )
: parse-cookie ( string -- seq )
[
f swap
(parse-cookie)
[
swap {
{ "$version" [ >>version ] }
{ "$domain" [ >>domain ] }
{ "$path" [ >>path ] }
[ <cookie> dup , nip ]
} case
] assoc-each
drop
] { } make ;
: check-cookie-string ( string -- string' )
dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
: unparse-cookie-value ( key value -- )
{
{ f [ drop ] }
{ t [ , ] }
{ t [ check-cookie-string , ] }
[
{
{ [ dup timestamp? ] [ timestamp>cookie-string ] }
{ [ dup duration? ] [ dt>seconds number>string ] }
{ [ dup real? ] [ number>string ] }
[ ]
} cond
"=" swap 3append ,
check-cookie-string "=" swap check-cookie-string 3append ,
]
} case ;
: unparse-cookie ( cookie -- strings )
: (unparse-cookie) ( cookie -- strings )
[
dup name>> >lower over value>> (unparse-cookie)
"path" over path>> (unparse-cookie)
"domain" over domain>> (unparse-cookie)
"expires" over expires>> (unparse-cookie)
"max-age" over max-age>> (unparse-cookie)
"httponly" over http-only>> (unparse-cookie)
dup name>> check-cookie-string >lower
over value>> unparse-cookie-value
"$path" over path>> unparse-cookie-value
"$domain" over domain>> unparse-cookie-value
drop
] { } make ;
: unparse-cookies ( cookies -- string )
[ unparse-cookie ] map concat "; " join ;
: unparse-cookie ( cookies -- string )
[ (unparse-cookie) ] map concat "; " join ;
: unparse-set-cookie ( cookie -- string )
[
dup name>> check-cookie-string >lower
over value>> unparse-cookie-value
"path" over path>> unparse-cookie-value
"domain" over domain>> unparse-cookie-value
"expires" over expires>> unparse-cookie-value
"max-age" over max-age>> unparse-cookie-value
"httponly" over http-only>> unparse-cookie-value
"secure" over secure>> unparse-cookie-value
drop
] { } make "; " join ;
TUPLE: request
method
@ -134,6 +147,13 @@ header
post-data
cookies ;
: check-url ( string -- url )
>url dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
: read-request-line ( request -- request )
read-crlf parse-request-line first3
[ >>method ] [ check-url >>url ] [ >>version ] tri* ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
@ -146,29 +166,11 @@ cookies ;
H{ } clone >>header
V{ } clone >>cookies
"close" "connection" set-header
"Factor http.client vocabulary" "user-agent" set-header ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
>>method ;
"Factor http.client" "user-agent" set-header ;
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
: read-url ( request -- request )
" " read-until [
dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
] [ "Bad request: URL" throw ] if ;
: parse-version ( string -- version )
"HTTP/" ?head [ "Bad request: version" throw ] unless
dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
: read-request-version ( request -- request )
read-crlf [ CHAR: \s = ] left-trim
parse-version
>>version ;
: read-request-header ( request -- request )
read-header >>header ;
@ -203,7 +205,7 @@ TUPLE: post-data raw content content-type ;
drop ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
dup "cookie" header [ parse-cookie >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
@ -213,22 +215,18 @@ TUPLE: post-data raw content content-type ;
: read-request ( -- request )
<request>
read-method
read-url
read-request-version
read-request-line
read-request-header
read-post-data
extract-host
extract-cookies ;
: write-method ( request -- request )
dup method>> write bl ;
: write-request-url ( request -- request )
dup url>> relative-url present write bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
: write-request-line ( request -- request )
dup
[ method>> write bl ]
[ url>> relative-url present write bl ]
[ "HTTP/" write version>> write crlf ]
tri ;
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
@ -242,7 +240,7 @@ TUPLE: post-data raw content content-type ;
[ content-type>> "content-type" pick set-at ]
bi
] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
write-header ;
GENERIC: >post-data ( object -- post-data )
@ -267,9 +265,7 @@ M: f >post-data ;
: write-request ( request -- )
unparse-post-data
write-method
write-request-url
write-version
write-request-line
write-request-header
write-post-data
flush
@ -295,26 +291,22 @@ body ;
H{ } clone >>header
"close" "connection" set-header
now timestamp>http-string "date" set-header
"Factor http.server" "server" set-header
latin1 >>content-charset
V{ } clone >>cookies ;
: read-response-version ( response -- response )
" \t" read-until
[ "Bad response: version" throw ] unless
parse-version
>>version ;
M: response clone
call-next-method
[ clone ] change-header
[ clone ] change-cookies ;
: read-response-code ( response -- response )
" \t" read-until [ "Bad response: code" throw ] unless
string>number [ "Bad response: code" throw ] unless*
>>code ;
: read-response-message ( response -- response )
read-crlf >>message ;
: read-response-line ( response -- response )
read-crlf parse-response-line first3
[ >>version ] [ >>code ] [ >>message ] tri* ;
: read-response-header ( response -- response )
read-header >>header
dup "set-cookie" header parse-cookies >>cookies
dup "set-cookie" header parse-set-cookie >>cookies
dup "content-type" header [
parse-content-type
[ >>content-type ]
@ -323,20 +315,15 @@ body ;
: read-response ( -- response )
<response>
read-response-version
read-response-code
read-response-message
read-response-line
read-response-header ;
: write-response-version ( response -- response )
"HTTP/" write
dup version>> write bl ;
: write-response-code ( response -- response )
dup code>> number>string write bl ;
: write-response-message ( response -- response )
dup message>> write crlf ;
: write-response-line ( response -- response )
dup
[ "HTTP/" write version>> write bl ]
[ code>> present write bl ]
[ message>> write crlf ]
tri ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
@ -344,26 +331,40 @@ body ;
bi
[ "; charset=" swap 3append ] when* ;
: ensure-domain ( cookie -- cookie )
[
request get url>>
host>> dup "localhost" =
[ drop ] [ or ] if
] change-domain ;
: write-response-header ( response -- response )
dup header>> clone
over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
#! We send one set-cookie header per cookie, because that's
#! what Firefox expects.
dup header>> >alist >vector
over unparse-content-type "content-type" pick set-at
over cookies>> [
ensure-domain unparse-set-cookie
"set-cookie" swap 2array over push
] each
write-header ;
: write-response-body ( response -- response )
dup body>> call-template ;
M: response write-response ( respose -- )
write-response-version
write-response-code
write-response-message
write-response-line
write-response-header
flush
drop ;
M: response write-full-response ( request response -- )
dup write-response
swap method>> "HEAD" = [ write-response-body ] unless ;
swap method>> "HEAD" = [
[ content-charset>> encode-output ]
[ write-response-body ]
bi
] unless ;
: get-cookie ( request/response name -- cookie/f )
[ cookies>> ] dip '[ , _ name>> = ] find nip ;
@ -386,9 +387,7 @@ body ;
"1.1" >>version ;
M: raw-response write-response ( respose -- )
write-response-version
write-response-code
write-response-message
write-response-line
write-response-body
drop ;

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

@ -0,0 +1,166 @@
USING: math math.order math.parser kernel combinators.lib
sequences sequences.deep peg peg.parsers assocs arrays
hashtables strings unicode.case namespaces ascii ;
IN: http.parsers
: except ( quot -- parser )
[ not ] compose satisfy ; inline
: except-these ( quots -- parser )
[ 1|| ] curry except ; inline
: ctl? ( ch -- ? )
{ [ 0 31 between? ] [ 127 = ] } 1|| ;
: tspecial? ( ch -- ? )
"()<>@,;:\\\"/[]?={} \t" member? ;
: 'token' ( -- parser )
{ [ ctl? ] [ tspecial? ] } except-these repeat1 ;
: case-insensitive ( parser -- parser' )
[ flatten >string >lower ] action ;
: case-sensitive ( parser -- parser' )
[ flatten >string ] action ;
: 'space' ( -- parser )
[ " \t" member? ] satisfy repeat0 hide ;
: one-of ( strings -- parser )
[ token ] map choice ;
: 'http-method' ( -- parser )
{ "OPTIONS" "GET" "HEAD" "POST" "PUT" "DELETE" "TRACE" "CONNECT" } one-of ;
: 'url' ( -- parser )
[ " \t\r\n" member? ] except repeat1 case-sensitive ;
: 'http-version' ( -- parser )
[
"HTTP" token hide ,
'space' ,
"/" token hide ,
'space' ,
"1" token ,
"." token ,
{ "0" "1" } one-of ,
] seq* [ concat >string ] action ;
PEG: parse-request-line ( string -- triple )
#! Triple is { method url version }
[
'space' ,
'http-method' ,
'space' ,
'url' ,
'space' ,
'http-version' ,
'space' ,
] seq* just ;
: 'text' ( -- parser )
[ ctl? ] except ;
: 'response-code' ( -- parser )
[ digit? ] satisfy 3 exactly-n [ string>number ] action ;
: 'response-message' ( -- parser )
'text' repeat0 case-sensitive ;
PEG: parse-response-line ( string -- triple )
#! Triple is { version code message }
[
'space' ,
'http-version' ,
'space' ,
'response-code' ,
'space' ,
'response-message' ,
] seq* just ;
: 'crlf' ( -- parser )
"\r\n" token ;
: 'lws' ( -- parser )
[ " \t" member? ] satisfy repeat1 ;
: 'qdtext' ( -- parser )
{ [ CHAR: " = ] [ ctl? ] } except-these ;
: 'quoted-char' ( -- parser )
"\\" token hide any-char 2seq ;
: 'quoted-string' ( -- parser )
'quoted-char' 'qdtext' 2choice repeat0 "\"" "\"" surrounded-by ;
: 'ctext' ( -- parser )
{ [ ctl? ] [ "()" member? ] } except-these ;
: 'comment' ( -- parser )
'ctext' 'comment' 2choice repeat0 "(" ")" surrounded-by ;
: 'field-name' ( -- parser )
'token' case-insensitive ;
: 'field-content' ( -- parser )
'quoted-string' case-sensitive
'text' repeat0 case-sensitive
2choice ;
PEG: parse-header-line ( string -- pair )
#! Pair is either { name value } or { f value }. If f, its a
#! continuation of the previous header line.
[
'field-name' ,
'space' ,
":" token hide ,
'space' ,
'field-content' ,
] seq*
[
'lws' [ drop f ] action ,
'field-content' ,
] seq*
2choice ;
: 'word' ( -- parser )
'token' 'quoted-string' 2choice ;
: 'value' ( -- parser )
'quoted-string'
[ ";" member? ] except repeat0
2choice case-sensitive ;
: 'attr' ( -- parser )
'token' case-insensitive ;
: 'av-pair' ( -- parser )
[
'space' ,
'attr' ,
'space' ,
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action
epsilon [ drop f ] action
2choice ,
'space' ,
] seq* ;
: 'av-pairs' ( -- parser )
'av-pair' ";" token list-of optional ;
PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
: 'cookie-value' ( -- parser )
[
'space' ,
'attr' ,
'space' ,
"=" token hide ,
'space' ,
'value' ,
'space' ,
] seq* ;
PEG: (parse-cookie) ( string -- alist )
'cookie-value' [ ";," member? ] satisfy list-of optional just ;

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

@ -2,9 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
combinators tools.vocabs math
combinators tools.vocabs tools.time math
io
io.server
io.sockets
io.sockets.secure
io.encodings
@ -12,8 +11,9 @@ io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.servers.connection
io.timeouts
fry logging calendar urls
fry logging logging.insomniac calendar urls
http
http.server.responses
html.elements
@ -26,7 +26,9 @@ SYMBOL: responder-nesting
SYMBOL: main-responder
SYMBOL: development-mode
SYMBOL: development?
SYMBOL: benchmark?
! path is a sequence of path component strings
GENERIC: call-responder* ( path responder -- response )
@ -55,32 +57,31 @@ main-responder global [ <404> <trivial-responder> or ] change-at
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
[ write-response ]
[ request get swap write-full-response ]
[
request get method>> "HEAD" = [ drop ] [
'[
,
[ content-charset>> encode-output ]
[ write-response-body ]
bi
]
[
utf8 [
development-mode get
[ http-error. ] [ drop "Response error" rethrow ] if
] with-encoded-output
] recover
] if
] bi ;
[ \ do-response log-error ]
[
utf8 [
development? get
[ http-error. ] [ drop "Response error" write ] if
] with-encoded-output
] bi
] recover ;
LOG: httpd-hit NOTICE
LOG: httpd-header NOTICE
: log-header ( headers name -- )
tuck header 2array httpd-header ;
: log-request ( request -- )
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi
3array httpd-hit ;
[ [ method>> ] [ url>> ] bi 2array httpd-hit ]
[ { "user-agent" "x-forwarded-for" } [ log-header ] with each ]
bi ;
: split-path ( string -- path )
"/" split harvest ;
@ -115,29 +116,39 @@ LOG: httpd-hit NOTICE
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
development-mode get-global
[ global [ refresh-all ] bind ] when ;
development? get-global [ global [ refresh-all ] bind ] when ;
: setup-limits ( -- )
1 minutes timeouts
64 1024 * limit-input ;
LOG: httpd-benchmark DEBUG
: handle-client ( -- )
: ?benchmark ( quot -- )
benchmark? get [
[ benchmark ] [ first ] bi request get url>> rot 3array
httpd-benchmark
] [ call ] if ; inline
TUPLE: http-server < threaded-server ;
M: http-server handle-client*
drop
[
setup-limits
ascii decode-input
ascii encode-output
64 1024 * limit-input
?refresh-all
read-request
do-request
do-response
[ do-request ] ?benchmark
[ do-response ] ?benchmark
] with-destructors ;
: <http-server> ( -- server )
http-server new-threaded-server
"http.server" >>name
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
: httpd ( port -- )
dup integer? [ internet-server ] when
"http.server" binary [ handle-client ] with-server ;
<http-server>
swap >>insecure
f >>secure
start-server ;
: httpd-main ( -- )
8888 httpd ;
MAIN: httpd-main
: http-insomniac ( -- )
"http.server" { "httpd-hit" } schedule-insomniac ;

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

@ -82,7 +82,7 @@ TUPLE: file-responder root hook special allow-listings ;
"index.html" append-path dup exists? [ drop f ] unless ;
: serve-directory ( filename -- response )
request get path>> "/" tail? [
request get url>> path>> "/" tail? [
dup
find-index [ serve-file ] [ list-directory ] ?if
] [

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

@ -5,12 +5,11 @@ IN: io.encodings.ascii
<PRIVATE
: encode-if< ( char stream encoding max -- )
nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
: decode-if< ( stream encoding max -- character )
nip swap stream-read1
[ tuck > [ drop replacement-char ] unless ]
[ drop f ] if* ;
nip swap stream-read1 dup
[ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii

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

@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.ports ;
io.streams.duplex io.ports debugger prettyprint inspector ;
IN: io.launcher
TUPLE: process < identity-tuple
@ -131,11 +131,16 @@ HOOK: run-process* io-backend ( process -- handle )
run-detached
dup detached>> [ dup wait-for-process drop ] unless ;
ERROR: process-failed code ;
ERROR: process-failed process code ;
M: process-failed error.
dup "Process exited with error code " write code>> . nl
"Launch descriptor:" print nl
process>> describe ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
[ drop ] [ process-failed ] if ;
run-process dup wait-for-process dup zero?
[ 2drop ] [ process-failed ] if ;
HOOK: kill-process* io-backend ( handle -- )

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

@ -64,7 +64,3 @@ HELP: (wait-to-read)
HELP: wait-to-read
{ $values { "port" input-port } { "eof?" "a boolean" } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ;
HELP: can-write?
{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;

6
extra/io/ports/ports.factor
View File

@ -98,11 +98,9 @@ TUPLE: output-port < buffered-port ;
: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
: can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ;
: wait-to-write ( len port -- )
tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
tuck buffer>> buffer-capacity <=
[ drop ] [ stream-flush ] if ;
M: output-port stream-write1
dup check-disposed

10
extra/io/server/server-docs.factor
View File

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

7
extra/io/server/server-tests.factor
View File

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

76
extra/io/server/server.factor
View File

@ -1,76 +0,0 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.sockets io.sockets.secure io.files
io.streams.duplex logging continuations destructors kernel math
math.parser namespaces parser sequences strings prettyprint
debugger quotations calendar threads concurrency.combinators
assocs fry accessors ;
IN: io.server
SYMBOL: servers
SYMBOL: remote-address
<PRIVATE
LOG: accepted-connection NOTICE
: with-connection ( client remote local quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi
, local-address set
@
] with-stream ; inline
\ with-connection DEBUG add-error-logging
: accept-loop ( server quot -- )
[
[ [ accept ] [ addr>> ] bi ] dip
'[ , , , , with-connection ] "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )
>r <server> dup servers get push r>
'[ , accept-loop ] with-disposal ; inline
\ server-loop NOTICE add-error-logging
PRIVATE>
: local-server ( port -- seq )
"localhost" swap t resolve-host ;
: internet-server ( port -- seq )
f swap t resolve-host ;
: secure-server ( port -- seq )
internet-server [ <secure> ] map ;
: with-server ( seq service encoding quot -- )
V{ } clone servers [
'[ , [ , , server-loop ] with-logging ] parallel-each
] with-variable ; inline
: stop-server ( -- )
servers get dispose-each ;
<PRIVATE
LOG: received-datagram NOTICE
: datagram-loop ( quot datagram -- )
[
[ receive dup received-datagram [ swap call ] dip ] keep
pick [ send ] [ 3drop ] if
] 2keep datagram-loop ; inline
: spawn-datagrams ( quot addrspec -- )
<datagram> [ datagram-loop ] with-disposal ; inline
\ spawn-datagrams NOTICE add-input-logging
PRIVATE>
: with-datagrams ( seq service quot -- )
'[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline

1
extra/io/server/summary.txt
View File

@ -1 +0,0 @@
TCP/IP and UDP/IP servers

0
extra/eval-server/authors.txt → extra/io/servers/connection/authors.txt
View File

2
extra/io/servers/connection/connection-docs.factor Executable file
View File

@ -0,0 +1,2 @@
USING: help help.syntax help.markup io ;
IN: io.servers.connection

47
extra/io/servers/connection/connection-tests.factor Executable file
View File

@ -0,0 +1,47 @@
IN: io.servers.connection
USING: tools.test io.servers.connection io.sockets namespaces
io.servers.connection.private kernel accessors sequences
concurrency.promises io.encodings.ascii io threads calendar ;
[ t ] [ <threaded-server> listen-on empty? ] unit-test
[ f ] [
<threaded-server>
25 internet-server >>insecure
listen-on
empty?
] unit-test
[ t ] [
T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
[ log-connection ] 2keep
[ remote-address get = ] [ local-address get = ] bi*
and
] unit-test
[ ] [ <threaded-server> init-server drop ] unit-test
[ 10 ] [
<threaded-server>
10 >>max-connections
init-server semaphore>> count>>
] unit-test
[ ] [ <promise> "p" set ] unit-test
[ ] [
[
<threaded-server>
5 >>max-connections
1237 >>insecure
[ "Hello world." write stop-server ] >>handler
start-server
t "p" get fulfill
] in-thread
] unit-test
[ ] [ 100 sleep ] unit-test
[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test

131
extra/io/servers/connection/connection.factor Executable file
View File

@ -0,0 +1,131 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint debugger
quotations combinators combinators.lib logging calendar assocs
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads concurrency.combinators
concurrency.semaphores ;
IN: io.servers.connection
TUPLE: threaded-server
name
secure insecure
secure-config
sockets
max-connections
semaphore
timeout
encoding
handler ;
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
: internet-server ( port -- addrspec ) f swap <inet> ;
: new-threaded-server ( class -- threaded-server )
new
"server" >>name
ascii >>encoding
1 minutes >>timeout
V{ } clone >>sockets
<secure-config> >>secure-config
[ "No handler quotation" throw ] >>handler ; inline
: <threaded-server> ( -- threaded-server )
threaded-server new-threaded-server ;
SYMBOL: remote-address
GENERIC: handle-client* ( server -- )
<PRIVATE
: >insecure ( addrspec -- addrspec' )
dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
: >secure ( addrspec -- addrspec' )
>insecure
dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
: listen-on ( threaded-server -- addrspecs )
[ secure>> >secure ] [ insecure>> >insecure ] bi
[ resolve-host ] bi@ append ;
LOG: accepted-connection NOTICE
: log-connection ( remote local -- )
[ [ remote-address set ] [ local-address set ] bi* ]
[ 2array accepted-connection ]
2bi ;
M: threaded-server handle-client* handler>> call ;
: handle-client ( client remote local -- )
'[
, , log-connection
threaded-server get
[ timeout>> timeouts ] [ handle-client* ] bi
] with-stream ;
: thread-name ( server-name addrspec -- string )
unparse " connection from " swap 3append ;
: accept-connection ( server -- )
[ accept ] [ addr>> ] bi
[ '[ , , , handle-client ] ]
[ drop threaded-server get name>> swap thread-name ] 2bi
spawn drop ;
: accept-loop ( server -- )
[
threaded-server get semaphore>>
[ [ accept-connection ] with-semaphore ]
[ accept-connection ]
if*
] [ accept-loop ] bi ; inline
: start-accept-loop ( server -- )
threaded-server get encoding>> <server>
[ threaded-server get sockets>> push ]
[ [ accept-loop ] with-disposal ]
bi ;
\ start-accept-loop ERROR add-error-logging
: init-server ( threaded-server -- threaded-server )
dup semaphore>> [
dup max-connections>> [
<semaphore> >>semaphore
] when*
] unless ;
PRIVATE>
: start-server ( threaded-server -- )
init-server
dup secure-config>> [
dup threaded-server [
dup name>> [
listen-on [
start-accept-loop
] parallel-each
] with-logging
] with-variable
] with-secure-context ;
: stop-server ( -- )
threaded-server get [ f ] change-sockets drop dispose-each ;
GENERIC: port ( addrspec -- n )
M: integer port ;
M: object port port>> ;
: secure-port ( -- n )
threaded-server get dup [ secure>> port ] when ;
: insecure-port ( -- n )
threaded-server get dup [ insecure>> port ] when ;

1
extra/io/servers/connection/summary.txt Normal file
View File

@ -0,0 +1 @@
Multi-threaded TCP/IP servers

0
extra/io/server/tags.txt → extra/io/servers/connection/tags.txt
View File

0
extra/io/server/authors.txt → extra/io/servers/packet/authors.txt
View File

21
extra/io/servers/packet/datagram.factor Normal file
View File

@ -0,0 +1,21 @@
IN: io.servers.datagram
<PRIVATE
LOG: received-datagram NOTICE
: datagram-loop ( quot datagram -- )
[
[ receive dup received-datagram [ swap call ] dip ] keep
pick [ send ] [ 3drop ] if
] 2keep datagram-loop ; inline
: spawn-datagrams ( quot addrspec -- )
<datagram> [ datagram-loop ] with-disposal ; inline
\ spawn-datagrams NOTICE add-input-logging
PRIVATE>
: with-datagrams ( seq service quot -- )
'[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline

1
extra/io/servers/packet/summary.txt Normal file
View File

@ -0,0 +1 @@
Multi-threaded UDP/IP servers

1
extra/io/servers/packet/tags.txt Normal file
View File

@ -0,0 +1 @@
network

5
extra/io/sockets/secure/secure-tests.factor
View File

@ -1 +1,4 @@
! No unit tests here, until Windows SSL is implemented
IN: io.sockets.secure.tests
USING: accessors kernel io.sockets io.sockets.secure tools.test ;
[ "hello" 24 ] [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test

13
extra/io/sockets/secure/secure.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences inspector calendar ;
destructors io.sockets sequences inspector calendar delegate ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
@ -42,8 +42,10 @@ TUPLE: secure addrspec ;
C: <secure> secure
: resolve-secure-host ( host port passive? -- seq )
resolve-host [ <secure> ] map ;
CONSULT: inet secure addrspec>> ;
M: secure resolve-host ( secure -- seq )
addrspec>> resolve-host [ <secure> ] map ;
HOOK: check-certificate secure-socket-backend ( host handle -- )
@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ;
M: secure-inet (client)
[
addrspec>>
[ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
host>> pick handle>> check-certificate
[ resolve-host (client) [ |dispose ] dip ] keep
addrspec>> host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE>

20
extra/io/sockets/sockets-docs.factor
View File

@ -27,7 +27,7 @@ $nl
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
}
"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link <server> } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
{ $see-also "io.sockets.secure" } ;
ARTICLE: "network-packet" "Packet-oriented networking"
@ -79,7 +79,7 @@ HELP: inet
HELP: inet4
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <inet4> } "." }
{ $notes
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
}
{ $examples
{ $code "\"127.0.0.1\" 8080 <inet4>" }
@ -88,7 +88,7 @@ HELP: inet4
HELP: inet6
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <inet6> } "." }
{ $notes
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." }
{ $examples
{ $code "\"::1\" 8080 <inet6>" }
} ;
@ -118,10 +118,10 @@ HELP: <server>
}
{ $notes
"To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
{ $code "f 1234 t resolve-host" }
{ $code "f 1234 <inet> resolve-host" }
"To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
{ $code "\"localhost\" 1234 t resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
{ $code "\"localhost\" 1234 <inet> resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this."
$nl
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
{ $unchecked-example
@ -148,9 +148,9 @@ HELP: <datagram>
}
{ $notes
"To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
{ $code "f 1234 t resolve-host" }
{ $code "f 1234 <inet> resolve-host" }
"To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
{ $code "\"localhost\" 1234 t resolve-host" }
{ $code "\"localhost\" 1234 <inet> resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
"Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
}
@ -165,3 +165,7 @@ HELP: send
{ $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } }
{ $description "Sends a packet to the given address." }
{ $errors "Throws an error if the packet could not be sent." } ;
HELP: resolve-host
{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
{ $description "Resolves host names to IP addresses." } ;

2
extra/io/sockets/sockets-tests.factor
View File

@ -45,7 +45,7 @@ concurrency.promises threads io.streams.string ;
[ "1:2:0:0:0:0:3:4" ]
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
[ t ] [ "localhost" 80 <inet> resolve-host length 1 >= ] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test

27
extra/io/sockets/sockets.factor
View File

@ -259,20 +259,26 @@ HOOK: (send) io-backend ( packet addrspec datagram -- )
[ addrinfo>addrspec ] map
sift ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
: prepare-resolve-host ( addrspec -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
>r
dup integer? [ port-override set "http" ] when
r> AI_PASSIVE 0 ? ;
[ host>> ]
[ port>> dup integer? [ port-override set "http" ] when ] bi
over 0 AI_PASSIVE ? ;
HOOK: addrinfo-error io-backend ( n -- )
: resolve-host ( host serv passive? -- seq )
GENERIC: resolve-host ( addrspec -- seq )
TUPLE: inet host port ;
C: <inet> inet
M: inet resolve-host
[
prepare-resolve-host
"addrinfo" <c-object>
@ -284,17 +290,16 @@ HOOK: addrinfo-error io-backend ( n -- )
freeaddrinfo
] with-scope ;
M: f resolve-host drop { } ;
M: object resolve-host 1array ;
: host-name ( -- string )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;
TUPLE: inet host port ;
C: <inet> inet
M: inet (client)
[ host>> ] [ port>> ] bi f resolve-host (client) ;
M: inet (client) resolve-host (client) ;
ERROR: invalid-inet-server addrspec ;

8
extra/io/streams/limited/limited-tests.factor
View File

@ -30,3 +30,11 @@ namespaces tools.test strings kernel ;
[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
[ "he" CHAR: l ] [
B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
ascii <byte-reader> [
5 limit-input
"l" read-until
] with-input-stream
] unit-test

13
extra/io/streams/limited/limited.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io destructors accessors sequences
namespaces ;
USING: kernel math io io.encodings destructors accessors
sequences namespaces ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit ;
@ -12,8 +12,13 @@ TUPLE: limited-stream stream count limit ;
swap >>stream
0 >>count ;
: limit-input ( limit -- )
input-stream [ swap <limited-stream> ] change ;
GENERIC# limit 1 ( stream limit -- stream' )
M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
M: object limit <limited-stream> ;
: limit-input ( limit -- ) input-stream [ swap limit ] change ;
ERROR: limit-exceeded ;

2
extra/io/unix/launcher/launcher.factor
View File

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

6
extra/io/unix/sockets/secure/secure-tests.factor
View File

@ -9,12 +9,12 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
[ ] [ <promise> "port" set ] unit-test
: with-test-context
: with-test-context ( quot -- )
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >>password
swap with-secure-context ;
swap with-secure-context ; inline
:: server-test ( quot -- )
[
@ -28,7 +28,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
] with-test-context
] "SSL server test" spawn drop ;
: client-test
: client-test ( -- string )
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context ;

24
extra/io/unix/sockets/secure/secure.factor
View File

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

8
extra/logging/logging.factor
View File

@ -42,11 +42,9 @@ SYMBOL: log-service
<PRIVATE
PREDICATE: one-string-array < array
[ length 1 = ] [ [ string? ] all? ] bi and ;
: stack>message ( obj -- inputs>message )
dup one-string-array? [ first ] [
dup array? [ dup length 1 = [ first ] when ] when
dup string? [
[
string-limit off
1 line-limit set
@ -54,7 +52,7 @@ PREDICATE: one-string-array < array
0 margin set
unparse
] with-scope
] if ;
] unless ;
PRIVATE>

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