diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,7 @@
+## 1.4.7
+
+SSL-only session security [#894](https://github.com/yesodweb/yesod/pull/894)
+
## 1.4.6.2
monad-control 1.0
diff --git a/Yesod/Core.hs b/Yesod/Core.hs
--- a/Yesod/Core.hs
+++ b/Yesod/Core.hs
@@ -47,6 +47,8 @@
, defaultClientSessionBackend
, envClientSessionBackend
, clientSessionBackend
+ , sslOnlySessions
+ , sslOnlyMiddleware
, clientSessionDateCacher
, loadClientSession
, Header(..)
diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs
--- a/Yesod/Core/Class/Yesod.hs
+++ b/Yesod/Core/Class/Yesod.hs
@@ -310,6 +310,43 @@
authorizationCheck
handler
+-- | Defends against session hijacking by setting the secure bit on session
+-- cookies so that browsers will not transmit them over http. With this
+-- setting on, it follows that the server will regard requests made over
+-- http as sessionless, because the session cookie will not be included in
+-- the request. Use this as part of a total security measure which also
+-- includes disabling HTTP traffic to the site or issuing redirects from
+-- HTTP urls, and composing 'sslOnlyMiddleware' with the site's
+-- 'yesodMiddleware'.
+--
+-- Since 1.4.7
+sslOnlySessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+sslOnlySessions = (fmap . fmap) secureSessionCookies
+ where
+ setSecureBit cookie = cookie { setCookieSecure = True }
+ secureSessionCookies = customizeSessionCookies setSecureBit
+
+-- | Apply a Strict-Transport-Security header with the specified timeout to
+-- all responses so that browsers will rewrite all http links to https
+-- until the timeout expires. For security, the max-age of the STS header
+-- should always equal or exceed the client sessions timeout. This defends
+-- against hijacking attacks on the sessions of users who attempt to access
+-- the site using an http url. This middleware makes a site functionally
+-- inaccessible over vanilla http in all standard browsers.
+--
+-- Since 1.4.7
+sslOnlyMiddleware :: Yesod site
+ => Int -- ^ minutes
+ -> HandlerT site IO res
+ -> HandlerT site IO res
+sslOnlyMiddleware timeout handler = do
+ addHeader "Strict-Transport-Security"
+ $ T.pack $ concat [ "max-age="
+ , show $ timeout * 60
+ , "; includeSubDomains"
+ ]
+ handler
+
-- | Check if a given request is authorized via 'isAuthorized' and
-- 'isWriteRequest'.
--
@@ -570,7 +607,8 @@
-- would work across many subdomains:
--
-- @
--- makeSessionBackend = fmap (customizeSessionCookie addDomain) ...
+-- makeSessionBackend site =
+-- (fmap . fmap) (customizeSessionCookies addDomain) ...
-- where
-- addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }
-- @
diff --git a/test/YesodCoreTest.hs b/test/YesodCoreTest.hs
--- a/test/YesodCoreTest.hs
+++ b/test/YesodCoreTest.hs
@@ -20,6 +20,7 @@
import qualified YesodCoreTest.Reps as Reps
import qualified YesodCoreTest.Auth as Auth
import qualified YesodCoreTest.LiteApp as LiteApp
+import qualified YesodCoreTest.Ssl as Ssl
import Test.Hspec
@@ -44,3 +45,5 @@
Reps.specs
Auth.specs
LiteApp.specs
+ Ssl.unsecSpec
+ Ssl.sslOnlySpec
diff --git a/test/YesodCoreTest/Ssl.hs b/test/YesodCoreTest/Ssl.hs
new file mode 100644
--- /dev/null
+++ b/test/YesodCoreTest/Ssl.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec ) where
+import qualified YesodCoreTest.StubSslOnly as Ssl
+import qualified YesodCoreTest.StubUnsecured as Unsecured
+import Yesod.Core
+import Test.Hspec
+import Network.Wai
+import Network.Wai.Test
+import qualified Data.ByteString.Char8 as C8
+import qualified Web.Cookie as Cookie
+import qualified Data.List as DL
+
+type CookieSpec = Cookie.SetCookie -> Bool
+
+type ResponseExpectation = SResponse -> Session ()
+
+homeFixtureFor :: YesodDispatch a => a -> ResponseExpectation -> IO ()
+homeFixtureFor app assertion = do
+ wa <- toWaiApp app
+ runSession (getHome >>= assertion) wa
+ where
+ getHome = request defaultRequest
+
+cookieShouldSatisfy :: String -> CookieSpec -> ResponseExpectation
+cookieShouldSatisfy name spec response =
+ liftIO $
+ case DL.filter matchesName $ cookiesIn response of
+ [] -> expectationFailure $ DL.concat
+ [ "Expected a cookie named "
+ , name
+ , " but none is set"
+ ]
+ [c] -> c `shouldSatisfy` spec
+ _ -> expectationFailure $ DL.concat
+ [ "Expected one cookie named "
+ , name
+ , " but found more than one"
+ ]
+ where
+ matchesName c = (Cookie.setCookieName c) == C8.pack name
+ cookiesIn r =
+ DL.map
+ (Cookie.parseSetCookie . snd)
+ (DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders r)
+
+sslOnlySpec :: Spec
+sslOnlySpec = describe "A Yesod application with sslOnly on" $ do
+ it "serves a Strict-Transport-Security header in all responses" $
+ atHome $ assertHeader "Strict-Transport-Security"
+ "max-age=7200; includeSubDomains"
+ it "sets the Secure flag on its session cookie" $
+ atHome $ "_SESSION" `cookieShouldSatisfy` Cookie.setCookieSecure
+ where
+ atHome = homeFixtureFor Ssl.App
+
+unsecSpec :: Spec
+unsecSpec = describe "A Yesod application with sslOnly off" $ do
+ it "never serves a Strict-Transport-Security header" $ do
+ atHome $ assertNoHeader "Strict-Transport-Security"
+ it "does not set the Secure flag on its session cookie" $ do
+ atHome $ "_SESSION" `cookieShouldSatisfy` isNotSecure
+ where
+ atHome = homeFixtureFor Unsecured.App
+ isNotSecure c = not $ Cookie.setCookieSecure c
diff --git a/test/YesodCoreTest/StubSslOnly.hs b/test/YesodCoreTest/StubSslOnly.hs
new file mode 100644
--- /dev/null
+++ b/test/YesodCoreTest/StubSslOnly.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+module YesodCoreTest.StubSslOnly ( App ( App ) ) where
+
+import Yesod.Core
+import qualified Web.ClientSession as CS
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App where
+ yesodMiddleware = defaultYesodMiddleware . (sslOnlyMiddleware 120)
+ makeSessionBackend _ = sslOnlySessions $
+ fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile
+
+getHomeR :: Handler Html
+getHomeR = defaultLayout
+ [whamlet|
+
+ Welcome to my test application.
+ |]
diff --git a/test/YesodCoreTest/StubUnsecured.hs b/test/YesodCoreTest/StubUnsecured.hs
new file mode 100644
--- /dev/null
+++ b/test/YesodCoreTest/StubUnsecured.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
+module YesodCoreTest.StubUnsecured ( App ( App ) ) where
+
+import Yesod.Core
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App
+
+getHomeR :: Handler Html
+getHomeR = defaultLayout
+ [whamlet|
+
+ Welcome to my test application.
+ |]
diff --git a/yesod-core.cabal b/yesod-core.cabal
--- a/yesod-core.cabal
+++ b/yesod-core.cabal
@@ -1,5 +1,5 @@
name: yesod-core
-version: 1.4.6.2
+version: 1.4.7
license: MIT
license-file: LICENSE
author: Michael Snoyman
@@ -138,6 +138,8 @@
cpp-options: -DTEST
build-depends: base
,hspec >= 1.3
+ ,hspec-expectations
+ ,clientsession
,wai >= 3.0
,yesod-core
,bytestring
@@ -159,6 +161,7 @@
, streaming-commons
, wai-extra
, mwc-random
+ , cookie >= 0.4.1 && < 0.5
ghc-options: -Wall
extensions: TemplateHaskell