yesod-core 1.2.5 → 1.2.6
raw patch · 10 files changed
+176/−23 lines, 10 filesdep +unix-compatdep +wai-loggerdep ~resourcetdep ~waidep ~wai-extra
Dependencies added: unix-compat, wai-logger
Dependency ranges changed: resourcet, wai, wai-extra
Files
- Yesod/Core/Class/Handler.hs +1/−1
- Yesod/Core/Class/Yesod.hs +40/−2
- Yesod/Core/Dispatch.hs +7/−0
- Yesod/Core/Handler.hs +35/−4
- Yesod/Core/Internal/Response.hs +47/−6
- Yesod/Core/Internal/Run.hs +20/−5
- Yesod/Core/Types.hs +16/−0
- test/YesodCoreTest/Auth.hs +2/−0
- test/YesodCoreTest/Redirect.hs +2/−1
- yesod-core.cabal +6/−4
Yesod/Core/Class/Handler.hs view
@@ -41,7 +41,7 @@ instance MonadResourceBase m => MonadHandler (HandlerT site m) where type HandlerSite (HandlerT site m) = site liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent-{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-}+{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-} instance MonadResourceBase m => MonadHandler (WidgetT site m) where type HandlerSite (WidgetT site m) = site
Yesod/Core/Class/Yesod.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-} module Yesod.Core.Class.Yesod where import Control.Monad.Logger (logErrorS)@@ -39,10 +40,16 @@ import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import System.IO (stdout)+#if MIN_VERSION_fast_logger(2, 0, 0)+import Network.Wai.Logger (ZonedDate, clockDateCacher)+import System.Log.FastLogger+import qualified GHC.IO.FD+#else+import System.Log.FastLogger.Date (ZonedDate) import System.Log.FastLogger (LogStr (..), Logger, loggerDate, loggerPutStr, mkLogger)-import System.Log.FastLogger.Date (ZonedDate)+#endif import Text.Blaze (customAttribute, textTag, toValue, (!)) import Text.Blaze (preEscapedToMarkup)@@ -209,7 +216,14 @@ -- -- Default: Sends to stdout and automatically flushes on each write. makeLogger :: site -> IO Logger+#if MIN_VERSION_fast_logger(2, 0, 0)+ makeLogger _ = do+ loggerSet <- newLoggerSet defaultBufSize GHC.IO.FD.stdout+ (getter, _) <- clockDateCacher+ return $! Logger loggerSet getter+#else makeLogger _ = mkLogger True stdout+#endif -- | Send a message to the @Logger@ provided by @getLogger@. --@@ -523,11 +537,35 @@ Nothing -> Nothing Just j -> Just $ jelper j +#if MIN_VERSION_fast_logger(2, 0, 0) formatLogMessage :: IO ZonedDate -> Loc -> LogSource -> LogLevel -> LogStr -- ^ message+ -> IO LogStr+formatLogMessage getdate loc src level msg = do+ now <- getdate+ return $+ toLogStr now `mappend`+ " [" `mappend`+ (case level of+ LevelOther t -> toLogStr t+ _ -> toLogStr $ drop 5 $ show level) `mappend`+ (if T.null src+ then mempty+ else "#" `mappend` toLogStr src) `mappend`+ "] " `mappend`+ msg `mappend`+ " @(" `mappend`+ toLogStr (fileLocationToString loc) `mappend`+ ")\n"+#else+formatLogMessage :: IO ZonedDate+ -> Loc+ -> LogSource+ -> LogLevel+ -> LogStr -- ^ message -> IO [LogStr] formatLogMessage getdate loc src level msg = do now <- getdate@@ -548,7 +586,7 @@ , LS $ fileLocationToString loc , LB ")\n" ]-+#endif -- | Customize the cookies used by the session backend. You may -- use this function on your definition of 'makeSessionBackend'.
Yesod/Core/Dispatch.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-} module Yesod.Core.Dispatch ( -- * Quasi-quoted routing parseRoutes@@ -146,6 +147,7 @@ warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings Network.Wai.Handler.Warp.defaultSettings { Network.Wai.Handler.Warp.settingsPort = port+ {- FIXME , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat [ "Warp/" , Network.Wai.Handler.Warp.warpVersion@@ -153,6 +155,7 @@ , showVersion Paths_yesod_core.version , " (core)" ]+ -} } -- | A default set of middlewares.@@ -161,7 +164,11 @@ mkDefaultMiddlewares :: Logger -> IO W.Middleware mkDefaultMiddlewares logger = do logWare <- mkRequestLogger def+#if MIN_VERSION_fast_logger(2, 0, 0)+ { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger+#else { destination = Logger logger+#endif , outputFormat = Apache FromSocket } return $ logWare
Yesod/Core/Handler.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -194,6 +195,9 @@ import Blaze.ByteString.Builder (Builder) import Safe (headMay) import Data.CaseInsensitive (CI)+#if MIN_VERSION_wai(2, 0, 0)+import qualified System.PosixCompat.Files as PC+#endif get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState@@ -229,11 +233,19 @@ Just rbc -> return rbc Nothing -> do rr <- waiRequest+#if MIN_VERSION_wai(2, 0, 0)+ rbc <- liftIO $ rbHelper upload rr+#else rbc <- liftResourceT $ rbHelper upload rr+#endif put x { ghsRBC = Just rbc } return rbc +#if MIN_VERSION_wai(2, 0, 0)+rbHelper :: FileUpload -> W.Request -> IO RequestBodyContents+#else rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents+#endif rbHelper upload = case upload of FileUploadMemory s -> rbHelper' s mkFileInfoLBS@@ -243,7 +255,11 @@ rbHelper' :: NWP.BackEnd x -> (Text -> Text -> x -> FileInfo) -> W.Request+#if MIN_VERSION_wai(2, 0, 0)+ -> IO ([(Text, Text)], [(Text, FileInfo)])+#else -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])+#endif rbHelper' backend mkFI req = (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req) where@@ -486,8 +502,17 @@ -> Integer -- ^ offset -> Integer -- ^ count -> m a-sendFilePart ct fp off count =+sendFilePart ct fp off count = do+#if MIN_VERSION_wai(2, 0, 0)+ fs <- liftIO $ PC.getFileStatus fp+ handlerError $ HCSendFile ct fp $ Just W.FilePart+ { W.filePartOffset = off+ , W.filePartByteCount = count+ , W.filePartFileSize = fromIntegral $ PC.fileSize fs+ }+#else handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count+#endif -- | Bypass remaining handler code and output the given content with a 200 -- status code.@@ -697,7 +722,7 @@ x <- get let i' = ghsIdent x + 1 put x { ghsIdent = i' }- return $ T.pack $ 'h' : show i'+ return $ T.pack $ "hident" ++ show i' -- | Redirect to a POST resource. --@@ -916,7 +941,7 @@ ]) reps -- match on the type for sub-type wildcards.- -- If the accept is text/* it should match a provided text/html+ -- If the accept is text/ * it should match a provided text/html mainTypeMap = Map.fromList $ reverse $ map (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps @@ -972,7 +997,13 @@ rawRequestBody :: MonadHandler m => Source m S.ByteString rawRequestBody = do req <- lift waiRequest- transPipe liftResourceT $ W.requestBody req+ transPipe+#if MIN_VERSION_wai(2, 0, 0)+ liftIO+#else+ liftResourceT+#endif+ (W.requestBody req) -- | Stream the data from the file. Since Yesod 1.2, this has been generalized -- to work in any @MonadResource@.
Yesod/Core/Internal/Response.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-}@@ -12,6 +13,13 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Network.Wai+#if MIN_VERSION_wai(2, 0, 0)+import Data.Conduit (transPipe)+import Control.Monad.Trans.Resource (runInternalState, getInternalState, runResourceT, InternalState, closeInternalState)+import Control.Monad.Trans.Class (lift)+import Network.Wai.Internal+import Control.Exception (finally)+#endif import Prelude hiding (catch) import Web.Cookie (renderSetCookie) import Yesod.Core.Content@@ -26,13 +34,30 @@ import Yesod.Core.Internal.Request (tokenKey) import Data.Text.Encoding (encodeUtf8) -yarToResponse :: Monad m- => YesodResponse- -> (SessionMap -> m [Header]) -- ^ save session+yarToResponse :: YesodResponse+ -> (SessionMap -> IO [Header]) -- ^ save session -> YesodRequest- -> m Response-yarToResponse (YRWai a) _ _ = return a-yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do+ -> Request+#if MIN_VERSION_wai(2, 0, 0)+ -> InternalState+#endif+ -> IO Response+#if MIN_VERSION_wai(2, 0, 0)+yarToResponse (YRWai a) _ _ _ is =+ case a of+ ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->+ w f `finally` closeInternalState is+ _ -> do+ closeInternalState is+ return a+#else+yarToResponse (YRWai a) _ _ _ = return a+#endif+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req+#if MIN_VERSION_wai(2, 0, 0)+ is+#endif+ = do extraHeaders <- do let nsToken = maybe newSess@@ -43,6 +68,21 @@ let finalHeaders = extraHeaders ++ map headerToPair hs finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders++#if MIN_VERSION_wai(2, 0, 0)+ let go (ContentBuilder b mlen) = do+ let hs' = maybe finalHeaders finalHeaders' mlen+ closeInternalState is+ return $ ResponseBuilder s hs' b+ go (ContentFile fp p) = do+ closeInternalState is+ return $ ResponseFile s finalHeaders fp p+ go (ContentSource body) = return $ ResponseSource s finalHeaders $ \f ->+ f (transPipe (flip runInternalState is) body) `finally`+ closeInternalState is+ go (ContentDontEvaluate c') = go c'+ go c+#else let go (ContentBuilder b mlen) = let hs' = maybe finalHeaders finalHeaders' mlen in ResponseBuilder s hs' b@@ -50,6 +90,7 @@ go (ContentSource body) = ResponseSource s finalHeaders body go (ContentDontEvaluate c') = go c' return $ go c+#endif where s | s' == defaultStatus = H.status200
Yesod/Core/Internal/Run.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-}@@ -9,13 +10,13 @@ import Yesod.Core.Internal.Response import Blaze.ByteString.Builder (toByteString) import Control.Applicative ((<$>))-import Control.Exception (fromException)+import Control.Exception (fromException, bracketOnError) import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc)-import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)+import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.IORef as I@@ -31,8 +32,13 @@ import Language.Haskell.TH.Syntax (Loc, qLocation) import qualified Network.HTTP.Types as H import Network.Wai+#if MIN_VERSION_wai(2, 0, 0)+import Network.Wai.Internal+#endif import Prelude hiding (catch)+#if !MIN_VERSION_fast_logger(2, 0, 0) import System.Log.FastLogger (Logger)+#endif import System.Log.FastLogger (LogStr, toLogStr) import System.Random (newStdGen) import Yesod.Core.Content@@ -179,14 +185,17 @@ typePlain (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) (reqSession req)- fakeWaiRequest =- Request+ fakeWaiRequest = Request { requestMethod = "POST" , httpVersion = H.http11 , rawPathInfo = "/runFakeHandler/pathInfo" , rawQueryString = ""+#if MIN_VERSION_wai(2, 0, 0)+ , requestHeaderHost = Nothing+#else , serverName = "runFakeHandler-serverName" , serverPort = 80+#endif , requestHeaders = [] , isSecure = False , remoteHost = error "runFakeHandler-remoteHost"@@ -243,8 +252,14 @@ rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler }+#if MIN_VERSION_wai(2, 0, 0)+ bracketOnError createInternalState closeInternalState $ \is -> do+ yar <- runInternalState (runHandler rhe handler yreq) is+ liftIO $ yarToResponse yar saveSession yreq req is+#else yar <- runHandler rhe handler yreq- liftIO $ yarToResponse yar saveSession yreq+ liftIO $ yarToResponse yar saveSession yreq req+#endif where mmaxLen = maximumContentLength yreSite route handler = yesodMiddleware handler'
Yesod/Core/Types.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-} module Yesod.Core.Types where import qualified Blaze.ByteString.Builder as BBuilder@@ -46,7 +47,12 @@ RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP+#if MIN_VERSION_fast_logger(2, 0, 0)+import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)+import Network.Wai.Logger (DateCacheGetter)+#else import System.Log.FastLogger (LogStr, Logger, toLogStr)+#endif import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl)@@ -445,3 +451,13 @@ renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) instance ParseRoute WaiSubsite where parseRoute (x, y) = Just $ WaiSubsiteRoute x y++#if MIN_VERSION_fast_logger(2, 0, 0)+data Logger = Logger+ { loggerSet :: !LoggerSet+ , loggerDate :: !DateCacheGetter+ }++loggerPutStr :: Logger -> LogStr -> IO ()+loggerPutStr (Logger ls _) = pushLogStr ls+#endif
test/YesodCoreTest/Auth.hs view
@@ -8,6 +8,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T import Data.List (isSuffixOf)+import qualified Network.HTTP.Types as H data App = App @@ -51,6 +52,7 @@ , requestHeaders = if not $ isSuffixOf "json" path then [] else [("Accept", S8.pack "application/json")]+ , httpVersion = H.http11 } f sres
test/YesodCoreTest/Redirect.hs view
@@ -45,7 +45,8 @@ it "303 redirect for regular, HTTP 1.1" $ app $ do res <- request defaultRequest {- pathInfo = ["rregular"]+ pathInfo = ["rregular"],+ httpVersion = H.http11 } assertStatus 303 res assertBodyContains "" res
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.2.5+version: 1.2.6 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -26,8 +26,8 @@ build-depends: base >= 4.3 && < 5 , time >= 1.1.4 , yesod-routes >= 1.2 && < 1.3- , wai >= 1.4 && < 1.5- , wai-extra >= 1.3 && < 1.4+ , wai >= 1.4+ , wai-extra >= 1.3 , bytestring >= 0.9.1.4 , text >= 0.7 && < 0.12 , template-haskell@@ -55,9 +55,10 @@ , vector >= 0.9 && < 0.11 , aeson >= 0.5 , fast-logger >= 0.2+ , wai-logger >= 0.2 , monad-logger >= 0.3.1 && < 0.4 , conduit >= 0.5- , resourcet >= 0.4.6 && < 0.5+ , resourcet >= 0.4.9 && < 0.5 , lifted-base >= 0.1.2 , attoparsec-conduit , blaze-html >= 0.5@@ -65,6 +66,7 @@ , data-default , safe , warp >= 1.3.8+ , unix-compat exposed-modules: Yesod.Core Yesod.Core.Content