From e47e7ec30c1b980a13118df8b0919476ca34680a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Jun 2008 05:16:51 -0500
Subject: [PATCH] Login authentication is now stored outside of the session,
allowing multiple independent login realms per site
---
extra/furnace/alloy/alloy.factor | 5 +-
extra/furnace/auth/auth-tests.factor | 6 ++
extra/furnace/auth/auth.factor | 9 +--
extra/furnace/auth/basic/basic.factor | 10 ++--
.../features/registration/registration.factor | 2 +-
extra/furnace/auth/login/login.factor | 56 +++++++++++++++----
.../furnace/auth/login/permits/permits.factor | 30 ++++++++++
.../auth/providers/assoc/assoc-tests.factor | 6 +-
extra/furnace/furnace.factor | 13 +++++
extra/furnace/sessions/sessions.factor | 24 ++------
extra/http/http.factor | 12 +++-
extra/http/server/static/static.factor | 2 +-
extra/webapps/wiki/wiki.factor | 7 ++-
13 files changed, 131 insertions(+), 51 deletions(-)
create mode 100644 extra/furnace/auth/auth-tests.factor
create mode 100644 extra/furnace/auth/login/permits/permits.factor
diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor
index 14ffbaba9d..28c34e6715 100644
--- a/extra/furnace/alloy/alloy.factor
+++ b/extra/furnace/alloy/alloy.factor
@@ -7,7 +7,8 @@ furnace.flash
furnace.sessions
furnace.referrer
furnace.db
-furnace.auth.providers ;
+furnace.auth.providers
+furnace.auth.login.permits ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
@@ -19,7 +20,7 @@ IN: furnace.alloy
<check-form-submissions>
] call ;
-: state-classes { session flash-scope aside } ; inline
+: state-classes { session flash-scope aside permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables
diff --git a/extra/furnace/auth/auth-tests.factor b/extra/furnace/auth/auth-tests.factor
new file mode 100644
index 0000000000..220a8cd04c
--- /dev/null
+++ b/extra/furnace/auth/auth-tests.factor
@@ -0,0 +1,6 @@
+USING: furnace.auth tools.test ;
+IN: furnace.auth.tests
+
+\ logged-in-username must-infer
+\ <protected> must-infer
+\ new-realm must-infer
diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor
index 9bb7ea105e..d9f517aaf4 100755
--- a/extra/furnace/auth/auth.factor
+++ b/extra/furnace/auth/auth.factor
@@ -82,15 +82,12 @@ M: user-saver dispose
: 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* ;
+: init-user ( user -- )
+ [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
M: realm call-responder* ( path responder -- response )
dup realm set
- dup init-user
+ dup logged-in-username dup [ users get-user ] when init-user
call-next-method ;
: encode-password ( string salt -- bytes )
diff --git a/extra/furnace/auth/basic/basic.factor b/extra/furnace/auth/basic/basic.factor
index ae9cbb82c1..e478f70dcc 100755
--- a/extra/furnace/auth/basic/basic.factor
+++ b/extra/furnace/auth/basic/basic.factor
@@ -1,17 +1,18 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel splitting base64 namespaces
+USING: accessors kernel splitting base64 namespaces strings
http http.server.responses furnace.auth ;
IN: furnace.auth.basic
TUPLE: basic-auth-realm < realm ;
-C: <basic-auth-realm> basic-auth-realm
+: <basic-auth-realm> ( responder name -- realm )
+ basic-auth-realm new-realm ;
: parse-basic-auth ( header -- username/f password/f )
dup [
" " split1 swap "Basic" = [
- base64> ":" split1
+ base64> >string ":" split1
] [ drop f f ] if
] [ drop f f ] if ;
@@ -23,5 +24,6 @@ M: basic-auth-realm login-required* ( realm -- response )
name>> <401> ;
M: basic-auth-realm logged-in-username ( realm -- uid )
+ drop
request get "authorization" header parse-basic-auth
- dup [ over realm get check-login swap and ] [ 2drop f ] if ;
+ dup [ over check-login swap and ] [ 2drop f ] if ;
diff --git a/extra/furnace/auth/features/registration/registration.factor b/extra/furnace/auth/features/registration/registration.factor
index 3deead4869..2bc7688b10 100644
--- a/extra/furnace/auth/features/registration/registration.factor
+++ b/extra/furnace/auth/features/registration/registration.factor
@@ -7,7 +7,7 @@ IN: furnace.auth.features.registration
: <register-action> ( -- action )
<page-action>
- { realm "register" } >>template
+ { realm "features/registration/register" } >>template
[
{
diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index 6a59c01c63..e2b208de3a 100755
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -1,28 +1,57 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces validators urls
-html.forms
-http.server.dispatchers
+USING: kernel accessors namespaces sequences math.parser
+calendar validators urls html.forms
+http http.server http.server.dispatchers
+furnace
furnace.auth
furnace.flash
furnace.asides
furnace.actions
furnace.sessions
-furnace.utilities ;
+furnace.utilities
+furnace.auth.login.permits ;
IN: furnace.auth.login
-TUPLE: login-realm < realm ;
+SYMBOL: permit-id
+
+: permit-id-key ( realm -- string )
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat
+ "__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 call-responder*
+ [ name>> client-permit-id permit-id set ]
+ [ call-next-method ]
+ bi ;
M: login-realm logged-in-username
- drop session get uid>> ;
+ drop permit-id get dup [ get-permit-uid ] when ;
-: set-uid ( username -- )
- session get [ (>>uid) ] [ (session-changed) ] bi ;
+M: login-realm modify-form ( responder -- )
+ 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 timeout>> from-now >>expires
+ realm get domain>> >>domain ;
+
+: put-permit-cookie ( response -- response' )
+ <permit-cookie> put-cookie ;
: successful-login ( user -- response )
- username>> set-uid URL" $realm" end-aside ;
+ [ username>> make-permit permit-id set ] [ init-user ] bi
+ URL" $realm" end-aside
+ put-permit-cookie ;
-: logout ( -- ) f set-uid URL" $realm" end-aside ;
+: logout ( -- )
+ permit-id get [ delete-permit ] when*
+ URL" $realm" end-aside ;
SYMBOL: description
SYMBOL: capabilities
@@ -56,7 +85,9 @@ SYMBOL: capabilities
: <logout-action> ( -- action )
<action>
- [ logout ] >>submit ;
+ [ logout ] >>submit
+ <protected>
+ "logout" >>description ;
M: login-realm login-required*
drop
@@ -68,4 +99,5 @@ M: login-realm login-required*
: <login-realm> ( responder name -- auth )
login-realm new-realm
<login-action> <auth-boilerplate> "login" add-responder
- <logout-action> "logout" add-responder ;
+ <logout-action> "logout" add-responder
+ 20 minutes >>timeout ;
diff --git a/extra/furnace/auth/login/permits/permits.factor b/extra/furnace/auth/login/permits/permits.factor
new file mode 100644
index 0000000000..49cf98e0e3
--- /dev/null
+++ b/extra/furnace/auth/login/permits/permits.factor
@@ -0,0 +1,30 @@
+USING: accessors namespaces combinators.lib kernel
+db.tuples db.types
+furnace.auth furnace.sessions furnace.cache ;
+IN: furnace.auth.login.permits
+
+TUPLE: permit < server-state session uid ;
+
+permit "PERMITS" {
+ { "session" "SESSION" BIG-INTEGER +not-null+ }
+ { "uid" "UID" { VARCHAR 255 } +not-null+ }
+} define-persistent
+
+: touch-permit ( permit -- )
+ realm get touch-state ;
+
+: get-permit-uid ( id -- uid )
+ permit get-state {
+ [ ]
+ [ session>> session get id>> = ]
+ [ [ touch-permit ] [ uid>> ] bi ]
+ } 1&& ;
+
+: make-permit ( uid -- id )
+ permit new
+ swap >>uid
+ session get id>> >>session
+ [ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
+
+: delete-permit ( id -- )
+ permit new-server-state delete-tuples ;
diff --git a/extra/furnace/auth/providers/assoc/assoc-tests.factor b/extra/furnace/auth/providers/assoc/assoc-tests.factor
index 8f9eeaa7a5..8fe1dd4dd4 100755
--- a/extra/furnace/auth/providers/assoc/assoc-tests.factor
+++ b/extra/furnace/auth/providers/assoc/assoc-tests.factor
@@ -1,11 +1,11 @@
IN: furnace.auth.providers.assoc.tests
-USING: furnace.actions furnace.auth.providers
+USING: furnace.actions furnace.auth furnace.auth.providers
furnace.auth.providers.assoc furnace.auth.login
tools.test namespaces accessors kernel ;
-<action> <login>
+<action> "Test" <login-realm>
<users-in-memory> >>users
-login set
+realm set
[ t ] [
"slava" <user>
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 6b47bc681b..521f8a3bc1 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -96,6 +96,19 @@ M: object modify-form drop ;
request get url>>
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+: cookie-client-state ( key request -- value/f )
+ swap get-cookie dup [ value>> ] when ;
+
+: post-client-state ( key request -- value/f )
+ request-params at ;
+
+: client-state ( key -- value/f )
+ request get dup method>> {
+ { "GET" [ cookie-client-state ] }
+ { "HEAD" [ cookie-client-state ] }
+ { "POST" [ post-client-state ] }
+ } case ;
+
SYMBOL: exit-continuation
: exit-with ( value -- )
diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor
index fe8053fc9c..bb0a844269 100755
--- a/extra/furnace/sessions/sessions.factor
+++ b/extra/furnace/sessions/sessions.factor
@@ -98,20 +98,6 @@ M: session-saver dispose
: session-id-key "__s" ;
-: cookie-session-id ( request -- id/f )
- session-id-key get-cookie
- dup [ value>> string>number ] when ;
-
-: post-session-id ( request -- id/f )
- session-id-key swap request-params at string>number ;
-
-: request-session-id ( -- id/f )
- request get dup method>> {
- { "GET" [ cookie-session-id ] }
- { "HEAD" [ cookie-session-id ] }
- { "POST" [ post-session-id ] }
- } case ;
-
: verify-session ( session -- session )
sessions get verify?>> [
dup [
@@ -123,16 +109,18 @@ M: session-saver dispose
] when ;
: request-session ( -- session/f )
- request-session-id get-session verify-session ;
+ session-id-key
+ client-state dup [ string>number ] when
+ get-session verify-session ;
-: <session-cookie> ( id -- cookie )
- session-id-key <cookie>
+: <session-cookie> ( -- cookie )
+ session get id>> session-id-key <cookie>
"$sessions" resolve-base-path >>path
sessions get timeout>> from-now >>expires
sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' )
- session get id>> number>string <session-cookie> put-cookie ;
+ <session-cookie> put-cookie ;
M: sessions modify-form ( responder -- )
drop session get id>> session-id-key hidden-form-field ;
diff --git a/extra/http/http.factor b/extra/http/http.factor
index d2a0b0f922..025e2c8441 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -99,23 +99,29 @@ TUPLE: cookie name value path domain expires max-age http-only ;
drop
] { } make ;
+: check-cookie-string ( string -- string' )
+ dup "=;'\"" intersect empty?
+ [ "Bad cookie name or value" throw ] unless ;
+
: (unparse-cookie) ( key value -- )
{
{ f [ drop ] }
- { t [ , ] }
+ { t [ check-cookie-string , ] }
[
{
{ [ dup timestamp? ] [ timestamp>cookie-string ] }
{ [ dup duration? ] [ dt>seconds number>string ] }
+ { [ dup real? ] [ number>string ] }
[ ]
} cond
- "=" swap 3append ,
+ check-cookie-string "=" swap check-cookie-string 3append ,
]
} case ;
: unparse-cookie ( cookie -- strings )
[
- dup name>> >lower over value>> (unparse-cookie)
+ dup name>> check-cookie-string >lower
+ over value>> (unparse-cookie)
"path" over path>> (unparse-cookie)
"domain" over domain>> (unparse-cookie)
"expires" over expires>> (unparse-cookie)
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 9d76c82e4a..83fcf6f4a9 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -82,7 +82,7 @@ TUPLE: file-responder root hook special allow-listings ;
"index.html" append-path dup exists? [ drop f ] unless ;
: serve-directory ( filename -- response )
- request get path>> "/" tail? [
+ request get url>> path>> "/" tail? [
dup
find-index [ serve-file ] [ list-directory ] ?if
] [
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 34bad6db18..13c445b0a8 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -284,6 +284,11 @@ M: revision feed-entry-url id>> revision-url ;
<boilerplate>
{ wiki "page-common" } >>template ;
+: init-sidebar ( -- )
+ "Sidebar" latest-revision [
+ "sidebar" [ from-object ] nest-form
+ ] when* ;
+
: <wiki> ( -- dispatcher )
wiki new-dispatcher
<main-article-action> <article-boilerplate> "" add-responder
@@ -301,5 +306,5 @@ M: revision feed-entry-url id>> revision-url ;
<list-changes-feed-action> "changes.atom" add-responder
<delete-action> "delete" add-responder
<boilerplate>
- [ "sidebar" [ "Sidebar" latest-revision from-object ] nest-form ] >>init
+ [ init-sidebar ] >>init
{ wiki "wiki-common" } >>template ;