Remove requestBody, live in Iteratee

Yesod/Dispatch.hs

@@ -43,6 +43,7 @@ import Network.Wai.Middleware.Gzip
 
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString as S
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as L
 import Blaze.ByteString.Builder (toLazyByteString)
 
@@ -70,7 +71,8 @@ import System.Random (randomR, newStdGen)
 import qualified Data.Map as Map
 
 import Control.Applicative ((<$>))
-import Data.Enumerator (($$), run_)
+import Data.Enumerator (($$), run_, Iteratee)
+import Control.Monad.IO.Class (liftIO)
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -251,10 +253,9 @@ toWaiApp' :: (Yesod y, YesodSite y)
           => y
           -> Maybe Key
           -> [String]
-          -> W.Request
+          -> W.Application
-          -> IO W.Response
 toWaiApp' y key' segments env = do
-    now <- getCurrentTime
+    now <- liftIO getCurrentTime
     let getExpires m = fromIntegral (m * 60) `addUTCTime` now
     let exp' = getExpires $ clientSessionDuration y
     let host = if sessionIpAddress y then W.remoteHost env else ""
@@ -276,7 +277,7 @@ toWaiApp' y key' segments env = do
                     (joinPath y (approot y) ps $ qs ++ qs')
                     (urlRenderOverride y u)
     let errorHandler' = localNoCurrent . errorHandler
-    rr <- parseWaiRequest env session' key'
+    rr <- liftIO $ parseWaiRequest env session' key'
     let h = do
           onRequest
           case eurl of
@@ -389,11 +390,10 @@ parseWaiRequest env session' key' = do
 nonceKey :: String
 nonceKey = "_NONCE"
 
-rbHelper :: W.Request -> IO RequestBodyContents
+rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
 rbHelper req =
-    (map fix1 *** map fix2) <$> run_ (enum $$ iter)
+    (map fix1 *** map fix2) <$> iter
   where
-    enum = W.requestBody req
     iter = parseRequestBody lbsSink req
     fix1 = bsToChars *** bsToChars
     fix2 (x, NWP.FileInfo a b c) =
@@ -402,11 +402,18 @@ rbHelper req =
 -- | Produces a \"compute on demand\" value. The computation will be run once
 -- it is requested, and then the result will be stored. This will happen only
 -- once.
-iothunk :: IO a -> IO (IO a)
+iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a)
-iothunk = fmap go . newMVar . Left where
+iothunk =
-    go :: MVar (Either (IO a) a) -> IO a
+    fmap go . liftIO . newMVar . Left
-    go mvar = modifyMVar mvar go'
+  where
-    go' :: Either (IO a) a -> IO (Either (IO a) a, a)
+    go :: MVar (Either (Iteratee ByteString IO a) a) -> Iteratee ByteString IO a
+    go mvar = do
+        x <- liftIO $ takeMVar mvar
+        (x', a) <- go' x
+        liftIO $ putMVar mvar x'
+        return a
+    go' :: Either (Iteratee ByteString IO a) a
+        -> Iteratee ByteString IO (Either (Iteratee ByteString IO a) a, a)
     go' (Right val) = return (Right val, val)
     go' (Left comp) = do
         val <- comp

Yesod/Handler.hs

@@ -101,6 +101,8 @@ import Control.Exception hiding (Handler, catch, finally)
 import qualified Control.Exception as E
 import Control.Applicative
 
+import Control.Monad (liftM)
+
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
@@ -117,6 +119,8 @@ import Text.Hamlet
 import Control.Monad.IO.Peel (MonadPeelIO)
 import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as S8
+import Data.ByteString (ByteString)
+import Data.Enumerator (Iteratee (..))
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -203,18 +207,20 @@ toMasterHandlerMaybe tm ts route (GHandler h) =
 -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
 -- special responses. It is declared as a newtype to make compiler errors more
 -- readable.
-newtype GHandler sub master a =
+newtype GGHandler sub master m a =
     GHandler
-        { unGHandler :: GHInner sub master a
+        { unGHandler :: GHInner sub master m a
         }
     deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)
 
-type GHInner s m =
+type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)
+
+type GHInner s m monad =
     ReaderT (HandlerData s m) (
     ErrorT HandlerContents (
     WriterT (Endo [Header]) (
     StateT SessionMap ( -- session
-    IO
+    monad
     ))))
 
 type SessionMap = Map.Map String String
