Compiles again, tests fails

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)

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
+        :: (m TypedContent
-        => (HandlerT parent m TypedContent
+                -> YesodRunnerEnv (HandlerSite m)
-                -> YesodRunnerEnv parent
+                -> Maybe (Route (HandlerSite m))
-                -> Maybe (Route parent)
                 -> W.Application)
-        -> (parent -> sub)
+        -> (HandlerSite m -> sub)
-        -> (Route sub -> Route parent)
+        -> (Route sub -> Route (HandlerSite m))
-        -> YesodRunnerEnv parent
+        -> YesodRunnerEnv (HandlerSite m)
         -> W.Application
 
 instance YesodSubDispatch WaiSubsite master where

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
+    askYesodRequest = WidgetT $ return . (, mempty) . handlerRequest
-    askHandlerEnv = WidgetT $ fmap (, mempty) $ askHandlerEnv
+    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

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'

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"

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

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)
+    return a = WidgetT $ const $ return (a, mempty)
-    WidgetT x >>= f = WidgetT $ do
+    WidgetT x >>= f = WidgetT $ \r -> do
-        (a, wa) <- x
+        (a, wa) <- x r
-        (b, wb) <- unWidgetT (f a)
+        (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 =
+    data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
-        StW (StM (HandlerT site m) (a, GWData (Route site)))
+    liftBaseWith f = WidgetT $ \reader ->
-    liftBaseWith f = WidgetT $ liftBaseWith $ \runInBase ->
+        liftBaseWith $ \runInBase ->
-        liftM (\x -> (x, mempty))
+            liftM (\x -> (x, mempty))
-        (f $ liftM StW . runInBase . unWidgetT)
+            (f $ liftM StW . runInBase . flip unWidgetT reader)
-    restoreM (StW base) = WidgetT $ restoreM base
+    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
+instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
-    liftResourceT = HandlerT . const . liftResourceT
+    liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
 
 instance MonadIO m => MonadLogger (HandlerT site m) where
     monadLoggerLog a b c d = HandlerT $ \hd ->

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
+    (a, gwd) <- liftIO $ f hd { handlerToParent = const () }
-    return $ WidgetT $ HandlerT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
+    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

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 :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml
-getBinR = defaultLayoutT
+getBinR = do
-    [whamlet|
+    widget <- liftWidget [whamlet|
         <p>Used defaultLayoutT
         <a href=@{BazR}>Baz
     |]
+    lift $ defaultLayout widget
 
 data Y = Y
 mkYesod "Y" [parseRoutes|

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 <- rawRequestBody $$ consume
-    body <- lift $ requestBody req $$ consume
     return $ RepPlain $ toContent $ S.concat body
 
 postPartialConsumeR = do
-    req <- waiRequest
+    body <- rawRequestBody $$ isolate 5 =$ consume
-    body <- lift $ requestBody req $$ isolate 5 =$ consume
     return $ RepPlain $ toContent $ S.concat body
 
 postUnusedR = return $ RepPlain ""

yesod-core/test/YesodCoreTest/Widget.hs

@@ -61,18 +61,14 @@ getTowidgetR = defaultLayout $ do
 
 getWhamletR :: Handler RepHtml
 getWhamletR = defaultLayout [whamlet|
-$newline never
+                    <h1>Test
-<h1>Test
+                    <h2>@{WhamletR}
-<h2>@{WhamletR}
+                    <h3>_{Goodbye}
-<h3>_{Goodbye}
+                    <h3>_{MsgAnother}
-<h3>_{MsgAnother}
+                    ^{embed}
-^{embed}
+                |]
-|]
   where
-    embed = [whamlet|
+    embed = [whamlet|<h4>Embed|]
-$newline never
-<h4>Embed
-|]
 
 getAutoR :: Handler RepHtml
 getAutoR = defaultLayout [whamlet|

yesod-core/yesod-core.cabal

@@ -133,6 +133,7 @@ test-suite tests
                   , conduit
                   , containers
                   , lifted-base
+                  , resourcet
     ghc-options:     -Wall
 
 source-repository head