diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor index d9f517aaf4..ae042f05bd 100755 --- a/extra/furnace/auth/auth.factor +++ b/extra/furnace/auth/auth.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs namespaces kernel sequences sets -destructors combinators +destructors combinators fry io.encodings.utf8 io.encodings.string io.binary random checksums checksums.sha2 html.forms @@ -10,6 +10,7 @@ http.server.filters http.server.dispatchers furnace furnace.actions +furnace.redirection furnace.boilerplate furnace.auth.providers furnace.auth.providers.db ; @@ -54,7 +55,7 @@ V{ } clone capabilities set-global : define-capability ( word -- ) capabilities get adjoin ; -TUPLE: realm < dispatcher name users checksum ; +TUPLE: realm < dispatcher name users checksum secure ; GENERIC: login-required* ( realm -- response ) @@ -67,7 +68,8 @@ GENERIC: logged-in-username ( realm -- username ) swap >>name swap >>default users-in-db >>users - sha-256 >>checksum ; inline + sha-256 >>checksum + t >>secure ; inline : users ( -- provider ) realm get users>> ; @@ -104,6 +106,16 @@ M: realm call-responder* ( path responder -- response ) : check-login ( password username -- user/f ) users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ; +: if-secure-realm ( quot -- ) + realm get secure>> [ if-secure ] [ call ] if ; inline + +TUPLE: secure-realm-only < filter-responder ; + +C: secure-realm-only + +M: secure-realm-only call-responder* + '[ , , call-next-method ] if-secure-realm ; + TUPLE: protected < filter-responder description capabilities ; : ( responder -- protected ) @@ -118,9 +130,12 @@ TUPLE: protected < filter-responder description capabilities ; } cond ; M: protected call-responder* ( path responder -- response ) - dup protected set - dup logged-in-user get check-capabilities - [ call-next-method ] [ 2drop realm get login-required* ] if ; + '[ + , , + dup protected set + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop realm get login-required* ] if + ] if-secure-realm ; : ( responder -- responder' ) { realm "boilerplate" } >>template ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 4c53cb9c89..68161382c1 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -39,8 +39,11 @@ M: login-realm modify-form ( responder -- ) : ( -- 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 ; + realm get + [ timeout>> from-now >>expires ] + [ domain>> >>domain ] + [ secure>> >>secure ] + tri ; : put-permit-cookie ( response -- response' ) put-cookie ; @@ -82,7 +85,9 @@ SYMBOL: capabilities "password" value "username" value check-login [ successful-login ] [ login-failed ] if* - ] >>submit ; + ] >>submit + + ; : ( -- action ) @@ -99,6 +104,6 @@ M: login-realm login-required* : ( responder name -- auth ) login-realm new-realm - "login" add-responder + "login" add-responder "logout" add-responder 20 minutes >>timeout ; diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor index a976199661..0e2a673d9b 100644 --- a/extra/furnace/boilerplate/boilerplate.factor +++ b/extra/furnace/boilerplate/boilerplate.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces +USING: accessors kernel math.order namespaces combinators.lib html.forms html.templates html.templates.chloe @@ -17,6 +17,12 @@ TUPLE: boilerplate < filter-responder template init ; swap >>responder [ ] >>init ; +: wrap-boilerplate? ( response -- ? ) + { + [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ] + [ content-type>> "text/html" = ] + } 1&& ; + M:: boilerplate call-responder* ( path responder -- ) begin-form path responder call-next-method diff --git a/extra/furnace/redirection/redirection.factor b/extra/furnace/redirection/redirection.factor index 7f87c677b9..88d621b573 100644 --- a/extra/furnace/redirection/redirection.factor +++ b/extra/furnace/redirection/redirection.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors combinators namespaces +USING: kernel accessors combinators namespaces fry io.servers.connection -http http.server http.server.redirection +http http.server http.server.redirection http.server.filters furnace ; IN: furnace.redirection @@ -27,3 +27,15 @@ TUPLE: redirect-responder to ; redirect-responder boa ; M: redirect-responder call-responder* nip to>> ; + +TUPLE: secure-only < filter-responder ; + +C: secure-only + +: if-secure ( quot -- ) + >r request get url>> protocol>> "http" = + [ request get url>> ] + r> if ; inline + +M: secure-only call-responder* + '[ , , call-next-method ] if-secure ;