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-16 16:30:31 -05:00
parent aa1708d0b5 12b79b287f
commit 6e1e844a90
77 changed files with 1166 additions and 901 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. }

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

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

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

27
extra/base64/base64.factor
View File

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

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

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 harvest
[ , (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

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

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

@ -1,15 +1,24 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
destructors combinators
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.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 +29,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 +53,86 @@ SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get adjoin ;
TUPLE: realm < dispatcher name users checksum ;
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 ; 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 ;
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 ;
: <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

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

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

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

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

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

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

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

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

@ -0,0 +1,123 @@
! 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 ;
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 )
"recover-3"
swap [
[ username>> "username" set ]
[ ticket>> "ticket" set ]
bi
] H{ } make-assoc
derive-url ;
: 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 %
"\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 "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>
{ realm "recover-2" } >>template ;
: <recover-action-3> ( -- action )
<page-action>
[
{
{ "username" [ v-username ] }
{ "ticket" [ v-required ] }
} validate-params
] >>init
{ realm "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>
{ realm "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

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

@ -0,0 +1,43 @@
! 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 ;
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 ;
: allow-registration ( login -- login )
<register-action> <auth-boilerplate> "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

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

@ -1,99 +1,67 @@
! 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.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
realm get domain>> >>domain ;
: 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 +70,7 @@ SYMBOL: capabilities
capabilities get words>strings "capabilities" set-value
] >>init
{ login "login" } >>template
{ login-realm "login" } >>template
[
{
@ -115,286 +83,21 @@ SYMBOL: capabilities
[ 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
<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" 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> <auth-boilerplate> "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

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

@ -1,19 +1,26 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces
html.templates html.templates.chloe
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 ;
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 ;

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

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

20
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' )
@ -95,6 +96,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 -- )
@ -154,11 +168,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 -- )

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

@ -9,14 +9,13 @@ 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,12 +56,6 @@ 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 ;
@ -104,20 +97,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 [
@ -129,16 +108,18 @@ M: session-saver dispose
] when ;
: request-session ( -- session/f )
request-session-id get-session verify-session ;
session-id-key
client-state dup [ 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 ;
@ -147,6 +128,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 ;

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

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

@ -1,85 +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
: check-value-name ( name -- name )
dup string? [ "Value name not a string" throw ] unless ;
: value ( name -- value ) check-value-name values get at ;
: set-value ( value name -- ) check-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

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

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

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"

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

@ -122,7 +122,7 @@ read-response-test-1' 1array [
! Live-fire exercise
USING: http.server http.server.static furnace.sessions furnace.alloy
furnace.actions furnace.auth.login furnace.db http.client
furnace.actions furnace.auth furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
accessors namespaces threads
http.server.responses http.server.redirection
@ -176,7 +176,7 @@ test-db [
[
<dispatcher>
<action> <protected>
<login>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
@ -206,7 +206,7 @@ test-db [
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
<login>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
@ -223,7 +223,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 +276,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

29
extra/http/http.factor
View File

@ -6,7 +6,8 @@ assocs 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
@ -98,23 +99,29 @@ TUPLE: cookie name value path domain expires max-age http-only ;
drop
] { } make ;
: check-cookie-string ( string -- string' )
dup "=;'\"" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
: (unparse-cookie) ( 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 )
[
dup name>> >lower over value>> (unparse-cookie)
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)
@ -146,7 +153,7 @@ cookies ;
H{ } clone >>header
V{ } clone >>cookies
"close" "connection" set-header
"Factor http.client vocabulary" "user-agent" set-header ;
"Factor http.client" "user-agent" set-header ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
@ -295,9 +302,15 @@ 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 ;
M: response clone
call-next-method
[ clone ] change-header
[ clone ] change-cookies ;
: read-response-version ( response -- response )
" \t" read-until
[ "Bad response: version" throw ] unless
@ -363,7 +376,11 @@ M: response write-response ( respose -- )
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 ;

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

@ -2,7 +2,7 @@
! 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
@ -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,26 +57,19 @@ 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
@ -84,7 +79,7 @@ LOG: httpd-header NOTICE
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 ;
@ -121,13 +116,20 @@ LOG: httpd-header 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
: ?benchmark ( quot -- )
benchmark? get [
[ benchmark ] [ first ] bi request get url>> rot 3array
httpd-benchmark
] [ call ] if ; inline
: handle-client ( -- )
[
setup-limits
@ -135,8 +137,8 @@ LOG: httpd-header NOTICE
ascii encode-output
?refresh-all
read-request
do-request
do-response
[ do-request ] ?benchmark
[ do-response ] ?benchmark
] with-destructors ;
: httpd ( port -- )

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

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

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

@ -4,7 +4,7 @@ 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 ;
assocs fry accessors arrays ;
IN: io.server
SYMBOL: servers
@ -17,13 +17,13 @@ LOG: accepted-connection NOTICE
: with-connection ( client remote local quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi
, local-address set
, ,
[ [ remote-address set ] [ local-address set ] bi* ]
[ 2array accepted-connection ]
2bi
@
] with-stream ; inline
\ with-connection DEBUG add-error-logging
: accept-loop ( server quot -- )
[
[ [ accept ] [ addr>> ] bi ] dip

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

@ -9,7 +9,7 @@ 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
@ -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) ;

154
extra/openssl/libssl/libssl.factor
View File

@ -1,12 +1,8 @@
! Copyright (C) 2007 Elie CHAFTARI
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
!
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
!
! export LD_LIBRARY_PATH=/opt/local/lib
USING: alien alien.syntax combinators kernel system namespaces
assocs parser sequences words quotations ;
assocs parser sequences words quotations math.bitfields ;
IN: openssl.libssl
@ -24,11 +20,47 @@ IN: openssl.libssl
: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline
: SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline
: SSL_CTRL_NEED_TMP_RSA 1 ; inline
: SSL_CTRL_SET_TMP_RSA 2 ; inline
: SSL_CTRL_SET_TMP_DH 3 ; inline
: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
: SSL_CTRL_NEED_TMP_RSA 1 ; inline
: SSL_CTRL_SET_TMP_RSA 2 ; inline
: SSL_CTRL_SET_TMP_DH 3 ; inline
: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
: SSL_CTRL_GET_SESSION_REUSED 6 ; inline
: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 ; inline
: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 ; inline
: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 ; inline
: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 ; inline
: SSL_CTRL_GET_FLAGS 11 ; inline
: SSL_CTRL_EXTRA_CHAIN_CERT 12 ; inline
: SSL_CTRL_SET_MSG_CALLBACK 13 ; inline
: SSL_CTRL_SET_MSG_CALLBACK_ARG 14 ; inline
: SSL_CTRL_SESS_NUMBER 20 ; inline
: SSL_CTRL_SESS_CONNECT 21 ; inline
: SSL_CTRL_SESS_CONNECT_GOOD 22 ; inline
: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23 ; inline
: SSL_CTRL_SESS_ACCEPT 24 ; inline
: SSL_CTRL_SESS_ACCEPT_GOOD 25 ; inline
: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26 ; inline
: SSL_CTRL_SESS_HIT 27 ; inline
: SSL_CTRL_SESS_CB_HIT 28 ; inline
: SSL_CTRL_SESS_MISSES 29 ; inline
: SSL_CTRL_SESS_TIMEOUTS 30 ; inline
: SSL_CTRL_SESS_CACHE_FULL 31 ; inline
: SSL_CTRL_OPTIONS 32 ; inline
: SSL_CTRL_MODE 33 ; inline
: SSL_CTRL_GET_READ_AHEAD 40 ; inline
: SSL_CTRL_SET_READ_AHEAD 41 ; inline
: SSL_CTRL_SET_SESS_CACHE_SIZE 42 ; inline
: SSL_CTRL_GET_SESS_CACHE_SIZE 43 ; inline
: SSL_CTRL_SET_SESS_CACHE_MODE 44 ; inline
: SSL_CTRL_GET_SESS_CACHE_MODE 45 ; inline
: SSL_CTRL_GET_MAX_CERT_LIST 50 ; inline
: SSL_CTRL_SET_MAX_CERT_LIST 51 ; inline
: SSL_ERROR_NONE 0 ; inline
: SSL_ERROR_SSL 1 ; inline
@ -55,8 +87,9 @@ IN: openssl.libssl
} ;
TYPEDEF: void* ssl-method
TYPEDEF: void* ssl-ctx
TYPEDEF: void* ssl-pointer
TYPEDEF: void* SSL_CTX*
TYPEDEF: void* SSL_SESSION*
TYPEDEF: void* SSL*
LIBRARY: libssl
@ -64,7 +97,7 @@ LIBRARY: libssl
! ssl.h
! ===============================================
FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ;
FUNCTION: char* SSL_get_version ( SSL* ssl ) ;
! Maps OpenSSL errors to strings
FUNCTION: void SSL_load_error_strings ( ) ;
@ -94,42 +127,50 @@ FUNCTION: ssl-method TLSv1_server_method ( ) ;
FUNCTION: ssl-method TLSv1_method ( ) ;
! Creates the context
FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ;
FUNCTION: SSL_CTX* SSL_CTX_new ( ssl-method method ) ;
! Load the certificates and private keys into the SSL_CTX
FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx,
FUNCTION: int SSL_CTX_use_certificate_chain_file ( SSL_CTX* ctx,
char* file ) ; ! PEM type
FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ;
FUNCTION: SSL* SSL_new ( SSL_CTX* ctx ) ;
FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ;
FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ;
FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ;
FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ;
FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ;
FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ;
FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ;
FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ;
FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ;
FUNCTION: void SSL_set_connect_state ( SSL* ssl ) ;
FUNCTION: int SSL_connect ( ssl-pointer ssl ) ;
FUNCTION: void SSL_set_accept_state ( SSL* ssl ) ;
FUNCTION: int SSL_accept ( ssl-pointer ssl ) ;
FUNCTION: int SSL_connect ( SSL* ssl ) ;
FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
FUNCTION: int SSL_accept ( SSL* ssl ) ;
FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num ) ;
FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num ) ;
FUNCTION: int SSL_shutdown ( SSL* ssl ) ;
: SSL_SENT_SHUTDOWN 1 ;
: SSL_RECEIVED_SHUTDOWN 2 ;
FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ;
FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ;
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, char* sid_ctx, uint len ) ;
FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ;
FUNCTION: void SSL_free ( SSL* ssl ) ;
FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ;
FUNCTION: int SSL_want ( SSL* ssl ) ;
: SSL_NOTHING 1 ; inline
: SSL_WRITING 2 ; inline
@ -140,55 +181,55 @@ FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ;
FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ;
FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ;
FUNCTION: void SSL_CTX_free ( SSL_CTX* ctx ) ;
FUNCTION: void RAND_seed ( void* buf, int num ) ;
FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ;
FUNCTION: int SSL_set_cipher_list ( SSL* ssl, char* str ) ;
FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ;
FUNCTION: int SSL_use_RSAPrivateKey_file ( SSL* ssl, char* str ) ;
FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ;
FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( SSL_CTX* ctx, int type ) ;
FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
FUNCTION: int SSL_use_certificate_file ( SSL* ssl,
char* str, int type ) ;
FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
FUNCTION: int SSL_CTX_load_verify_locations ( SSL_CTX* ctx, char* CAfile,
char* CApath ) ;
FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ;
FUNCTION: int SSL_CTX_set_default_verify_paths ( SSL_CTX* ctx ) ;
: SSL_VERIFY_NONE 0 ; inline
: SSL_VERIFY_PEER 1 ; inline
: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
: SSL_VERIFY_CLIENT_ONCE 4 ; inline
FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ;
FUNCTION: void SSL_CTX_set_verify ( SSL_CTX* ctx, int mode, void* callback ) ;
FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
FUNCTION: void SSL_CTX_set_client_CA_list ( SSL_CTX* ctx, SSL* list ) ;
FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
FUNCTION: SSL* SSL_load_client_CA_file ( char* file ) ;
! Used to manipulate settings of the SSL_CTX and SSL objects.
! This function should never be called directly
FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ;
FUNCTION: long SSL_CTX_ctrl ( SSL_CTX* ctx, int cmd, long larg, void* parg ) ;
FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ;
FUNCTION: void SSL_CTX_set_default_passwd_cb ( SSL_CTX* ctx, void* cb ) ;
FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx,
FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( SSL_CTX* ctx,
void* u ) ;
FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file,
FUNCTION: int SSL_CTX_use_PrivateKey_file ( SSL_CTX* ctx, char* file,
int type ) ;
! Sets the maximum depth for the allowed ctx certificate chain verification
FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ;
! Sets the maximum depth for the allowed ctx certificate chain verification
FUNCTION: void SSL_CTX_set_verify_depth ( SSL_CTX* ctx, int depth ) ;
! Sets DH parameters to be used to be dh.
! The key is inherited by all ssl objects created from ctx
FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ;
FUNCTION: void SSL_CTX_set_tmp_dh_callback ( SSL_CTX* ctx, void* dh ) ;
FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ;
@ -198,6 +239,23 @@ FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
: SSL_CTX_set_session_cache_mode ( ctx mode -- n )
>r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ;
: SSL_SESS_CACHE_OFF HEX: 0000 ; inline
: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline
: SSL_SESS_CACHE_SERVER HEX: 0002 ; inline
: SSL_SESS_CACHE_BOTH ( -- n )
{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 ; inline
: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 ; inline
: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 ; inline
: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
! ===============================================
! x509.h
! ===============================================

32
extra/openssl/openssl.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector splitting
locals unicode.case
continuations destructors debugger inspector splitting assocs
random math.parser locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
io.timeouts ;
@ -48,7 +48,13 @@ SYMBOL: ssl-initialized?
[ f ssl-initialized? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < secure-context aliens ;
TUPLE: openssl-context < secure-context aliens sessions ;
: set-session-cache ( ctx -- )
handle>>
[ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
[ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
bi ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
@ -133,12 +139,20 @@ M: rsa dispose* handle>> RSA_free ;
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
: <openssl-context> ( config ctx -- context )
openssl-context new
swap >>handle
swap >>config
V{ } clone >>aliens
H{ } clone >>sessions ;
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
dup ssl-error f V{ } clone openssl-context boa |dispose
dup ssl-error <openssl-context> |dispose
{
[ set-session-cache ]
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
@ -152,8 +166,9 @@ M: openssl <secure-context> ( config -- context )
M: openssl-context dispose*
[ aliens>> [ free ] each ]
[ sessions>> values [ SSL_SESSION_free ] each ]
[ handle>> SSL_CTX_free ]
bi ;
tri ;
TUPLE: ssl-handle file handle connected disposed ;
@ -204,4 +219,11 @@ M: openssl check-certificate ( host ssl -- )
2bi
] [ 2drop ] if ;
: get-session ( addrspec -- session/f )
current-secure-context sessions>> at
dup expired? [ drop f ] when ;
: save-session ( session addrspec -- )
current-secure-context sessions>> set-at ;
openssl secure-socket-backend set-global

3
extra/sequences/lib/lib.factor
View File

@ -201,9 +201,6 @@ USE: continuations
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq

2
extra/tangle/sandbox/sandbox.factor
View File

@ -12,7 +12,7 @@ IN: tangle.sandbox
] with-tangle ;
: new-sandbox ( -- )
development-mode on
development? on
delete-db sandbox-db f <tangle>
[ make-sandbox ] [ <tangle-dispatcher> ] bi
main-responder set ;

64
extra/validators/validators-tests.factor
View File

@ -2,14 +2,6 @@ IN: validators.tests
USING: kernel sequences tools.test validators accessors
namespaces assocs ;
: with-validation ( quot -- messages )
[
init-validation
call
validation-messages get
named-validation-messages get >alist append
] with-scope ; inline
[ "" v-one-line ] must-fail
[ "hello world" ] [ "hello world" v-one-line ] unit-test
[ "hello\nworld" v-one-line ] must-fail
@ -60,59 +52,3 @@ namespaces assocs ;
[ "4561_2612_1234_5467" v-credit-card ] must-fail
[ "4561-2621-1234-5467" v-credit-card ] must-fail
[ 14 V{ } ] [
[
"14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
] with-validation
] unit-test
[ f t ] [
[
"140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
] with-validation first
[ first "age" = ]
[ second validation-error? ]
[ second value>> "140" = ]
tri and and
] unit-test
TUPLE: person name age ;
person {
{ "name" [ ] }
{ "age" [ v-number 13 v-min-value 100 v-max-value ] }
} define-validators
[ t t ] [
[
{ { "age" "" } } required-values
validation-failed?
] with-validation first
[ first "age" = ]
[ second validation-error? ]
[ second message>> "required" = ]
tri and and
] unit-test
[ H{ { "a" 123 } } f V{ } ] [
[
H{
{ "a" "123" }
{ "b" "c" }
{ "c" "d" }
}
H{
{ "a" [ v-integer ] }
} validate-values
validation-failed?
] with-validation
] unit-test
[ t "foo" ] [
[
"foo" validation-error
validation-failed?
] with-validation first message>>
] unit-test

54
extra/validators/validators.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences sequences.lib math
namespaces sets math.parser math.ranges assocs regexp fry
unicode.categories arrays hashtables words combinators mirrors
namespaces sets math.parser math.ranges assocs regexp
unicode.categories arrays hashtables words
classes quotations xmode.catalog ;
IN: validators
@ -107,53 +107,3 @@ IN: validators
] [
"invalid credit card number format" throw
] if ;
SYMBOL: validation-messages
SYMBOL: named-validation-messages
: init-validation ( -- )
V{ } clone validation-messages set
H{ } clone named-validation-messages set ;
: (validation-message) ( obj -- )
validation-messages get push ;
: (validation-message-for) ( obj name -- )
named-validation-messages get set-at ;
TUPLE: validation-message message ;
C: <validation-message> validation-message
: validation-message ( string -- )
<validation-message> (validation-message) ;
: validation-message-for ( string name -- )
[ <validation-message> ] dip (validation-message-for) ;
TUPLE: validation-error message value ;
C: <validation-error> validation-error
: validation-error ( message -- )
f <validation-error> (validation-message) ;
: validation-error-for ( message value name -- )
[ <validation-error> ] dip (validation-message-for) ;
: validation-failed? ( -- ? )
validation-messages get [ validation-error? ] contains?
named-validation-messages get [ nip validation-error? ] assoc-contains?
or ;
: define-validators ( class validators -- )
>hashtable "validators" set-word-prop ;
: validate ( value name quot -- result )
'[ drop @ ] [ -rot validation-error-for f ] recover ; inline
: required-values ( assoc -- )
[ swap [ v-required ] validate drop ] assoc-each ;
: validate-values ( assoc validators -- assoc' )
swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;

8
extra/webapps/blogs/blogs-common.xml
View File

@ -12,13 +12,13 @@
| <t:a t:href="$blogs/by">My Posts</t:a>
| <t:a t:href="$blogs/new-post">New Post</t:a>
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth:logged-in?">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>

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

@ -1,14 +1,15 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math.order math.parser
urls validators html.components db db.types db.tuples calendar
present http.server.dispatchers
urls validators db db.types db.tuples calendar present namespaces
html.forms
html.components
http.server.dispatchers
furnace
furnace.actions
furnace.auth
furnace.auth.login
furnace.boilerplate
furnace.sessions
furnace.syndication ;
IN: webapps.blogs
@ -142,7 +143,7 @@ M: comment entity-url
"id" value
"new-comment" [
"parent" set-value
] nest-values
] nest-form
] >>init
{ blogs "view-post" } >>template ;
@ -158,13 +159,13 @@ M: comment entity-url
[
validate-post
uid "author" set-value
logged-in-user get username>> "author" set-value
] >>validate
[
f <post>
dup { "title" "content" } deposit-slots
uid >>author
dup { "title" "content" } to-object
logged-in-user get username>> >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit
@ -175,7 +176,8 @@ M: comment entity-url
"make a new blog post" >>description ;
: authorize-author ( author -- )
uid = can-administer-blogs? have-capability? or
logged-in-user get username>> =
can-administer-blogs? have-capability? or
[ login-required ] unless ;
: do-post-action ( -- )
@ -195,7 +197,7 @@ M: comment entity-url
[
"id" value <post>
dup { "title" "author" "date" "content" } deposit-slots
dup { "title" "author" "date" "content" } to-object
[ update-tuple ] [ entity-url <redirect> ] bi
] >>submit
@ -251,13 +253,13 @@ M: comment entity-url
[
validate-comment
uid "author" set-value
logged-in-user get username>> "author" set-value
] >>validate
[
"parent" value f <comment>
"content" value >>content
uid >>author
logged-in-user get username>> >>author
now >>date
[ insert-tuple ] [ entity-url <redirect> ] bi
] >>submit

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

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

11
extra/webapps/factor-website/factor-website.factor
View File

@ -7,12 +7,11 @@ logging.insomniac
http.server
http.server.dispatchers
furnace.alloy
furnace.db
furnace.asides
furnace.flash
furnace.sessions
furnace.auth.login
furnace.auth.providers.db
furnace.auth.features.edit-profile
furnace.auth.features.recover-password
furnace.auth.features.registration
furnace.boilerplate
webapps.blogs
webapps.pastebin
@ -50,8 +49,8 @@ TUPLE: factor-website < dispatcher ;
<wiki> "wiki" add-responder
<wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
<login>
users-in-db >>users
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile

8
extra/webapps/pastebin/pastebin-common.xml
View File

@ -11,13 +11,13 @@
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth:logged-in?">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>

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

@ -4,6 +4,7 @@ USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
calendar calendar.format math.parser syndication urls xml.writer
xmode.catalog validators
html.forms
html.components
html.templates.chloe
http.server
@ -126,7 +127,7 @@ M: annotation entity-url
"parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
] nest-values
] nest-form
] >>init
{ pastebin "paste" } >>template ;
@ -149,7 +150,7 @@ M: annotation entity-url
: deposit-entity-slots ( tuple -- )
now >>date
{ "summary" "author" "mode" "contents" } deposit-slots ;
{ "summary" "author" "mode" "contents" } to-object ;
: <new-paste-action> ( -- action )
<page-action>
@ -160,11 +161,12 @@ M: annotation entity-url
{ pastebin "new-paste" } >>template
[ mode-names "modes" set-value ] >>validate
[
mode-names "modes" set-value
validate-entity
] >>validate
[
validate-entity
f <paste>
[ deposit-entity-slots ]
[ insert-tuple ]
@ -196,6 +198,7 @@ M: annotation entity-url
: <new-annotation-action> ( -- action )
<action>
[
mode-names "modes" set-value
{ { "parent" [ v-integer ] } } validate-params
validate-entity
] >>validate

8
extra/webapps/planet/planet-common.xml
View File

@ -9,12 +9,12 @@
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
<t:if t:code="furnace.auth:logged-in?">
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>

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

@ -3,9 +3,9 @@
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
syndication urls xml.writer validators
html.forms
html.components
syndication urls xml.writer
validators
http.server
http.server.dispatchers
furnace
@ -130,7 +130,7 @@ posting "POSTINGS"
} validate-params ;
: deposit-blog-slots ( blog -- )
{ "name" "www-url" "feed-url" } deposit-slots ;
{ "name" "www-url" "feed-url" } to-object ;
: <new-blog-action> ( -- action )
<page-action>

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

@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces
db db.types db.tuples validators hashtables urls
html.forms
html.components
html.templates.chloe
http.server
http.server.dispatchers
furnace
furnace.sessions
furnace.boilerplate
furnace.auth
furnace.actions
@ -31,7 +31,7 @@ todo "TODO"
: <todo> ( id -- todo )
todo new
swap >>id
uid >>uid ;
logged-in-user get username>> >>uid ;
: <view-action> ( -- action )
<page-action>
@ -62,7 +62,7 @@ todo "TODO"
[
f <todo>
dup { "summary" "priority" "description" } deposit-slots
dup { "summary" "priority" "description" } to-object
[ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
@ -82,7 +82,7 @@ todo "TODO"
[
f <todo>
dup { "id" "summary" "priority" "description" } deposit-slots
dup { "id" "summary" "priority" "description" } to-object
[ update-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;

6
extra/webapps/todo/todo.xml
View File

@ -8,11 +8,11 @@
<t:a t:href="$todo-list/list">List Items</t:a>
| <t:a t:href="$todo-list/new">Add Item</t:a>
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>

4
extra/webapps/user-admin/edit-user.xml
View File

@ -50,11 +50,11 @@
</table>
<p>
<button type="submit" class="link-button link">Update</button>
<button type="submit" >Update</button>
<t:validation-messages />
</p>
</t:form>
<t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
<t:button t:action="$user-admin/delete" t:for="username">Delete</t:button>
</t:chloe>

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

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls
html.forms
html.elements
html.components
furnace
@ -10,8 +11,8 @@ furnace.auth.providers
furnace.auth.providers.db
furnace.auth.login
furnace.auth
furnace.sessions
furnace.actions
furnace.utilities
http.server
http.server.dispatchers ;
IN: webapps.user-admin
@ -26,10 +27,19 @@ TUPLE: user-admin < dispatcher ;
: init-capabilities ( -- )
capabilities get words>strings "capabilities" set-value ;
: selected-capabilities ( -- seq )
: validate-capabilities ( -- )
"capabilities" value
[ param empty? not ] filter
[ string>word ] map ;
[ [ param empty? not ] keep set-value ] each ;
: selected-capabilities ( -- seq )
"capabilities" value [ value ] filter [ string>word ] map ;
: validate-user ( -- )
{
{ "username" [ v-username ] }
{ "realname" [ [ v-one-line ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
} validate-params ;
: <new-user-action> ( -- action )
<page-action>
@ -42,14 +52,13 @@ TUPLE: user-admin < dispatcher ;
[
init-capabilities
validate-capabilities
validate-user
{
{ "username" [ v-username ] }
{ "realname" [ v-one-line ] }
{ "new-password" [ v-password ] }
{ "verify-password" [ v-password ] }
{ "email" [ [ v-email ] v-optional ] }
{ "capabilities" [ ] }
} validate-params
same-password-twice
@ -74,14 +83,16 @@ TUPLE: user-admin < dispatcher ;
: validate-username ( -- )
{ { "username" [ v-username ] } } validate-params ;
: select-capabilities ( seq -- )
[ t swap word>string set-value ] each ;
: <edit-user-action> ( -- action )
<page-action>
[
validate-username
"username" value <user> select-tuple
[ from-object ]
[ capabilities>> [ "true" swap word>string set-value ] each ] bi
[ from-object ] [ capabilities>> select-capabilities ] bi
init-capabilities
] >>init
@ -89,14 +100,17 @@ TUPLE: user-admin < dispatcher ;
{ user-admin "edit-user" } >>template
[
"username" value <user> select-tuple
[ from-object ] [ capabilities>> select-capabilities ] bi
init-capabilities
validate-capabilities
validate-user
{
{ "username" [ v-username ] }
{ "realname" [ v-one-line ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
} validate-params
"new-password" "verify-password"
@ -124,11 +138,7 @@ TUPLE: user-admin < dispatcher ;
<action>
[
validate-username
[ <user> select-tuple 1 >>deleted update-tuple ]
[ logout-all-sessions ]
bi
<user> select-tuple 1 >>deleted update-tuple
URL" $user-admin" <redirect>
] >>submit ;

6
extra/webapps/user-admin/user-admin.xml
View File

@ -6,11 +6,11 @@
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>

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

@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math.ranges sequences random accessors combinators.lib
kernel namespaces fry db.types db.tuples urls validators
html.components http http.server.dispatchers furnace
html.components html.forms http http.server.dispatchers furnace
furnace.actions furnace.boilerplate ;
IN: webapps.wee-url

27
extra/webapps/wiki/wiki-common.xml
View File

@ -14,13 +14,13 @@
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
<t:if t:code="furnace.sessions:uid">
<t:if t:code="furnace.auth:logged-in?">
<t:if t:code="furnace.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
| <t:a t:href="$realm/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
| <t:button t:action="$login-realm/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
@ -28,6 +28,23 @@
<h1><t:write-title /></h1>
<t:call-next-template />
<table width="100%">
<tr>
<td> <t:call-next-template /> </td>
<t:if t:value="sidebar">
<td valign="top">
<t:bind t:name="sidebar">
<h2>
<t:a t:href="$wiki/view" t:query="title">
<t:label t:name="title" />
</t:a>
</h2>
<t:farkup t:name="content" />
</t:bind>
</td>
</t:if>
</tr>
</table>
</t:chloe>

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
namespaces splitting sequences sorting math.order present
html.components syndication
syndication
html.components html.forms
http.server
http.server.dispatchers
furnace
@ -77,6 +78,10 @@ M: revision feed-entry-url id>> revision-url ;
<action>
[ "Front Page" view-url <redirect> ] >>display ;
: latest-revision ( title -- revision/f )
<article> select-tuple
dup [ revision>> <revision> select-tuple ] when ;
: <view-article-action> ( -- action )
<action>
@ -87,8 +92,8 @@ M: revision feed-entry-url id>> revision-url ;
] >>init
[
"title" value dup <article> select-tuple [
revision>> <revision> select-tuple from-object
"title" value dup latest-revision [
from-object
{ wiki "view" } <chloe-content>
] [
edit-url <redirect>
@ -231,8 +236,8 @@ M: revision feed-entry-url id>> revision-url ;
"old-id" "new-id"
[ value <revision> select-tuple ] bi@
[
[ [ title>> "title" set-value ] [ "old" set-value ] bi ]
[ "new" set-value ] bi*
[ [ title>> "title" set-value ] [ "old" [ from-object ] nest-form ] bi ]
[ "new" [ from-object ] nest-form ] bi*
]
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
@ -279,6 +284,11 @@ M: revision feed-entry-url id>> revision-url ;
<boilerplate>
{ wiki "page-common" } >>template ;
: init-sidebar ( -- )
"Sidebar" latest-revision [
"sidebar" [ from-object ] nest-form
] when* ;
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<main-article-action> <article-boilerplate> "" add-responder
@ -296,4 +306,5 @@ M: revision feed-entry-url id>> revision-url ;
<list-changes-feed-action> "changes.atom" add-responder
<delete-action> "delete" add-responder
<boilerplate>
[ init-sidebar ] >>init
{ wiki "wiki-common" } >>template ;

2
extra/xmode/catalog/catalog.factor
View File

@ -5,7 +5,7 @@ IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
<TAGS: parse-mode-tag
<TAGS: parse-mode-tag ( modes tag -- )
TAG: MODE
"NAME" over at >r

8
extra/xmode/loader/loader.factor
View File

@ -7,15 +7,15 @@ IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler
! RULES and its children
<TAGS: parse-rule-tag
<TAGS: parse-rule-tag ( rule-set tag -- )
TAG: PROPS ( rule-set tag -- )
TAG: PROPS
parse-props-tag swap set-rule-set-props ;
TAG: IMPORT ( rule-set tag -- )
TAG: IMPORT
"DELEGATE" swap at swap import-rule-set ;
TAG: TERMINATE ( rule-set tag -- )
TAG: TERMINATE
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ;
RULE: SEQ seq-rule

2
extra/xmode/loader/syntax/syntax.factor
View File

@ -75,7 +75,7 @@ SYMBOL: ignore-case?
[ parse-literal-matcher swap set-rule-end ] , ;
! SPAN's children
<TAGS: parse-begin/end-tag
<TAGS: parse-begin/end-tag ( rule tag -- )
TAG: BEGIN
! XXX

3
extra/xmode/utilities/utilities.factor
View File

@ -48,11 +48,10 @@ SYMBOL: tag-handler-word
: (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
: TAG:
f set-word
scan parse-definition
(TAG:) ; parsing
: TAGS>
tag-handler-word get
tag-handlers get >alist [ >r dup name-tag r> case ] curry
(( tag -- )) define-declared ; parsing
define ; parsing