Switch to SubHandlerFor

This is much more consistent than suddenly using a ReaderT for subsites. Thanks to @jprider63 for the inspiration for this, I think it cleans things up a lot!
2018-01-24 13:01:26 +02:00 · 2018-01-24 13:01:26 +02:00 · fa8e1ac00f
commit fa8e1ac00f
parent 0f09393c34
9 changed files with 111 additions and 89 deletions
--- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs
+++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs
@ -52,7 +52,7 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
    oauthSessionName = "__oauth_token_secret"

    dispatch
-      :: ( MonadSubHandler m
+      :: ( MonadHandler m
         , master ~ HandlerSite m
         , Auth ~ SubHandlerSite m
         , MonadUnliftIO m
--- a/yesod-auth/Yesod/Auth.hs
+++ b/yesod-auth/Yesod/Auth.hs
@ -78,7 +78,7 @@ import Control.Monad (void)

 type AuthRoute = Route Auth

-type MonadAuthHandler master m = (MonadSubHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
+type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
 type AuthHandler master a = forall m. MonadAuthHandler master m => m a

 type Method = Text
--- a/yesod-core/Yesod/Core.hs
+++ b/yesod-core/Yesod/Core.hs
@ -73,12 +73,6 @@ module Yesod.Core
    , guessApproot
    , guessApprootOr
    , getApprootText
-      -- * Subsites
-    , MonadSubHandler (..)
-    , getSubYesod
-    , getRouteToParent
-    , getSubCurrentRoute
-    , SubsiteData
      -- * Misc
    , yesodVersion
    , yesodRender
--- a/yesod-core/Yesod/Core/Class/Dispatch.hs
+++ b/yesod-core/Yesod/Core/Class/Dispatch.hs
@ -9,10 +9,8 @@ module Yesod.Core.Class.Dispatch where
 import qualified Network.Wai as W
 import Yesod.Core.Types
 import Yesod.Core.Content (ToTypedContent (..))
-import Yesod.Core.Handler (sendWaiApplication, getYesod, getCurrentRoute)
-import Yesod.Core.Class.Handler
+import Yesod.Core.Handler (sendWaiApplication)
 import Yesod.Core.Class.Yesod
-import Control.Monad.Trans.Reader (ReaderT (..))

 -- | This class is automatically instantiated when you use the template haskell
 -- mkYesod function. You should never need to deal with it directly.
@ -35,72 +33,20 @@ instance YesodSubDispatch WaiSubsiteWithAuth master where
      WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
      handlert = sendWaiApplication set

-data SubsiteData child parent = SubsiteData
-  { sdRouteToParent :: !(Route child -> Route parent)
-  , sdCurrentRoute :: !(Maybe (Route child))
-  , sdSubsiteData :: !child
-  }
-
-class MonadHandler m => MonadSubHandler m where
-  type SubHandlerSite m
-
-  liftSubHandler :: ReaderT (SubsiteData (SubHandlerSite m) (HandlerSite m)) (HandlerFor (HandlerSite m)) a -> m a
-
-getSubYesod :: MonadSubHandler m => m (SubHandlerSite m)
-getSubYesod = liftSubHandler $ ReaderT $ return . sdSubsiteData
-
-getRouteToParent :: MonadSubHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))
-getRouteToParent = liftSubHandler $ ReaderT $ return . sdRouteToParent
-
-getSubCurrentRoute :: MonadSubHandler m => m (Maybe (Route (SubHandlerSite m)))
-getSubCurrentRoute = liftSubHandler $ ReaderT $ return . sdCurrentRoute
-
-instance MonadSubHandler (HandlerFor site) where
-  type SubHandlerSite (HandlerFor site) = site
-
-  liftSubHandler (ReaderT x) = do
-    parent <- getYesod
-    currentRoute <- getCurrentRoute
-    x SubsiteData
-      { sdRouteToParent = id
-      , sdCurrentRoute = currentRoute
-      , sdSubsiteData = parent
-      }
-
-instance MonadSubHandler (WidgetFor site) where
-  type SubHandlerSite (WidgetFor site) = site
-
-  liftSubHandler (ReaderT x) = do
-    parent <- getYesod
-    currentRoute <- getCurrentRoute
-    liftHandler $ x SubsiteData
-      { sdRouteToParent = id
-      , sdCurrentRoute = currentRoute
-      , sdSubsiteData = parent
-      }
-
-instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (ReaderT (SubsiteData child parent) m) where
-  type SubHandlerSite (ReaderT (SubsiteData child parent) m) = child
-
-  liftSubHandler (ReaderT f) = ReaderT $ \env -> do
-    toParent' <- getRouteToParent
-    liftHandler $ f env
-      { sdRouteToParent = toParent' . sdRouteToParent env
-      }
-
 subHelper
  :: ToTypedContent content
-  => ReaderT (SubsiteData child master) (HandlerFor master) content
+  => SubHandlerFor child master content
  -> YesodSubRunnerEnv child master
  -> Maybe (Route child)
  -> W.Application
-subHelper (ReaderT f) YesodSubRunnerEnv {..} mroute =
+subHelper (SubHandlerFor f) YesodSubRunnerEnv {..} mroute =
    ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
  where
-    handler = fmap toTypedContent $ do
-      tm <- getRouteToParent
-      liftHandler $ f SubsiteData
-        { sdRouteToParent = tm . ysreToParentRoute
-        , sdCurrentRoute = mroute
-        , sdSubsiteData = ysreGetSub $ yreSite ysreParentEnv
-        }
+    handler = fmap toTypedContent $ HandlerFor $ \hd ->
+      let rhe = handlerEnv hd
+          rhe' = rhe
+            { rheRoute = mroute
+            , rheChild = ysreGetSub $ yreSite ysreParentEnv
+            , rheRouteToMaster = ysreToParentRoute
+            }
+       in f hd { handlerEnv = rhe' }
--- a/yesod-core/Yesod/Core/Class/Handler.hs
+++ b/yesod-core/Yesod/Core/Class/Handler.hs
@ -36,7 +36,9 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
 -- FIXME should we just use MonadReader instances instead?
 class (MonadResource m, MonadLogger m) => MonadHandler m where
    type HandlerSite m
+    type SubHandlerSite m
    liftHandler :: HandlerFor (HandlerSite m) a -> m a
+    liftSubHandler :: SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a

 liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
 liftHandlerT = liftHandler
@ -44,16 +46,38 @@ liftHandlerT = liftHandler

 instance MonadHandler (HandlerFor site) where
    type HandlerSite (HandlerFor site) = site
+    type SubHandlerSite (HandlerFor site) = site
    liftHandler = id
    {-# INLINE liftHandler #-}
+    liftSubHandler (SubHandlerFor f) = HandlerFor f
+    {-# INLINE liftSubHandler #-}
+
+instance MonadHandler (SubHandlerFor sub master) where
+    type HandlerSite (SubHandlerFor sub master) = master
+    type SubHandlerSite (SubHandlerFor sub master) = sub
+    liftHandler (HandlerFor f) = SubHandlerFor $ \hd -> f hd
+      { handlerEnv =
+          let rhe = handlerEnv hd
+           in rhe
+                { rheRoute = fmap (rheRouteToMaster rhe) (rheRoute rhe)
+                , rheRouteToMaster = id
+                , rheChild = rheSite rhe
+                }
+      }
+    {-# INLINE liftHandler #-}
+    liftSubHandler = id
+    {-# INLINE liftSubHandler #-}

 instance MonadHandler (WidgetFor site) where
    type HandlerSite (WidgetFor site) = site
+    type SubHandlerSite (WidgetFor site) = site
    liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler
    {-# INLINE liftHandler #-}
+    liftSubHandler (SubHandlerFor f) = WidgetFor $ f . wdHandler
+    {-# INLINE liftSubHandler #-}

-#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandler = lift . liftHandler
-#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandler = lift . liftHandler
+#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler
 GO(IdentityT)
 GO(ListT)
 GO(MaybeT)
--- a/yesod-core/Yesod/Core/Handler.hs
+++ b/yesod-core/Yesod/Core/Handler.hs
@ -147,6 +147,10 @@ module Yesod.Core.Handler
    , setMessage
    , setMessageI
    , getMessage
+      -- * Subsites
+    , getSubYesod
+    , getRouteToParent
+    , getSubCurrentRoute
      -- * Helpers for specific content
      -- ** Hamlet
    , hamletToRepHtml
@ -321,7 +325,7 @@ rbHelper' backend mkFI req =
            | otherwise = a'
    go = decodeUtf8With lenientDecode

-askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))
+askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
 askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv

 -- | Get the master site application argument.
@ -1593,3 +1597,12 @@ csrfErrorMessage expectedLocations = T.intercalate "\n"
        formatValue maybeText = case maybeText of
          Nothing -> "(which is not currently set)"
          Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"]
+
+getSubYesod :: MonadHandler m => m (SubHandlerSite m)
+getSubYesod = liftSubHandler $ SubHandlerFor $ return . rheChild . handlerEnv
+
+getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))
+getRouteToParent = liftSubHandler $ SubHandlerFor $ return . rheRouteToMaster . handlerEnv
+
+getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))
+getSubCurrentRoute = liftSubHandler $ SubHandlerFor $ return . rheRoute . handlerEnv
--- a/yesod-core/Yesod/Core/Internal/Run.hs
+++ b/yesod-core/Yesod/Core/Internal/Run.hs
@ -64,7 +64,7 @@ errFromShow x = do
 -- exceptions, but all other synchronous exceptions will be caught and
 -- represented by the @HandlerContents@.
 basicRunHandler :: ToTypedContent c
-                => RunHandlerEnv site
+                => RunHandlerEnv site site
                -> HandlerFor site c
                -> YesodRequest
                -> InternalState
@ -107,7 +107,7 @@ basicRunHandler rhe handler yreq resState = do
        }

 -- | Convert an @ErrorResponse@ into a @YesodResponse@
-handleError :: RunHandlerEnv site
+handleError :: RunHandlerEnv sub site
            -> YesodRequest
            -> InternalState
            -> Map.Map Text S8.ByteString
@ -188,7 +188,7 @@ evalFallback contents val = catchAny
 -- | Function used internally by Yesod in the process of converting a
 -- 'HandlerT' into an 'Application'. Should not be needed by users.
 runHandler :: ToTypedContent c
-           => RunHandlerEnv site
+           => RunHandlerEnv site site
           -> HandlerFor site c
           -> YesodApp
 runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
@ -255,6 +255,8 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
         RunHandlerEnv
            { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
            , rheRoute = Nothing
+            , rheRouteToMaster = id
+            , rheChild = site
            , rheSite = site
            , rheUpload = fileUpload site
            , rheLog = messageLoggerSource site $ logger site
@ -329,6 +331,8 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
        rheSafe = RunHandlerEnv
            { rheRender = yesodRender yreSite ra
            , rheRoute = route
+            , rheRouteToMaster = id
+            , rheChild = yreSite
            , rheSite = yreSite
            , rheUpload = fileUpload yreSite
            , rheLog = log'
--- a/yesod-core/Yesod/Core/Types.hs
+++ b/yesod-core/Yesod/Core/Types.hs
@ -175,10 +175,12 @@ newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
 -- @since 1.4.34
 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }

-data RunHandlerEnv site = RunHandlerEnv
+data RunHandlerEnv child site = RunHandlerEnv
    { rheRender   :: !(Route site -> [(Text, Text)] -> Text)
-    , rheRoute    :: !(Maybe (Route site))
+    , rheRoute    :: !(Maybe (Route child))
+    , rheRouteToMaster :: !(Route child -> Route site)
    , rheSite     :: !site
+    , rheChild    :: !child
    , rheUpload   :: !(RequestBodyLength -> FileUpload)
    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
    , rheOnError  :: !(ErrorResponse -> YesodApp)
@ -188,9 +190,9 @@ data RunHandlerEnv site = RunHandlerEnv
    , rheMaxExpires :: !Text
    }

-data HandlerData site = HandlerData
+data HandlerData child site = HandlerData
    { handlerRequest  :: !YesodRequest
-    , handlerEnv      :: !(RunHandlerEnv site)
+    , handlerEnv      :: !(RunHandlerEnv child site)
    , handlerState    :: !(IORef GHState)
    , handlerResource :: !InternalState
    }
@ -220,7 +222,7 @@ type ParentRunner parent
 -- | A generic handler monad, which can have a different subsite and master
 -- site. We define a newtype for better error message.
 newtype HandlerFor site a = HandlerFor
-    { unHandlerFor :: HandlerData site -> IO a
+    { unHandlerFor :: HandlerData site site -> IO a
    }
    deriving Functor

@ -248,7 +250,7 @@ newtype WidgetFor site a = WidgetFor

 data WidgetData site = WidgetData
  { wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
-  , wdHandler :: {-# UNPACK #-} !(HandlerData site)
+  , wdHandler :: {-# UNPACK #-} !(HandlerData site site)
  }

 instance a ~ () => Monoid (WidgetFor site a) where
@ -446,7 +448,7 @@ instance Monad (HandlerFor site) where
    HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
 instance MonadIO (HandlerFor site) where
    liftIO = HandlerFor . const
-instance MonadReader (HandlerData site) (HandlerFor site) where
+instance MonadReader (HandlerData site site) (HandlerFor site) where
    ask = HandlerFor return
    local f (HandlerFor g) = HandlerFor $ g . f

@ -499,3 +501,42 @@ data Logger = Logger

 loggerPutStr :: Logger -> LogStr -> IO ()
 loggerPutStr (Logger ls _) = pushLogStr ls
+
+-- | A handler monad for subsite
+--
+-- @since 1.6.0
+newtype SubHandlerFor sub master a = SubHandlerFor
+    { unSubHandlerFor :: HandlerData sub master -> IO a
+    }
+    deriving Functor
+
+instance Applicative (SubHandlerFor child master) where
+    pure = SubHandlerFor . const . return
+    (<*>) = ap
+instance Monad (SubHandlerFor child master) where
+    return = pure
+    SubHandlerFor x >>= f = SubHandlerFor $ \r -> x r >>= \x' -> unSubHandlerFor (f x') r
+instance MonadIO (SubHandlerFor child master) where
+    liftIO = SubHandlerFor . const
+instance MonadReader (HandlerData child master) (SubHandlerFor child master) where
+    ask = SubHandlerFor return
+    local f (SubHandlerFor g) = SubHandlerFor $ g . f
+
+-- | @since 1.4.38
+instance MonadUnliftIO (SubHandlerFor child master) where
+  {-# INLINE askUnliftIO #-}
+  askUnliftIO = SubHandlerFor $ \r ->
+                return (UnliftIO (flip unSubHandlerFor r))
+
+instance MonadThrow (SubHandlerFor child master) where
+    throwM = liftIO . throwM
+
+instance MonadResource (SubHandlerFor child master) where
+    liftResourceT f = SubHandlerFor $ runInternalState f . handlerResource
+
+instance MonadLogger (SubHandlerFor child master) where
+    monadLoggerLog a b c d = SubHandlerFor $ \sd ->
+        rheLog (handlerEnv sd) a b c (toLogStr d)
+
+instance MonadLoggerIO (SubHandlerFor child master) where
+    askLoggerIO = SubHandlerFor $ return . rheLog . handlerEnv
--- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
+++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
@ -21,13 +21,13 @@ import qualified Data.ByteString.Lazy.Char8 as L8
 getSubsite :: a -> Subsite
 getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)

-getBarR :: MonadSubHandler m => m T.Text
+getBarR :: MonadHandler m => m T.Text
 getBarR = return $ T.pack "BarR"

-getBazR :: (MonadSubHandler m, Yesod (HandlerSite m)) => m Html
+getBazR :: (MonadHandler m, Yesod (HandlerSite m)) => m Html
 getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]

-getBinR :: (MonadSubHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
+getBinR :: (MonadHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
 getBinR = do
    routeToParent <- getRouteToParent
    liftHandler $ defaultLayout [whamlet|