From 49f81f0f870ce881416715ea2319de749e2468f7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 1 Apr 2011 13:06:29 +0300 Subject: [PATCH] Finally removed RequestReader --- Yesod/Handler.hs | 36 +++++++++++++------- Yesod/Internal/Request.hs | 29 +++++++++++++++- Yesod/Request.hs | 71 ++++++++------------------------------- 3 files changed, 65 insertions(+), 71 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1c70923f..9b3e6268 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -35,6 +35,9 @@ module Yesod.Handler , getUrlRenderParams , getCurrentRoute , getRouteToMaster + , getRequest + , waiRequest + , runRequestBody -- * Special responses -- ** Redirecting , RedirectType (..) @@ -103,7 +106,7 @@ module Yesod.Handler ) where import Prelude hiding (catch) -import Yesod.Request +import Yesod.Internal.Request import Yesod.Internal import Data.Time (UTCTime) @@ -289,19 +292,22 @@ data HandlerContents = instance Error HandlerContents where strMsg = HCError . InternalError . T.pack +getRequest :: Monad mo => GGHandler s m mo Request +getRequest = handlerRequest `liftM` GHandler ask + instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where failure = GHandler . lift . throwError . HCError -instance RequestReader (GHandler sub master) where -- FIXME kill this typeclass, does not work for GGHandler - getRequest = handlerRequest <$> GHandler ask - runRequestBody = do - x <- GHandler $ lift $ lift $ lift get - case ghsRBC x of - Just rbc -> return rbc - Nothing -> do - rr <- waiRequest - rbc <- lift $ rbHelper rr - GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc } - return rbc + +runRequestBody :: GHandler s m RequestBodyContents +runRequestBody = do + x <- GHandler $ lift $ lift $ lift get + case ghsRBC x of + Just rbc -> return rbc + Nothing -> do + rr <- waiRequest + rbc <- lift $ rbHelper rr + GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc } + return rbc rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents rbHelper req = @@ -555,7 +561,7 @@ notFound :: Failure ErrorResponse m => m a notFound = failure NotFound -- | Return a 405 method not supported page. -badMethod :: (RequestReader m, Failure ErrorResponse m) => m a +badMethod :: Monad mo => GGHandler s m mo a badMethod = do w <- waiRequest failure $ BadMethod $ W.requestMethod w @@ -807,3 +813,7 @@ hamletToContent h = do hamletToRepHtml :: Monad mo => Hamlet (Route master) -> GGHandler sub master mo RepHtml hamletToRepHtml = liftM RepHtml . hamletToContent + +-- | Get the request\'s 'W.Request' value. +waiRequest :: Monad mo => GGHandler sub master mo W.Request +waiRequest = reqWaiRequest `liftM` getRequest diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs index 183b5cb3..f668f6a4 100644 --- a/Yesod/Internal/Request.hs +++ b/Yesod/Internal/Request.hs @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Yesod.Internal.Request ( parseWaiRequest + , Request (..) + , RequestBodyContents + , FileInfo (..) ) where -import Yesod.Request import Control.Arrow (first, second) import qualified Network.Wai.Parse as NWP import Yesod.Internal @@ -16,6 +18,18 @@ import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText) import Control.Monad (join) import Data.Maybe (fromMaybe) +import qualified Data.ByteString.Lazy as L + +-- | The parsed request information. +data Request = Request + { reqGetParams :: [(Text, Text)] + , reqCookies :: [(Text, Text)] + , reqWaiRequest :: W.Request + -- | Languages which the client supports. + , reqLangs :: [Text] + -- | A random, session-specific nonce used to prevent CSRF attacks. + , reqNonce :: Maybe Text + } parseWaiRequest :: W.Request -> [(Text, Text)] -- ^ session @@ -57,3 +71,16 @@ parseWaiRequest env session' key' = do | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 | otherwise = toEnum $ i + fromEnum '0' - 52 + +-- | A tuple containing both the POST parameters and submitted files. +type RequestBodyContents = + ( [(Text, Text)] + , [(Text, FileInfo)] + ) + +data FileInfo = FileInfo + { fileName :: Text + , fileContentType :: Text + , fileContent :: L.ByteString + } + deriving (Eq, Show) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index ce257946..3d42e3cb 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -16,10 +16,8 @@ module Yesod.Request -- * Request datatype RequestBodyContents , Request (..) - , RequestReader (..) , FileInfo (..) -- * Convenience functions - , waiRequest , languages -- * Lookup parameters , lookupGetParam @@ -33,21 +31,13 @@ module Yesod.Request , lookupFiles ) where -import qualified Network.Wai as W -import qualified Data.ByteString.Lazy as BL -import Control.Monad.IO.Class +import Yesod.Internal.Request +import Yesod.Handler import Control.Monad (liftM) import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) import Data.Text (Text) --- 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 - runRequestBody :: m RequestBodyContents - -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following three (in descending order @@ -62,83 +52,50 @@ class Monad m => RequestReader m where -- * Accept-Language HTTP header. -- -- This is handled by parseWaiRequest (not exposed). -languages :: RequestReader m => m [Text] +languages :: Monad mo => GGHandler s m mo [Text] languages = reqLangs `liftM` getRequest --- | Get the request\'s 'W.Request' value. -waiRequest :: RequestReader m => m W.Request -waiRequest = reqWaiRequest `liftM` getRequest - --- | A tuple containing both the POST parameters and submitted files. -type RequestBodyContents = - ( [(Text, Text)] - , [(Text, FileInfo)] - ) - -data FileInfo = FileInfo - { fileName :: Text - , fileContentType :: Text - , fileContent :: BL.ByteString - } - deriving (Eq, Show) - --- | The parsed request information. -data Request = Request - { reqGetParams :: [(Text, Text)] - , reqCookies :: [(Text, Text)] - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [Text] - -- | A random, session-specific nonce used to prevent CSRF attacks. - , reqNonce :: Maybe Text - } - lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x) -- | Lookup for GET parameters. -lookupGetParams :: RequestReader m => Text -> m [Text] +lookupGetParams :: Monad mo => Text -> GGHandler s m mo [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. -lookupGetParam :: RequestReader m => Text -> m (Maybe Text) +lookupGetParam :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters. -lookupPostParams :: RequestReader m - => Text - -> m [Text] +lookupPostParams :: Text -> GHandler s m [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp -lookupPostParam :: (MonadIO m, RequestReader m) - => Text - -> m (Maybe Text) +lookupPostParam :: Text + -> GHandler s m (Maybe Text) lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. -lookupFile :: (MonadIO m, RequestReader m) - => Text - -> m (Maybe FileInfo) +lookupFile :: Text + -> GHandler s m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. -lookupFiles :: RequestReader m - => Text - -> m [FileInfo] +lookupFiles :: Text + -> GHandler s m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. -lookupCookie :: RequestReader m => Text -> m (Maybe Text) +lookupCookie :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data. -lookupCookies :: RequestReader m => Text -> m [Text] +lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr