added functions to simplify application of an ssl-only policy to a site

yesod-core/Yesod/Core.hs

@@ -47,6 +47,8 @@ module Yesod.Core
     , defaultClientSessionBackend
     , envClientSessionBackend
     , clientSessionBackend
+    , sslOnlySessions
+    , sslOnlyMiddleware
     , clientSessionDateCacher
     , loadClientSession
     , Header(..)

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -310,6 +310,39 @@ defaultYesodMiddleware handler = do
     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'.
+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.
+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 +603,8 @@ formatLogMessage getdate loc src level msg = do
 -- would work across many subdomains:
 --
 -- @
--- makeSessionBackend = fmap (customizeSessionCookie addDomain) ...
+-- makeSessionBackend site =
+--     (fmap . fmap) (customizeSessionCookies addDomain) ...
 --   where
 --     addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }
 -- @

yesod-core/test/YesodCoreTest.hs

@@ -20,6 +20,7 @@ import qualified YesodCoreTest.Streaming as Streaming
 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 @@ specs = do
       Reps.specs
       Auth.specs
       LiteApp.specs
+      Ssl.unsecSpec
+      Ssl.sslOnlySpec

yesod-core/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

yesod-core/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|
+        <p>
+            Welcome to my test application.
+    |]

yesod-core/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|
+        <p>
+            Welcome to my test application.
+    |]

yesod-core/yesod-core.cabal

@@ -138,6 +138,8 @@ test-suite tests
     cpp-options:   -DTEST
     build-depends: base
                   ,hspec >= 1.3
+                  ,hspec-expectations
+                  ,clientsession
                   ,wai >= 3.0
                   ,yesod-core
                   ,bytestring
@@ -159,6 +161,7 @@ test-suite tests
                   , streaming-commons
                   , wai-extra
                   , mwc-random
+                  , cookie >= 0.4.1    && < 0.5
     ghc-options:     -Wall
     extensions: TemplateHaskell