Refactoring furnace.auth
Slava Pestov
parent
a943a237d9
commit
39d8bec7ef
|
|
@ -1,11 +1,18 @@
|
|||
! 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
|
||||
|
|
@ -20,6 +27,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 +51,89 @@ 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 ( realm -- )
|
||||
logged-in-username [
|
||||
users get-user
|
||||
[ logged-in-user set ] [ save-user-after ] bi
|
||||
] when* ;
|
||||
|
||||
M: realm call-responder* ( path responder -- response )
|
||||
dup realm set
|
||||
dup 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>> ] [ 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,27 @@
|
|||
! 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
|
||||
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
|
||||
C: <basic-auth-realm> basic-auth-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> ":" 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 )
|
||||
request get "authorization" header parse-basic-auth
|
||||
dup [ over realm get 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 get responders>> "edit-profile" swap key? ;
|
||||
|
|
@ -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 "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,103 +1,35 @@
|
|||
! 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
|
||||
USING: kernel accessors namespaces validators urls
|
||||
html.forms
|
||||
html.components
|
||||
html.elements
|
||||
urls
|
||||
http
|
||||
http.server
|
||||
http.server.dispatchers
|
||||
http.server.filters
|
||||
http.server.responses
|
||||
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 ;
|
||||
IN: furnace.auth.login
|
||||
|
||||
: word>string ( word -- string )
|
||||
[ word-vocabulary ] [ word-name ] bi ":" swap 3append ;
|
||||
TUPLE: login-realm < realm ;
|
||||
|
||||
: words>strings ( seq -- seq' )
|
||||
[ word>string ] map ;
|
||||
: set-uid ( username -- )
|
||||
session get [ (>>uid) ] [ (session-changed) ] bi ;
|
||||
|
||||
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 ;
|
||||
|
||||
TUPLE: login < dispatcher users checksum ;
|
||||
|
||||
TUPLE: protected < filter-responder description capabilities ;
|
||||
|
||||
: <protected> ( responder -- protected )
|
||||
protected new
|
||||
swap >>responder ;
|
||||
|
||||
: users ( -- provider )
|
||||
login get users>> ;
|
||||
|
||||
: encode-password ( string salt -- bytes )
|
||||
[ utf8 encode ] [ 4 >be ] bi* append
|
||||
login 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 ;
|
||||
|
||||
! 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>> set-uid URL" $realm" end-aside ;
|
||||
|
||||
: login-failed ( -- * )
|
||||
"invalid username or password" validation-error
|
||||
validation-failed ;
|
||||
: logout ( -- ) f set-uid ;
|
||||
|
||||
SYMBOL: description
|
||||
SYMBOL: capabilities
|
||||
|
||||
: flashed-variables { description capabilities } ;
|
||||
|
||||
: login-failed ( -- * )
|
||||
"invalid username or password" validation-error
|
||||
validation-failed ;
|
||||
|
||||
: <login-action> ( -- action )
|
||||
<page-action>
|
||||
[
|
||||
|
|
@ -106,7 +38,7 @@ SYMBOL: capabilities
|
|||
capabilities get words>strings "capabilities" set-value
|
||||
] >>init
|
||||
|
||||
{ login "login" } >>template
|
||||
{ login-realm "login" } >>template
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -119,286 +51,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 URL" $login-realm" end-aside ] >>submit ;
|
||||
|
||||
! ! ! 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> ;
|
||||
|
||||
: login-required ( -- * )
|
||||
show-login-page exit-with ;
|
||||
M: login-realm logged-in-username
|
||||
drop session get uid>> ;
|
||||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -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,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 ;
|
||||
|
|
|
|||
|
|
@ -57,12 +57,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 ;
|
||||
|
||||
|
|
@ -147,6 +141,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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -147,7 +147,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
|
||||
|
|
@ -296,6 +296,7 @@ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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 db db.types db.tuples calendar present
|
||||
urls validators db db.types db.tuples calendar present namespaces
|
||||
html.forms
|
||||
html.components
|
||||
http.server.dispatchers
|
||||
|
|
@ -10,7 +10,6 @@ furnace.actions
|
|||
furnace.auth
|
||||
furnace.auth.login
|
||||
furnace.boilerplate
|
||||
furnace.sessions
|
||||
furnace.syndication ;
|
||||
IN: webapps.blogs
|
||||
|
||||
|
|
@ -160,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" } to-object
|
||||
uid >>author
|
||||
logged-in-user get username>> >>author
|
||||
now >>date
|
||||
[ insert-tuple ] [ entity-url <redirect> ] bi
|
||||
] >>submit
|
||||
|
|
@ -177,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 ( -- )
|
||||
|
|
@ -253,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
|
||||
|
|
|
|||
|
|
@ -7,12 +7,11 @@ logging.insomniac
|
|||
http.server
|
||||
http.server.dispatchers
|
||||
furnace.alloy
|
||||
furnace.db
|
||||
furnace.asides
|
||||
furnace.flash
|
||||
furnace.sessions
|
||||
furnace.auth.login
|
||||
furnace.auth.providers.db
|
||||
furnace.auth.features.edit-profile
|
||||
furnace.auth.features.recover-password
|
||||
furnace.auth.features.registration
|
||||
furnace.boilerplate
|
||||
webapps.blogs
|
||||
webapps.pastebin
|
||||
|
|
@ -50,8 +49,8 @@ TUPLE: factor-website < dispatcher ;
|
|||
<wiki> "wiki" add-responder
|
||||
<wee-url> "wee-url" add-responder
|
||||
<user-admin> "user-admin" add-responder
|
||||
<login>
|
||||
users-in-db >>users
|
||||
"Factor website" <login-realm>
|
||||
"Factor website" >>name
|
||||
allow-registration
|
||||
allow-password-recovery
|
||||
allow-edit-profile
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ html.templates.chloe
|
|||
http.server
|
||||
http.server.dispatchers
|
||||
furnace
|
||||
furnace.sessions
|
||||
furnace.boilerplate
|
||||
furnace.auth
|
||||
furnace.actions
|
||||
|
|
@ -32,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>
|
||||
|
|
|
|||
|
|
@ -11,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
|
||||
|
|
@ -138,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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue