https support

diff --git a/extra/furnace/auth/auth.factor b/extra/furnace/auth/auth.factor
index d9f517aaf4f2871735bf1a9759a74335aa9153e1..ae042f05bd7892059c78de0b30092705852459fe 100755 (executable)
--- a/extra/furnace/auth/auth.factor
+++ b/extra/furnace/auth/auth.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Slava Pestov\r
 ! See http://factorcode.org/license.txt for BSD license.\r
 USING: accessors assocs namespaces kernel sequences sets\r
-destructors combinators\r
+destructors combinators fry\r
 io.encodings.utf8 io.encodings.string io.binary random\r
 checksums checksums.sha2\r
 html.forms\r
@@ -10,6 +10,7 @@ http.server.filters
 http.server.dispatchers\r
 furnace\r
 furnace.actions\r
+furnace.redirection\r
 furnace.boilerplate\r
 furnace.auth.providers\r
 furnace.auth.providers.db ;\r
@@ -54,7 +55,7 @@ V{ } clone capabilities set-global
 \r
 : define-capability ( word -- ) capabilities get adjoin ;\r
 \r
-TUPLE: realm < dispatcher name users checksum ;\r
+TUPLE: realm < dispatcher name users checksum secure ;\r
 \r
 GENERIC: login-required* ( realm -- response )\r
 \r
@@ -67,7 +68,8 @@ GENERIC: logged-in-username ( realm -- username )
         swap >>name\r
         swap >>default\r
         users-in-db >>users\r
-        sha-256 >>checksum ; inline\r
+        sha-256 >>checksum\r
+        t >>secure ; inline\r
 \r
 : users ( -- provider )\r
     realm get users>> ;\r
@@ -104,6 +106,16 @@ M: realm call-responder* ( path responder -- response )
 : check-login ( password username -- user/f )\r
     users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
 \r
+: if-secure-realm ( quot -- )\r
+    realm get secure>> [ if-secure ] [ call ] if ; inline\r
+\r
+TUPLE: secure-realm-only < filter-responder ;\r
+\r
+C: <secure-realm-only> secure-realm-only\r
+\r
+M: secure-realm-only call-responder*\r
+    '[ , , call-next-method ] if-secure-realm ;\r
+\r
 TUPLE: protected < filter-responder description capabilities ;\r
 \r
 : <protected> ( responder -- protected )\r
@@ -118,9 +130,12 @@ TUPLE: protected < filter-responder description capabilities ;
     } cond ;\r
 \r
 M: protected call-responder* ( path responder -- response )\r
-    dup protected set\r
-    dup logged-in-user get check-capabilities\r
-    [ call-next-method ] [ 2drop realm get login-required* ] if ;\r
+    '[\r
+        , ,\r
+        dup protected set\r
+        dup logged-in-user get check-capabilities\r
+        [ call-next-method ] [ 2drop realm get login-required* ] if\r
+    ] if-secure-realm ;\r
 \r
 : <auth-boilerplate> ( responder -- responder' )\r
     <boilerplate> { realm "boilerplate" } >>template ;\r

diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor
index 4c53cb9c89991e8081c4dbaef9cb123efaf1bc7b..68161382c1bd76b2b1b0fe697790fae6aa51b81f 100755 (executable)
--- a/extra/furnace/auth/login/login.factor
+++ b/extra/furnace/auth/login/login.factor
@@ -39,8 +39,11 @@ M: login-realm modify-form ( responder -- )
 : <permit-cookie> ( -- cookie )\r
     permit-id get realm get name>> permit-id-key <cookie>\r
         "$login-realm" resolve-base-path >>path\r
-        realm get timeout>> from-now >>expires\r
-        realm get domain>> >>domain ;\r
+        realm get\r
+        [ timeout>> from-now >>expires ]\r
+        [ domain>> >>domain ]\r
+        [ secure>> >>secure ]\r
+        tri ;\r
 \r
 : put-permit-cookie ( response -- response' )\r
     <permit-cookie> put-cookie ;\r
@@ -82,7 +85,9 @@ SYMBOL: capabilities
             "password" value\r
             "username" value check-login\r
             [ successful-login ] [ login-failed ] if*\r
-        ] >>submit ;\r
+        ] >>submit\r
+    <auth-boilerplate>\r
+    <secure-realm-only> ;\r
 \r
 : <logout-action> ( -- action )\r
     <action>\r
@@ -99,6 +104,6 @@ M: login-realm login-required*
 \r
 : <login-realm> ( responder name -- auth )\r
     login-realm new-realm\r
-        <login-action> <auth-boilerplate> "login" add-responder\r
+        <login-action> "login" add-responder\r
         <logout-action> "logout" add-responder\r
         20 minutes >>timeout ;\r

diff --git a/extra/furnace/boilerplate/boilerplate.factor b/extra/furnace/boilerplate/boilerplate.factor
index a97619966126e70030e84b56835f651ce2cc118f..0e2a673d9b3b031f5ebcd2e7935cdc1c1dbdf692 100644 (file)
--- 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 7f87c677b9484b5643b98ad6805257338ef233a0..88d621b57382ffe05b6a6dceb1fa3906266d60b5 100644 (file)
--- 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>> <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 ;