diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index c025060a..fecbb74f 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -94,7 +94,7 @@ import Data.Version (showVersion) import Yesod.Routes.Class (RenderRoute (..)) -- | Return an 'Unauthorized' value, with the given i18n message. -unauthorizedI :: RenderMessage site msg => msg -> GHandler site AuthResult +unauthorizedI :: (Monad m, RenderMessage site msg) => msg -> HandlerT site m AuthResult unauthorizedI msg = do mr <- getMessageRender return $ Unauthorized $ mr msg @@ -109,44 +109,14 @@ yesodVersion = showVersion Paths_yesod_core.version maybeAuthorized :: Yesod site => Route site -> Bool -- ^ is this a write request? - -> GHandler site (Maybe (Route site)) + -> HandlerT site IO (Maybe (Route site)) maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing -defaultLayoutT :: ( HandlerSite m ~ sub - , Yesod (HandlerMaster m) - , MonadHandler m - ) - => GWidget sub () - -> m RepHtml -defaultLayoutT (GWidget (GHandler f)) = do - hd <- askHandlerData +defaultLayoutT :: Yesod parent + => WidgetT child m () + -> HandlerT parent m RepHtml +defaultLayoutT (WidgetT (HandlerT f)) = HandlerT $ \hd -> do ((), gwdata) <- liftResourceT $ f hd - liftHandlerMaster $ defaultLayout $ GWidget $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata) - -renderGWData :: (x -> [(Text, Text)] -> Text) -> GWData x -> GWData y -renderGWData render 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 - fixBody (Body h) = Body $ const $ h render - fixHead (Head h) = Head $ const $ h render - - 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) = Remote $ render url [] - fixLoc (Remote t) = Remote t - - fixCss f = const $ f render - - fixJS f = const $ f render + 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 6c71c6ba..562501dc 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -21,16 +21,16 @@ import Control.Monad.Trans.Control (MonadBaseControl) class Yesod site => YesodDispatch site where yesodDispatch :: YesodRunnerEnv site -> W.Application -class YesodSubDispatch sub m where +class YesodSubDispatch sub parent where yesodSubDispatch - :: (MonadHandler m, master ~ HandlerMaster m, Yesod master) - => (m TypedContent - -> YesodRunnerEnv master - -> Maybe (Route master) + :: Monad m + => (HandlerT parent m TypedContent + -> YesodRunnerEnv parent + -> Maybe (Route parent) -> W.Application) - -> (master -> sub) - -> (Route sub -> Route master) - -> YesodRunnerEnv master + -> (parent -> sub) + -> (Route sub -> Route parent) + -> YesodRunnerEnv parent -> W.Application instance YesodSubDispatch WaiSubsite master where @@ -39,16 +39,18 @@ instance YesodSubDispatch WaiSubsite master where where WaiSubsite app = toSub site -subHelper :: (HandlerSite m ~ master, MonadHandler m) - => (m TypedContent - -> YesodRunnerEnv master - -> Maybe (Route master) +-- | A helper function for creating YesodSubDispatch instances, used by the +-- internal generated code. +subHelper :: Monad m + => (HandlerT parent m TypedContent + -> YesodRunnerEnv parent + -> Maybe (Route parent) -> W.Application) - -> (master -> sub) - -> (Route sub -> Route master) - -> HandlerT sub m TypedContent - -> YesodRunnerEnv master - -> Maybe (Route sub) + -> (parent -> child) + -> (Route child -> Route parent) + -> HandlerT child (HandlerT parent m) TypedContent + -> YesodRunnerEnv parent + -> Maybe (Route child) -> W.Application subHelper parentRunner getSub toMaster handlert env route = parentRunner base env (fmap toMaster route) diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index af0330ec..020e496b 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -122,8 +122,8 @@ mkYesodGeneral name args clazzes isSub resS = do context = if isSub then cxt $ yesod : map return clazzes else return [] yesod = classP ''HandlerReader [master] - handler = tySynD (mkName "Handler") [] [t| GHandler $master |] - widget = tySynD (mkName "Widget") [] [t| GWidget $master () |] + handler = tySynD (mkName "Handler") [] [t| HandlerT $master IO |] + widget = tySynD (mkName "Widget") [] [t| WidgetT $master IO () |] res = map (fmap parseType) resS subCons = conT $ mkName name subArgs = map (varT. mkName) args diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index dbab8595..bef4a708 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -297,7 +297,8 @@ handlerToIO = newReq = oldReq { reqWaiRequest = newWaiReq } clearedOldHandlerData = oldHandlerData { handlerRequest = err "handlerRequest never here" - , handlerState = err "handlerState never here" } + , handlerState = err "handlerState never here" + , handlerToParent = const () } where err :: String -> a err = error . ("handlerToIO: clearedOldHandlerData/" ++) diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index a57fbd55..5a6924ba 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -12,11 +12,12 @@ import Blaze.ByteString.Builder (toByteString) import Control.Applicative ((<$>)) import Control.Exception (fromException) import Control.Exception.Lifted (catch) +import Control.Monad (join) 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) +import Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -45,10 +46,10 @@ import Yesod.Core.Internal.Request (parseWaiRequest, import Yesod.Routes.Class (Route, renderRoute) -- | Function used internally by Yesod in the process of converting a --- 'GHandler' into an 'Application'. Should not be needed by users. +-- 'HandlerT' into an 'Application'. Should not be needed by users. runHandler :: ToTypedContent c => RunHandlerEnv site - -> GHandler site c + -> HandlerT site IO c -> YesodApp runHandler rhe@RunHandlerEnv {..} handler yreq = do let toErrorHandler e = @@ -66,8 +67,9 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do { handlerRequest = yreq , handlerEnv = rhe , handlerState = istate + , handlerToParent = const () } - contents' <- catch (fmap Right $ unGHandler handler hd) + contents' <- catch (fmap Right $ unHandlerT handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id $ fromException e) state <- liftIO $ I.readIORef istate @@ -128,31 +130,31 @@ safeEh log' er req = do (toContent ("Internal Server Error" :: S.ByteString)) (reqSession req) --- | Run a 'GHandler' completely outside of Yesod. This +-- | Run a 'HandlerT' completely outside of Yesod. This -- function comes with many caveats and you shouldn't use it -- unless you fully understand what it's doing and how it works. -- -- As of now, there's only one reason to use this function at --- all: in order to run unit tests of functions inside 'GHandler' +-- all: in order to run unit tests of functions inside 'HandlerT' -- but that aren't easily testable with a full HTTP request. -- Even so, it's better to use @wai-test@ or @yesod-test@ instead -- of using this function. -- -- This function will create a fake HTTP request (both @wai@'s -- 'Request' and @yesod@'s 'Request') and feed it to the --- @GHandler@. The only useful information the @GHandler@ may +-- @HandlerT@. The only useful information the @HandlerT@ may -- get from the request is the session map, which you must supply -- as argument to @runFakeHandler@. All other fields contain -- fake information, which means that they can be accessed but -- won't have any useful information. The response of the --- @GHandler@ is completely ignored, including changes to the +-- @HandlerT@ is completely ignored, including changes to the -- session, cookies or headers. We only return you the --- @GHandler@'s return value. +-- @HandlerT@'s return value. runFakeHandler :: (Yesod site, MonadIO m) => SessionMap -> (site -> Logger) -> site - -> GHandler site a + -> HandlerT site IO a -> m (Either ErrorResponse a) runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") @@ -208,7 +210,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} yesodRunner :: (ToTypedContent res, Yesod site) - => GHandler site res + => HandlerT site IO res -> YesodRunnerEnv site -> Maybe (Route site) -> Application @@ -269,20 +271,18 @@ resolveApproot master req = ApprootMaster f -> f master ApprootRequest f -> f master req -stripHandlerT :: (MonadHandler m, MonadBaseControl IO m) - => HandlerT sub m a - -> (HandlerSite m -> sub) - -> (Route sub -> Route (HandlerSite m)) - -> Maybe (Route sub) - -> m a -stripHandlerT (HandlerT f) getSub toMaster newRoute = do - hd <- askHandlerData - +stripHandlerT :: HandlerT child (HandlerT parent m) a + -> (parent -> child) + -> (Route child -> Route parent) + -> Maybe (Route child) + -> HandlerT parent m a +stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do let env = handlerEnv hd - f hd + joinResourceT $ transResourceT (($ hd) . unHandlerT) $ f hd { handlerEnv = env { rheSite = getSub $ rheSite env , rheRoute = newRoute , rheRender = \url params -> rheRender env (toMaster url) params } + , handlerToParent = toMaster } diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index e322608b..20952c21 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -48,9 +48,9 @@ import Control.Monad.Trans.Resource (liftResourceT) -- -- /Since: 0.3.0/ defaultLayoutJson :: (Yesod site, J.ToJSON a) - => WidgetT site m () -- ^ HTML - -> HandlerT site m a -- ^ JSON - -> HandlerT site m TypedContent + => WidgetT site IO () -- ^ HTML + -> HandlerT site IO a -- ^ JSON + -> HandlerT site IO TypedContent defaultLayoutJson w json = selectRep $ do provideRep $ defaultLayout w provideRep $ fmap J.toJSON json @@ -59,7 +59,7 @@ defaultLayoutJson w json = selectRep $ do -- support conversion to JSON via 'J.ToJSON'. -- -- /Since: 0.3.0/ -jsonToRepJson :: J.ToJSON a => a -> HandlerT site m J.Value +jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value jsonToRepJson = return . J.toJSON -- | Parse the request body to a data type as a JSON value. The @@ -68,7 +68,7 @@ jsonToRepJson = return . J.toJSON -- 'J.Value'@. -- -- /Since: 0.3.0/ -parseJsonBody :: (MonadResource m, J.FromJSON a) => m (J.Result a) +parseJsonBody :: (MonadResource m, HandlerReader m, J.FromJSON a) => m (J.Result a) parseJsonBody = do req <- waiRequest eValue <- runExceptionT diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 5dd09657..2a174493 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -179,10 +179,11 @@ data RunHandlerEnv site = RunHandlerEnv -- Since 1.2.0 } -data HandlerData site = HandlerData - { handlerRequest :: !YesodRequest - , handlerEnv :: !(RunHandlerEnv site) - , handlerState :: !(IORef GHState) +data HandlerData site parentRoute = HandlerData + { handlerRequest :: !YesodRequest + , handlerEnv :: !(RunHandlerEnv site) + , handlerState :: !(IORef GHState) + , handlerToParent :: !(Route site -> parentRoute) } data YesodRunnerEnv site = YesodRunnerEnv @@ -194,9 +195,13 @@ 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 -> ResourceT m a + { unHandlerT :: HandlerData site (MonadRoute m) -> ResourceT m a } +type family MonadRoute (m :: * -> *) +type instance MonadRoute IO = () +type instance MonadRoute (HandlerT site m) = (Route site) + data GHState = GHState { ghsSession :: SessionMap , ghsRBC :: Maybe RequestBodyContents diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index 81624e3b..2ee75040 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} @@ -50,6 +51,8 @@ import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) +import Control.Monad.Trans.Resource (transResourceT) +import Control.Monad.IO.Class (MonadIO, liftIO) import Text.Shakespeare.I18N (RenderMessage) import Control.Monad (liftM) import Data.Text (Text) @@ -215,3 +218,21 @@ tell w = WidgetT $ return ((), w) toUnique :: x -> UniqueList x toUnique = UniqueList . (:) + +liftHandlerT :: MonadIO m + => HandlerT site IO a + -> HandlerT site m a +liftHandlerT (HandlerT f) = + HandlerT $ transResourceT liftIO . f . fixToParent + where + fixToParent hd = hd { handlerToParent = const () } + +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) + +liftGWD :: (child -> parent) -> GWData child -> GWData parent +liftGWD = error "liftGWD"