yesod-csp 0.2.0.0 → 0.2.1.0

raw patch · 5 files changed

+100/−20 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/Yesod/Csp.hs +29/−9
• src/Yesod/Csp/Example.hs +29/−0
• src/Yesod/Csp/TH.hs +27/−7
• test/Test.hs +12/−1
• yesod-csp.cabal +3/−3

@@ -7,17 +7,20 @@   , getCspPolicy   , EscapedURI   , escapeAndParseURI+  , escapedTextForNonce+  , nonce   , DirectiveList   , Directive(..)   , SourceList   , Source(..)   , SandboxOptions(..)+  , textSource   ) where  import           Data.Data          (Data) import           Data.List.NonEmpty-import qualified Data.Sequences     as S import           Data.Text+import qualified Data.Text          as T import           Data.Typeable      (Typeable) import           Network.URI import           Yesod.Core@@ -41,19 +44,34 @@  newtype EscapedURI = EscapedURI { uri :: URI } deriving (Eq, Data, Typeable) +newtype EscapedText = EscapedText { text :: String } deriving (Eq, Data, Typeable)+ instance Show EscapedURI where   show x = show (uri x) +instance Show EscapedText where+  show x = mconcat ["'nonce-", text x, "'"]++toEscape :: String+toEscape = ";'* "++notEscapable :: Char -> Bool+notEscapable = not . flip elem toEscape+ -- | 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 = ";'* "+escapeAndParseURI = fmap EscapedURI . parseURI . escapeURIString notEscapable . unpack +-- | Escapes Text to be a valid nonce value+escapedTextForNonce :: String -> EscapedText+escapedTextForNonce = EscapedText . Prelude.filter notEscapable++-- | Escapes a Text value, returning a valid Nonce+nonce :: Text -> Source+nonce = Nonce . escapedTextForNonce . unpack+ directiveListToHeader :: DirectiveList -> Text-directiveListToHeader = S.intercalate "; " . fmap textDirective+directiveListToHeader = intercalate "; " . fmap textDirective  w :: Text -> SourceList -> Text w = wrap@@ -62,7 +80,7 @@ wrap k x = mconcat [k, " ", textSourceList x]  textSourceList :: SourceList -> Text-textSourceList = S.unwords . toList . filtered+textSourceList = T.unwords . toList . filtered   where filtered = fmap textSource . filterOut  -- * and none should be alone if present@@ -80,6 +98,7 @@               | Https               | UnsafeInline               | UnsafeEval+              | Nonce EscapedText               | MetaSource Text deriving (Eq, Show, Data, Typeable)  -- | A list of allowed sources for a directive.@@ -95,6 +114,7 @@ textSource UnsafeInline = "'unsafe-inline'" textSource UnsafeEval = "'unsafe-eval'" textSource (MetaSource _) = ""+textSource (Nonce x) = (pack . show) x  -- | A list of restrictions to apply. type DirectiveList = [Directive]@@ -132,7 +152,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 ", S.unwords . fmap textSandbox $ s]+textDirective (Sandbox s) = mconcat ["sandbox ", T.unwords . fmap textSandbox $ s]   where textSandbox AllowForms = "allow-forms"         textSandbox AllowScripts = "allow-scripts"         textSandbox AllowSameOrigin = "allow-same-origin"

@@ -22,6 +22,9 @@   /6 Example6R GET   /7 Example7R GET POST   /8 Example8R GET+  /9 Example9R GET+  /10 Example10R GET+  /11 Example11R GET |]  instance Yesod Example@@ -108,6 +111,32 @@   where addCdn = transform f         f (ScriptSrc x) = ScriptSrc $ cdn <| x         f x = x++getExample9R :: Handler Html+getExample9R = do+  cspPolicy [csp|script-src 'nonce-foo'|]+  defaultLayout $ [whamlet|+    <script nonce="foo">+      alert("ayyyy");+  |]++getExample10R :: Handler Html+getExample10R = do+  let n = "foo"+  cspPolicy [csp|script-src $nonce-n|]+  defaultLayout $ [whamlet|+    <script nonce="foo">+      alert("ayyyy");+  |]++getExample11R :: Handler Html+getExample11R = do+  let n = "bar"+  cspPolicy [csp|script-src $nonce-n|]+  defaultLayout $ [whamlet|+    <script nonce="foo">+      alert("ayyyy");+  |]  -- | Run a webserver to serve these examples at /1, /2, etc. runExamples :: IO ()

@@ -32,13 +32,17 @@     }  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 (MetaSource x) = if T.isPrefixOf noncePrefix x+  then Just . return $ TH.AppE (TH.VarE (TH.mkName "nonce")) (TH.VarE (TH.mkName (T.unpack (nonceVar x))))+  else Just . return $ TH.AppE (TH.ConE (TH.mkName "Host")) (TH.VarE (TH.mkName (T.unpack x)))+  where noncePrefix = "nonce-"+        nonceVar = T.drop (T.length noncePrefix) antiCsp _ = Nothing  metaSource :: Parser Source metaSource = do   _ <- char '$'-  x <- many (digit <|> letter)+  x <- many (digit <|> letter <|> char '-')   return $ MetaSource (T.pack x)  source :: Parser Source@@ -50,11 +54,20 @@          <|> host          <|> unsafeInline          <|> unsafeEval+         <|> parseNonce          <|> metaSource   where wildcard = string "*" *> pure Wildcard         none = string "'none'" *> pure None         self = string "'self'" *> pure Self         dataScheme = string "data:" *> pure DataScheme+        parseNonce :: Parser Source+        parseNonce = do+          _ <- char '\''+          _ <- string "nonce"+          _ <- char '-'+          n <- takeTill (== '\'')+          _ <- char '\''+          return $ nonce n         host :: Parser Source         host = do           u <- takeTill separated@@ -101,12 +114,15 @@         frameSrc = d "frame-src" FrameSrc         d x y = string x >> s >> slist >>= mkWithSource y         slist = sepBy1 source (char ' ')-        s = string " "+        s = spaces +spaces :: Parser ()+spaces = many space *> pure ()+ reportUri :: Parser Directive reportUri = do   _ <- string "report-uri"-  _ <- string " "+  _ <- spaces   u <- takeTill separated   case escapeAndParseURI u of     Nothing -> fail "reportUri" -- n.b. compile time error@@ -115,8 +131,8 @@ sandbox :: Parser Directive sandbox = do   _ <- string "sandbox"-  _ <- string " "-  x <- sepBy sandboxOptions (char ' ')+  _ <- spaces+  x <- sepBy sandboxOptions spaces   return $ Sandbox x  sandboxOptions :: Parser SandboxOptions@@ -129,6 +145,10 @@         allowSameOrigin = string "allow-same-origin" *> pure AllowSameOrigin         allowTopNavigation = string "allow-top-navigation" *> pure AllowTopNavigation +separator :: Parser ()+separator = comma *> (spaces *> pure ())+  where comma = string ";"+ directive :: Parser DirectiveList-directive = sepBy d (string "; ") <* endOfInput+directive = sepBy d separator <* endOfInput   where d = withSourceList <|> reportUri <|> sandbox

@@ -33,6 +33,9 @@       let dom = fromJust $ escapeAndParseURI "https://foo.com/bar *"           header = getCspPolicy [ScriptSrc (Host dom :| [])]       assertEqual "foo.com script-src" header "script-src https://foo.com/bar%20%2A"+    yit "works with nonce-source" $ do+      let header = getCspPolicy [ScriptSrc (nonce "foo" :| [])]+      assertEqual "basic nonce-source" header "script-src 'nonce-foo'"     yit "works with report_uri" $ do       let dom = fromJust $ escapeAndParseURI "https://foo.com"           header = getCspPolicy [ReportUri dom]@@ -57,6 +60,7 @@   ydescribe "Parsing" $ do     yit "works" $ do       assertEqual "*" (parseOnly source "*") (Right Wildcard)+      assertEqual "nonce" (parseOnly source "'nonce-foo'") (Right $ nonce "foo")       assertEqual "none" (parseOnly source "'none'") (Right None)       assertEqual "self" (parseOnly source "'self'") (Right Self)       assertEqual "data:" (parseOnly source "data:") (Right DataScheme)@@ -72,8 +76,15 @@       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 nonces and th" $ do+      let result = [ScriptSrc $ (nonce "foo") :| []]+      assertEqual "nonces and th" [csp|script-src 'nonce-foo'|] result+    yit "works with dynamic nonces and th" $ do+      let n = "bar"+          result = [ScriptSrc $ (nonce "bar") :| []]+      assertEqual "dynamic nonces and th" [csp|script-src $nonce-n|] 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+      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

@@ -1,8 +1,8 @@--- Initial yesod-csp.cabal generated by cabal init.  For further +-- Initial yesod-csp.cabal generated by cabal init.  For further -- documentation, see http://haskell.org/cabal/users-guide/  name:                yesod-csp-version:             0.2.0.0+version:             0.2.1.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@@ -21,7 +21,7 @@   exposed-modules:     Yesod.Csp                        , Yesod.Csp.Example                        , Yesod.Csp.TH-  -- other-extensions:    +  -- other-extensions:   build-depends:       base < 5                        , text                        , yesod-core