Unified some datatypes

yesod-core/Yesod/Core/Run.hs

@@ -12,7 +12,6 @@ import           Control.Exception            (SomeException, fromException,
 import           Control.Exception.Lifted     (catch)
 import           Control.Monad.IO.Class       (MonadIO)
 import           Control.Monad.IO.Class       (liftIO)
-import           Control.Monad.Logger         (LogLevel, LogSource)
 import           Control.Monad.Trans.Resource (runResourceT)
 import           Data.ByteString              (ByteString)
 import qualified Data.ByteString              as S
@@ -30,12 +29,10 @@ import qualified Data.Text                    as T
 import           Data.Text.Encoding           (encodeUtf8)
 import           Data.Text.Encoding           (decodeUtf8With)
 import           Data.Text.Encoding.Error     (lenientDecode)
-import           Language.Haskell.TH.Syntax   (Loc)
 import qualified Network.HTTP.Types           as H
 import           Network.Wai
 import           Prelude                      hiding (catch)
 import           System.IO                    (hPutStrLn, stderr)
-import           System.Log.FastLogger        (LogStr)
 import           System.Log.FastLogger        (Logger)
 import           System.Random                (newStdGen)
 import           Web.Cookie                   (renderSetCookie)
@@ -83,30 +80,20 @@ headerToPair (Header key value) = (CI.mk key, value)
 
 localNoCurrent :: GHandler s m a -> GHandler s m a
 localNoCurrent =
-    local (\hd -> hd { handlerRoute = Nothing })
+    local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheRoute = Nothing }})
 
 local :: (HandlerData sub' master' -> HandlerData sub master)
       -> GHandler sub master a
       -> GHandler sub' master' a
 local f (GHandler x) = GHandler $ \r -> x $ f r
 
-data RunHandlerEnv sub master = RunHandlerEnv -- FIXME merge with YesodRunnerEnv? Or HandlerData
-    { rheRender :: !(Route master -> [(Text, Text)] -> Text)
-    , rheRoute :: !(Maybe (Route sub))
-    , rheToMaster :: !(Route sub -> Route master)
-    , rheMaster :: !master
-    , rheSub :: !sub
-    , rheUpload :: !(RequestBodyLength -> FileUpload)
-    , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-    }
-
 -- | Function used internally by Yesod in the process of converting a
 -- 'GHandler' into an 'Application'. Should not be needed by users.
 runHandler :: HasReps c
            => RunHandlerEnv sub master
            -> GHandler sub master c
            -> YesodApp
-runHandler RunHandlerEnv {..} handler yreq = do
+runHandler rhe@RunHandlerEnv {..} handler yreq = do
     let toErrorHandler e =
             case fromException e of
                 Just (HCError x) -> x
@@ -120,14 +107,8 @@ runHandler RunHandlerEnv {..} handler yreq = do
         }
     let hd = HandlerData
             { handlerRequest = yreq
-            , handlerSub = rheSub
+            , handlerEnv     = rhe
-            , handlerMaster = rheMaster
+            , handlerState   = istate
-            , handlerRoute = rheRoute
-            , handlerRender = rheRender
-            , handlerToMaster = rheToMaster
-            , handlerState = istate
-            , handlerUpload = rheUpload
-            , handlerLog = rheLog
             }
     contents' <- catch (fmap Right $ unGHandler handler hd)
         (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
@@ -290,15 +271,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
   I.readIORef ret
 {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
 
-data YesodRunnerEnv sub master = YesodRunnerEnv
-    { yreLogger         :: !Logger
-    , yreMaster         :: !master
-    , yreSub            :: !sub
-    , yreRoute          :: !(Maybe (Route sub))
-    , yreToMaster       :: !(Route sub -> Route master)
-    , yreSessionBackend :: !(Maybe (SessionBackend master))
-    }
-
 defaultYesodRunner :: Yesod master
                    => YesodRunnerEnv sub master
                    -> GHandler sub master ChooseRep
@@ -410,9 +382,11 @@ handlerSubDataMaybe :: (Route sub -> Route master)
                     -> HandlerData oldSub master
                     -> HandlerData sub master
 handlerSubDataMaybe tm ts route hd = hd
-    { handlerSub = ts $ handlerMaster hd
+    { handlerEnv = (handlerEnv hd)
-    , handlerToMaster = tm
+        { rheSub      = ts $ rheMaster $ handlerEnv hd
-    , handlerRoute = route
+        , rheToMaster = tm
+        , rheRoute    = route
+        }
     }
 
 resolveApproot :: Yesod master => master -> Request -> ResolvedApproot

yesod-core/Yesod/Core/Types.hs

@@ -44,7 +44,7 @@ import           Network.Wai                        (FilePart,
                                                      RequestBodyLength)
 import qualified Network.Wai                        as W
 import qualified Network.Wai.Parse                  as NWP
-import           System.Log.FastLogger              (LogStr, toLogStr)
+import           System.Log.FastLogger              (LogStr, toLogStr, Logger)
 import           Text.Blaze.Html                    (Html)
 import           Text.Hamlet                        (HtmlUrl)
 import           Text.Julius                        (JavascriptUrl)
@@ -114,8 +114,8 @@ data YesodRequest = YesodRequest
 -- | An augmented WAI 'W.Response'. This can either be a standard @Response@,
 -- or a higher-level data structure which Yesod will turn into a @Response@.
 data YesodResponse
-    = YRWai W.Response
+    = YRWai !W.Response
-    | YRPlain H.Status [Header] ContentType Content SessionMap
+    | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap
 
 -- | A tuple containing both the POST parameters and submitted files.
 type RequestBodyContents =
@@ -124,15 +124,15 @@ type RequestBodyContents =
     )
 
 data FileInfo = FileInfo
-    { fileName        :: Text
+    { fileName        :: !Text
-    , fileContentType :: Text
+    , fileContentType :: !Text
-    , fileSource      :: Source (ResourceT IO) ByteString
+    , fileSource      :: !(Source (ResourceT IO) ByteString)
-    , fileMove        :: FilePath -> IO ()
+    , fileMove        :: !(FilePath -> IO ())
     }
 
-data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)
+data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
-                | FileUploadDisk (NWP.BackEnd FilePath)
+                | FileUploadDisk !(NWP.BackEnd FilePath)
-                | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))
+                | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
 
 -- | How to determine the root of the application for constructing URLs.
 --
