happstack-server 7.4.3 → 7.4.4

raw patch · 3 files changed

+46/−32 lines, 3 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• happstack-server.cabal +1/−1
• src/Happstack/Server/Internal/Monads.hs +40/−1
• src/Happstack/Server/RqData.hs +5/−30

@@ -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 <http://happstack.com/docs/crashcourse/index.html> License:             BSD3

@@ -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

@@ -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