diff --git a/src/Yesod/Csp.hs b/src/Yesod/Csp.hs --- a/src/Yesod/Csp.hs +++ b/src/Yesod/Csp.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} -- | Add headers to Yesod apps. -- This helps reduce the risk of exposure to XSS and bad assets. module Yesod.Csp ( cspPolicy , getCspPolicy + , EscapedURI + , escapeAndParseURI , DirectiveList , Directive(..) , SourceList @@ -11,9 +14,11 @@ , SandboxOptions(..) ) where +import Data.Data (Data) import Data.List.NonEmpty -import Data.Text hiding (filter, null) -import qualified Data.Text as T +import qualified Data.Sequences as S +import Data.Text +import Data.Typeable (Typeable) import Network.URI import Yesod.Core @@ -34,24 +39,48 @@ getCspPolicy :: DirectiveList -> Text getCspPolicy = directiveListToHeader -withSpaces :: [Text] -> Text -withSpaces = T.intercalate " " +newtype EscapedURI = EscapedURI { uri :: URI } deriving (Eq, Data, Typeable) +instance Show EscapedURI where + show x = show (uri x) + +-- | Escapes ';' '\'' and ' ', and parses to URI +escapeAndParseURI :: Text -> Maybe EscapedURI +escapeAndParseURI = fmap EscapedURI . parseURI . escapeURIString f . unpack + where f :: Char -> Bool + f = not . flip elem toEscape + toEscape :: String + toEscape = ";'* " + +directiveListToHeader :: DirectiveList -> Text +directiveListToHeader = S.intercalate "; " . fmap textDirective + w :: Text -> SourceList -> Text w = wrap wrap :: Text -> SourceList -> Text wrap k x = mconcat [k, " ", textSourceList x] +textSourceList :: SourceList -> Text +textSourceList = S.unwords . toList . filtered + where filtered = fmap textSource . filterOut + +-- * and none should be alone if present +filterOut :: SourceList -> SourceList +filterOut x | Wildcard `elem` x = Wildcard :| [] +filterOut x | None `elem` x = None :| [] + | otherwise = x + -- | Represents a location from which assets may be loaded. data Source = Wildcard | None | Self | DataScheme - | Host URI + | Host EscapedURI | Https | UnsafeInline - | UnsafeEval deriving (Eq) + | UnsafeEval + | MetaSource Text deriving (Eq, Show, Data, Typeable) -- | A list of allowed sources for a directive. type SourceList = NonEmpty Source @@ -65,16 +94,7 @@ textSource Https = "https:" textSource UnsafeInline = "'unsafe-inline'" textSource UnsafeEval = "'unsafe-eval'" - -textSourceList :: SourceList -> Text -textSourceList = withSpaces . toList . filtered - where filtered = fmap textSource . filterOut - --- * and none should be alone if present -filterOut :: SourceList -> SourceList -filterOut x | Wildcard `elem` x = Wildcard :| [] -filterOut x | None `elem` x = None :| [] - | otherwise = x +textSource (MetaSource _) = "" -- | A list of restrictions to apply. type DirectiveList = [Directive] @@ -92,16 +112,13 @@ | FrameSrc SourceList -- | Applies a sandbox to the result. for more info. | Sandbox [SandboxOptions] - | ReportUri URI + | ReportUri EscapedURI deriving (Eq, Show, Data, Typeable) -- | Configuration options for the sandbox. data SandboxOptions = AllowForms | AllowScripts | AllowSameOrigin - | AllowTopNavigation - -directiveListToHeader :: DirectiveList -> Text -directiveListToHeader = T.intercalate "; " . fmap textDirective + | AllowTopNavigation deriving (Eq, Show, Data, Typeable) textDirective :: Directive -> Text textDirective (DefaultSrc x) = w "default-src" x @@ -115,7 +132,7 @@ textDirective (FrameSrc x) = w "frame-src" x textDirective (ReportUri t) = mconcat ["report-uri ", (pack . show) t] textDirective (Sandbox []) = "sandbox" -textDirective (Sandbox s) = mconcat ["sandbox ", withSpaces . fmap textSandbox $ s] +textDirective (Sandbox s) = mconcat ["sandbox ", S.unwords . fmap textSandbox $ s] where textSandbox AllowForms = "allow-forms" textSandbox AllowScripts = "allow-scripts" textSandbox AllowSameOrigin = "allow-same-origin" diff --git a/src/Yesod/Csp/Example.hs b/src/Yesod/Csp/Example.hs --- a/src/Yesod/Csp/Example.hs +++ b/src/Yesod/Csp/Example.hs @@ -5,11 +5,12 @@ -- | Assorted examples demonstrating different policies. module Yesod.Csp.Example where +import Data.Generics.Uniplate.Data import Data.List.NonEmpty import Data.Maybe -import Network.URI -import Yesod hiding (get) +import Yesod hiding (get) import Yesod.Csp +import Yesod.Csp.TH data Example = Example mkYesod "Example" [parseRoutes| @@ -20,6 +21,7 @@ /5 Example5R GET /6 Example6R GET /7 Example7R GET POST + /8 Example8R GET |] instance Yesod Example @@ -43,7 +45,7 @@ -- | Allows images from a certain uri. getExample3R :: Handler Html getExample3R = do - let dom = fromJust (parseURI "http://httpbin.org") + let dom = fromJust (escapeAndParseURI "http://httpbin.org") cspPolicy [ImgSrc (Host dom :| [])] defaultLayout $ [whamlet| @@ -94,6 +96,18 @@ cspPolicy [Sandbox [AllowForms]] defaultLayout $ [whamlet|yayyy|] + +cdn :: Source +cdn = Host (fromJust $ escapeAndParseURI "https://cdn.com") + +getExample8R :: Handler Html +getExample8R = do + let policy = [csp|script-src 'self'|] + cspPolicy $ addCdn <$> policy + defaultLayout [whamlet|wooo|] + where addCdn = transform f + f (ScriptSrc x) = ScriptSrc $ cdn <| x + f x = x -- | Run a webserver to serve these examples at /1, /2, etc. runExamples :: IO () diff --git a/src/Yesod/Csp/TH.hs b/src/Yesod/Csp/TH.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Csp/TH.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Yesod.Csp.TH ( + source + , withSourceList + , reportUri + , sandbox + , sandboxOptions + , directive + , csp + ) where + +import Control.Applicative +import Data.Attoparsec.Text +import Data.Generics +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Text as T +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote +import Yesod.Csp + +csp :: QuasiQuoter +csp = QuasiQuoter { + quoteExp = \str -> do + let c = parseOnly directive (T.pack str) + case c of + Left err -> error $ "csp parsing error: " ++ err -- compile time error + Right x -> dataToExpQ (const Nothing `extQ` antiCsp) x + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +antiCsp :: Source -> Maybe (TH.Q TH.Exp) +antiCsp (MetaSource x) = Just . return $ TH.AppE (TH.ConE (TH.mkName "Host")) (TH.VarE (TH.mkName (T.unpack x))) +antiCsp _ = Nothing + +metaSource :: Parser Source +metaSource = do + _ <- char '$' + x <- many (digit <|> letter) + return $ MetaSource (T.pack x) + +source :: Parser Source +source = wildcard + <|> none + <|> self + <|> dataScheme + <|> https + <|> host + <|> unsafeInline + <|> unsafeEval + <|> metaSource + where wildcard = string "*" *> pure Wildcard + none = string "'none'" *> pure None + self = string "'self'" *> pure Self + dataScheme = string "data:" *> pure DataScheme + host :: Parser Source + host = do + u <- takeTill separated + case escapeAndParseURI u of + Nothing -> fail "host" + Just uri -> return $ Host uri + https = do + _ <- string "https:" + c <- peekChar + case c of + (Just ' ') -> return Https + (Just ';') -> return Https + Nothing -> return Https + _ -> fail "https" + unsafeInline = string "unsafe-inline" *> pure UnsafeInline + unsafeEval = string "unsafe-eval" *> pure UnsafeEval + +separated :: Char -> Bool +separated x = x == ';' || x == ' ' + +-- Safe to head and tail these sources as they come from the `sepBy1` combinator +mkWithSource :: (NonEmpty Source -> Directive) -> [Source] -> Parser Directive +mkWithSource f x = pure $ f (head x :| tail x) + +withSourceList :: Parser Directive +withSourceList = defaultSrc + <|> scriptSrc + <|> scriptSrc + <|> styleSrc + <|> imgSrc + <|> connectSrc + <|> fontSrc + <|> objectSrc + <|> mediaSrc + <|> frameSrc + where defaultSrc = d "default-src" DefaultSrc + scriptSrc = d "script-src" ScriptSrc + styleSrc = d "style-src" StyleSrc + imgSrc = d "img-src" ImgSrc + connectSrc = d "connect-src" ConnectSrc + fontSrc = d "font-src" FontSrc + objectSrc = d "object-src" ObjectSrc + mediaSrc = d "media-src" MediaSrc + frameSrc = d "frame-src" FrameSrc + d x y = string x >> s >> slist >>= mkWithSource y + slist = sepBy1 source (char ' ') + s = string " " + +reportUri :: Parser Directive +reportUri = do + _ <- string "report-uri" + _ <- string " " + u <- takeTill separated + case escapeAndParseURI u of + Nothing -> fail "reportUri" -- n.b. compile time error + Just uri -> return $ ReportUri uri + +sandbox :: Parser Directive +sandbox = do + _ <- string "sandbox" + _ <- string " " + x <- sepBy sandboxOptions (char ' ') + return $ Sandbox x + +sandboxOptions :: Parser SandboxOptions +sandboxOptions = allowForms + <|> allowScripts + <|> allowSameOrigin + <|> allowTopNavigation + where allowForms = string "allow-forms" *> pure AllowForms + allowScripts = string "allow-scripts" *> pure AllowScripts + allowSameOrigin = string "allow-same-origin" *> pure AllowSameOrigin + allowTopNavigation = string "allow-top-navigation" *> pure AllowTopNavigation + +directive :: Parser DirectiveList +directive = sepBy d (string "; ") <* endOfInput + where d = withSourceList <|> reportUri <|> sandbox diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -4,12 +4,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +import Data.Attoparsec.Text import Data.List.NonEmpty import Data.Maybe -import Network.URI import Test.Hspec -import Yesod hiding (get) +import Yesod hiding (get) import Yesod.Csp +import Yesod.Csp.TH import Yesod.Test data Test = Test @@ -29,13 +30,19 @@ let header = getCspPolicy [ScriptSrc (Self :| []), StyleSrc (Https :| [Self])] assertEqual "simple header" header "script-src 'self'; style-src https: 'self'" yit "works with domains" $ do - let dom = fromJust $ parseURI "https://foo.com" + let dom = fromJust $ escapeAndParseURI "https://foo.com/bar *" header = getCspPolicy [ScriptSrc (Host dom :| [])] - assertEqual "foo.com script-src" header "script-src https://foo.com" + assertEqual "foo.com script-src" header "script-src https://foo.com/bar%20%2A" yit "works with report_uri" $ do - let dom = fromJust $ parseURI "https://foo.com" + let dom = fromJust $ escapeAndParseURI "https://foo.com" header = getCspPolicy [ReportUri dom] assertEqual "report-uri" header "report-uri https://foo.com" + yit "enforces wildcards" $ do + let header = getCspPolicy [ScriptSrc (Wildcard :| [Https])] + assertEqual "* should be alone" header "script-src *" + yit "enforces nones" $ do + let header = getCspPolicy [ScriptSrc (None :| [Https])] + assertEqual "none should be alone" header "script-src 'none'" ydescribe "Headers" $ yit "get set" $ do get HomeR @@ -47,3 +54,26 @@ yit "works when not empty" $ do let header = getCspPolicy [Sandbox [AllowForms, AllowScripts]] assertEqual "empty sandbox" header "sandbox allow-forms allow-scripts" + ydescribe "Parsing" $ do + yit "works" $ do + assertEqual "*" (parseOnly source "*") (Right Wildcard) + assertEqual "none" (parseOnly source "'none'") (Right None) + assertEqual "self" (parseOnly source "'self'") (Right Self) + assertEqual "data:" (parseOnly source "data:") (Right DataScheme) + assertEqual "https://foo.com" (parseOnly source "https://foo.com") (Right $ Host (fromJust (escapeAndParseURI "https://foo.com"))) + assertEqual "https:" (parseOnly source "https:") (Right Https) + assertEqual "unsafe-inline" (parseOnly source "unsafe-inline") (Right UnsafeInline) + assertEqual "unsafe-eval" (parseOnly source "unsafe-eval") (Right UnsafeEval) + assertEqual "default-src self data:" (parseOnly withSourceList "default-src 'self' data:") (Right $ DefaultSrc (Self :| [DataScheme])) + assertEqual "report-uri http://hello.com" (parseOnly reportUri "report-uri http://hello.com") (Right $ ReportUri (fromJust (escapeAndParseURI "http://hello.com"))) + assertEqual "sandbox allow-forms allow-scripts" (parseOnly sandbox "sandbox allow-forms allow-scripts") (Right $ Sandbox [AllowForms, AllowScripts]) + yit "works with lists" $ do + let result = [ImgSrc $ Self :| [Https], ScriptSrc $ Host (fromJust $ escapeAndParseURI "https://foo.com") :| []] + assertEqual "scripts and images" (parseOnly directive "img-src 'self' https:; script-src https://foo.com") (Right result) + let result = [ImgSrc $ Self :| [DataScheme, Host (fromJust $ escapeAndParseURI "https://foo.com")]] + assertEqual "data and hosts" (parseOnly directive "img-src 'self' data: https://foo.com") (Right result) + yit "works with th" $ do + let result = [ImgSrc $ Self :| [Https], ScriptSrc $ Host (fromJust $ escapeAndParseURI "https://foo.com") :| []] + assertEqual "with th" [csp|img-src 'self' https:; script-src https://foo.com|] result + let url = fromJust $ escapeAndParseURI "https://foo.com" + assertEqual "with antiquoting" [csp|img-src 'self' https:; script-src $url|] result diff --git a/yesod-csp.cabal b/yesod-csp.cabal --- a/yesod-csp.cabal +++ b/yesod-csp.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yesod-csp -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Add CSP headers to Yesod apps description: Add CSP headers to Yesod apps. This helps reduce exposure to XSS attacks and bad assets. license: MIT @@ -20,6 +20,7 @@ library exposed-modules: Yesod.Csp , Yesod.Csp.Example + , Yesod.Csp.TH -- other-extensions: build-depends: base < 5 , text @@ -27,6 +28,11 @@ , semigroups , network-uri , yesod + , mono-traversable + , attoparsec + , template-haskell + , uniplate + , syb hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -43,4 +49,6 @@ , yesod , hspec , network-uri + , attoparsec + , template-haskell default-language: Haskell2010