1 ! Copyright (c) 2008 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors calendar furnace.actions furnace.asides
4 furnace.auth furnace.auth.login.permits furnace.conversations
5 furnace.redirection furnace.utilities html.forms http
6 http.server.dispatchers kernel logging math.parser namespaces
7 sequences urls validators ;
12 : permit-id-key ( realm -- string )
13 bytes>hex-string "__p_" prepend ;
15 : client-permit-id ( realm -- id/f )
16 permit-id-key client-state dup [ string>number ] when ;
18 TUPLE: login-realm < realm timeout domain ;
20 M: login-realm init-realm
21 name>> client-permit-id permit-id set ;
23 M: login-realm logged-in-username
24 drop permit-id get dup [ get-permit-uid ] when ;
26 M: login-realm modify-form
27 drop permit-id get realm get name>> permit-id-key hidden-form-field ;
29 : <permit-cookie> ( -- cookie )
30 permit-id get realm get name>> permit-id-key <cookie>
31 "$login-realm" resolve-base-path >>path
37 : put-permit-cookie ( response -- response' )
38 <permit-cookie> put-cookie ;
40 \ put-permit-cookie DEBUG add-input-logging
42 : successful-login ( user -- response )
43 [ username>> make-permit permit-id set ] [ init-user ] bi
44 URL" $realm" end-aside
47 \ successful-login DEBUG add-input-logging
49 : logout ( -- response )
50 permit-id get [ delete-permit ] when*
51 URL" $realm" end-aside ;
60 CONSTANT: flashed-variables { description capabilities }
62 : login-failed ( -- * )
63 "invalid username or password" validation-error
66 : <login-action> ( -- action )
69 description cget "description" set-value
70 capabilities cget words>strings "capabilities" set-value
73 { login-realm "login" } >>template
77 { "username" [ v-required ] }
78 { "password" [ v-required ] }
82 "username" value check-login
83 [ successful-login ] [ login-failed ] if*
88 : <logout-action> ( -- action )
92 M: login-realm login-required*
94 [ description cset ] [ capabilities cset ] [ secure>> ] tri*
96 url get >secure-url begin-aside
97 URL" $realm/login" >secure-url <continue-conversation>
100 URL" $realm/login" <continue-conversation>
103 M: login-realm user-registered
104 drop successful-login ;
106 : <login-realm> ( responder name -- realm )
107 login-realm new-realm
108 <login-action> "login" add-responder
109 <logout-action> "logout" add-responder
110 20 minutes >>timeout ;