@@ -230,7 +236,7 @@ newtype YesodApp = YesodApp
     -> Request
     -> [ContentType]
     -> SessionMap
-    -> IO YesodAppResult
+    -> Iteratee ByteString IO YesodAppResult
     }
 
 data YesodAppResult
@@ -248,38 +254,43 @@ data HandlerContents =
 instance Error HandlerContents where
     strMsg = HCError . InternalError
 
-instance Failure ErrorResponse (GHandler sub master) where
+instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
     failure = GHandler . lift . throwError . HCError
 instance RequestReader (GHandler sub master) where
     getRequest = handlerRequest <$> GHandler ask
+    runRequestBody = do
+        rr <- getRequest
+        GHandler $ lift $ lift $ lift $ lift $ reqRequestBody rr
 
 -- | Get the sub application argument.
-getYesodSub :: GHandler sub master sub
+getYesodSub :: Monad m => GGHandler sub master m sub
-getYesodSub = handlerSub <$> GHandler ask
+getYesodSub = handlerSub `liftM` GHandler ask
 
 -- | Get the master site appliation argument.
-getYesod :: GHandler sub master master
+getYesod :: Monad m => GGHandler sub master m master
-getYesod = handlerMaster <$> GHandler ask
+getYesod = handlerMaster `liftM` GHandler ask
 
 -- | Get the URL rendering function.
-getUrlRender :: GHandler sub master (Route master -> String)
+getUrlRender :: Monad m => GGHandler sub master m (Route master -> String)
 getUrlRender = do
-    x <- handlerRender <$> GHandler ask
+    x <- handlerRender `liftM` GHandler ask
     return $ flip x []
 
 -- | The URL rendering function with query-string parameters.
-getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String)
+getUrlRenderParams
-getUrlRenderParams = handlerRender <$> GHandler ask
+    :: Monad m
+    => GGHandler sub master m (Route master -> [(String, String)] -> String)
+getUrlRenderParams = handlerRender `liftM` GHandler 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 :: Monad m => GGHandler sub master m (Maybe (Route sub))
-getCurrentRoute = handlerRoute <$> GHandler ask
+getCurrentRoute = handlerRoute `liftM` GHandler 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 :: Monad m => GGHandler sub master m (Route sub -> Route master)
-getRouteToMaster = handlerToMaster <$> GHandler ask
+getRouteToMaster = handlerToMaster `liftM` GHandler ask
 
 -- | Function used internally by Yesod in the process of converting a
 -- 'GHandler' into an 'W.Application'. Should not be needed by users.
@@ -304,7 +315,7 @@ runHandler handler mrender sroute tomr ma tosa =
             , handlerRender = mrender
             , handlerToMaster = tomr
             }