@@ -140,9 +140,9 @@ data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)
 -- the major version number. As a result, you should /not/ pattern match on
 -- @Approot@ values.
 data Approot master = ApprootRelative -- ^ No application root.
-                    | ApprootStatic Text
+                    | ApprootStatic !Text
-                    | ApprootMaster (master -> Text)
+                    | ApprootMaster !(master -> Text)
-                    | ApprootRequest (master -> W.Request -> Text)
+                    | ApprootRequest !(master -> W.Request -> Text)
 
 type ResolvedApproot = Text
 
@@ -169,16 +169,29 @@ type Texts = [Text]
 -- | Wrap up a normal WAI application as a Yesod subsite.
 newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
 
+data RunHandlerEnv sub master = RunHandlerEnv
+    { rheRender   :: !(Route master -> [(Text, Text)] -> Text)
+    , rheRoute    :: !(Maybe (Route sub))
+    , rheToMaster :: !(Route sub -> Route master)
+    , rheMaster   :: !master
+    , rheSub      :: !sub
+    , rheUpload   :: !(RequestBodyLength -> FileUpload)
+    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+    }
+
 data HandlerData sub master = HandlerData
-    { handlerRequest  :: YesodRequest
+    { handlerRequest  :: !YesodRequest
-    , handlerSub      :: sub
+    , handlerEnv      :: !(RunHandlerEnv sub master)
-    , handlerMaster   :: master
+    , handlerState    :: !(IORef GHState)
-    , handlerRoute    :: Maybe (Route sub)
+    }
-    , handlerRender   :: Route master -> [(Text, Text)] -> Text
+
-    , handlerToMaster :: Route sub -> Route master
+data YesodRunnerEnv sub master = YesodRunnerEnv
-    , handlerState    :: IORef GHState
+    { yreLogger         :: !Logger
-    , handlerUpload   :: RequestBodyLength -> FileUpload
+    , yreMaster         :: !master
-    , handlerLog      :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+    , yreSub            :: !sub
+    , yreRoute          :: !(Maybe (Route sub))
+    , yreToMaster       :: !(Route sub -> Route master)
+    , yreSessionBackend :: !(Maybe (SessionBackend master))
     }
 
 -- | A generic handler monad, which can have a different subsite and master
@@ -407,7 +420,7 @@ instance MonadResource (GHandler sub master) where
 
 instance MonadLogger (GHandler sub master) where
     monadLoggerLog a b c d = GHandler $ \hd ->
-        liftIO $ handlerLog hd a b c (toLogStr d)
+        liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
 
 instance Exception e => Failure e (GHandler sub master) where
     failure = liftIO . throwIO

yesod-core/Yesod/Handler.hs

@@ -199,7 +199,7 @@ hcError = liftIO . throwIO . HCError
 runRequestBody :: GHandler s m RequestBodyContents
 runRequestBody = do
     hd <- ask
-    let getUpload = handlerUpload hd
+    let getUpload = rheUpload $ handlerEnv hd
         len = W.requestBodyLength
             $ reqWaiRequest
             $ handlerRequest hd
@@ -241,32 +241,32 @@ rbHelper' backend mkFI req =
 
 -- | Get the sub application argument.
 getYesodSub :: GHandler sub master sub
-getYesodSub = handlerSub `liftM` ask
+getYesodSub = (rheSub . handlerEnv) `liftM` ask
 
 -- | Get the master site appliation argument.
 getYesod :: GHandler sub master master
-getYesod = handlerMaster `liftM` ask
+getYesod = (rheMaster . handlerEnv) `liftM` ask
 
 -- | Get the URL rendering function.
 getUrlRender :: GHandler sub master (Route master -> Text)
 getUrlRender = do
-    x <- handlerRender `liftM` ask
+    x <- (rheRender . handlerEnv) `liftM` ask
     return $ flip x []
 
 -- | The URL rendering function with query-string parameters.
 getUrlRenderParams
     :: GHandler sub master (Route master -> [(Text, Text)] -> Text)
-getUrlRenderParams = handlerRender `liftM` ask
+getUrlRenderParams = (rheRender . handlerEnv) `liftM` ask
 
 -- | Get the route requested by the user. If this is a 404 response- where the
 -- user requested an invalid route- this function will return 'Nothing'.
 getCurrentRoute :: GHandler sub master (Maybe (Route sub))
-getCurrentRoute = handlerRoute `liftM` ask
+getCurrentRoute = (rheRoute . handlerEnv) `liftM` ask
 
 -- | Get the function to promote a route for a subsite to a route for the
 -- master site.
 getRouteToMaster :: GHandler sub master (Route sub -> Route master)
-getRouteToMaster = handlerToMaster `liftM` ask
+getRouteToMaster = (rheToMaster . handlerEnv) `liftM` ask
 
 
 -- | Returns a function that runs 'GHandler' actions inside @IO@.