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

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

db4
Eduardo Cavazos 2008-06-19 19:12:16 -05:00
parent d5b56fc5bc ebb3423e4a
commit 482f1d4c36
72 changed files with 982 additions and 467 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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 ;

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

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 ;

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 ;

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

@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
destructors combinators
destructors combinators fry
io.encodings.utf8 io.encodings.string io.binary random
checksums checksums.sha2
html.forms
@ -10,6 +10,7 @@ http.server.filters
http.server.dispatchers
furnace
furnace.actions
furnace.redirection
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db ;
@ -54,7 +55,7 @@ V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get adjoin ;
TUPLE: realm < dispatcher name users checksum ;
TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( realm -- response )
@ -67,7 +68,8 @@ GENERIC: logged-in-username ( realm -- username )
swap >>name
swap >>default
users-in-db >>users
sha-256 >>checksum ; inline
sha-256 >>checksum
t >>secure ; inline
: users ( -- provider )
realm get users>> ;
@ -104,6 +106,16 @@ M: realm call-responder* ( path responder -- response )
: 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 )
@ -118,9 +130,12 @@ TUPLE: protected < filter-responder description capabilities ;
} 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 ;
'[
, ,
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 ;

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

3
extra/furnace/auth/features/edit-profile/edit-profile.xml
View File

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

2
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/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>

33
extra/furnace/auth/features/recover-password/recover-password.factor
View File

@ -1,9 +1,11 @@
! 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
http http.server.responses http.server.dispatchers
furnace furnace.actions furnace.auth furnace.auth.providers ;
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
@ -12,13 +14,12 @@ SYMBOL: lost-password-from
request get url>> host>> host-name or ;
: new-password-url ( user -- url )
"recover-3"
swap [
[ username>> "username" set ]
[ ticket>> "ticket" set ]
URL" recover-3" clone
swap
[ username>> "username" set-query-param ]
[ ticket>> "ticket" set-query-param ]
bi
] H{ } make-assoc
derive-url ;
adjust-url relative-to-request ;
: password-email ( user -- email )
<email>
@ -34,7 +35,7 @@ SYMBOL: lost-password-from
"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 %
swap new-password-url present %
"\n\n" %
"Love,\n" %
"\n" %
@ -47,7 +48,7 @@ SYMBOL: lost-password-from
: <recover-action-1> ( -- action )
<page-action>
{ realm "recover-1" } >>template
{ realm "features/recover-password/recover-1" } >>template
[
{
@ -63,12 +64,12 @@ SYMBOL: lost-password-from
send-password-email
] when*
URL" $login/recover-2" <redirect>
URL" $realm/recover-2" <redirect>
] >>submit ;
: <recover-action-2> ( -- action )
<page-action>
{ realm "recover-2" } >>template ;
{ realm "features/recover-password/recover-2" } >>template ;
: <recover-action-3> ( -- action )
<page-action>
@ -79,7 +80,7 @@ SYMBOL: lost-password-from
} validate-params
] >>init
{ realm "recover-3" } >>template
{ realm "features/recover-password/recover-3" } >>template
[
{
@ -99,7 +100,7 @@ SYMBOL: lost-password-from
"new-password" value >>encoded-password
users update-user
URL" $login/recover-4" <redirect>
URL" $realm/recover-4" <redirect>
] [
<403>
] if*
@ -107,7 +108,7 @@ SYMBOL: lost-password-from
: <recover-action-4> ( -- action )
<page-action>
{ realm "recover-4" } >>template ;
{ realm "features/recover-password/recover-4" } >>template ;
: allow-password-recovery ( login -- login )
<recover-action-1> <auth-boilerplate>

8
extra/furnace/auth/features/registration/registration.factor
View File

@ -2,7 +2,8 @@
! 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 furnace.auth furnace.auth.providers furnace.actions
furnace.redirection ;
IN: furnace.auth.features.registration
: <register-action> ( -- action )
@ -34,10 +35,11 @@ IN: furnace.auth.features.registration
realm get init-user-profile
URL" $realm" <redirect>
] >>submit ;
] >>submit
<auth-boilerplate> ;
: allow-registration ( login -- login )
<register-action> <auth-boilerplate> "register" add-responder ;
<register-action> "register" add-responder ;
: allow-registration? ( -- ? )
realm get responders>> "register" swap key? ;

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

