diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index fecbb74f..e10d0384 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -48,8 +48,6 @@ module Yesod.Core , ScriptLoadPosition (..) , BottomOfHeadAsync -- * Subsites - , defaultLayoutT - , MonadHandler (..) , HandlerReader (..) , HandlerState (..) , HandlerError (..) @@ -63,7 +61,6 @@ module Yesod.Core , module Yesod.Core.Handler , module Yesod.Core.Widget , module Yesod.Core.Json - , module Yesod.Core.Class.MonadLift , module Text.Shakespeare.I18N , module Yesod.Core.Internal.Util ) where @@ -113,10 +110,3 @@ maybeAuthorized :: Yesod site maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing - -defaultLayoutT :: Yesod parent - => WidgetT child m () - -> HandlerT parent m RepHtml -defaultLayoutT (WidgetT (HandlerT f)) = HandlerT $ \hd -> do - ((), gwdata) <- liftResourceT $ f hd - unHandlerT $ defaultLayout $ WidgetT $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata) diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index 562501dc..c3f8abb9 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -21,16 +21,15 @@ import Control.Monad.Trans.Control (MonadBaseControl) class Yesod site => YesodDispatch site where yesodDispatch :: YesodRunnerEnv site -> W.Application -class YesodSubDispatch sub parent where +class YesodSubDispatch sub m where yesodSubDispatch - :: Monad m - => (HandlerT parent m TypedContent - -> YesodRunnerEnv parent - -> Maybe (Route parent) + :: (m TypedContent + -> YesodRunnerEnv (HandlerSite m) + -> Maybe (Route (HandlerSite m)) -> W.Application) - -> (parent -> sub) - -> (Route sub -> Route parent) - -> YesodRunnerEnv parent + -> (HandlerSite m -> sub) + -> (Route sub -> Route (HandlerSite m)) + -> YesodRunnerEnv (HandlerSite m) -> W.Application instance YesodSubDispatch WaiSubsite master where diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index 9c109c46..326d2dba 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -29,8 +29,8 @@ instance Monad m => HandlerReader (HandlerT site m) where instance Monad m => HandlerReader (WidgetT site m) where type HandlerSite (WidgetT site m) = site - askYesodRequest = WidgetT $ fmap (, mempty) $ askYesodRequest - askHandlerEnv = WidgetT $ fmap (, mempty) $ askHandlerEnv + askYesodRequest = WidgetT $ return . (, mempty) . handlerRequest + askHandlerEnv = WidgetT $ return . (, mempty) . handlerEnv class HandlerReader m => HandlerState m where stateGHState :: (GHState -> (a, GHState)) -> m a @@ -48,7 +48,10 @@ instance MonadBase IO m => HandlerState (HandlerT site m) where f' z = let (x, y) = f z in (y, x) instance MonadBase IO m => HandlerState (WidgetT site m) where - stateGHState = WidgetT . fmap (, mempty) . stateGHState + stateGHState f = + WidgetT $ fmap (, mempty) . flip atomicModifyIORef f' . handlerState + where + f' z = let (x, y) = f z in (y, x) class HandlerReader m => HandlerError m where handlerError :: HandlerContents -> m a diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index 341dda0c..d85efd74 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -58,6 +58,7 @@ import Web.Cookie (SetCookie (..)) import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget +import Control.Monad.Trans.Class (lift) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -302,7 +303,8 @@ widgetToPageContent :: (Eq (Route site), Yesod site) -> HandlerT site IO (PageContent (Route site)) widgetToPageContent w = do master <- getYesod - ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unWidgetT w + hd <- HandlerT return + ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd let title = maybe mempty unTitle mTitle scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index bef4a708..ee673632 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -30,6 +30,7 @@ module Yesod.Core.Handler , getRequest , waiRequest , runRequestBody + , rawRequestBody -- ** Request information -- *** Request datatype , RequestBodyContents @@ -147,6 +148,7 @@ import Text.Hamlet (Html, HtmlUrl, hamlet) import qualified Data.ByteString as S import qualified Data.Map as Map +import Data.Conduit (Source) import Control.Arrow ((***)) import qualified Data.ByteString.Char8 as S8 import Data.Maybe (mapMaybe) @@ -314,7 +316,9 @@ handlerToIO = -- The state IORef needs to be created here, otherwise it -- will be shared by different invocations of this function. newStateIORef <- I.newIORef newState - runResourceT $ f clearedOldHandlerData + -- FIXME previously runResourceT was used here, but that could mean resources might vanish... + -- Check if this new behavior is correct. + f clearedOldHandlerData { handlerRequest = newReq , handlerState = newStateIORef } @@ -875,3 +879,9 @@ provideRepType :: (MonadIO m, ToContent a) -> Writer.Writer (Endo [ProvidedRep m]) () provideRepType ct handler = Writer.tell $ Endo $ (ProvidedRep ct (liftM toContent handler):) + +-- | Stream in the raw request body without any parsing. +-- +-- Since 1.2.0 +rawRequestBody :: Source m S.ByteString +rawRequestBody = error "rawRequestBody" diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 5a6924ba..1643eefa 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -17,7 +17,7 @@ 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, transResourceT, ResourceT, joinResourceT) +import Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT, withInternalState, runInternalState) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -51,7 +51,7 @@ runHandler :: ToTypedContent c => RunHandlerEnv site -> HandlerT site IO c -> YesodApp -runHandler rhe@RunHandlerEnv {..} handler yreq = do +runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do let toErrorHandler e = case fromException e of Just (HCError x) -> x @@ -68,6 +68,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do , handlerEnv = rhe , handlerState = istate , handlerToParent = const () + , handlerResource = resState } contents' <- catch (fmap Right $ unHandlerT handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id @@ -76,7 +77,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do let finalSession = ghsSession state let headers = ghsHeaders state let contents = either id (HCContent H.status200 . toTypedContent) contents' - let handleError e = do + let handleError e = flip runInternalState resState $ do yar <- rheOnError e yreq { reqSession = finalSession } @@ -278,7 +279,7 @@ stripHandlerT :: HandlerT child (HandlerT parent m) a -> HandlerT parent m a stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do let env = handlerEnv hd - joinResourceT $ transResourceT (($ hd) . unHandlerT) $ f hd + ($ hd) $ unHandlerT $ f hd { handlerEnv = env { rheSite = getSub $ rheSite env , rheRoute = newRoute diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 2a174493..9f98f702 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -22,7 +22,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..)) import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Resource (MonadResource (..)) +import Control.Monad.Trans.Resource import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.Conduit (Flush, MonadThrow (..), @@ -184,6 +184,7 @@ data HandlerData site parentRoute = HandlerData , handlerEnv :: !(RunHandlerEnv site) , handlerState :: !(IORef GHState) , handlerToParent :: !(Route site -> parentRoute) + , handlerResource :: !InternalState } data YesodRunnerEnv site = YesodRunnerEnv @@ -195,7 +196,7 @@ data YesodRunnerEnv site = YesodRunnerEnv -- | A generic handler monad, which can have a different subsite and master -- site. We define a newtype for better error message. newtype HandlerT site m a = HandlerT - { unHandlerT :: HandlerData site (MonadRoute m) -> ResourceT m a + { unHandlerT :: HandlerData site (MonadRoute m) -> m a } type family MonadRoute (m :: * -> *) @@ -219,7 +220,7 @@ type YesodApp = YesodRequest -> ResourceT IO YesodResponse -- site datatypes. While this is simply a @WriterT@, we define a newtype for -- better error messages. newtype WidgetT site m a = WidgetT - { unWidgetT :: HandlerT site m (a, GWData (Route site)) + { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site)) } instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where @@ -344,35 +345,36 @@ instance Monad m => Applicative (WidgetT site m) where pure = return (<*>) = ap instance Monad m => Monad (WidgetT site m) where - return a = WidgetT $ pure (a, mempty) - WidgetT x >>= f = WidgetT $ do - (a, wa) <- x - (b, wb) <- unWidgetT (f a) + return a = WidgetT $ const $ return (a, mempty) + WidgetT x >>= f = WidgetT $ \r -> do + (a, wa) <- x r + (b, wb) <- unWidgetT (f a) r return (b, wa `mappend` wb) instance MonadIO m => MonadIO (WidgetT site m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (WidgetT site m) where - liftBase = WidgetT . fmap (\a -> (a, mempty)) . liftBase + liftBase = WidgetT . const . liftBase . fmap (, mempty) instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where - data StM (WidgetT site m) a = - StW (StM (HandlerT site m) (a, GWData (Route site))) - liftBaseWith f = WidgetT $ liftBaseWith $ \runInBase -> - liftM (\x -> (x, mempty)) - (f $ liftM StW . runInBase . unWidgetT) - restoreM (StW base) = WidgetT $ restoreM base + data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site))) + liftBaseWith f = WidgetT $ \reader -> + liftBaseWith $ \runInBase -> + liftM (\x -> (x, mempty)) + (f $ liftM StW . runInBase . flip unWidgetT reader) + restoreM (StW base) = WidgetT $ const $ restoreM base instance MonadTrans (WidgetT site) where - lift = WidgetT . fmap (, mempty) . lift + lift = WidgetT . const . liftM (, mempty) instance MonadThrow m => MonadThrow (WidgetT site m) where monadThrow = lift . monadThrow instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where - liftResourceT = WidgetT . fmap (, mempty) . liftResourceT + liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd) instance MonadIO m => MonadLogger (WidgetT site m) where - monadLoggerLog a b c d = WidgetT $ fmap (, mempty) $ monadLoggerLog a b c d + monadLoggerLog a b c d = WidgetT $ \hd -> + liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d) instance MonadTrans (HandlerT site) where - lift = HandlerT . const . lift + lift = HandlerT . const -- Instances for HandlerT instance Monad m => Functor (HandlerT site m) where @@ -396,7 +398,7 @@ instance MonadBase b m => MonadBase b (HandlerT site m) where -- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed -- after cleanup. Please contact the maintainers.\" instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where - data StM (HandlerT site m) a = StH (StM (ResourceT m) a) + data StM (HandlerT site m) a = StH (StM m a) liftBaseWith f = HandlerT $ \reader -> liftBaseWith $ \runInBase -> f $ liftM StH . runInBase . (\(HandlerT r) -> r reader) @@ -404,8 +406,8 @@ instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where instance MonadThrow m => MonadThrow (HandlerT site m) where monadThrow = lift . monadThrow -instance (MonadIO m, MonadUnsafeIO m, MonadThrow m, Applicative m) => MonadResource (HandlerT site m) where - liftResourceT = HandlerT . const . liftResourceT +instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where + liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd) instance MonadIO m => MonadLogger (HandlerT site m) where monadLoggerLog a b c d = HandlerT $ \hd -> diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index 2ee75040..b6e1cb6f 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -40,6 +40,8 @@ module Yesod.Core.Widget , addScriptRemote , addScriptRemoteAttrs , addScriptEither + -- * Subsites + , liftWidget -- * Internal , whamletFileWithSettings ) where @@ -83,7 +85,7 @@ instance (Monad m, render ~ RY site) => ToWidget site m (render -> CssBuilder) w toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance (Monad m, render ~ RY site) => ToWidget site m (render -> Javascript) where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -instance (site' ~ site, Monad m) => ToWidget site' m (WidgetT site m ()) where +instance (site' ~ site, Monad m, m' ~ m) => ToWidget site' m' (WidgetT site m ()) where toWidget = id instance Monad m => ToWidget site m Html where toWidget = toWidget . const @@ -214,7 +216,7 @@ ihamletToRepHtml ih = do return $ ih (toHtml . mrender) urender tell :: Monad m => GWData (Route site) -> WidgetT site m () -tell w = WidgetT $ return ((), w) +tell w = WidgetT $ const $ return ((), w) toUnique :: x -> UniqueList x toUnique = UniqueList . (:) @@ -223,7 +225,7 @@ liftHandlerT :: MonadIO m => HandlerT site IO a -> HandlerT site m a liftHandlerT (HandlerT f) = - HandlerT $ transResourceT liftIO . f . fixToParent + HandlerT $ liftIO . f . fixToParent where fixToParent hd = hd { handlerToParent = const () } @@ -231,8 +233,33 @@ liftWidget :: MonadIO m => WidgetT child IO a -> HandlerT child (HandlerT parent m) (WidgetT parent m a) liftWidget (WidgetT f) = HandlerT $ \hd -> do - (a, gwd) <- unHandlerT (liftHandlerT f) hd - return $ WidgetT $ HandlerT $ const $ return (a, liftGWD (handlerToParent hd) gwd) + (a, gwd) <- liftIO $ f hd { handlerToParent = const () } + return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd) liftGWD :: (child -> parent) -> GWData child -> GWData parent -liftGWD = error "liftGWD" +liftGWD tp gwd = GWData + { gwdBody = fixBody $ gwdBody gwd + , gwdTitle = gwdTitle gwd + , gwdScripts = fixUnique fixScript $ gwdScripts gwd + , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd + , gwdCss = fmap fixCss $ gwdCss gwd + , gwdJavascript = fmap fixJS $ gwdJavascript gwd + , gwdHead = fixHead $ gwdHead gwd + } + where + fixRender f route params = f (tp route) params + + fixBody (Body h) = Body $ h . fixRender + fixHead (Head h) = Head $ h . fixRender + + fixUnique go (UniqueList f) = UniqueList (map go (f []) ++) + + fixScript (Script loc attrs) = Script (fixLoc loc) attrs + fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs + + fixLoc (Local url) = Local $ tp url + fixLoc (Remote t) = Remote t + + fixCss f = f . fixRender + + fixJS f = f . fixRender diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index ae698287..e7325166 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -11,25 +11,27 @@ import Network.Wai.Test import Data.Monoid (mempty) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 +import Control.Monad.Trans.Class getSubsite :: a -> Subsite getSubsite = const Subsite -instance YesodSubDispatch Subsite (GHandler master) where +instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite) getBarR :: Monad m => m T.Text getBarR = return $ T.pack "BarR" -getBazR :: Yesod master => HandlerT Subsite (GHandler master) RepHtml +getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] -getBinR :: MonadHandler m => HandlerT Subsite m RepHtml -getBinR = defaultLayoutT - [whamlet| +getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml +getBinR = do + widget <- liftWidget [whamlet|

Used defaultLayoutT Baz |] + lift $ defaultLayout widget data Y = Y mkYesod "Y" [parseRoutes| diff --git a/yesod-core/test/YesodCoreTest/RequestBodySize.hs b/yesod-core/test/YesodCoreTest/RequestBodySize.hs index 5b5fc933..98ee3cb5 100644 --- a/yesod-core/test/YesodCoreTest/RequestBodySize.hs +++ b/yesod-core/test/YesodCoreTest/RequestBodySize.hs @@ -18,6 +18,8 @@ import qualified Data.Text as T import Data.Conduit import Data.Conduit.List (consume) import Data.Conduit.Binary (isolate) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Resource data Y = Y @@ -38,13 +40,11 @@ postPostR = do return $ RepPlain $ toContent $ T.concat val postConsumeR = do - req <- waiRequest - body <- lift $ requestBody req $$ consume + body <- rawRequestBody $$ consume return $ RepPlain $ toContent $ S.concat body postPartialConsumeR = do - req <- waiRequest - body <- lift $ requestBody req $$ isolate 5 =$ consume + body <- rawRequestBody $$ isolate 5 =$ consume return $ RepPlain $ toContent $ S.concat body postUnusedR = return $ RepPlain "" diff --git a/yesod-core/test/YesodCoreTest/Widget.hs b/yesod-core/test/YesodCoreTest/Widget.hs index d69515b1..38a9f71e 100644 --- a/yesod-core/test/YesodCoreTest/Widget.hs +++ b/yesod-core/test/YesodCoreTest/Widget.hs @@ -61,18 +61,14 @@ getTowidgetR = defaultLayout $ do getWhamletR :: Handler RepHtml getWhamletR = defaultLayout [whamlet| -$newline never -

Test -

@{WhamletR} -

_{Goodbye} -

_{MsgAnother} -^{embed} -|] +

Test +

@{WhamletR} +

_{Goodbye} +

_{MsgAnother} + ^{embed} + |] where - embed = [whamlet| -$newline never -

Embed -|] + embed = [whamlet|

Embed|] getAutoR :: Handler RepHtml getAutoR = defaultLayout [whamlet| diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index c81439bb..0f20e308 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -133,6 +133,7 @@ test-suite tests , conduit , containers , lifted-base + , resourcet ghc-options: -Wall source-repository head