Remove requestBody, live in Iteratee
This commit is contained in:
Michael Snoyman
parent
5c730104c8
commit
db5e987797
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user