@ -10,6 +10,7 @@ furnace.asides
furnace.actions
furnace.sessions
furnace.utilities
furnace.redirection
furnace.auth.login.permits ;
IN: furnace.auth.login
@ -38,8 +39,11 @@ M: login-realm modify-form ( responder -- )
: <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
realm get domain>> >>domain ;
realm get
[ timeout>> from-now >>expires ]
[ domain>> >>domain ]
[ secure>> >>secure ]
tri ;
: put-permit-cookie ( response -- response' )
<permit-cookie> put-cookie ;
@ -81,7 +85,9 @@ SYMBOL: capabilities
"password" value
"username" value check-login
[ successful-login ] [ login-failed ] if*
] >>submit ;
] >>submit
<auth-boilerplate>
<secure-realm-only> ;
: <logout-action> ( -- action )
<action>
@ -94,10 +100,10 @@ M: login-realm login-required*
begin-aside
protected get description>> description set
protected get capabilities>> capabilities set
URL" $realm/login" flashed-variables <flash-redirect> ;
URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;
: <login-realm> ( responder name -- auth )
login-realm new-realm
<login-action> <auth-boilerplate> "login" add-responder
<login-action> "login" add-responder
<logout-action> "logout" add-responder
20 minutes >>timeout ;

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

@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces
USING: accessors kernel math.order namespaces combinators.lib
html.forms
html.templates
html.templates.chloe
@ -17,6 +17,12 @@ TUPLE: boilerplate < filter-responder template init ;
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

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

7
extra/furnace/furnace.factor
View File

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

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 ;

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

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

@ -1,8 +1,9 @@
! 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 combinators.lib 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
@ -109,7 +110,7 @@ M: session-saver dispose
: request-session ( -- session/f )
session-id-key
client-state dup [ string>number ] when
client-state dup string? [ string>number ] when
get-session verify-session ;
: <session-cookie> ( -- cookie )

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
[

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

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

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 ;

53
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 furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
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

224
extra/http/http.factor
View File

@ -1,8 +1,7 @@
! 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
@ -11,7 +10,9 @@ io.encodings.8-bit
unicode.case unicode.categories qualified
urls html.templates xml xml.data xml.writer ;
urls html.templates xml xml.data xml.writer
http.parsers ;
EXCLUDE: fry => , ;
@ -19,40 +20,20 @@ IN: http
: crlf ( -- ) "\r\n" write ;
: add-header ( value key assoc -- )
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
: header-line ( line -- )
dup first blank? [
[ blank? ] left-trim
"last-header" get
"header" get
add-header
] [
":" split1 dup [
[ blank? ] left-trim
swap >lower dup "last-header" set
"header" get add-header
] [
2drop
] if
] if ;
: read-lf ( -- bytes )
"\n" read-until CHAR: \n assert= ;
: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: (read-header) ( -- )
read-crlf dup
empty? [ drop ] [ header-line (read-header) ] if ;
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
: process-header ( alist -- assoc )
f swap [ [ swap or dup ] dip swap ] assoc-map nip
[ ?push ] histogram [ "; " join ] assoc-map
>hashtable ;
: read-header ( -- assoc )
H{ } clone [
"header" [ (read-header) ] with-variable
] keep ;
(read-header) process-header ;
: header-value>string ( value -- string )
{
@ -63,47 +44,62 @@ 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 ;
: 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 "=;'\"" intersect empty?
dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
: (unparse-cookie) ( key value -- )
: unparse-cookie-value ( key value -- )
{
{ f [ drop ] }
{ t [ check-cookie-string , ] }
@ -118,20 +114,30 @@ TUPLE: cookie name value path domain expires max-age http-only ;
]
} case ;
: unparse-cookie ( cookie -- strings )
: (unparse-cookie) ( cookie -- strings )
[
dup name>> check-cookie-string >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)
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
@ -141,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 ;
@ -155,27 +168,9 @@ cookies ;
"close" "connection" set-header
"Factor http.client" "user-agent" set-header ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
>>method ;
: 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 ;
@ -210,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 ;
@ -220,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 =
@ -249,7 +240,7 @@ TUPLE: post-data raw content content-type ;
[ content-type>> "content-type" pick set-at ]
bi
] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
write-header ;
GENERIC: >post-data ( object -- post-data )
@ -274,9 +265,7 @@ M: f >post-data ;
: write-request ( request -- )
unparse-post-data
write-method
write-request-url
write-version
write-request-line
write-request-header
write-post-data
flush
@ -311,23 +300,13 @@ M: response clone
[ clone ] change-header
[ clone ] change-cookies ;
: read-response-version ( response -- response )
" \t" read-until
[ "Bad response: version" throw ] unless
parse-version
>>version ;
: 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 ]
@ -336,20 +315,15 @@ M: response clone
: 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 ]
@ -357,19 +331,29 @@ M: response clone
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 ;
@ -403,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 ;

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

