yesod-core 1.2.15.2 → 1.2.16
raw patch · 11 files changed
+172/−24 lines, 11 filesdep ~transformersdep ~wai-extra
Dependency ranges changed: transformers, wai-extra
Files
- Yesod/Core/Dispatch.hs +5/−0
- Yesod/Core/Handler.hs +50/−0
- Yesod/Core/Internal/Request.hs +34/−14
- Yesod/Core/Internal/Response.hs +43/−0
- Yesod/Core/Internal/Run.hs +20/−0
- test/YesodCoreTest/CleanPath.hs +5/−0
- test/YesodCoreTest/ErrorHandling.hs +3/−4
- test/YesodCoreTest/InternalRequest.hs +2/−1
- test/YesodCoreTest/RequestBodySize.hs +2/−2
- test/YesodCoreTest/WaiSubsite.hs +5/−1
- yesod-core.cabal +3/−2
Yesod/Core/Dispatch.hs view
@@ -92,8 +92,13 @@ where site = yreSite yre sendRedirect :: Yesod master => master -> [Text] -> W.Application+#if MIN_VERSION_wai(3, 0, 0)+ sendRedirect y segments' env sendResponse =+ sendResponse $ W.responseLBS status301+#else sendRedirect y segments' env = return $ W.responseLBS status301+#endif [ ("Content-Type", "text/plain") , ("Location", Blaze.ByteString.Builder.toByteString dest') ] "Redirecting"
Yesod/Core/Handler.hs view
@@ -94,6 +94,9 @@ #if MIN_VERSION_wai(2, 1, 0) , sendRawResponse #endif+#if MIN_VERSION_wai(3, 0, 0)+ , sendRawResponseNoConduit+#endif -- * Different representations -- $representations , selectRep@@ -198,6 +201,8 @@ import Blaze.ByteString.Builder (Builder) import Safe (headMay) import Data.CaseInsensitive (CI)+import qualified Data.Conduit.List as CL+import Control.Monad (unless) import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO #if MIN_VERSION_wai(2, 0, 0) #else@@ -368,7 +373,11 @@ where oldReq = handlerRequest oldHandlerData oldWaiReq = reqWaiRequest oldReq+#if MIN_VERSION_wai(3, 0, 0)+ newWaiReq = oldWaiReq { W.requestBody = return mempty+#else newWaiReq = oldWaiReq { W.requestBody = mempty+#endif , W.requestBodyLength = W.KnownLength 0 } oldEnv = handlerEnv oldHandlerData@@ -576,6 +585,24 @@ sendWaiResponse :: MonadHandler m => W.Response -> m b sendWaiResponse = handlerError . HCWai +#if MIN_VERSION_wai(3, 0, 0)+-- | Send a raw response without conduit. This is used for cases such as+-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw+-- responses (e.g., Warp).+--+-- Since 1.2.16+sendRawResponseNoConduit+ :: (MonadHandler m, MonadBaseControl IO m)+ => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())+ -> m a+sendRawResponseNoConduit raw = control $ \runInIO ->+ runInIO $ sendWaiResponse $ flip W.responseRaw fallback+ $ \src sink -> runInIO (raw src sink) >> return ()+ where+ fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]+ "sendRawResponse: backend does not support raw responses"+#endif+ #if MIN_VERSION_wai(2, 1, 0) -- | Send a raw response. This is used for cases such as WebSockets. Requires -- WAI 2.1 or later, and a web server which supports raw responses (e.g.,@@ -585,13 +612,27 @@ sendRawResponse :: (MonadHandler m, MonadBaseControl IO m) => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ()) -> m a+#if MIN_VERSION_wai(3, 0, 0) sendRawResponse raw = control $ \runInIO -> runInIO $ sendWaiResponse $ flip W.responseRaw fallback+ $ \src sink -> runInIO (raw (src' src) (CL.mapM_ sink)) >> return ()+ where+ fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]+ "sendRawResponse: backend does not support raw responses"+ src' src = do+ bs <- liftIO src+ unless (S.null bs) $ do+ yield bs+ src' src+#else+sendRawResponse raw = control $ \runInIO ->+ runInIO $ sendWaiResponse $ flip W.responseRaw fallback $ \src sink -> runInIO (raw src sink) >> return () where fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")] "sendRawResponse: backend does not support raw responses" #endif+#endif -- | Return a 404 not found page. Also denotes no handler available. notFound :: MonadHandler m => m a@@ -1068,6 +1109,14 @@ rawRequestBody :: MonadHandler m => Source m S.ByteString rawRequestBody = do req <- lift waiRequest+#if MIN_VERSION_wai(3, 0, 0)+ let loop = do+ bs <- liftIO $ W.requestBody req+ unless (S.null bs) $ do+ yield bs+ loop+ loop+#else transPipe #if MIN_VERSION_wai(2, 0, 0) liftIO@@ -1075,6 +1124,7 @@ liftResourceT #endif (W.requestBody req)+#endif -- | Stream the data from the file. Since Yesod 1.2, this has been generalized -- to work in any @MonadResource@.
Yesod/Core/Internal/Request.hs view
@@ -44,11 +44,28 @@ import Control.Exception (throwIO) import Yesod.Core.Types import qualified Data.Map as Map+import Data.IORef -- | Impose a limit on the size of the request body.-limitRequestBody :: Word64 -> W.Request -> W.Request+limitRequestBody :: Word64 -> W.Request -> IO W.Request+#if MIN_VERSION_wai(3, 0, 0)+limitRequestBody maxLen req = do+ ref <- newIORef maxLen+ return req+ { W.requestBody = do+ bs <- W.requestBody req+ remaining <- readIORef ref+ let len = fromIntegral $ S8.length bs+ remaining' = remaining - len+ if remaining < len+ then throwIO $ HCWai tooLargeResponse+ else do+ writeIORef ref remaining'+ return bs+ }+#else limitRequestBody maxLen req =- req { W.requestBody = W.requestBody req $= limit maxLen }+ return req { W.requestBody = W.requestBody req $= limit maxLen } where tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse @@ -63,6 +80,7 @@ else do yield bs limit $ remaining - len+#endif tooLargeResponse :: W.Response tooLargeResponse = W.responseLBS@@ -75,7 +93,7 @@ -> SessionMap -> Bool -> Maybe Word64 -- ^ max body size- -> (Either YesodRequest (g -> YesodRequest))+ -> (Either (IO YesodRequest) (g -> IO YesodRequest)) parseWaiRequest env session useToken mmaxBodySize = -- In most cases, we won't need to generate any random values. Therefore, -- we split our results: if we need a random generator, return a Right@@ -85,17 +103,19 @@ Left token -> Left $ mkRequest token Right mkToken -> Right $ mkRequest . mkToken where- mkRequest token' = YesodRequest- { reqGetParams = gets- , reqCookies = cookies- , reqWaiRequest = maybe id limitRequestBody mmaxBodySize env- , reqLangs = langs''- , reqToken = token'- , reqSession = if useToken- then Map.delete tokenKey session- else session- , reqAccept = httpAccept env- }+ mkRequest token' = do+ envLimited <- maybe return limitRequestBody mmaxBodySize env+ return YesodRequest+ { reqGetParams = gets+ , reqCookies = cookies+ , reqWaiRequest = envLimited+ , reqLangs = langs''+ , reqToken = token'+ , reqSession = if useToken+ then Map.delete tokenKey session+ else session+ , reqAccept = httpAccept env+ } gets = textQueryString env reqCookie = lookup "Cookie" $ W.requestHeaders env cookies = maybe [] parseCookiesText reqCookie
Yesod/Core/Internal/Response.hs view
@@ -33,11 +33,53 @@ import qualified Data.Map as Map import Yesod.Core.Internal.Request (tokenKey) import Data.Text.Encoding (encodeUtf8)+import Data.Conduit (Flush (..), ($$))+import qualified Data.Conduit.List as CL +#if MIN_VERSION_wai(3, 0, 0) yarToResponse :: YesodResponse -> (SessionMap -> IO [Header]) -- ^ save session -> YesodRequest -> Request+ -> InternalState+ -> IO Response+yarToResponse (YRWai a) _ _ _ _ = return a+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is = do+ extraHeaders <- do+ let nsToken = maybe+ newSess+ (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)+ (reqToken yreq)+ sessionHeaders <- saveSession nsToken+ return $ ("Content-Type", ct) : map headerToPair sessionHeaders+ let finalHeaders = extraHeaders ++ map headerToPair hs+ finalHeaders' len = ("Content-Length", S8.pack $ show len)+ : finalHeaders++ let go (ContentBuilder b mlen) = do+ let hs' = maybe finalHeaders finalHeaders' mlen+ return $ ResponseBuilder s hs' b+ go (ContentFile fp p) = do+ return $ ResponseFile s finalHeaders fp p+ go (ContentSource body) = return $ responseStream s finalHeaders+ $ \sendChunk flush -> do+ transPipe (flip runInternalState is) body+ $$ CL.mapM_ (\mchunk ->+ case mchunk of+ Flush -> flush+ Chunk builder -> sendChunk builder)+ go (ContentDontEvaluate c') = go c'+ go c+ where+ s+ | s' == defaultStatus = H.status200+ | otherwise = s'++#else+yarToResponse :: YesodResponse+ -> (SessionMap -> IO [Header]) -- ^ save session+ -> YesodRequest+ -> Request #if MIN_VERSION_wai(2, 0, 0) -> InternalState #endif@@ -106,6 +148,7 @@ s | s' == defaultStatus = H.status200 | otherwise = s'+#endif -- | 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
Yesod/Core/Internal/Run.hs view
@@ -230,7 +230,11 @@ , remoteHost = error "runFakeHandler-remoteHost" , pathInfo = ["runFakeHandler", "pathInfo"] , queryString = []+#if MIN_VERSION_wai(3, 0, 0)+ , requestBody = return mempty+#else , requestBody = mempty+#endif , vault = mempty , requestBodyLength = KnownLength 0 }@@ -253,8 +257,13 @@ -> YesodRunnerEnv site -> Maybe (Route site) -> Application+#if MIN_VERSION_wai(3, 0, 0)+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse+ | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse+#else yesodRunner handler' YesodRunnerEnv {..} route req | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse+#endif | otherwise = do let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ do@@ -281,6 +290,16 @@ rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler }+#if MIN_VERSION_wai(3, 0, 0)++ E.bracket createInternalState closeInternalState $ \is -> do+ yreq' <- yreq+ yar <- runInternalState (runHandler rhe handler yreq') is+ res <- yarToResponse yar saveSession yreq' req is+ sendResponse res++#else+ #if MIN_VERSION_wai(2, 0, 0) bracketOnError createInternalState closeInternalState $ \is -> do yar <- runInternalState (runHandler rhe handler yreq) is@@ -288,6 +307,7 @@ #else yar <- runHandler rhe handler yreq liftIO $ yarToResponse yar saveSession yreq req+#endif #endif where mmaxLen = maximumContentLength yreSite route
test/YesodCoreTest/CleanPath.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} module YesodCoreTest.CleanPath (cleanPathTest, Widget) where import Test.Hspec@@ -32,7 +33,11 @@ parseRoute (x, _) = Just $ SubsiteRoute x instance YesodSubDispatch Subsite master where+#if MIN_VERSION_wai(3, 0, 0)+ yesodSubDispatch _ req f = f $ responseLBS+#else yesodSubDispatch _ req = return $ responseLBS+#endif status200 [ ("Content-Type", "SUBSITE") ] $ L8.pack $ show (pathInfo req)
test/YesodCoreTest/ErrorHandling.hs view
@@ -128,7 +128,7 @@ it "builder includes content-length" caseGoodBuilder forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i) -runner :: Session () -> IO ()+runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f caseNotFound :: IO ()@@ -175,11 +175,10 @@ caseErrorInBodyNoEval :: IO () caseErrorInBodyNoEval = do eres <- try $ runner $ do- _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] }- return ()+ request defaultRequest { pathInfo = ["error-in-body-noeval"] } case eres of Left (_ :: SomeException) -> return ()- Right _ -> error "Expected an exception"+ Right x -> error $ "Expected an exception, got: " ++ show x caseOverrideStatus :: IO () caseOverrideStatus = runner $ do
test/YesodCoreTest/InternalRequest.hs view
@@ -12,6 +12,7 @@ import Data.Map (singleton) import Yesod.Core import Data.Word (Word64)+import System.IO.Unsafe (unsafePerformIO) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do@@ -36,7 +37,7 @@ -> Bool -> Word64 -> YesodRequest-parseWaiRequest' a b c d =+parseWaiRequest' a b c d = unsafePerformIO $ -- ugly hack, just to ease migration, should be removed case parseWaiRequest a b c (Just d) of Left yreq -> yreq Right needGen -> needGen g
test/YesodCoreTest/RequestBodySize.hs view
@@ -83,8 +83,8 @@ specs = describe "Test.RequestBodySize" $ do caseHelper "lookupPostParam- large" "post" "foobarbaz=bin" 413 413 caseHelper "lookupPostParam- small" "post" "foo=bin" 200 200- caseHelper "consume- large" "consume" "this is longer than 10" 413 413- caseHelper "consume- small" "consume" "smaller" 200 200+ caseHelper "total consume- large" "consume" "this is longer than 10" 413 413+ caseHelper "total consume- small" "consume" "smaller" 200 200 caseHelper "partial consume- large" "partial-consume" "this is longer than 10" 200 413 caseHelper "partial consume- small" "partial-consume" "smaller" 200 200 caseHelper "unused- large" "unused" "this is longer than 10" 200 413
test/YesodCoreTest/WaiSubsite.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} module YesodCoreTest.WaiSubsite (specs, Widget) where import YesodCoreTest.YesodTest@@ -6,7 +6,11 @@ import qualified Network.HTTP.Types as H myApp :: Application+#if MIN_VERSION_wai(3, 0, 0)+myApp _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"+#else myApp _ = return $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"+#endif getApp :: a -> WaiSubsite getApp _ = WaiSubsite myApp
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.2.15.2+version: 1.2.16 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -38,7 +38,7 @@ , shakespeare-css >= 1.0 , shakespeare-i18n >= 1.0 , blaze-builder >= 0.2.1.4 && < 0.4- , transformers >= 0.2.2 && < 0.4+ , transformers >= 0.2.2 , mtl , clientsession >= 0.9 && < 0.10 , random >= 1.0.0.2 && < 1.1@@ -131,6 +131,7 @@ , conduit-extra , shakespeare , streaming-commons+ , wai-extra ghc-options: -Wall extensions: TemplateHaskell