yesod-middleware-csp (empty) → 1.0.0
raw patch · 8 files changed
+632/−0 lines, 8 filesdep +basedep +base64-bytestringdep +bytestring
Dependencies added: base, base64-bytestring, bytestring, case-insensitive, classy-prelude, classy-prelude-yesod, conduit, containers, directory, fast-logger, filepath, hspec, http-client, http-types, monad-logger, network-uri, template-haskell, text, time, uuid, wai-extra, yesod, yesod-core, yesod-static, yesod-test
Files
- LICENSE +21/−0
- README.md +52/−0
- src/Yesod/Middleware/CSP.hs +289/−0
- test/ExampleApp.hs +85/−0
- test/Spec.hs +1/−0
- test/TestImport.hs +48/−0
- test/Yesod/Middleware/CSPSpec.hs +58/−0
- yesod-middleware-csp.cabal +78/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2019 Jezen Thomas++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,52 @@+# yesod-middleware-csp++Deals with CSP without disabling it.+This is done by overriding the default yesod+provided addScript functionalities and adding+a nonce to the tag, and the right headers to the request.++## Usage++Because there is no good way of enforcing CSP+at typelevel in yesod,+It's best to override classy prelude with your+own custom prelude.+This allows hiding the addScript functions from+there with the ones provided by this library:++```haskell++-- | Mirrors classy prelude yesod but with our supercede patches+module Supercede.Prelude.Yesod+ ( -- * rexport+ module X+ -- ** use CSP variant instead of yesod's+ , addScriptEither+ , addScript+ , addScriptRemote+ ) where++import Supercede.Prelude as X hiding (delete, deleteBy, Handler (..))+import Yesod as X hiding (addScriptEither, addScript, addScriptRemote, addScriptAttrs, addScriptRemoteAttrs)++import Yesod.Middleware.CSP (addScriptEither, addScript, addScriptRemote)++```++Then in hlint you can simply dis-recommend usage of classy prelude:++```haskell+- modules:+ - {name: [ClassyPrelude], message: "Use Supercede.Prelude instead"}+ - {name: [ClassyPrelude.Yesod], message: "Use Supercede.Prelude.Yesod instead"}+```++## How to run tests++```+cabal configure --enable-tests && cabal build && cabal test+```++## Contributing++PR's are welcome.
+ src/Yesod/Middleware/CSP.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Deals with CSP without disabling it.+-- This is done by overriding the default yesod+-- provided addScript functionalities and adding+-- a nonce to the tag, and the right headers to the request.+module Yesod.Middleware.CSP+ ( CombineSettings (..)+ , CSPNonce (..)+ , Directive (..)+ , Source (..)+ , addCSP+ , addCSPMiddleware+ , addScript+ , addScriptEither+ , addScriptRemote+ , combineScripts'+ , combineStylesheets'+ , getRequestNonce+ ) where++import ClassyPrelude+import Conduit hiding (Source)+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as L+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import Data.UUID (toASCIIBytes)+import Data.UUID.V4 (nextRandom)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax as TH+import System.Directory+import System.FilePath (takeDirectory)+import qualified System.FilePath as F+import Yesod.Core(HandlerSite, MonadWidget, MonadHandler, HandlerFor)+import qualified Yesod.Core as Core+import Yesod.Static hiding+ (CombineSettings, combineScripts', combineStylesheets')++type DirSet = Map Directive (Set Source)++newtype CSPNonce = CSPNonce { unCSPNonce :: Text } deriving (Eq, Ord)++data Source+ = Wildcard+ | None+ | Self+ | DataScheme+ | BlobScheme+ | Host Text+ | Https+ | Http+ | UnsafeInline+ | UnsafeEval+ | StrictDynamic+ | Nonce Text+ deriving (Eq, Ord)++instance IsString Source where+ fromString = Host . pack++instance Show Source where+ show Wildcard = "*"+ show None = "'none'"+ show Self = "'self'"+ show DataScheme = "data:"+ show BlobScheme = "blob:"+ show (Host h) = unpack h+ show Https = "https:"+ show Http = "http:"+ show UnsafeInline = "'unsafe-inline'"+ show UnsafeEval = "'unsafe-eval'"+ show StrictDynamic = "'strict-dynamic'"+ show (Nonce n) = "'nonce-" <> unpack n <> "'"++data Directive+ = DefaultSrc+ | StyleSrc+ | ScriptSrc+ | ObjectSrc+ | ImgSrc+ | FontSrc+ | ConnectSrc+ | MediaSrc+ | FrameSrc+ | FormAction+ | FrameAncestors+ | BaseURI+ | ReportURI+ deriving (Eq, Ord)++instance Show Directive where+ show DefaultSrc = "default-src"+ show StyleSrc = "style-src"+ show ScriptSrc = "script-src"+ show ObjectSrc = "object-src"+ show ImgSrc = "img-src"+ show FontSrc = "font-src"+ show ConnectSrc = "connect-src"+ show MediaSrc = "media-src"+ show FrameSrc = "frame-src"+ show FormAction = "form-action"+ show FrameAncestors = "frame-ancestors"+ show BaseURI = "base-uri"+ show ReportURI = "report-uri"++cachedDirectives :: MonadHandler m => m DirSet+cachedDirectives = fromMaybe M.empty <$> Core.cacheGet++-- | Add a directive to the current Content-Security Policy+addCSP :: MonadWidget m => Directive -> Source -> m ()+addCSP d s = cachedDirectives+ >>= Core.cacheSet . M.insertWith insertSource d (S.singleton s)++insertSource :: Set Source -> Set Source -> Set Source+insertSource a b = case S.toList a of+ [ None ] -> a+ _ -> a <> S.filter (`notElem` [None]) b++showSources :: Set Source -> Text+showSources = pack . unwords . map show . S.toList++showDirective :: (Directive, Set Source) -> Text+showDirective (d, s) = tshow d <> " " <> showSources s++showDirectives :: DirSet -> Text+showDirectives = intercalate "; " . map showDirective . M.toList++cspHeaderName :: Text+cspHeaderName = "Content-Security-Policy"++augment :: Maybe CSPNonce -> DirSet -> DirSet+augment Nothing d = d+augment (Just (CSPNonce n)) d =+ let srcs = S.fromList [ Nonce n ]+ existingScriptSrcs = S.toList (fromMaybe S.empty (lookup ScriptSrc d))+ in if any (`elem` existingScriptSrcs) [ None ]+ then d+ else M.insertWith insertSource ScriptSrc srcs d++addCSPMiddleware :: (HandlerFor m) a -> (HandlerFor m) a+addCSPMiddleware handler = do+ (r, n) <- (,) <$> handler <*> Core.cacheGet+ d <- augment n <$> cachedDirectives+ when (not (null (showDirectives d))) $+ Core.addHeader cspHeaderName (showDirectives d)+ pure r++-- | Get a nonce for the request+--+-- CSP nonces must be unique per request, but they do not need to be unique+-- amongst themselves. This function checks the per-request cache to see if we+-- have already generated a nonce. If we have, we use the cached value. If this+-- is the first call to this function for the request, we generate a new+-- @CSPNonce@ by base64-encoding a UUIDV4 value.+--+-- n.b. It is not important to use a high-quality random value to generate the+-- nonce, but @Data.UUID.V4.nextRandom@ just happens to be faster than+-- @System.Random.randomIO@.+getRequestNonce :: MonadHandler m => m CSPNonce+getRequestNonce = Core.cacheGet >>= maybe mkNonce pure+ where mkNonce = do+ let decode = decodeUtf8 . B64.encode . toASCIIBytes+ nonce <- CSPNonce . decode <$> liftIO nextRandom+ Core.cacheSet nonce+ pure nonce++-- | Add a local JavaScript asset to the widget+--+-- This is intended to a be a drop-in replacement for+-- @Yesod.Core.Widget.addScript@. It takes the nonce generated for the current+-- request and embeds it as an HTML attribute in the script tag.+addScript :: MonadWidget m => Route (HandlerSite m) -> m ()+addScript route = addScriptAttrs route []++addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()+addScriptAttrs route attrs = do+ nonce <- getRequestNonce+ Core.addScriptAttrs route $ ("nonce", unCSPNonce nonce) : attrs++-- | Add a remote JavaScript asset to the widget+--+-- The same notes for @addScript@ apply here.+addScriptRemote :: MonadWidget m => Text -> m ()+addScriptRemote uri = addScriptRemoteAttrs uri []++addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()+addScriptRemoteAttrs uri attrs = do+ nonce <- getRequestNonce+ Core.addScriptRemoteAttrs uri $ ("nonce", unCSPNonce nonce) : attrs++addScriptEither :: MonadWidget m => Either (Route (HandlerSite m)) Text -> m ()+addScriptEither = either addScript addScriptRemote++data CombineSettings = CombineSettings+ { csStaticDir :: FilePath+ -- ^ File path containing static files.+ , csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString+ -- ^ Post processing to be performed on CSS files.+ , csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString+ -- ^ Post processing to be performed on Javascript files.+ , csCssPreProcess :: TL.Text -> IO TL.Text+ -- ^ Pre-processing to be performed on CSS files.+ , csJsPreProcess :: TL.Text -> IO TL.Text+ -- ^ Pre-processing to be performed on Javascript files.+ , csCombinedFolder :: FilePath+ -- ^ Subfolder to put combined files into.+ }++data CombineType = JS | CSS++combineStatics' :: CombineType+ -> CombineSettings+ -> [Route Static] -- ^ files to combine+ -> Q Exp+combineStatics' combineType CombineSettings {..} routes = do+ texts <- qRunIO $ runConduitRes+ $ yieldMany fps+ .| awaitForever readUTFFile+ .| sinkLazy+ ltext <- qRunIO $ preProcess texts+ bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext+ let hash' = base64md5 bs+ suffix = csCombinedFolder </> hash' <.> extension+ fp = csStaticDir </> suffix+ qRunIO $ do+ createDirectoryIfMissing True $ takeDirectory fp+ L.writeFile fp bs+ let pieces = map T.unpack $ T.splitOn "/" $ T.pack suffix+ [|StaticRoute (map pack pieces) []|]+ where+ fps :: [FilePath]+ fps = map toFP routes+ toFP (StaticRoute pieces _) = csStaticDir </> F.joinPath (map T.unpack pieces)+ readUTFFile fp = sourceFile fp .| decodeUtf8C+ postProcess =+ case combineType of+ JS -> csJsPostProcess+ CSS -> csCssPostProcess+ preProcess =+ case combineType of+ JS -> csJsPreProcess+ CSS -> csCssPreProcess+ extension =+ case combineType of+ JS -> "js"+ CSS -> "css"++liftRoutes :: [Route Static] -> Q Exp+liftRoutes =+ fmap ListE . mapM go+ where+ go :: Route Static -> Q Exp+ go (StaticRoute x y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|]++ liftTexts = fmap ListE . mapM liftT+ liftT t = [|pack $(TH.lift $ unpack t)|]++ liftPairs = fmap ListE . mapM liftPair+ liftPair (x, y) = [|($(liftT x), $(liftT y))|]++-- | Combine multiple CSS files together+combineStylesheets' :: Bool -- ^ development? if so, perform no combining+ -> CombineSettings+ -> Name -- ^ Static route constructor name, e.g. \'StaticR+ -> [Route Static] -- ^ files to combine+ -> Q Exp+combineStylesheets' development cs con routes+ | development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |]+ | otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |]+++-- | Combine multiple JS files together+combineScripts' :: Bool -- ^ development? if so, perform no combining+ -> CombineSettings+ -> Name -- ^ Static route constructor name, e.g. \'StaticR+ -> [Route Static] -- ^ files to combine+ -> Q Exp+combineScripts' development cs con routes+ | development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |]+ | otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |]
+ test/ExampleApp.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module ExampleApp where++import ClassyPrelude.Yesod hiding (addScript, addScriptRemote)+import Yesod.Core.Types (Logger)+import Yesod.EmbeddedStatic+import Yesod.Middleware.CSP++data ExampleApp = ExampleApp+ { appLogger :: Logger+ , getStatic :: EmbeddedStatic+ }++mkEmbeddedStatic False "eStatic" [ embedDir "test/static" ]++mkYesod "ExampleApp" [parseRoutes|+/static StaticR EmbeddedStatic getStatic++/1 Example1 GET+/2 Example2 GET+/3 Example3 GET+/4 Example4 GET+/5 Example5 GET+/6 Example6 GET+/7 Example7 GET+/8 Example8 GET+|]++getExample1 :: Handler Html+getExample1 = defaultLayout $ do+ addCSP ScriptSrc Https+ addCSP ScriptSrc StrictDynamic+ addCSP ObjectSrc None+ toWidget $ asText ""++getExample2 :: Handler Html+getExample2 = defaultLayout $ do+ addCSP ScriptSrc None+ addCSP ScriptSrc Wildcard+ toWidget $ asText ""++getExample3 :: Handler Html+getExample3 = defaultLayout $ do+ addCSP ScriptSrc Wildcard+ addCSP ScriptSrc None+ toWidget $ asText ""++getExample4 :: Handler Html+getExample4 = defaultLayout $ do+ addCSP ScriptSrc Wildcard+ addCSP ScriptSrc None+ addCSP ScriptSrc DataScheme+ addCSP ScriptSrc Https+ toWidget $ asText ""++getExample5 :: Handler Html+getExample5 = defaultLayout $ do+ addScript $ StaticR js_test_js+ toWidget $ asText ""++getExample6 :: Handler Html+getExample6 = defaultLayout $ do+ addScriptRemote "https://example.com/test.js"+ toWidget $ asText ""++getExample7 :: Handler Html+getExample7 = defaultLayout $ toWidget $ asText ""++getExample8 :: Handler Html+getExample8 = defaultLayout $ do+ addScript $ StaticR js_test_js+ addCSP ScriptSrc None+ toWidget $ asText ""++instance Yesod ExampleApp where+ yesodMiddleware = addCSPMiddleware+ addStaticContent = embedStaticContent getStatic StaticR Right
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImport.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module TestImport+ ( module TestImport+ , module X+ ) where++import qualified Data.Map.Strict as M+import qualified System.Log.FastLogger as F+import qualified Yesod+import qualified Yesod.Default.Config2 as C++import ClassyPrelude as X hiding (Handler, delete, deleteBy)+import Control.Monad (when)+import Data.CaseInsensitive (CI)+import ExampleApp as X+import Network.Wai.Test (SResponse(..))+import Test.Hspec as X+import Yesod.Test as X+import Yesod.Test.TransversingCSS (Query, findAttributeBySelector)++withApp :: SpecWith (TestApp ExampleApp) -> Spec+withApp = before $ do+ logF <- F.newStdoutLoggerSet 1 >>= C.makeYesodLogger+ pure (ExampleApp logF eStatic, Yesod.defaultMiddlewaresNoLogging)++assertCSP :: HasCallStack => ByteString -> YesodExample site ()+assertCSP = assertHeader "Content-Security-Policy"++lookupResponseHeader :: CI ByteString -> YesodExample site (Maybe ByteString)+lookupResponseHeader k = (lookupHeader =<<) <$> getResponse+ where lookupHeader = lookup k . M.fromList . simpleHeaders++getNonceFromCSP :: YesodExample site (Maybe ByteString)+getNonceFromCSP = lookupResponseHeader "Content-Security-Policy"+ >>= \h -> pure $ filter (isPrefixOf "'nonce-") . words . decodeUtf8 <$> h+ >>= fmap (encodeUtf8 . dropEnd 1 . dropPrefix "'nonce-") . headMay++getAttrFromResponseMatch :: Query -> Text -> YesodExample site (Maybe Text)+getAttrFromResponseMatch q a = do+ body <- getAttr . simpleBody <<$>> getResponse+ pure $ body >>= either (const Nothing) headMay >>= headMay+ where getAttr b = findAttributeBySelector b q a++infixl 4 <<$>>+(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+(<<$>>) = fmap . fmap
+ test/Yesod/Middleware/CSPSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Middleware.CSPSpec (spec) where++import Data.Maybe (fromJust)+import TestImport++spec :: Spec+spec = withApp $ do++ describe "composing directives" $++ it "groups sources by directive" $ do+ get Example1+ assertCSP "script-src https: 'strict-dynamic'; object-src 'none'"++ describe "with an exclusive directive" $ do++ it "the last applied exclusive directive wins" $ do+ get Example2+ assertCSP "script-src *"++ get Example3+ assertCSP "script-src 'none'"++ it "subsequent non-exlusive directives disable exclusive directives" $ do+ get Example4+ assertCSP "script-src data: https:"++ describe "when the user includes a local JavaScript asset" $++ it "adds the nonce to both the script tag and the header" $ do+ get Example5+ h <- getNonceFromCSP+ a <- getAttrFromResponseMatch "script" "nonce"+ assertCSP $ "script-src 'nonce-" <> fromJust h <> "'"+ assertEq "match" h (encodeUtf8 <$> a)++ describe "when the user includes a remote JavaScript asset" $++ it "adds the nonce to both the script tag and the header" $ do+ get Example6+ h <- getNonceFromCSP+ a <- getAttrFromResponseMatch "script" "nonce"+ assertCSP $ "script-src 'nonce-" <> fromJust h <> "'"+ assertEq "match" h (encodeUtf8 <$> a)++ describe "when no CSP directives are added" $++ it "does not add a CSP header" $ do+ get Example7+ assertNoHeader "Content-Security-Policy"++ describe "when non-exclusive directives have been set" $++ it "they are overwritten by exclusive directives" $ do+ get Example8+ assertCSP "script-src 'none'"
+ yesod-middleware-csp.cabal view
@@ -0,0 +1,78 @@+Cabal-Version: >= 1.10+Name: yesod-middleware-csp+Version: 1.0.0+Author: Jezen Thomas <jezen@riskbook.com>+Maintainer: Jezen Thomas <jezen@riskbook.com>+License: MIT+License-File: LICENSE+Build-Type: Simple+Description: Deals with CSP without disabling it.+ This is done by overriding the default yesod+ provided addScript functionalities and adding+ a nonce to the tag, and the right headers to the request.+Extra-Source-Files: README.md+Category: Web, Yesod+Synopsis: A middleware for building CSP headers on the fly++Library+ Default-Language: Haskell2010+ HS-Source-Dirs: src+ GHC-Options: -Wall+ Default-Extensions: NoImplicitPrelude+ Exposed-Modules: Yesod.Middleware.CSP+ Build-Depends:+ base >= 4 && < 5+ , base64-bytestring+ , bytestring >=0.9 && <0.11+ , classy-prelude >=0.10.2+ , conduit+ , containers+ , directory+ , filepath+ , http-client+ , network-uri+ , template-haskell+ , text+ , time+ , uuid+ , yesod >= 1.6.0+ , yesod-core >= 1.6.15+ , yesod-static >= 1.6 && <1.7++Test-Suite spec+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , test+ Ghc-Options: -Wall+ Default-Extensions: NoImplicitPrelude+ Main-Is: Spec.hs+ Build-Depends:+ base+ , base64-bytestring+ , bytestring >=0.9 && <0.11+ , case-insensitive+ , classy-prelude >=0.10.2+ , classy-prelude-yesod >= 1.1+ , conduit+ , containers+ , directory+ , fast-logger+ , filepath+ , hspec+ , http-types+ , monad-logger+ , network-uri+ , template-haskell+ , text+ , uuid+ , wai-extra >=3.0+ , yesod+ , yesod-core >= 1.6.15 && < 1.7+ , yesod-static >=1.6 && <1.7+ , yesod-test+ Other-Modules:+ ExampleApp+ TestImport+ Yesod.Middleware.CSP+ Yesod.Middleware.CSPSpec