Merge branch 'master' of factorcode.org:/git/factor
commit
6e1e844a90
|
@ -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
|
||||
|
|
|
@ -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. }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
|
@ -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,0 +1,4 @@
|
|||
IN: furnace.auth.features.edit-profile.tests
|
||||
USING: tools.test furnace.auth.features.edit-profile ;
|
||||
|
||||
\ allow-edit-profile must-infer
|
|
@ -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? ;
|
|
@ -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,0 +1,4 @@
|
|||
IN: furnace.auth.features.recover-password
|
||||
USING: tools.test furnace.auth.features.recover-password ;
|
||||
|
||||
\ allow-password-recovery must-infer
|
|
@ -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,0 +1,4 @@
|
|||
IN: furnace.auth.features.registration.tests
|
||||
USING: tools.test furnace.auth.features.registration ;
|
||||
|
||||
\ allow-registration must-infer
|
|
@ -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? ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 ;
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 |
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
] [
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
|
|||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors
|
||||
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||
io.streams.duplex io.ports ;
|
||||
io.streams.duplex io.ports debugger prettyprint inspector ;
|
||||
IN: io.launcher
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
@ -131,11 +131,16 @@ HOOK: run-process* io-backend ( process -- handle )
|
|||
run-detached
|
||||
dup detached>> [ dup wait-for-process drop ] unless ;
|
||||
|
||||
ERROR: process-failed code ;
|
||||
ERROR: process-failed process code ;
|
||||
|
||||
M: process-failed error.
|
||||
dup "Process exited with error code " write code>> . nl
|
||||
"Launch descriptor:" print nl
|
||||
process>> describe ;
|
||||
|
||||
: try-process ( desc -- )
|
||||
run-process wait-for-process dup zero?
|
||||
[ drop ] [ process-failed ] if ;
|
||||
run-process dup wait-for-process dup zero?
|
||||
[ 2drop ] [ process-failed ] if ;
|
||||
|
||||
HOOK: kill-process* io-backend ( handle -- )
|
||||
|
||||
|
|
|
@ -4,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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -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
|
||||
! ===============================================
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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,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>
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue