yesod-core 1.6.6 → 1.6.7
raw patch · 9 files changed
+106/−12 lines, 9 filesdep +primitive
Dependencies added: primitive
Files
- ChangeLog.md +11/−0
- Yesod/Core/Class/Yesod.hs +3/−1
- Yesod/Core/Handler.hs +1/−7
- Yesod/Core/Json.hs +4/−2
- Yesod/Core/Types.hs +9/−0
- test/YesodCoreTest/ErrorHandling.hs +69/−0
- test/YesodCoreTest/Header.hs +7/−0
- test/YesodCoreTest/Reps.hs +0/−1
- yesod-core.cabal +2/−1
ChangeLog.md view
@@ -1,3 +1,14 @@+# ChangeLog for yesod-core++## 1.6.7++* If no matches are found, `selectRep` chooses first representation regardless+ of the presence or absence of a `Content-Type` header in the request+ [#1540](https://github.com/yesodweb/yesod/pull/1540)+* Sets the `X-XSS-Protection` header to `1; mode=block` [#1550](https://github.com/yesodweb/yesod/pull/1550)+* Add `PrimMonad` instances for `HandlerFor` and `WidgetFor` [from+ StackOverflow](https://stackoverflow.com/q/52692508/369198)+ ## 1.6.6 * `defaultErrorHandler` handles text/plain requests [#1522](https://github.com/yesodweb/yesod/pull/1520)
Yesod/Core/Class/Yesod.hs view
@@ -337,12 +337,14 @@ defaultShouldLogIO _ level = return $ level >= LevelInfo -- | Default implementation of 'yesodMiddleware'. Adds the response header--- \"Vary: Accept, Accept-Language\" and performs authorization checks.+-- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and+-- performs authorization checks. -- -- Since 1.2.0 defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res defaultYesodMiddleware handler = do addHeader "Vary" "Accept, Accept-Language"+ addHeader "X-XSS-Protection" "1; mode=block" authorizationCheck handler
Yesod/Core/Handler.hs view
@@ -1289,15 +1289,9 @@ [] -> case reps of [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)- rep:_ ->- if null cts- then returnRep rep- else sendResponseStatus H.status406 explainUnaccepted+ rep:_ -> returnRep rep rep:_ -> returnRep rep where- explainUnaccepted :: Text- explainUnaccepted = "no match found for accept header"- returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent reps = appEndo (Writer.execWriter w) []
Yesod/Core/Json.hs view
@@ -133,8 +133,10 @@ J.Error s -> invalidArgs [pack s] J.Success a -> return a --- | Same as 'requireJsonBody', but ensures that the mime type--- indicates JSON content.+-- | Same as 'requireJsonBody', but ensures that the MIME type+-- indicates JSON content. Requiring a JSON content-type helps secure your site against+-- CSRF attacks (browsers will perform POST requests for form and text/plain content-types+-- without doing a CORS check, and those content-types can easily contain valid JSON). requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a requireCheckJsonBody = do ra <- parseCheckJsonBody
Yesod/Core/Types.hs view
@@ -17,6 +17,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..))+import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L@@ -417,6 +418,10 @@ unWidgetFor (f a) wd instance MonadIO (WidgetFor site) where liftIO = WidgetFor . const+-- | @since 1.6.7+instance PrimMonad (WidgetFor site) where+ type PrimState (WidgetFor site) = PrimState IO+ primitive = liftIO . primitive -- | @since 1.4.38 instance MonadUnliftIO (WidgetFor site) where {-# INLINE askUnliftIO #-}@@ -448,6 +453,10 @@ HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r instance MonadIO (HandlerFor site) where liftIO = HandlerFor . const+-- | @since 1.6.7+instance PrimMonad (HandlerFor site) where+ type PrimState (HandlerFor site) = PrimState IO+ primitive = liftIO . primitive instance MonadReader (HandlerData site site) (HandlerFor site) where ask = HandlerFor return local f (HandlerFor g) = HandlerFor $ g . f
test/YesodCoreTest/ErrorHandling.hs view
@@ -40,6 +40,11 @@ /file-bad-name FileBadNameR GET /good-builder GoodBuilderR GET++/auth-not-accepted AuthNotAcceptedR GET+/auth-not-adequate AuthNotAdequateR GET+/args-not-valid ArgsNotValidR POST+/only-plain-text OnlyPlainTextR GET |] overrideStatus :: Status@@ -119,6 +124,18 @@ getErrorR 10 = setMessage undefined getErrorR x = error $ "getErrorR: " ++ show x +getAuthNotAcceptedR :: Handler TypedContent+getAuthNotAcceptedR = notAuthenticated++getAuthNotAdequateR :: Handler TypedContent+getAuthNotAdequateR = permissionDenied "That doesn't belong to you. "++postArgsNotValidR :: Handler TypedContent+postArgsNotValidR = invalidArgs ["Doesn't matter.", "Don't want it."]++getOnlyPlainTextR :: Handler TypedContent+getOnlyPlainTextR = selectRep $ provideRepType "text/plain" $ return ("Only plain text." :: Text)+ errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do it "says not found" caseNotFound@@ -132,6 +149,11 @@ it "file with bad name" caseFileBadName it "builder includes content-length" caseGoodBuilder forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)+ it "accept DVI file, invalid args -> 400" caseDviInvalidArgs+ it "accept audio, not authenticated -> 401" caseAudioNotAuthenticated+ it "accept CSS, permission denied -> 403" caseCssPermissionDenied+ it "accept image, non-existent path -> 404" caseImageNotFound+ it "accept video, bad method -> 405" caseVideoBadMethod runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f@@ -222,3 +244,50 @@ ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do liftIO $ print res E.throwIO (e :: E.SomeException)++caseDviInvalidArgs :: IO ()+caseDviInvalidArgs = runner $ do+ res <- request defaultRequest+ { pathInfo = ["args-not-valid"]+ , requestMethod = "POST"+ , requestHeaders =+ ("accept", "application/x-dvi") : requestHeaders defaultRequest+ }+ assertStatus 400 res++caseAudioNotAuthenticated :: IO ()+caseAudioNotAuthenticated = runner $ do+ res <- request defaultRequest+ { pathInfo = ["auth-not-accepted"]+ , requestHeaders =+ ("accept", "audio/mpeg") : requestHeaders defaultRequest+ }+ assertStatus 401 res++caseCssPermissionDenied :: IO ()+caseCssPermissionDenied = runner $ do+ res <- request defaultRequest+ { pathInfo = ["auth-not-adequate"]+ , requestHeaders =+ ("accept", "text/css") : requestHeaders defaultRequest+ }+ assertStatus 403 res++caseImageNotFound :: IO ()+caseImageNotFound = runner $ do+ res <- request defaultRequest+ { pathInfo = ["not_a_path"]+ , requestHeaders =+ ("accept", "image/jpeg") : requestHeaders defaultRequest+ }+ assertStatus 404 res++caseVideoBadMethod :: IO ()+caseVideoBadMethod = runner $ do+ res <- request defaultRequest+ { pathInfo = ["good-builder"]+ , requestMethod = "DELETE"+ , requestHeaders =+ ("accept", "video/webm") : requestHeaders defaultRequest+ }+ assertStatus 405 res
test/YesodCoreTest/Header.hs view
@@ -69,9 +69,16 @@ assertHeader "michael" "snoyman" res assertHeader "yesod" "book" res +xssHeaderTest :: IO ()+xssHeaderTest = do+ runner $ do+ res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}+ assertHeader "X-XSS-Protection" "1; mode=block" res+ headerTest :: Spec headerTest = describe "Test.Header" $ do it "addHeader" addHeaderTest it "multiple header" multipleHeaderTest it "persist headers" header3Test+ it "has X-XSS-Protection: 1; mode=block" xssHeaderTest
test/YesodCoreTest/Reps.hs view
@@ -85,7 +85,6 @@ test "text/html" "HTML" test specialHtml "HTMLSPECIAL" testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}"- testRequest 406 (acceptRequest "text/foo") "no match found for accept header" test "text/*" "HTML" test "*/*" "HTML" describe "routeAttrs" $ do
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.6.6+version: 1.6.7 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -42,6 +42,7 @@ , mtl , parsec >= 2 && < 3.2 , path-pieces >= 0.1.2 && < 0.3+ , primitive >= 0.6 , random >= 1.0.0.2 && < 1.2 , resourcet >= 1.2 , rio