From 8b7c58f381f738b359ba9a6280917b9f06e4c184 Mon Sep 17 00:00:00 2001 From: Patrick Boe Date: Sat, 20 Dec 2014 10:26:32 -0500 Subject: [PATCH] added functions to simplify application of an ssl-only policy to a site --- yesod-core/Yesod/Core.hs | 2 + yesod-core/Yesod/Core/Class/Yesod.hs | 36 ++++++++++- yesod-core/test/YesodCoreTest.hs | 3 + yesod-core/test/YesodCoreTest/Ssl.hs | 64 +++++++++++++++++++ yesod-core/test/YesodCoreTest/StubSslOnly.hs | 23 +++++++ .../test/YesodCoreTest/StubUnsecured.hs | 19 ++++++ yesod-core/yesod-core.cabal | 3 + 7 files changed, 149 insertions(+), 1 deletion(-) create mode 100644 yesod-core/test/YesodCoreTest/Ssl.hs create mode 100644 yesod-core/test/YesodCoreTest/StubSslOnly.hs create mode 100644 yesod-core/test/YesodCoreTest/StubUnsecured.hs diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index afd5235e..f7436e66 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -47,6 +47,8 @@ module Yesod.Core , defaultClientSessionBackend , envClientSessionBackend , clientSessionBackend + , sslOnlySessions + , sslOnlyMiddleware , clientSessionDateCacher , loadClientSession , Header(..) diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index 6162ce03..fa22715d 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/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\" } -- @ diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index af4ed550..9d40de40 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/Ssl.hs b/yesod-core/test/YesodCoreTest/Ssl.hs new file mode 100644 index 00000000..b6162c0f --- /dev/null +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/StubSslOnly.hs b/yesod-core/test/YesodCoreTest/StubSslOnly.hs new file mode 100644 index 00000000..3ee24fd2 --- /dev/null +++ b/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| +

+ Welcome to my test application. + |] diff --git a/yesod-core/test/YesodCoreTest/StubUnsecured.hs b/yesod-core/test/YesodCoreTest/StubUnsecured.hs new file mode 100644 index 00000000..44367dae --- /dev/null +++ b/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| +

+ Welcome to my test application. + |] diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 19b018c5..240412fc 100644 --- a/yesod-core/yesod-core.cabal +++ b/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