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 : ( responder db params -- responder' ) @@ -19,7 +20,7 @@ IN: furnace.alloy ] 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 +\ 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 -- ) &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 +: ( 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 : ( -- 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 ; + +: ( -- cookie ) + permit-id get realm get name>> permit-id-key + "$login-realm" resolve-base-path >>path + realm get timeout>> from-now >>expires + realm get domain>> >>domain ; + +: put-permit-cookie ( response -- response' ) + 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 : ( -- action ) - [ logout ] >>submit ; + [ logout ] >>submit + + "logout" >>description ; M: login-realm login-required* drop @@ -68,4 +99,5 @@ M: login-realm login-required* : ( responder name -- auth ) login-realm new-realm "login" add-responder - "logout" add-responder ; + "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 ; - + "Test" >>users -login set +realm set [ t ] [ "slava" 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 ; -: ( id -- cookie ) - session-id-key +: ( -- cookie ) + session get id>> session-id-key "$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 put-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 ; { wiki "page-common" } >>template ; +: init-sidebar ( -- ) + "Sidebar" latest-revision [ + "sidebar" [ from-object ] nest-form + ] when* ; + : ( -- dispatcher ) wiki new-dispatcher "" add-responder @@ -301,5 +306,5 @@ M: revision feed-entry-url id>> revision-url ; "changes.atom" add-responder "delete" add-responder - [ "sidebar" [ "Sidebar" latest-revision from-object ] nest-form ] >>init + [ init-sidebar ] >>init { wiki "wiki-common" } >>template ;