From fa8e1ac00f34b371c911e656290cc372da186f63 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 24 Jan 2018 13:01:26 +0200
Subject: [PATCH] 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!
---
 yesod-auth-oauth/Yesod/Auth/OAuth.hs          |  2 +-
 yesod-auth/Yesod/Auth.hs                      |  2 +-
 yesod-core/Yesod/Core.hs                      |  6 --
 yesod-core/Yesod/Core/Class/Dispatch.hs       | 76 +++----------------
 yesod-core/Yesod/Core/Class/Handler.hs        | 28 ++++++-
 yesod-core/Yesod/Core/Handler.hs              | 15 +++-
 yesod-core/Yesod/Core/Internal/Run.hs         | 10 ++-
 yesod-core/Yesod/Core/Types.hs                | 55 ++++++++++++--
 .../test/YesodCoreTest/NoOverloadedStrings.hs |  6 +-
 9 files changed, 111 insertions(+), 89 deletions(-)

diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs
index 11e691c8..1a2d1852 100644
--- 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
diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs
index ae89dd12..baae2e9e 100644
--- 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
diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs
index 2aa04b10..13ed2136 100644
--- 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
diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs
index be9db709..4abe179c 100644
--- 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' }
diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs
index 97cf1aa7..a67f6b72 100644
--- 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)
diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs
index 67f99216..4673a82e 100644
--- 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
diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs
index 0fdcaf5c..5d9aa475 100644
--- 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'
diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs
index 51d9bbe8..2bdf4072 100644
--- 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
diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
index 11d3a145..0a980c87 100644
--- 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|