diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c0eb4491..f277ef37 100644 --- a/Yesod/Dispatch.hs +++ b/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 - -> IO W.Response + -> W.Application 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 = fmap go . newMVar . Left where - go :: MVar (Either (IO a) a) -> IO a - go mvar = modifyMVar mvar go' - go' :: Either (IO a) a -> IO (Either (IO a) a, a) +iothunk :: Iteratee ByteString IO a -> IO (Iteratee ByteString IO a) +iothunk = + fmap go . liftIO . newMVar . Left + where + 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 diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 174acf48..85354d50 100644 --- a/Yesod/Handler.hs +++ b/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 = handlerSub <$> GHandler ask +getYesodSub :: Monad m => GGHandler sub master m sub +getYesodSub = handlerSub `liftM` GHandler ask -- | Get the master site appliation argument. -getYesod :: GHandler sub master master -getYesod = handlerMaster <$> GHandler ask +getYesod :: Monad m => GGHandler sub master m master +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 = handlerRender <$> GHandler ask +getUrlRenderParams + :: 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 = handlerRoute <$> GHandler ask +getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub)) +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 = handlerToMaster <$> GHandler ask +getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master) +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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 48cc4236..d0c1573c 100644 --- a/Yesod/Request.hs +++ b/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 - getRequest = id + runRequestBody :: m RequestBodyContents -- | 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, _) <- liftIO $ reqRequestBody rr + (pp, _) <- runRequestBody 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) <- liftIO $ reqRequestBody rr + (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index e1c20b9a..62a7cd07 100644 --- a/Yesod/Widget.hs +++ b/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 - newtype HamletMonad (GWidget s m ()) a = - GWidget' { runGWidget' :: GWidget s m a } - type HamletUrl (GWidget s m ()) = Route m +instance Monad monad => HamletValue (GGWidget s m monad ()) where + newtype HamletMonad (GGWidget s m monad ()) a = + GWidget' { runGWidget' :: GGWidget s m monad a } + 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)