Started on the Handler typeclasses

yesod-core/Yesod/Core/Handler/Class.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Yesod.Core.Handler.Class where
+
+import Yesod.Core.Types
+import Yesod.Core.Trans.Class (lift)
+import Control.Monad.Trans.Class (MonadTrans)
+import Data.IORef.Lifted (atomicModifyIORef)
+import Control.Exception.Lifted (throwIO)
+
+class Monad m => HandlerReader m where
+    type HandlerReaderSub m
+    type HandlerReaderMaster m
+
+    askYesodRequest :: m YesodRequest
+    askHandlerEnv :: m (RunHandlerEnv (HandlerReaderSub m) (HandlerReaderMaster m))
+
+instance HandlerReader (GHandler sub master) where
+    type HandlerReaderSub (GHandler sub master) = sub
+    type HandlerReaderMaster (GHandler sub master) = master
+
+    askYesodRequest = GHandler $ return . handlerRequest
+    askHandlerEnv = GHandler $ return . handlerEnv
+
+instance HandlerReader (GWidget sub master) where
+    type HandlerReaderSub (GWidget sub master) = sub
+    type HandlerReaderMaster (GWidget sub master) = master
+
+    askYesodRequest = lift askYesodRequest
+    askHandlerEnv = lift askHandlerEnv
+
+instance (MonadTrans t, HandlerReader m, Monad (t m)) => HandlerReader (t m) where
+    type HandlerReaderSub (t m) = HandlerReaderSub m
+    type HandlerReaderMaster (t m) = HandlerReaderMaster m
+
+    askYesodRequest = lift askYesodRequest
+    askHandlerEnv = lift askHandlerEnv
+
+class HandlerReader m => HandlerState m where
+    type HandlerStateSub m
+    type HandlerStateMaster m
+
+    stateGHState :: (GHState -> (a, GHState)) -> m a
+
+    getGHState :: m GHState
+    getGHState = stateGHState $ \s -> (s, s)
+
+    putGHState :: GHState -> m ()
+    putGHState s = stateGHState $ const ((), s)
+
+instance HandlerState (GHandler sub master) where
+    type HandlerStateSub (GHandler sub master) = sub
+    type HandlerStateMaster (GHandler sub master) = master
+
+    stateGHState f =
+        GHandler $ flip atomicModifyIORef f' . handlerState
+      where
+        f' z = let (x, y) = f z in (y, x)
+
+instance HandlerState (GWidget sub master) where
+    type HandlerStateSub (GWidget sub master) = sub
+    type HandlerStateMaster (GWidget sub master) = master
+
+    stateGHState = lift . stateGHState
+
+instance (MonadTrans t, HandlerState m, Monad (t m)) => HandlerState (t m) where
+    type HandlerStateSub (t m) = HandlerStateSub m
+    type HandlerStateMaster (t m) = HandlerStateMaster m
+
+    stateGHState = lift . stateGHState
+
+class Monad m => HandlerError m where
+    handlerError :: ErrorResponse -> m a
+
+instance HandlerError (GHandler sub master) where
+    handlerError = throwIO . HCError
+
+instance HandlerError (GWidget sub master) where
+    handlerError = lift . handlerError
+
+instance (HandlerError m, MonadTrans t, Monad (t m)) => HandlerError (t m) where
+    handlerError = lift . handlerError

yesod-core/Yesod/Handler.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -138,6 +140,7 @@ import Control.Applicative
 import Control.Monad (liftM)
 
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource (MonadResource, liftResourceT)
 
 import qualified Network.Wai as W
 import qualified Network.HTTP.Types as H
@@ -173,28 +176,26 @@ import Yesod.Core.Trans.Class
 import Data.Maybe (listToMaybe)
 import Data.Typeable (Typeable, typeOf)
 import Data.Dynamic (fromDynamic, toDyn)
+import Yesod.Core.Handler.Class
 
 class YesodSubRoute s y where
     fromSubRoute :: s -> y -> Route s -> Route y
 
-get :: GHandler sub master GHState
-get = do
-    hd <- ask
-    liftIO $ I.readIORef $ handlerState hd
+get :: HandlerState m => m GHState
+get = getGHState
 
-put :: GHState -> GHandler sub master ()
-put g = do
-    hd <- ask
-    liftIO $ I.writeIORef (handlerState hd) g
+put :: HandlerState m => GHState -> m ()
+put = putGHState
 
-modify :: (GHState -> GHState) -> GHandler sub master ()
-modify f = do
-    hd <- ask
-    liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
+modify :: HandlerState m => (GHState -> GHState) -> m ()
+modify = stateGHState . (((), ) .)
 
-tell :: Endo [Header] -> GHandler sub master ()
+tell :: HandlerState m => Endo [Header] -> m ()
 tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
 