@ -4,7 +4,6 @@ USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
combinators tools.vocabs tools.time math
io
io.server
io.sockets
io.sockets.secure
io.encodings
@ -12,6 +11,7 @@ io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.servers.connection
io.timeouts
fry logging logging.insomniac calendar urls
http
@ -118,10 +118,6 @@ LOG: httpd-header NOTICE
: ?refresh-all ( -- )
development? get-global [ global [ refresh-all ] bind ] when ;
: setup-limits ( -- )
1 minutes timeouts
64 1024 * limit-input ;
LOG: httpd-benchmark DEBUG
: ?benchmark ( quot -- )
@ -130,25 +126,29 @@ LOG: httpd-benchmark DEBUG
httpd-benchmark
] [ call ] if ; inline
: handle-client ( -- )
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 ] ?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 ;
: httpd-insomniac ( -- )
"http.server" { httpd-hit } schedule-insomniac ;
MAIN: httpd-main
: http-insomniac ( -- )
"http.server" { "httpd-hit" } schedule-insomniac ;

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

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 arrays ;
IN: io.server
SYMBOL: servers
SYMBOL: remote-address
<PRIVATE
LOG: accepted-connection NOTICE
: with-connection ( client remote local quot -- )
'[
, ,
[ [ remote-address set ] [ local-address set ] bi* ]
[ 2array accepted-connection ]
2bi
@
] with-stream ; inline
: 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

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

