yesod-core 1.2.3 → 1.2.4

raw patch · 5 files changed

+57/−8 lines, 5 files

Files

• Yesod/Core/Class/Yesod.hs +16/−2
• Yesod/Core/Internal/Response.hs +18/−1
• Yesod/Core/Internal/Run.hs +6/−3
• test/YesodCoreTest/ErrorHandling.hs +16/−1
• yesod-core.cabal +1/−1

@@ -222,8 +222,9 @@                         -> LogLevel                         -> LogStr -- ^ message                         -> IO ()-    messageLoggerSource a logger loc source level msg =-        when (shouldLog a source level) $+    messageLoggerSource a logger loc source level msg = do+        sl <- shouldLogIO a source level+        when sl $             formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger      -- | Where to Load sripts from. We recommend the default value,@@ -259,6 +260,19 @@     -- Default: Logs everything at or above 'logLevel'     shouldLog :: site -> LogSource -> LogLevel -> Bool     shouldLog _ _ level = level >= LevelInfo++    -- | Should we log the given log source/level combination.+    --+    -- Note that this is almost identical to @shouldLog@, except the result+    -- lives in @IO@. This allows you to dynamically alter the logging level of+    -- your application by having this result depend on, e.g., an @IORef@.+    --+    -- The default implementation simply uses @shouldLog@. Future versions of+    -- Yesod will remove @shouldLog@ and use this method exclusively.+    --+    -- Since 1.2.4+    shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool+    shouldLogIO a b c = return (shouldLog a b c)      -- | A Yesod middleware, which will wrap every handler function. This     -- allows you to run code before and after a normal handler.

@@ -32,7 +32,7 @@               -> YesodRequest               -> m Response yarToResponse (YRWai a) _ _ = return a-yarToResponse (YRPlain s hs ct c newSess) saveSession yreq = do+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do     extraHeaders <- do         let nsToken = maybe                 newSess@@ -50,6 +50,23 @@         go (ContentSource body) = ResponseSource s finalHeaders body         go (ContentDontEvaluate c') = go c'     return $ go c+  where+    s+        | s' == defaultStatus = H.status200+        | otherwise = s'++-- | Indicates that the user provided no specific status code to be used, and+-- therefore the default status code should be used. For normal responses, this+-- would be a 200 response, whereas for error responses this would be an+-- appropriate status code.+--+-- For more information on motivation for this, see:+--+-- https://groups.google.com/d/msg/yesodweb/vHDBzyu28TM/bezCvviWp4sJ+--+-- Since 1.2.3.1+defaultStatus :: H.Status+defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"  -- | Convert Header to a key/value pair. headerToPair :: Header

@@ -73,15 +73,18 @@     state <- liftIO $ I.readIORef istate     let finalSession = ghsSession state     let headers = ghsHeaders state-    let contents = either id (HCContent H.status200 . toTypedContent) contents'+    let contents = either id (HCContent defaultStatus . toTypedContent) contents'     let handleError e = flip runInternalState resState $ do             yar <- rheOnError e yreq                 { reqSession = finalSession                 }             case yar of-                YRPlain _ hs ct c sess ->+                YRPlain status' hs ct c sess ->                     let hs' = appEndo headers hs-                     in return $ YRPlain (getStatus e) hs' ct c sess+                        status+                            | status' == defaultStatus = getStatus e+                            | otherwise = status'+                     in return $ YRPlain status hs' ct c sess                 YRWai _ -> return yar     let sendFile' ct fp p =             return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession

@@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try)+import Network.HTTP.Types (mkStatus)  data App = App @@ -22,10 +23,15 @@ /after_runRequestBody AfterRunRequestBodyR POST /error-in-body ErrorInBodyR GET /error-in-body-noeval ErrorInBodyNoEvalR GET+/override-status OverrideStatusR GET |] -instance Yesod App+overrideStatus = mkStatus 15 "OVERRIDE" +instance Yesod App where+    errorHandler (InvalidArgs ["OVERRIDE"]) = sendResponseStatus overrideStatus ("OH HAI" :: String)+    errorHandler x = defaultErrorHandler x+ getHomeR :: Handler Html getHomeR = do     $logDebug "Testing logging"@@ -65,6 +71,9 @@ getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate Html) getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR +getOverrideStatusR :: Handler ()+getOverrideStatusR = invalidArgs ["OVERRIDE"]+ errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do       it "says not found" caseNotFound@@ -72,6 +81,7 @@       it "says 'There was an error' after runRequestBody" caseAfter       it "error in body == 500" caseErrorInBody       it "error in body, no eval == 200" caseErrorInBodyNoEval+      it "can override status code" caseOverrideStatus  runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f@@ -125,3 +135,8 @@     case eres of         Left (_ :: SomeException) -> return ()         Right _ -> error "Expected an exception"++caseOverrideStatus :: IO ()+caseOverrideStatus = runner $ do+    res <- request defaultRequest { pathInfo = ["override-status"] }+    assertStatus 15 res

@@ -1,5 +1,5 @@ name:            yesod-core-version:         1.2.3+version:         1.2.4 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>