-    ((contents', headers), finalSession) <- E.catch (
+    ((contents', headers), finalSession) <- catchIter (
         flip runStateT initSession
       $ runWriterT
       $ runErrorT
@@ -323,7 +334,7 @@ runHandler handler mrender sroute tomr ma tosa =
             return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession
     case contents of
         HCContent status a -> do
-            (ct, c) <- chooseRep a cts
+            (ct, c) <- liftIO $ chooseRep a cts
             return $ YARPlain status (headers []) ct c finalSession
         HCError e -> handleError e
         HCRedirect rt loc -> do
@@ -331,7 +342,7 @@ runHandler handler mrender sroute tomr ma tosa =
             return $ YARPlain
                 (getRedirectStatus rt) hs typePlain emptyContent
                 finalSession
-        HCSendFile ct fp -> E.catch
+        HCSendFile ct fp -> catchIter
             (sendFile' ct fp)
             (handleError . toErrorHandler)
         HCCreated loc -> do -- FIXME add status201 to WAI
@@ -344,6 +355,12 @@ runHandler handler mrender sroute tomr ma tosa =
                 finalSession
         HCEnum e -> return $ YAREnum e
 
+catchIter :: Exception e
+          => Iteratee ByteString IO a
+          -> (e -> Iteratee ByteString IO a)
+          -> Iteratee ByteString IO a
+catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f)
+
 safeEh :: ErrorResponse -> YesodApp
 safeEh er = YesodApp $ \_ _ _ session -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er

Yesod/Request.hs

@@ -41,6 +41,8 @@ module Yesod.Request
     ) where
 
 import qualified Network.Wai as W
+import Data.ByteString (ByteString)
+import Data.Enumerator (Iteratee)
 import qualified Data.ByteString.Lazy as BL
 import "transformers" Control.Monad.IO.Class
 import Control.Monad (liftM)
@@ -51,11 +53,12 @@ type ParamName = String
 type ParamValue = String
 type ParamError = String
 
+-- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler
+
 -- | The reader monad specialized for 'Request'.
 class Monad m => RequestReader m where
     getRequest :: m Request
-instance RequestReader ((->) Request) where
+    runRequestBody :: m RequestBodyContents
-    getRequest = id
 
 -- | Get the list of supported languages supplied by the user.
 --
@@ -107,7 +110,7 @@ data Request = Request
       -- service, you may want to accept JSON-encoded data. Just be aware that
       -- if you do such parsing, the standard POST form parsing functions will
       -- no longer work.
-    , reqRequestBody :: IO RequestBodyContents
+    , reqRequestBody :: Iteratee ByteString IO RequestBodyContents
     , reqWaiRequest :: W.Request
       -- | Languages which the client supports.
     , reqLangs :: [String]
@@ -129,12 +132,11 @@ lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)
 lookupGetParam = liftM listToMaybe . lookupGetParams
 
 -- | Lookup for POST parameters.
-lookupPostParams :: (MonadIO m, RequestReader m)
+lookupPostParams :: RequestReader m
                  => ParamName
                  -> m [ParamValue]
 lookupPostParams pn = do
-    rr <- getRequest
+    (pp, _) <- runRequestBody
-    (pp, _) <- liftIO $ reqRequestBody rr
     return $ lookup' pn pp
 
 lookupPostParam :: (MonadIO m, RequestReader m)
@@ -149,12 +151,11 @@ lookupFile :: (MonadIO m, RequestReader m)
 lookupFile = liftM listToMaybe . lookupFiles
 
 -- | Lookup for POSTed files.
-lookupFiles :: (MonadIO m, RequestReader m)
+lookupFiles :: RequestReader m
             => ParamName
             -> m [FileInfo]
 lookupFiles pn = do
-    rr <- getRequest
+    (_, files) <- runRequestBody
-    (_, files) <- liftIO $ reqRequestBody rr
     return $ lookup' pn files
 
 -- | Lookup for cookie data.

Yesod/Widget.hs

@@ -7,7 +7,8 @@
 -- generator, allowing you to create truly modular HTML components.
 module Yesod.Widget
     ( -- * Datatype
-      GWidget (..)
+      GWidget
+    , GGWidget (..)
     , liftHandler
     , PageContent (..)
       -- * Creating
@@ -54,15 +55,17 @@ import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Class (lift)
 import Yesod.Internal
 import Yesod.Content (RepHtml (RepHtml), Content, toContent)
+import Control.Monad (liftM)
 
 import Control.Monad.IO.Peel (MonadPeelIO)
 
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. This is basically a large 'WriterT' stack keeping track of
 -- dependencies along with a 'StateT' to track unique identifiers.
-newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a }
+newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a }
     deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)
-type GWInner sub master =
+type GWidget s m = GGWidget s m (GHandler s m)
+type GWInner sub master monad =
     WriterT (Body (Route master)) (
     WriterT (Last Title) (
     WriterT (UniqueList (Script (Route master))) (
@@ -71,28 +74,28 @@ type GWInner sub master =
     WriterT (Maybe (Julius (Route master))) (
     WriterT (Head (Route master)) (
     StateT Int (
-    GHandler sub master
+    monad
     ))))))))
-instance Monoid (GWidget sub master ()) where
+instance Monad monad => Monoid (GGWidget sub master monad ()) where
     mempty = return ()
     mappend x y = x >> y
 
-instance HamletValue (GWidget s m ()) where
+instance Monad monad => HamletValue (GGWidget s m monad ()) where
-    newtype HamletMonad (GWidget s m ()) a =
+    newtype HamletMonad (GGWidget s m monad ()) a =
-        GWidget' { runGWidget' :: GWidget s m a }
+        GWidget' { runGWidget' :: GGWidget s m monad a }
-    type HamletUrl (GWidget s m ()) = Route m
+    type HamletUrl (GGWidget s m monad ()) = Route m
     toHamletValue = runGWidget'
     htmlToHamletMonad = GWidget' . addHtml
     urlToHamletMonad url params = GWidget' $
         addHamlet $ \r -> preEscapedString (r url params)
     fromHamletValue = GWidget'
