2008-03-06 04:00:10 -05:00
|
|
|
! Copyright (C) 2008 Slava Pestov.
|
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-03-20 16:30:59 -04:00
|
|
|
USING: kernel accessors random math.parser locals
|
2008-04-30 17:11:55 -04:00
|
|
|
sequences math ;
|
2008-06-01 18:22:39 -04:00
|
|
|
IN: furnace.auth.providers
|
2008-03-06 04:00:10 -05:00
|
|
|
|
2008-05-01 21:03:02 -04:00
|
|
|
TUPLE: user
|
|
|
|
|
username realname
|
|
|
|
|
password salt
|
|
|
|
|
email ticket capabilities profile deleted changed? ;
|
2008-03-06 04:00:10 -05:00
|
|
|
|
2008-04-29 22:04:06 -04:00
|
|
|
: <user> ( username -- user )
|
|
|
|
|
user new
|
2008-04-30 05:53:01 -04:00
|
|
|
swap >>username
|
|
|
|
|
0 >>deleted ;
|
2008-03-06 04:00:10 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
GENERIC: get-user ( username provider -- user/f )
|
2008-03-06 04:00:10 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
GENERIC: update-user ( user provider -- )
|
2008-03-06 04:00:10 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
GENERIC: new-user ( user provider -- user/f )
|
2008-03-06 04:00:10 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
! Password recovery support
|
|
|
|
|
|
|
|
|
|
:: issue-ticket ( email username provider -- user/f )
|
2009-10-27 22:50:31 -04:00
|
|
|
username provider get-user :> user
|
|
|
|
|
user [
|
|
|
|
|
user email>> length 0 > [
|
|
|
|
|
user email>> email = [
|
|
|
|
|
user
|
|
|
|
|
256 random-bits >hex >>ticket
|
|
|
|
|
dup provider update-user
|
2008-03-11 04:39:09 -04:00
|
|
|
] [ f ] if
|
|
|
|
|
] [ f ] if
|
2009-10-27 22:50:31 -04:00
|
|
|
] [ f ] if ;
|
2008-03-11 04:39:09 -04:00
|
|
|
|
|
|
|
|
:: claim-ticket ( ticket username provider -- user/f )
|
2009-10-27 22:50:31 -04:00
|
|
|
username provider get-user :> user
|
|
|
|
|
user [
|
|
|
|
|
user ticket>> ticket = [
|
|
|
|
|
user f >>ticket dup provider update-user
|
2008-03-11 04:39:09 -04:00
|
|
|
] [ f ] if
|
2009-10-27 22:50:31 -04:00
|
|
|
] [ f ] if ;
|
2008-03-11 04:39:09 -04:00
|
|
|
|
|
|
|
|
! For configuration
|
|
|
|
|
|
|
|
|
|
: add-user ( provider user -- provider )
|
|
|
|
|
over new-user [ "User exists" throw ] when ;
|