+hcError :: HandlerError m => ErrorResponse -> m a
+hcError = handlerError
+
 class SubsiteGetter g m s | g -> s where
   runSubsiteGetter :: g -> m s
 
@@ -207,26 +208,22 @@ instance (anySub ~ anySub'
          ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where
   runSubsiteGetter = id
 
-getRequest :: GHandler s m YesodRequest
-getRequest = handlerRequest `liftM` ask
+getRequest :: HandlerReader m => m YesodRequest
+getRequest = askYesodRequest
 
-hcError :: ErrorResponse -> GHandler sub master a
-hcError = liftIO . throwIO . HCError
-
-runRequestBody :: GHandler s m RequestBodyContents
+runRequestBody :: (MonadResource m, HandlerReader m, HandlerState m)
+               => m RequestBodyContents
 runRequestBody = do
-    hd <- ask
-    let getUpload = rheUpload $ handlerEnv hd
-        len = W.requestBodyLength
-            $ reqWaiRequest
-            $ handlerRequest hd
-        upload = getUpload len
+    RunHandlerEnv {..} <- askHandlerEnv
+    req <- askYesodRequest
+    let len = W.requestBodyLength $ reqWaiRequest req
+        upload = rheUpload len
     x <- get
     case ghsRBC x of
         Just rbc -> return rbc
         Nothing -> do
             rr <- waiRequest
-            rbc <- lift $ rbHelper upload rr
+            rbc <- liftResourceT $ rbHelper upload rr
             put x { ghsRBC = Just rbc }
             return rbc
 
@@ -257,33 +254,33 @@ rbHelper' backend mkFI req =
     go = decodeUtf8With lenientDecode
 
 -- | Get the sub application argument.
-getYesodSub :: GHandler sub master sub
-getYesodSub = (rheSub . handlerEnv) `liftM` ask
+getYesodSub :: HandlerReader m => m (HandlerReaderSub m)
+getYesodSub = rheSub `liftM` askHandlerEnv
 
 -- | Get the master site appliation argument.
-getYesod :: GHandler sub master master
-getYesod = (rheMaster . handlerEnv) `liftM` ask
+getYesod :: HandlerReader m => m (HandlerReaderMaster m)
+getYesod = rheMaster `liftM` askHandlerEnv
 
 -- | Get the URL rendering function.
 getUrlRender :: GHandler sub master (Route master -> Text)
 getUrlRender = do
-    x <- (rheRender . handlerEnv) `liftM` ask
+    x <- rheRender `liftM` askHandlerEnv
     return $ flip x []
 
 -- | The URL rendering function with query-string parameters.
 getUrlRenderParams
     :: GHandler sub master (Route master -> [(Text, Text)] -> Text)
-getUrlRenderParams = (rheRender . handlerEnv) `liftM` ask
+getUrlRenderParams = rheRender `liftM` askHandlerEnv
 
 -- | 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 = (rheRoute . handlerEnv) `liftM` ask
+getCurrentRoute = rheRoute `liftM` askHandlerEnv
 
 -- | 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 = (rheToMaster . handlerEnv) `liftM` ask
+getRouteToMaster = rheToMaster `liftM` askHandlerEnv
 
 
 -- | Returns a function that runs 'GHandler' actions inside @IO@.
@@ -400,7 +397,7 @@ setUltDestCurrent = do
         Nothing -> return ()
         Just r -> do
             tm <- getRouteToMaster
-            gets' <- reqGetParams `liftM` handlerRequest `liftM` ask
+            gets' <- reqGetParams `liftM` askYesodRequest
             setUltDest (tm r, gets')
 
 -- | Sets the ultimate destination to the referer request header, if present.
@@ -709,7 +706,7 @@ hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml
 hamletToRepHtml = liftM RepHtml . hamletToContent
 
 -- | Get the request\'s 'W.Request' value.
-waiRequest :: GHandler sub master W.Request
+waiRequest :: HandlerReader m => m W.Request
 waiRequest = reqWaiRequest `liftM` getRequest
 
 getMessageRender :: RenderMessage master message => GHandler s master (message -> Text)
@@ -747,9 +744,6 @@ cached f = do
     cinsert :: Typeable a => a -> Cache -> Cache
     cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m)
 
-ask :: GHandler sub master (HandlerData sub master)
-ask = GHandler return
-
 -- | Get the list of supported languages supplied by the user.
 --
 -- Languages are determined based on the following three (in descending order

yesod-core/yesod-core.cabal

@@ -91,6 +91,7 @@ library
     exposed-modules: Yesod.Content
                      Yesod.Core
                      Yesod.Core.Json
+                     Yesod.Core.Handler.Class
                      Yesod.Dispatch
                      Yesod.Handler
                      Yesod.Widget