-instance Monad (HamletMonad (GWidget s m ())) where
+instance Monad monad => Monad (HamletMonad (GGWidget s m monad ())) where
     return = GWidget' . return
     x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y
 
 -- | Lift an action in the 'GHandler' monad into an action in the 'GWidget'
 -- monad.
-liftHandler :: GHandler sub master a -> GWidget sub master a
+liftHandler :: Monad monad => monad a -> GGWidget sub master monad a
 liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift
 
 addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
@@ -125,32 +128,32 @@ addSubWidget sub w = do master <- liftHandler getYesod
 
 -- | Set the page title. Calling 'setTitle' multiple times overrides previously
 -- set values.
-setTitle :: Html -> GWidget sub master ()
+setTitle :: Monad m => Html -> GGWidget sub master m ()
 setTitle = GWidget . lift . tell . Last . Just . Title
 
 -- | Add a 'Hamlet' to the head tag.
-addHamletHead :: Hamlet (Route master) -> GWidget sub master ()
+addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
 addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head
 
 -- | Add a 'Html' to the head tag.
-addHtmlHead :: Html -> GWidget sub master ()
+addHtmlHead :: Monad m => Html -> GGWidget sub master m ()
 addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const
 
 -- | Add a 'Hamlet' to the body tag.
-addHamlet :: Hamlet (Route master) -> GWidget sub master ()
+addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()
 addHamlet = GWidget . tell . Body
 
 -- | Add a 'Html' to the body tag.
-addHtml :: Html -> GWidget sub master ()
+addHtml :: Monad m => Html -> GGWidget sub master m ()
 addHtml = GWidget . tell . Body . const
 
 -- | Add another widget. This is defined as 'id', by can help with types, and
 -- makes widget blocks look more consistent.
-addWidget :: GWidget s m () -> GWidget s m ()
+addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo ()
 addWidget = id
 
 -- | Get a unique identifier.
-newIdent :: GWidget sub master String
+newIdent :: Monad mo => GGWidget sub master mo String
 newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do
     i <- get
     let i' = i + 1
@@ -158,42 +161,42 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do
     return $ "w" ++ show i'
 
 -- | Add some raw CSS to the style tag.
-addCassius :: Cassius (Route master) -> GWidget sub master ()
+addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m ()
 addCassius = GWidget . lift . lift . lift . lift . tell . Just
 
 -- | Link to the specified local stylesheet.
-addStylesheet :: Route master -> GWidget sub master ()
+addStylesheet :: Monad m => Route master -> GGWidget sub master m ()
 addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local
 
 -- | Link to the specified remote stylesheet.
-addStylesheetRemote :: String -> GWidget sub master ()
+addStylesheetRemote :: Monad m => String -> GGWidget sub master m ()
 addStylesheetRemote =
     GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
 
-addStylesheetEither :: Either (Route master) String -> GWidget sub master ()
+addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
 addStylesheetEither = either addStylesheet addStylesheetRemote
 
-addScriptEither :: Either (Route master) String -> GWidget sub master ()
+addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()
 addScriptEither = either addScript addScriptRemote
 
 -- | Link to the specified local script.
-addScript :: Route master -> GWidget sub master ()
+addScript :: Monad m => Route master -> GGWidget sub master m ()
 addScript = GWidget . lift . lift . tell . toUnique . Script . Local
 
 -- | Link to the specified remote script.
-addScriptRemote :: String -> GWidget sub master ()
+addScriptRemote :: Monad m => String -> GGWidget sub master m ()
 addScriptRemote =
     GWidget . lift . lift . tell . toUnique . Script . Remote
 
 -- | Include raw Javascript in the page's script tag.
-addJulius :: Julius (Route master) -> GWidget sub master ()
+addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m ()
 addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just
 
 -- | Pull out the HTML tag contents and return it. Useful for performing some
 -- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
-extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m))
+extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m))
 extractBody (GWidget w) =
-    GWidget $ mapWriterT (fmap go) w
+    GWidget $ mapWriterT (liftM go) w
   where
     go ((), Body h) = (h, Body mempty)