-! Copyright (c) 2008 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors namespaces sequences math.parser\r
-calendar checksums validators urls logging html.forms\r
-http http.server http.server.dispatchers\r
-furnace.auth\r
-furnace.asides\r
-furnace.actions\r
-furnace.sessions\r
-furnace.utilities\r
-furnace.redirection\r
-furnace.conversations\r
-furnace.auth.login.permits ;\r
-IN: furnace.auth.login\r
-\r
-SYMBOL: permit-id\r
-\r
-: permit-id-key ( realm -- string )\r
- hex-string "__p_" prepend ;\r
-\r
-: client-permit-id ( realm -- id/f )\r
- permit-id-key client-state dup [ string>number ] when ;\r
-\r
-TUPLE: login-realm < realm timeout domain ;\r
-\r
-M: login-realm init-realm\r
- name>> client-permit-id permit-id set ;\r
-\r
-M: login-realm logged-in-username\r
- drop permit-id get dup [ get-permit-uid ] when ;\r
-\r
-M: login-realm modify-form ( responder -- xml/f )\r
- drop permit-id get realm get name>> permit-id-key hidden-form-field ;\r
-\r
-: <permit-cookie> ( -- cookie )\r
- permit-id get realm get name>> permit-id-key <cookie>\r
- "$login-realm" resolve-base-path >>path\r
- realm get\r
- [ domain>> >>domain ]\r
- [ secure>> >>secure ]\r
- bi ;\r
-\r
-: put-permit-cookie ( response -- response' )\r
- <permit-cookie> put-cookie ;\r
-\r
-\ put-permit-cookie DEBUG add-input-logging\r
-\r
-: successful-login ( user -- response )\r
- [ username>> make-permit permit-id set ] [ init-user ] bi\r
- URL" $realm" end-aside\r
- put-permit-cookie ;\r
-\r
-\ successful-login DEBUG add-input-logging\r
-\r
-: logout ( -- response )\r
- permit-id get [ delete-permit ] when*\r
- URL" $realm" end-aside ;\r
-\r
-<PRIVATE\r
-\r
-SYMBOL: description\r
-SYMBOL: capabilities\r
-\r
-PRIVATE>\r
-\r
-CONSTANT: flashed-variables { description capabilities }\r
-\r
-: login-failed ( -- * )\r
- "invalid username or password" validation-error\r
- validation-failed ;\r
-\r
-: <login-action> ( -- action )\r
- <page-action>\r
- [\r
- description cget "description" set-value\r
- capabilities cget words>strings "capabilities" set-value\r
- ] >>init\r
-\r
- { login-realm "login" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-required ] }\r
- { "password" [ v-required ] }\r
- } validate-params\r
-\r
- "password" value\r
- "username" value check-login\r
- [ successful-login ] [ login-failed ] if*\r
- ] >>submit\r
- <auth-boilerplate>\r
- <secure-realm-only> ;\r
-\r
-: <logout-action> ( -- action )\r
- <action>\r
- [ logout ] >>submit ;\r
-\r
-M: login-realm login-required* ( description capabilities login -- response )\r
- begin-conversation\r
- [ description cset ] [ capabilities cset ] [ secure>> ] tri*\r
- [\r
- url get >secure-url begin-aside\r
- URL" $realm/login" >secure-url <continue-conversation>\r
- ] [\r
- url get begin-aside\r
- URL" $realm/login" <continue-conversation>\r
- ] if ;\r
-\r
-M: login-realm user-registered ( user realm -- response )\r
- drop successful-login ;\r
-\r
-: <login-realm> ( responder name -- realm )\r
- login-realm new-realm\r
- <login-action> "login" add-responder\r
- <logout-action> "logout" add-responder\r
- 20 minutes >>timeout ;\r
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences math.parser
+calendar checksums validators urls logging html.forms
+http http.server http.server.dispatchers
+furnace.auth
+furnace.asides
+furnace.actions
+furnace.sessions
+furnace.utilities
+furnace.redirection
+furnace.conversations
+furnace.auth.login.permits ;
+IN: furnace.auth.login
+
+SYMBOL: permit-id
+
+: permit-id-key ( realm -- string )
+ hex-string "__p_" prepend ;
+
+: client-permit-id ( realm -- id/f )
+ permit-id-key client-state dup [ string>number ] when ;
+
+TUPLE: login-realm < realm timeout domain ;
+
+M: login-realm init-realm
+ name>> client-permit-id permit-id set ;
+
+M: login-realm logged-in-username
+ drop permit-id get dup [ get-permit-uid ] when ;
+
+M: login-realm modify-form ( responder -- xml/f )
+ drop permit-id get realm get name>> permit-id-key hidden-form-field ;
+
+: <permit-cookie> ( -- cookie )
+ permit-id get realm get name>> permit-id-key <cookie>
+ "$login-realm" resolve-base-path >>path
+ realm get
+ [ domain>> >>domain ]
+ [ secure>> >>secure ]
+ bi ;
+
+: put-permit-cookie ( response -- response' )
+ <permit-cookie> put-cookie ;
+
+\ put-permit-cookie DEBUG add-input-logging
+
+: successful-login ( user -- response )
+ [ username>> make-permit permit-id set ] [ init-user ] bi
+ URL" $realm" end-aside
+ put-permit-cookie ;
+
+\ successful-login DEBUG add-input-logging
+
+: logout ( -- response )
+ permit-id get [ delete-permit ] when*
+ URL" $realm" end-aside ;
+
+<PRIVATE
+
+SYMBOL: description
+SYMBOL: capabilities
+
+PRIVATE>
+
+CONSTANT: flashed-variables { description capabilities }
+
+: login-failed ( -- * )
+ "invalid username or password" validation-error
+ validation-failed ;
+
+: <login-action> ( -- action )
+ <page-action>
+ [
+ description cget "description" set-value
+ capabilities cget words>strings "capabilities" set-value
+ ] >>init
+
+ { login-realm "login" } >>template
+
+ [
+ {
+ { "username" [ v-required ] }
+ { "password" [ v-required ] }
+ } validate-params
+
+ "password" value
+ "username" value check-login
+ [ successful-login ] [ login-failed ] if*
+ ] >>submit
+ <auth-boilerplate>
+ <secure-realm-only> ;
+
+: <logout-action> ( -- action )
+ <action>
+ [ logout ] >>submit ;
+
+M: login-realm login-required* ( description capabilities login -- response )
+ begin-conversation
+ [ description cset ] [ capabilities cset ] [ secure>> ] tri*
+ [
+ url get >secure-url begin-aside
+ URL" $realm/login" >secure-url <continue-conversation>
+ ] [
+ url get begin-aside
+ URL" $realm/login" <continue-conversation>
+ ] if ;
+
+M: login-realm user-registered ( user realm -- response )
+ drop successful-login ;
+
+: <login-realm> ( responder name -- realm )
+ login-realm new-realm
+ <login-action> "login" add-responder
+ <logout-action> "logout" add-responder
+ 20 minutes >>timeout ;
projects / factor.git / blobdiff