1 ! Copyright (c) 2008 Slava Pestov
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: accessors assocs namespaces kernel sequences sets
\r
4 destructors combinators fry logging
\r
5 io.encodings.utf8 io.encodings.string io.binary random
\r
6 checksums checksums.sha urls
\r
10 http.server.dispatchers
\r
15 furnace.auth.providers
\r
16 furnace.auth.providers.db ;
\r
17 FROM: namespaces => set ;
\r
20 SYMBOL: logged-in-user
\r
22 : logged-in? ( -- ? )
\r
23 logged-in-user get >boolean ;
\r
25 : username ( -- string/f )
\r
26 logged-in-user get dup [ username>> ] when ;
\r
28 GENERIC: init-user-profile ( responder -- )
\r
30 M: object init-user-profile drop ;
\r
32 M: dispatcher init-user-profile
\r
33 default>> init-user-profile ;
\r
35 M: filter-responder init-user-profile
\r
36 responder>> init-user-profile ;
\r
38 : profile ( -- assoc ) logged-in-user get profile>> ;
\r
40 : user-changed ( -- )
\r
41 logged-in-user get t >>changed? drop ;
\r
43 : uget ( key -- value )
\r
46 : uset ( value key -- )
\r
50 : uchange ( quot key -- )
\r
51 profile swap change-at
\r
52 user-changed ; inline
\r
54 SYMBOL: capabilities
\r
56 V{ } clone capabilities set-global
\r
58 : define-capability ( word -- ) capabilities get adjoin ;
\r
60 TUPLE: realm < dispatcher name users checksum secure ;
\r
62 GENERIC: login-required* ( description capabilities realm -- response )
\r
64 GENERIC: user-registered ( user realm -- response )
\r
66 M: object user-registered 2drop URL" $realm" <redirect> ;
\r
68 GENERIC: init-realm ( realm -- )
\r
70 GENERIC: logged-in-username ( realm -- username )
\r
72 : login-required ( description capabilities -- * )
\r
73 realm get login-required* exit-with ;
\r
75 : new-realm ( responder name class -- realm )
\r
83 : users ( -- provider )
\r
86 TUPLE: user-saver user ;
\r
88 C: <user-saver> user-saver
\r
90 M: user-saver dispose
\r
91 user>> dup changed?>> [ users update-user ] [ drop ] if ;
\r
93 : save-user-after ( user -- )
\r
94 <user-saver> &dispose drop ;
\r
96 : init-user ( user -- )
\r
97 [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
\r
99 \ init-user DEBUG add-input-logging
\r
101 M: realm call-responder* ( path responder -- response )
\r
105 dup logged-in-username
\r
106 dup [ users get-user ] when
\r
111 : encode-password ( string salt -- bytes )
\r
112 [ utf8 encode ] [ 4 >be ] bi* append
\r
113 realm get checksum>> checksum-bytes ;
\r
115 : >>encoded-password ( user string -- user )
\r
116 32 random-bits [ encode-password ] keep
\r
117 [ >>password ] [ >>salt ] bi* ; inline
\r
119 : valid-login? ( password user -- ? )
\r
120 [ salt>> encode-password ] [ password>> ] bi = ;
\r
122 : check-login ( password username -- user/f )
\r
123 users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
\r
125 : if-secure-realm ( quot -- )
\r
126 realm get secure>> [ if-secure ] [ call ] if ; inline
\r
128 TUPLE: secure-realm-only < filter-responder ;
\r
130 C: <secure-realm-only> secure-realm-only
\r
132 M: secure-realm-only call-responder*
\r
133 '[ _ _ call-next-method ] if-secure-realm ;
\r
135 TUPLE: protected < filter-responder description capabilities ;
\r
137 : <protected> ( responder -- protected )
\r
141 : have-capabilities? ( capabilities -- ? )
\r
142 realm get secure>> secure-connection? not and [ drop f ] [
\r
143 logged-in-user get {
\r
144 { [ dup not ] [ 2drop f ] }
\r
145 { [ dup deleted>> 1 = ] [ 2drop f ] }
\r
146 [ capabilities>> subset? ]
\r
150 M: protected call-responder* ( path responder -- response )
\r
152 dup capabilities>> have-capabilities?
\r
153 [ call-next-method ] [
\r
154 [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
\r
155 realm get login-required*
\r
158 : <auth-boilerplate> ( responder -- responder' )
\r
159 <boilerplate> { realm "boilerplate" } >>template ;
\r
161 : password-mismatch ( -- * )
\r
162 "passwords do not match" validation-error
\r
163 validation-failed ;
\r
165 : same-password-twice ( -- )
\r
166 "new-password" value "verify-password" value =
\r
167 [ password-mismatch ] unless ;
\r
169 : user-exists ( -- * )
\r
170 "username taken" validation-error
\r
171 validation-failed ;
\r