yesod-csp 0.1.1.0 → 0.2.0.0

raw patch · 5 files changed

+235/−32 lines, 5 filesdep +attoparsecdep +mono-traversabledep +sybPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, mono-traversable, syb, template-haskell, uniplate

API changes (from Hackage documentation)

Files

• src/Yesod/Csp.hs +40/−23
• src/Yesod/Csp/Example.hs +17/−3
• src/Yesod/Csp/TH.hs +134/−0
• test/Test.hs +35/−5
• yesod-csp.cabal +9/−1

@@ -1,9 +1,12 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-} -- | Add <http://content-security-policy.com/ CSP> 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. <http://content-security-policy.com/ See here> 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"

@@ -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 ()

@@ -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

@@ -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

@@ -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