Login authentication is now stored outside of the session, allowing multiple independent login realms per site

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

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

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 )

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 ;

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
 
         [
             {

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 ;

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 ;

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>

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 -- )

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 ;

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)

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
     ] [

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 ;