@ -14,7 +14,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
"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 -- )
[

2
extra/peg/parsers/parsers.factor
View File

@ -24,11 +24,9 @@ MEMO: just ( parser -- parser )
: 1token ( ch -- parser ) 1string token ;
<PRIVATE
: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
PRIVATE>
: list-of ( items separator -- parser )
hide f (list-of) ;

27
extra/peg/peg.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order
unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
@ -563,11 +563,24 @@ PRIVATE>
#! to fix boxes so this isn't needed...
box-parser boa next-id f <parser> over set-delegate [ ] action ;
ERROR: parse-failed input word ;
M: parse-failed error.
"The " write dup word>> pprint " word could not parse the following input:" print nl
input>> . ;
: PEG:
(:) [
(:)
[let | def [ ] word [ ] |
[
call compile [ compiled-parse ] curry
[ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
append define
] with-compilation-unit
] 2curry over push-all ; parsing
[
[let | compiled-def [ def call compile ] |
[
dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if
]
word swap define
]
] with-compilation-unit
] over push-all
] ; parsing

2
extra/smtp/server/server.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Elie CHAFTARI
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel prettyprint io io.timeouts io.server
USING: combinators kernel prettyprint io io.timeouts
sequences namespaces io.sockets continuations calendar
io.encodings.ascii io.streams.duplex destructors ;
IN: smtp.server

18
extra/tty-server/tty-server.factor
View File

@ -1,11 +1,15 @@
USING: listener io.server io.encodings.utf8 ;
USING: listener io.servers.connection io.encodings.utf8
accessors kernel ;
IN: tty-server
: tty-server ( port -- )
local-server
"tty-server"
utf8 [ listener ] with-server ;
: <tty-server> ( port -- )
<threaded-server>
"tty-server" >>name
utf8 >>encoding
swap local-server >>insecure
[ listener ] >>handler
start-server ;
: default-tty-server ( -- ) 9999 tty-server ;
: tty-server ( -- ) 9999 <tty-server> ;
MAIN: default-tty-server
MAIN: tty-server

1
extra/webapps/blogs/blogs.factor
View File

@ -7,6 +7,7 @@ html.components
http.server.dispatchers
furnace
furnace.actions
furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate

2
extra/webapps/counter/counter.factor
View File

@ -1,5 +1,5 @@
USING: math kernel accessors http.server http.server.dispatchers
furnace furnace.actions furnace.sessions
furnace furnace.actions furnace.sessions furnace.redirection
html.components html.forms html.templates.chloe
fry urls ;
IN: webapps.counter

1
extra/webapps/pastebin/pastebin.factor
View File

@ -12,6 +12,7 @@ http.server.dispatchers
http.server.redirection
furnace
furnace.actions
furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate

1
extra/webapps/planet/planet.factor
View File

@ -10,6 +10,7 @@ http.server
http.server.dispatchers
furnace
furnace.actions
furnace.redirection
furnace.boilerplate
furnace.auth.login
furnace.auth

1
extra/webapps/todo/todo.factor
View File

@ -11,6 +11,7 @@ furnace
furnace.boilerplate
furnace.auth
furnace.actions
furnace.redirection
furnace.db
furnace.auth.login ;
IN: webapps.todo

3
extra/webapps/user-admin/user-admin.factor
View File

@ -12,6 +12,7 @@ furnace.auth.providers.db
furnace.auth.login
furnace.auth
furnace.actions
furnace.redirection
furnace.utilities
http.server
http.server.dispatchers ;
@ -138,7 +139,7 @@ TUPLE: user-admin < dispatcher ;
<action>
[
validate-username
<user> select-tuple 1 >>deleted update-tuple
"username" value <user> delete-tuples
URL" $user-admin" <redirect>
] >>submit ;

2
extra/webapps/wee-url/wee-url.factor
View File

@ -4,7 +4,7 @@
USING: math.ranges sequences random accessors combinators.lib
kernel namespaces fry db.types db.tuples urls validators
html.components html.forms http http.server.dispatchers furnace
furnace.actions furnace.boilerplate ;
furnace.actions furnace.boilerplate furnace.redirection ;
IN: webapps.wee-url
TUPLE: wee-url < dispatcher ;

1
extra/webapps/wiki/wiki.factor
View File

@ -8,6 +8,7 @@ http.server
http.server.dispatchers
furnace
furnace.actions
furnace.redirection
furnace.auth
furnace.auth.login
furnace.boilerplate

57
extra/webapps/factor-website/factor-website.factor → extra/websites/concatenative/concatenative.factor
View File

@ -1,18 +1,21 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs io.files io.sockets
io.server
namespaces db db.tuples db.sqlite smtp
io.sockets.secure io.servers.connection
namespaces db db.tuples db.sqlite smtp urls
logging.insomniac
http.server
http.server.dispatchers
http.server.redirection
furnace.alloy
furnace.auth.login
furnace.auth.providers.db
furnace.auth.features.edit-profile
furnace.auth.features.recover-password
furnace.auth.features.registration
furnace.auth.features.deactivate-user
furnace.boilerplate
furnace.redirection
webapps.blogs
webapps.pastebin
webapps.planet
@ -20,7 +23,7 @@ webapps.todo
webapps.wiki
webapps.wee-url
webapps.user-admin ;
IN: webapps.factor-website
IN: websites.concatenative
: test-db ( -- db params ) "resource:test.db" sqlite-db ;
@ -49,25 +52,53 @@ TUPLE: factor-website < dispatcher ;
<wiki> "wiki" add-responder
<wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
URL" /wiki/view/Front Page" <redirect-responder> "" add-responder
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
allow-deactivation
<boilerplate>
{ factor-website "page" } >>template
test-db <alloy> ;
: init-factor-website ( -- )
"factorcode.org" 25 <inet> smtp-server set-global
"todo@factorcode.org" lost-password-from set-global
"website@factorcode.org" insomniac-sender set-global
"slava@factorcode.org" insomniac-recipients set-global
init-factor-db
<factor-website> main-responder set-global ;
SYMBOL: key-password
SYMBOL: key-file
SYMBOL: dh-file
: start-factor-website ( -- )
: common-configuration ( -- )
"concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
"slava@factorcode.org" insomniac-recipients set-global
<factor-website> main-responder set-global
init-factor-db ;
: init-testing ( -- )
"resource:extra/openssl/test/dh1024.pem" dh-file set-global
"resource:extra/openssl/test/server.pem" key-file set-global
"password" key-password set-global
common-configuration ;
: init-production ( -- )
"/home/slava/cert/host.pem" key-file set-global
common-configuration ;
: <factor-secure-config> ( -- config )
<secure-config>
key-file get >>key-file
dh-file get >>dh-file
key-password get >>password ;
: <factor-website-server> ( -- threaded-server )
<http-server>
<factor-secure-config> >>secure-config
8080 >>insecure
8431 >>secure ;
: start-website ( -- )
test-db start-expiring
test-db start-update-task
httpd-insomniac
8812 httpd ;
http-insomniac
<factor-website-server> start-server ;

0
extra/webapps/factor-website/page.css → extra/websites/concatenative/page.css
View File

2
extra/webapps/factor-website/page.xml → extra/websites/concatenative/page.xml
View File

@ -12,7 +12,7 @@
<t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
<t:style t:include="resource:extra/webapps/factor-website/page.css" />
<t:style t:include="resource:extra/websites/concatenative/page.css" />
<t:write-style />