https support

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> secure-realm-only
+
+M: secure-realm-only call-responder*
+    '[ , , call-next-method ] if-secure-realm ;
+
 TUPLE: protected < filter-responder description capabilities ;
 
 : <protected> ( 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 ;
 
 : <auth-boilerplate> ( responder -- responder' )
     <boilerplate> { realm "boilerplate" } >>template ;

extra/furnace/auth/login/login.factor

@@ -39,8 +39,11 @@ M: login-realm modify-form ( responder -- )
 : <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
-        realm get domain>> >>domain ;
+        [ timeout>> from-now >>expires ]
+        [ domain>> >>domain ]
+        [ secure>> >>secure ]
+        tri ;
 
 : put-permit-cookie ( response -- response' )
     <permit-cookie> put-cookie ;
@@ -82,7 +85,9 @@ SYMBOL: capabilities
             "password" value
             "username" value check-login
             [ successful-login ] [ login-failed ] if*
-        ] >>submit ;
+        ] >>submit
+    <auth-boilerplate>
+    <secure-realm-only> ;
 
 : <logout-action> ( -- action )
     <action>
@@ -99,6 +104,6 @@ M: login-realm login-required*
 
 : <login-realm> ( responder name -- auth )
     login-realm new-realm
-        <login-action> <auth-boilerplate> "login" add-responder
+        <login-action> "login" add-responder
         <logout-action> "logout" add-responder
         20 minutes >>timeout ;

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

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>> <redirect> ;
+
+TUPLE: secure-only < filter-responder ;
+
+C: <secure-only> secure-only
+
+: if-secure ( quot -- )
+    >r request get url>> protocol>> "http" =
+    [ request get url>> <secure-redirect> ]
+    r> if ; inline
+
+M: secure-only call-responder*
+    '[ , , call-next-method ] if-secure ;