diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 7.4.3 +Version: 7.4.4 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 diff --git a/src/Happstack/Server/Internal/Monads.hs b/src/Happstack/Server/Internal/Monads.hs --- a/src/Happstack/Server/Internal/Monads.hs +++ b/src/Happstack/Server/Internal/Monads.hs @@ -5,6 +5,8 @@ import Control.Applicative (Applicative, pure, (<*>), Alternative(empty,(<|>))) +import Control.Concurrent (newMVar) + import Control.Monad ( MonadPlus(mzero, mplus), ap, liftM, msum ) import Control.Monad.Base ( MonadBase, liftBase ) @@ -36,15 +38,21 @@ import qualified Control.Monad.Writer.Class as Writer ( listen ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) +import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) import Data.Char (ord) import Data.List (inits, isPrefixOf, stripPrefix, tails) +import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(mempty, mappend), Dual(..), Endo(..)) import qualified Paths_happstack_server as Cabal import qualified Data.Version as DV import Debug.Trace (trace) -import Happstack.Server.Types (Request, Response, resultBS, setHeader) +import Happstack.Server.Internal.Cookie (Cookie) +import Happstack.Server.Internal.RFC822Headers (parseContentType) +import Happstack.Server.Types +import Prelude (Bool(..), Either(..), Eq(..), Functor(..), IO(..), Monad(..), Char, Maybe(..), String, Show(..), ($), (.), (>), (++), (&&), (||), (=<<), const, concatMap, flip, id, otherwise, zip) + -- | An alias for 'WebT' when using 'IO'. type Web a = WebT IO a @@ -222,6 +230,37 @@ instance (Monad m) => ServerMonad (ServerPartT m) where askRq = ServerPartT $ ask localRq f m = ServerPartT $ local f (unServerPartT m) + +-- | Implementation of 'askRqEnv' for arbitrary 'ServerMonad'. +smAskRqEnv :: (ServerMonad m, MonadIO m) => m ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)]) +smAskRqEnv = do + rq <- askRq + mbi <- liftIO $ if ((rqMethod rq == POST) || (rqMethod rq == PUT)) && (isDecodable (ctype rq)) + then readInputsBody rq + else return (Just []) + return (rqInputsQuery rq, mbi, rqCookies rq) + where + ctype :: Request -> Maybe ContentType + ctype req = parseContentType . P.unpack =<< getHeader "content-type" req + + isDecodable :: Maybe ContentType -> Bool + isDecodable Nothing = True -- assume it is application/x-www-form-urlencoded + isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True + isDecodable (Just (ContentType "multipart" "form-data" _ps)) = True + isDecodable (Just _) = False + +-- | Implementation of 'localRqEnv' for arbitrary 'ServerMonad'. +smLocalRqEnv :: (ServerMonad m, MonadIO m) => (([(String, Input)], Maybe [(String, Input)], [(String, Cookie)]) -> ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])) -> m b -> m b +smLocalRqEnv f m = do + rq <- askRq + b <- liftIO $ readInputsBody rq + let (q', b', c') = f (rqInputsQuery rq, b, rqCookies rq) + bv <- liftIO $ newMVar (fromMaybe [] b') + let rq' = rq { rqInputsQuery = q' + , rqInputsBody = bv + , rqCookies = c' + } + localRq (const rq') m ------------------------------- -- HERE BEGINS WebT definitions diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs --- a/src/Happstack/Server/RqData.hs +++ b/src/Happstack/Server/RqData.hs @@ -59,7 +59,6 @@ ) where import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>)) -import Control.Concurrent.MVar (newMVar) import Control.Monad (MonadPlus(mzero)) import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT) import qualified Control.Monad.State.Lazy as Lazy (StateT, mapStateT) @@ -77,15 +76,14 @@ import Data.Char (toLower) import Data.Either (partitionEithers) import Data.Generics (Data, Typeable) -import Data.Maybe (fromMaybe, fromJust) +import Data.Maybe (fromJust) import Data.Monoid (Monoid(mempty, mappend, mconcat)) import Data.Text (Text) import qualified Data.Text.Lazy as LazyText import qualified Data.Text.Lazy.Encoding as LazyText import Happstack.Server.Cookie (Cookie (cookieValue)) -import Happstack.Server.Internal.Monads (ServerMonad(askRq, localRq), FilterMonad, WebMonad, ServerPartT, escape) -import Happstack.Server.Internal.RFC822Headers (parseContentType) -import Happstack.Server.Types (ContentType(..), FromReqURI(..), Input(inputValue, inputFilename, inputContentType), Response, Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), getHeader, readInputsBody) +import Happstack.Server.Internal.Monads +import Happstack.Server.Types import Happstack.Server.Internal.MessageWrap (BodyPolicy(..), bodyInput, defaultBodyPolicy) import Happstack.Server.Response (requestEntityTooLarge, toResponse) @@ -158,32 +156,9 @@ -- instance (MonadPlus m, MonadIO m, ServerMonad m) => (HasRqData m) where instance (MonadIO m, MonadPlus m) => HasRqData (ServerPartT m) where - askRqEnv = - do rq <- askRq - mbi <- liftIO $ if ((rqMethod rq == POST) || (rqMethod rq == PUT)) && (isDecodable (ctype rq)) - then readInputsBody rq - else return (Just []) - return (rqInputsQuery rq, mbi, rqCookies rq) - where - ctype :: Request -> Maybe ContentType - ctype req = parseContentType . P.unpack =<< getHeader "content-type" req - isDecodable :: Maybe ContentType -> Bool - isDecodable Nothing = True -- assume it is application/x-www-form-urlencoded - isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True - isDecodable (Just (ContentType "multipart" "form-data" _ps)) = True - isDecodable (Just _) = False - + askRqEnv = smAskRqEnv rqDataError _e = mzero - localRqEnv f m = - do rq <- askRq - b <- liftIO $ readInputsBody rq - let (q', b', c') = f (rqInputsQuery rq, b, rqCookies rq) - bv <- liftIO $ newMVar (fromMaybe [] b') - let rq' = rq { rqInputsQuery = q' - , rqInputsBody = bv - , rqCookies = c' - } - localRq (const rq') m + localRqEnv = smLocalRqEnv ------------------------------------------------------------------------------ -- HasRqData instances for ReaderT, StateT, WriterT, RWST, and ErrorT