From e802df12dce7d69bfd1a7dc2daa33bc42163da0a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 24 Jan 2011 05:58:58 +0200 Subject: [PATCH] Removed iothunk --- Yesod/Core.hs | 34 +--------------------------------- Yesod/Handler.hs | 38 ++++++++++++++++++++++++++++---------- Yesod/Request.hs | 14 -------------- 3 files changed, 29 insertions(+), 57 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 72cf9a25..f702a2a3 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -598,14 +598,13 @@ parseWaiRequest env session' key' = do langs''' = case lookup langKey gets' of Nothing -> langs'' Just x -> x : langs'' - rbthunk <- iothunk $ rbHelper env nonce <- case (key', lookup nonceKey session') of (Nothing, _) -> return $ error "You have attempted to use the nonce, but sessions are disabled." -- FIXME maybe this should be handled without an error? (_, Just x) -> return x (_, Nothing) -> do g <- newStdGen return $ fst $ randomString 10 g - return $ Request gets' cookies' rbthunk env langs''' nonce + return $ Request gets' cookies' env langs''' nonce where randomString len = first (map toChar) . sequence' (replicate len (randomR (0, 61))) @@ -622,37 +621,6 @@ parseWaiRequest env session' key' = do nonceKey :: String nonceKey = "_NONCE" -rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents -rbHelper req = - (map fix1 *** map fix2) <$> iter - where - iter = NWP.parseRequestBody NWP.lbsSink req - fix1 = bsToChars *** bsToChars - fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) - --- | 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. --- --- FIXME: remove this function and use a StateT in Handler -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 - return (Right val, val) - -- FIXME don't duplicate sessionName :: ByteString sessionName = "_SESSION" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 847a6737..710547ec 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -138,6 +138,8 @@ import Data.Maybe (fromMaybe) import Web.Cookie (SetCookie (..), renderSetCookie) import Blaze.ByteString.Builder (toByteString) import Data.Enumerator (run_, ($$)) +import Control.Arrow (first, (***)) +import qualified Network.Wai.Parse as NWP -- | The type-safe URLs associated with a site argument. type family Route a @@ -233,7 +235,7 @@ type GHInner s m monad = ReaderT (HandlerData s m) ( ErrorT HandlerContents ( WriterT (Endo [Header]) ( - StateT SessionMap ( -- session + StateT (SessionMap, Maybe RequestBodyContents) ( monad )))) @@ -273,8 +275,23 @@ instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> GHandler ask runRequestBody = do - rr <- getRequest - GHandler $ lift $ lift $ lift $ lift $ reqRequestBody rr + (sm, mrbc) <- GHandler $ lift $ lift $ lift get + case mrbc of + Just rbc -> return rbc + Nothing -> do + rr <- waiRequest + rbc <- lift $ rbHelper rr + GHandler $ lift $ lift $ lift $ put (sm, Just rbc) + return rbc + +rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents +rbHelper req = + (map fix1 *** map fix2) <$> iter + where + iter = NWP.parseRequestBody NWP.lbsSink req + fix1 = bsToChars *** bsToChars + fix2 (x, NWP.FileInfo a b c) = + (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) -- | Get the sub application argument. getYesodSub :: Monad m => GGHandler sub master m sub @@ -329,13 +346,14 @@ runHandler handler mrender sroute tomr ma tosa = , handlerRender = mrender , handlerToMaster = tomr } - ((contents', headers), finalSession) <- catchIter ( - flip runStateT initSession + let initSession' = (initSession, Nothing) + ((contents', headers), (finalSession, _)) <- catchIter ( + flip runStateT initSession' $ runWriterT $ runErrorT $ flip runReaderT hd $ unGHandler handler - ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) + ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession')) let contents = either id (HCContent W.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession @@ -566,11 +584,11 @@ expiresAt = setHeader "Expires" . S8.pack . formatRFC1123 setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () -setSession k = GHandler . lift . lift . lift . modify . Map.insert k +setSession k = GHandler . lift . lift . lift . modify . first . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: String -> GHandler sub master () -deleteSession = GHandler . lift . lift . lift . modify . Map.delete +deleteSession = GHandler . lift . lift . lift . modify . first . Map.delete -- | Internal use only, not to be confused with 'setHeader'. addHeader :: Header -> GHandler sub master () @@ -601,12 +619,12 @@ localNoCurrent = -- | Lookup for session data. lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) lookupSession n = GHandler $ do - m <- lift $ lift $ lift get + m <- fmap fst $ lift $ lift $ lift get return $ Map.lookup n m -- | Get all session variables. getSession :: GHandler s m SessionMap -getSession = GHandler $ lift $ lift $ lift get +getSession = fmap fst $ GHandler $ lift $ lift $ lift get #if TEST diff --git a/Yesod/Request.hs b/Yesod/Request.hs index d0c1573c..17b2f8d0 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -41,8 +41,6 @@ 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) @@ -99,18 +97,6 @@ data FileInfo = FileInfo data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)] - -- | The POST parameters and submitted files. This is stored in an IO - -- thunk, which essentially means it will be computed once at most, but - -- only if requested. This allows avoidance of the potentially costly - -- parsing of POST bodies for pages which do not use them. - -- - -- Additionally, since the request body is not read until needed, you can - -- directly access the 'W.requestBody' record in 'reqWaiRequest' and - -- perform other forms of parsing. For example, when designing a web - -- 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 :: Iteratee ByteString IO RequestBodyContents , reqWaiRequest :: W.Request -- | Languages which the client supports. , reqLangs :: [String]