packages feed

happstack-server 7.6.1 → 7.9.3

raw patch · 19 files changed

Files

README.md view
@@ -1,4 +1,4 @@-# happstack-server [![Hackage Status](https://img.shields.io/hackage/v/happstack-server.svg)][hackage] [![Build Status](https://travis-ci.org/Happstack/happstack-server.svg?branch=master)](https://travis-ci.org/Happstack/happstack-server)+# happstack-server [![Hackage Status](https://img.shields.io/hackage/v/happstack-server.svg)][hackage]  [hackage]: https://hackage.haskell.org/package/happstack-server
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             7.6.1+Version:             7.9.3 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@@ -11,8 +11,23 @@ Build-Type:          Simple Cabal-Version:       >= 1.10 Extra-Source-Files:  tests/Happstack/Server/Tests.hs README.md-tested-with:         GHC==8.0.1, GHC==8.2.2, GHC==8.4.1, GHC==8.6.5, GHC==8.8.3, GHC==8.10.1 +tested-with:+  GHC == 9.14.1+  GHC == 9.12.2+  GHC == 9.10.2+  GHC == 9.8.2+  GHC == 9.6.7+  GHC == 9.4.8+  GHC == 9.2.8+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+  GHC == 8.2.2+  GHC == 8.0.2+ source-repository head     type:     git     location: https://github.com/Happstack/happstack-server.git@@ -62,13 +77,12 @@                        Paths_happstack_server    if flag(network-uri)-     build-depends:    network     >= 3.0.0 && < 3.2,-                       network-bsd >= 2.8.1 && < 2.9,+     build-depends:    network     >= 3.0.0 && < 3.3,                        network-uri >= 2.6 && < 2.7   else      build-depends:    network               < 2.6   Build-Depends:       base                   >= 4    && < 5,-                       base64-bytestring      >= 1.0  && < 1.2,+                       base64-bytestring      >= 1.0  && < 1.3,                        blaze-html             >= 0.5  && < 0.10,                        bytestring,                        containers,@@ -78,23 +92,20 @@                        filepath,                        hslogger               >= 1.0.2,                        html,-                       monad-control          >= 0.3  && < 1.1,-                       mtl                    >= 2    && < 2.3,-                       old-locale,+                       monad-control          >= 1.0  && < 1.1,+                       mtl                    >= 2.2  && < 2.4,                        parsec                            < 4,                        process,-                       semigroups             >= 0.16,                        sendfile               >= 0.7.1 && < 0.8,                        system-filepath        >= 0.3.1,                        syb,-                       text                   >= 0.10  && < 1.3,-                       time,+                       text                   >= 0.10  && < 2.2,+                       time                   >= 1.5,                        threads                >= 0.5,-                       transformers           >= 0.1.3 && < 0.6,+                       transformers           >= 0.1.3 && < 0.7,                        transformers-base      >= 0.4   && < 0.5,-                       transformers-compat    >= 0.3   && < 0.7,                        utf8-string            >= 0.3.4 && < 1.1,-                       xhtml,+                       xhtml                              < 3000.4,                        zlib    hs-source-dirs:      src@@ -117,7 +128,7 @@   -- available 18 months ago. In order to avoid people spending time   -- keeping the build working for older versions, we tell Cabal that   -- it shouldn't allow builds with them.-  if impl(ghc < 7.0)+  if impl(ghc < 8.0)     buildable: False  Test-Suite happstack-server-tests
src/Happstack/Server/Auth.hs view
@@ -2,8 +2,12 @@ -- | Support for basic access authentication <http://en.wikipedia.org/wiki/Basic_access_authentication> module Happstack.Server.Auth where +import Data.Foldable (foldl')+import Data.Bits (xor, (.|.))+import Data.Maybe (fromMaybe) import Control.Monad                             (MonadPlus(mzero, mplus)) import Data.ByteString.Base64                    as Base64+import qualified Data.ByteString                 as BS import qualified Data.ByteString.Char8           as B import qualified Data.Map                        as M import Happstack.Server.Monads                   (Happstack, escape, getHeaderM, setHeaderM)@@ -72,9 +76,28 @@  -- | Function that looks up the plain text password for username in a -- Map and returns True if it matches with the given password.+--+-- Note: The implementation is hardened against timing attacks but not+-- completely safe. Ideally you should build your own predicate, using+-- a robust constant-time equality comparison from a cryptographic+-- library like sodium. validLoginPlaintext ::   M.Map String String -- ^ the username password map   -> B.ByteString -- ^ the username   -> B.ByteString -- ^ the password   -> Bool-validLoginPlaintext authMap name password = M.lookup (B.unpack name) authMap == Just (B.unpack password)+validLoginPlaintext authMap name password = fromMaybe False $ do+    r <- M.lookup (B.unpack name) authMap+    pure (constTimeEq (B.pack r) password)+  where+    -- (Mostly) constant time equality of bytestrings to prevent timing attacks by testing out passwords. This still+    -- allows to extract the length of the configured password via timing attacks. This implementation is still brittle+    -- in the sense that it relies on GHC not unrolling or vectorizing the loop.+    {-# NOINLINE constTimeEq #-}+    constTimeEq :: BS.ByteString -> BS.ByteString -> Bool+    constTimeEq x y+      | BS.length x /= BS.length y+      = False++      | otherwise+      = foldl' (.|.) 0 (BS.zipWith xor x y) == 0
src/Happstack/Server/Cookie.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} -- | Functions for creating, adding, and expiring cookies. To lookup cookie values see "Happstack.Server.RqData". module Happstack.Server.Cookie     ( Cookie(..)     , CookieLife(..)+    , SameSite(..)     , mkCookie     , addCookie     , addCookies@@ -12,13 +13,13 @@  import Control.Monad.Trans              (MonadIO(..)) import Happstack.Server.Internal.Monads (FilterMonad, composeFilter)-import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), calcLife, mkCookie, mkCookieHeader)+import Happstack.Server.Internal.Cookie (Cookie(..), CookieLife(..), SameSite(..), calcLife, mkCookie, mkCookieHeader) import Happstack.Server.Types           (Response, addHeader)  -- | Add the 'Cookie' to 'Response'. -- -- example--- +-- -- > main = simpleHTTP nullConf $ -- >   do addCookie Session (mkCookie "name" "value") -- >      ok $ "You now have a session cookie."@@ -32,7 +33,7 @@       addHeaderM a v = composeFilter $ \res-> addHeader a v res  -- | Add the list 'Cookie' to the 'Response'.--- +-- -- see also: 'addCookie' addCookies :: (MonadIO m, FilterMonad Response m) => [(CookieLife, Cookie)] -> m () addCookies = mapM_ (uncurry addCookie)@@ -43,5 +44,5 @@ -- >   do expireCookie "name" -- >      ok $ "The cookie has been expired." -expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () +expireCookie :: (MonadIO m, FilterMonad Response m) => String -> m () expireCookie name = addCookie Expired (mkCookie name "")
src/Happstack/Server/Error.hs view
@@ -1,7 +1,7 @@ -- | Some useful functions if you want to wrap the 'ServerPartT' monad transformer around the 'ErrorT' monad transformer. e.g., @'ServerPartT' ('ErrorT' e m) a@. This allows you to use 'throwError' and 'catchError' inside your monad.   module Happstack.Server.Error where -import Control.Monad.Error              (Error, ErrorT(runErrorT))+import Control.Monad.Trans.Except       (ExceptT, runExceptT) import Happstack.Server.Monads          (ServerPartT) import Happstack.Server.Internal.Monads (WebT, UnWebT, withRequest, mkWebT, runServerPartT, ununWebT) import Happstack.Server.Response        (ok, toResponse)@@ -22,10 +22,10 @@ -- see also: 'simpleErrorHandler' spUnwrapErrorT:: Monad m => (e -> ServerPartT m a)               -> Request-              -> UnWebT (ErrorT e m) a+              -> UnWebT (ExceptT e m) a               -> UnWebT m a spUnwrapErrorT handler rq = \x -> do-    err <- runErrorT x+    err <- runExceptT x     case err of         Left e -> ununWebT $ runServerPartT (handler e) rq         Right a -> return a@@ -48,9 +48,9 @@ -- function. -- -- DEPRECATED: use 'spUnwrapErrorT' instead.-errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a+errorHandlerSP :: (Monad m) => (Request -> e -> WebT m a) -> ServerPartT (ExceptT e m) a -> ServerPartT m a errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do-                        eer <- runErrorT $ ununWebT $ runServerPartT sps req+                        eer <- runExceptT $ ununWebT $ runServerPartT sps req                         case eer of                                 Left err -> ununWebT (handler req err)                                 Right res -> return res
src/Happstack/Server/FileServe/BuildingBlocks.hs view
@@ -59,11 +59,13 @@ import Control.Monad.Trans          (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S-import Data.Data                    (Data, Typeable)+import Data.Char                    (toLower)+import Data.Data                    (Data) import Data.List                    (sort) import Data.Maybe                   (fromMaybe) import           Data.Map           (Map) import qualified Data.Map           as Map+import Data.Time                    (UTCTime, formatTime, defaultTimeLocale) import Filesystem.Path.CurrentOS    (commonPrefix, encodeString, decodeString, collapse, append) import Happstack.Server.Monads      (ServerMonad(askRq), FilterMonad, WebMonad) import Happstack.Server.Response    (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther)@@ -76,13 +78,6 @@ import qualified Text.Blaze.Html5            as H import qualified Text.Blaze.Html5.Attributes as A -#if MIN_VERSION_time(1,5,0)-import Data.Time     (UTCTime, formatTime, defaultTimeLocale)-#else-import System.Locale (defaultTimeLocale)-import Data.Time     (UTCTime, formatTime)-#endif- -- * Mime-Type / Content-Type  -- |a 'Map' from file extensions to content-types@@ -102,7 +97,7 @@ guessContentType mimeMap filepath =     case getExt filepath of       "" -> Nothing-      ext -> Map.lookup ext mimeMap+      ext -> Map.lookup (map toLower ext) mimeMap -- FIXME? @foldCase@ would be more proper than @map toLower@ but would add a dependency. But are those edge cases ever going to be relevant here?  -- | try to guess the content-type of a file based on its extension --@@ -127,7 +122,7 @@  -- | a list of common index files. Specifically: @index.html@, @index.xml@, @index.gif@ ----- Typically used as an argument to 'serveDiretory'.+-- Typically used as an argumebnt to 'serveDiretory'. defaultIxFiles :: [FilePath] defaultIxFiles= ["index.html","index.xml","index.gif"] @@ -136,6 +131,8 @@ fileNotFound fp = return $ result 404 $ "File not found " ++ fp  -- | Similar to 'takeExtension' but does not include the extension separator char+--+-- NOTE: this does not perform case folding. So @example.jpg@ will return @.jpg@ and @example.JPG@ will return @.JPG@. getExt :: FilePath -> String getExt fp = drop 1 $ takeExtension fp @@ -529,7 +526,7 @@        listing <- renderFn localPath $ filter (/= ".") (sort c)        ok $ toResponse $ listing -data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Typeable, Enum)+data EntryKind = File | Directory | UnknownKind deriving (Eq, Ord, Read, Show, Data, Enum)  -- | a function to generate an HTML page showing the contents of a directory on the disk --@@ -631,7 +628,7 @@ -- | see 'serveDirectory' data Browsing     = EnableBrowsing | DisableBrowsing-      deriving (Eq, Enum, Ord, Read, Show, Data, Typeable)+      deriving (Eq, Enum, Ord, Read, Show, Data)  -- | Serve files and directories from a directory and its subdirectories using 'sendFile'. --
src/Happstack/Server/Internal/Clock.hs view
@@ -9,19 +9,12 @@  import Control.Concurrent import Control.Monad+import qualified Data.ByteString.Char8 as B import Data.IORef import Data.Time.Clock       (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)-import System.IO.Unsafe--#if MIN_VERSION_time(1,5,0) import Data.Time.Format (formatTime, defaultTimeLocale)-#else-import Data.Time.Format (formatTime)-import System.Locale    (defaultTimeLocale)-#endif--import qualified Data.ByteString.Char8 as B+import System.IO.Unsafe  data DateCache = DateCache {       cachedPOSIXTime :: !(IORef POSIXTime)
src/Happstack/Server/Internal/Cookie.hs view
@@ -4,6 +4,7 @@ module Happstack.Server.Internal.Cookie     ( Cookie(..)     , CookieLife(..)+    , SameSite(..)     , calcLife     , mkCookie     , mkCookieHeader@@ -20,21 +21,18 @@ import Control.Monad.Fail (MonadFail) import qualified Data.ByteString.Char8 as C import Data.Char             (chr, toLower)-import Data.Data             (Data, Typeable)+import Data.Data             (Data) import Data.List             ((\\), intersperse) import Data.Time.Clock       (UTCTime, addUTCTime, diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format      (formatTime, defaultTimeLocale) import Happstack.Server.Internal.Clock (getApproximateUTCTime) import Network.URI           (escapeURIString) import Text.ParserCombinators.Parsec hiding (token) -#if MIN_VERSION_time(1,5,0)-import Data.Time.Format (formatTime, defaultTimeLocale)-#else-import Data.Time.Format (formatTime)-import System.Locale    (defaultTimeLocale)-#endif ++ -- | a type for HTTP cookies. Usually created using 'mkCookie'. data Cookie = Cookie     { cookieVersion :: String@@ -44,7 +42,9 @@     , cookieValue   :: String     , secure        :: Bool     , httpOnly      :: Bool-    } deriving(Show,Eq,Read,Typeable,Data)+    , sameSite      :: SameSite+    , partitioned   :: Bool+    } deriving (Show, Eq, Read, Data)  -- | Specify the lifetime of a cookie. --@@ -58,8 +58,33 @@     | MaxAge Int      -- ^ life time of cookie in seconds     | Expires UTCTime -- ^ cookie expiration date     | Expired         -- ^ cookie already expired-      deriving (Eq, Ord, Read, Show, Typeable)+      deriving (Eq, Ord, Read, Show) +-- | Options for specifying third party cookie behaviour.+--+-- Note that most or all web clients require the cookie to be secure if "none" is+-- specified.+data SameSite+    = SameSiteLax+    -- ^ The cookie is sent in first party contexts as well as linked requests initiated+    -- from other contexts.+    | SameSiteStrict+    -- ^ The cookie is sent in first party contexts only.+    | SameSiteNone+    -- ^ The cookie is sent in first as well as third party contexts if the cookie is+    -- secure.+    | SameSiteNoValue+    -- ^ The default; used if you do not wish a SameSite attribute present at all.+      deriving (Eq, Ord, Data, Show, Read)++displaySameSite :: SameSite -> String+displaySameSite ss =+  case ss of+    SameSiteLax     -> "SameSite=Lax"+    SameSiteStrict  -> "SameSite=Strict"+    SameSiteNone    -> "SameSite=None"+    SameSiteNoValue -> ""+ -- convert 'CookieLife' to the argument needed for calling 'mkCookieHeader' calcLife :: CookieLife -> IO (Maybe (Int, UTCTime)) calcLife Session = return Nothing@@ -74,13 +99,14 @@   -- | Creates a cookie with a default version of 1, empty domain, a--- path of "/", secure == False and httpOnly == False+-- path of "/", secure == False, httpOnly == False and+-- sameSite == SameSiteNoValue and partitioned = False -- -- see also: 'addCookie' mkCookie :: String  -- ^ cookie name          -> String  -- ^ cookie value          -> Cookie-mkCookie key val = Cookie "1" "/" "" key val False False+mkCookie key val = Cookie "1" "/" "" key val False False SameSiteNoValue False  -- | Set a Cookie in the Result. -- The values are escaped as per RFC 2109, but some browsers may@@ -117,8 +143,9 @@          (cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ]       ++ (if secure   cookie then ["Secure"]   else [])       ++ (if httpOnly cookie then ["HttpOnly"] else [])--+      ++ (if sameSite cookie /= SameSiteNoValue+          then [displaySameSite . sameSite $ cookie] else [])+      ++ (if partitioned cookie then ["Partitioned"] else [])  -- | Not an supported api.  Takes a cookie header and returns -- either a String error message or an array of parsed cookies@@ -142,7 +169,7 @@             val<-value             path<-option "" $ try (cookieSep >> cookie_path)             domain<-option "" $ try (cookieSep >> cookie_domain)-            return $ Cookie ver path domain (low name) val False False+            return $ Cookie ver path domain (low name) val False False SameSiteNoValue False           cookie_version = cookie_special "$Version"           cookie_path = cookie_special "$Path"           cookie_domain = cookie_special "$Domain"
src/Happstack/Server/Internal/Listen.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} module Happstack.Server.Internal.Listen(listen, listen',listenOn,listenOnIPv4) where +import Data.Maybe                               (isNothing) import Happstack.Server.Internal.Types          (Conf(..), Request, Response) import Happstack.Server.Internal.Handler        (request) import Happstack.Server.Internal.Socket         (acceptLite)@@ -11,9 +12,9 @@ import Control.Concurrent                       (forkIO, killThread, myThreadId) import Control.Monad import qualified Data.Maybe as Maybe-import Network.BSD                              (getProtocolNumber) import qualified Network.Socket                 as Socket import System.IO.Error                          (isFullError)+import Foreign.C (CInt) {- #ifndef mingw32_HOST_OS -}@@ -25,6 +26,12 @@ log':: Priority -> String -> IO () log' = logM "Happstack.Server.HTTP.Listen" +-- Meant to be TCP in practise.+-- See https://www.gnu.org/software/libc/manual/html_node/Creating-a-Socket.html+-- which says "zero is usually right".  It could theoretically be SCTP, but it+-- would be a bizarre system that defaults to SCTP over TCP.+proto :: CInt+proto = Socket.defaultProtocol  {-    Network.listenOn binds randomly to IPv4 or IPv6 or both,@@ -34,7 +41,6 @@  listenOn :: Int -> IO Socket.Socket listenOn portm = do-    proto <- getProtocolNumber "tcp"     E.bracketOnError         (Socket.socket Socket.AF_INET Socket.Stream proto)         (Socket.close)@@ -49,7 +55,6 @@              -> Int     -- ^ port number to listen on              -> IO Socket.Socket listenOnIPv4 ip portm = do-    proto <- getProtocolNumber "tcp"     hostAddr <- inet_addr ip     E.bracketOnError         (Socket.socket Socket.AF_INET Socket.Stream proto)@@ -63,7 +68,7 @@  inet_addr :: String -> IO Socket.HostAddress inet_addr ip = do-  addrInfos <- Socket.getAddrInfo (Just Socket.defaultHints) (Just ip) (Just "tcp")+  addrInfos <- Socket.getAddrInfo (Just Socket.defaultHints) (Just ip) Nothing   let getHostAddress addrInfo = case Socket.addrAddress addrInfo of         Socket.SockAddrInet _ hostAddress -> Just hostAddress         _ -> Nothing@@ -114,7 +119,7 @@       infi :: IO ()       infi = loop `catchSome` pe >> infi -  infi `finally` (Socket.close s >> forceTimeoutAll tm)+  infi `finally` (Socket.close s >> when (isNothing $ threadGroup conf) (forceTimeoutAll tm))  {-- #ifndef mingw32_HOST_OS
src/Happstack/Server/Internal/LogFormat.hs view
@@ -4,12 +4,7 @@   , formatRequestCombined   ) where -#if MIN_VERSION_time(1,5,0) import Data.Time.Format (FormatTime(..), formatTime, defaultTimeLocale)-#else-import Data.Time.Format (FormatTime(..), formatTime)-import System.Locale    (defaultTimeLocale)-#endif  -- | Format the time as describe in the Apache combined log format. --   http://httpd.apache.org/docs/2.2/logs.html#combined
src/Happstack/Server/Internal/Monads.hs view
@@ -12,9 +12,11 @@                                                  ) import Control.Monad.Base                        ( MonadBase, liftBase ) import Control.Monad.Catch                       ( MonadCatch(..), MonadThrow(..) )-import Control.Monad.Error                       ( ErrorT(ErrorT), runErrorT-                                                 , Error, MonadError, throwError-                                                 , catchError, mapErrorT+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error                 ( ErrorT, Error, mapErrorT )+#endif+import Control.Monad.Except                      ( MonadError, throwError+                                                 , catchError                                                  ) #if MIN_VERSION_base(4,9,0) import Control.Monad.Fail                        (MonadFail)@@ -26,7 +28,7 @@ import qualified Control.Monad.RWS.Lazy as Lazy       ( RWST, mapRWST ) import qualified Control.Monad.RWS.Strict as Strict   ( RWST, mapRWST ) -import Control.Monad.Trans.Except                ( ExceptT, mapExceptT )+import Control.Monad.Trans.Except                ( ExceptT(ExceptT), mapExceptT, runExceptT ) import Control.Monad.State.Class                      ( MonadState, get, put ) import qualified Control.Monad.State.Lazy as Lazy     ( StateT, mapStateT ) import qualified Control.Monad.State.Strict as Strict ( StateT, mapStateT )@@ -93,7 +95,6 @@     liftIO = ServerPartT . liftIO     {-# INLINE liftIO #-} -#if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl ServerPartT where     type StT ServerPartT a = StT WebT (StT (ReaderT Request) a)     liftWith f = ServerPartT $ liftWith $ \runReader ->@@ -105,20 +106,7 @@     type StM (ServerPartT m) a = ComposeSt ServerPartT m a     liftBaseWith = defaultLiftBaseWith     restoreM     = defaultRestoreM-#else-instance MonadTransControl ServerPartT where-    newtype StT ServerPartT a = StSP {unStSP :: StT WebT (StT (ReaderT Request) a)}-    liftWith f = ServerPartT $ liftWith $ \runReader ->-                                 liftWith $ \runWeb ->-                                   f $ liftM StSP . runWeb . runReader . unServerPartT-    restoreT = ServerPartT . restoreT . restoreT . liftM unStSP -instance MonadBaseControl b m => MonadBaseControl b (ServerPartT m) where-    newtype StM (ServerPartT m) a = StMSP {unStMSP :: ComposeSt ServerPartT m a}-    liftBaseWith = defaultLiftBaseWith StMSP-    restoreM     = defaultRestoreM     unStMSP-#endif- -- | Particularly useful when combined with 'runWebT' to produce -- a @m ('Maybe' 'Response')@ from a 'Request'. runServerPartT :: ServerPartT m a -> Request -> WebT m a@@ -342,7 +330,6 @@     liftIO = FilterT . liftIO     {-# INLINE liftIO #-} -#if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl (FilterT a) where     type StT (FilterT a) b = StT (Lazy.WriterT (FilterFun a)) b     liftWith f = FilterT $ liftWith $ \run -> f $ run . unFilterT@@ -352,18 +339,7 @@     type StM (FilterT a m) c = ComposeSt (FilterT a) m c     liftBaseWith = defaultLiftBaseWith     restoreM     = defaultRestoreM-#else-instance MonadTransControl (FilterT a) where-    newtype StT (FilterT a) b = StFilter {unStFilter :: StT (Lazy.WriterT (FilterFun a)) b}-    liftWith f = FilterT $ liftWith $ \run -> f $ liftM StFilter . run . unFilterT-    restoreT = FilterT . restoreT . liftM unStFilter -instance MonadBaseControl b m => MonadBaseControl b (FilterT a m) where-    newtype StM (FilterT a m) c = StMFilter {unStMFilter :: ComposeSt (FilterT a) m c}-    liftBaseWith = defaultLiftBaseWith StMFilter-    restoreM     = defaultRestoreM     unStMFilter-#endif- -- | A set of functions for manipulating filters. -- -- 'ServerPartT' implements 'FilterMonad' 'Response' so these methods@@ -397,7 +373,7 @@     getFilter     = FilterT . listens unFilterFun . unFilterT  -- | The basic 'Response' building object.-newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }+newtype WebT m a = WebT { unWebT :: ExceptT Response (FilterT (Response) (MaybeT m)) a }     deriving (Functor)  instance MonadCatch m => MonadCatch (WebT m) where@@ -413,41 +389,23 @@     liftIO = WebT . liftIO     {-# INLINE liftIO #-} -#if MIN_VERSION_monad_control(1,0,0) instance MonadTransControl WebT where     type StT WebT a = StT MaybeT                        (StT (FilterT Response)-                        (StT (ErrorT Response) a))+                        (StT (ExceptT Response) a))     liftWith f = WebT $ liftWith $ \runError ->                           liftWith $ \runFilter ->                             liftWith $ \runMaybe ->                               f $ runMaybe .                                    runFilter .-                                    runError . unWebT+                                    runExceptT . unWebT     restoreT = WebT . restoreT . restoreT . restoreT  instance MonadBaseControl b m => MonadBaseControl b (WebT m) where     type StM (WebT m) a = ComposeSt WebT m a     liftBaseWith = defaultLiftBaseWith     restoreM     = defaultRestoreM-#else-instance MonadTransControl WebT where-    newtype StT WebT a = StWeb {unStWeb :: StT MaybeT-                                             (StT (FilterT Response)-                                               (StT (ErrorT Response) a))}-    liftWith f = WebT $ liftWith $ \runError ->-                          liftWith $ \runFilter ->-                            liftWith $ \runMaybe ->-                              f $ liftM StWeb . runMaybe .-                                                  runFilter .-                                                    runError . unWebT-    restoreT = WebT . restoreT . restoreT . restoreT . liftM unStWeb -instance MonadBaseControl b m => MonadBaseControl b (WebT m) where-    newtype StM (WebT m) a = StMWeb {unStMWeb :: ComposeSt WebT m a}-    liftBaseWith = defaultLiftBaseWith StMWeb-    restoreM     = defaultRestoreM     unStMWeb-#endif -- | 'UnWebT' is almost exclusively used with 'mapServerPartT'. If you -- are not using 'mapServerPartT' then you do not need to wrap your -- head around this type. If you are -- the type is not as complex as@@ -555,13 +513,13 @@     -- is exactly the semantics expected from objects that take lists     -- of 'ServerPartT'.     mzero = WebT $ lift $ lift $ mzero-    mplus x y =  WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y)-        where lower = (unFilterT . runErrorT . unWebT)+    mplus x y =  WebT $ ExceptT $ FilterT $ (lower x) `mplus` (lower y)+        where lower = (unFilterT . runExceptT . unWebT)  instance (Monad m) => FilterMonad Response (WebT m) where     setFilter f = WebT $ lift $ setFilter $ f     composeFilter f = WebT . lift . composeFilter $ f-    getFilter     m = WebT $ ErrorT $ liftM lft $ getFilter (runErrorT $ unWebT m)+    getFilter     m = WebT $ ExceptT $ liftM lft $ getFilter (runExceptT $ unWebT m)         where           lft (Left  r, _) = Left r           lft (Right a, f) = Right (a, f)@@ -576,11 +534,11 @@ -- | For when you really need to unpack a 'WebT' entirely (and not -- just unwrap the first layer with 'unWebT'). ununWebT :: WebT m a -> UnWebT m a-ununWebT = runMaybeT . Lazy.runWriterT . unFilterT . runErrorT . unWebT+ununWebT = runMaybeT . Lazy.runWriterT . unFilterT . runExceptT . unWebT  -- | For wrapping a 'WebT' back up.  @'mkWebT' . 'ununWebT' = 'id'@ mkWebT :: UnWebT m a -> WebT m a-mkWebT = WebT . ErrorT . FilterT . Lazy.WriterT . MaybeT+mkWebT = WebT . ExceptT . FilterT . Lazy.WriterT . MaybeT  -- | See 'mapServerPartT' for a discussion of this function. mapWebT :: (UnWebT m a -> UnWebT n b)@@ -798,6 +756,7 @@  -- ErrorT +#if !MIN_VERSION_transformers(0,6,0) instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where     askRq     = lift askRq     localRq f = mapErrorT $ localRq f@@ -814,6 +773,7 @@  instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where     finishWith    = lift . finishWith+#endif  -- ExceptT
src/Happstack/Server/Internal/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes, CPP #-}  module Happstack.Server.Internal.Types     (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),@@ -21,7 +21,9 @@   import Control.Exception (Exception, SomeException)-import Control.Monad.Error (Error(strMsg))+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error (Error(strMsg))+#endif import Control.Monad.Fail (MonadFail) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Control.Concurrent.Thread.Group as TG@@ -30,7 +32,6 @@ import Data.Data (Data) import Data.String (fromString) import Data.Time.Format (FormatTime(..))-import Data.Typeable(Typeable) import qualified Data.ByteString.Char8 as P import Data.ByteString.Char8 (ByteString,pack) import qualified Data.ByteString.Lazy.Char8 as L@@ -115,7 +116,7 @@     , validator   :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly     , logAccess   :: forall t. FormatTime t => Maybe (LogAccess t) -- ^ function to log access requests (see also: 'logMAccess')     , timeout     :: Int             -- ^ number of seconds to wait before killing an inactive thread-    , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests+    , threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests.     }  -- | Default configuration contains no validator and the port is set to 8000@@ -137,7 +138,7 @@  -- | HTTP request method data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT | PATCH | EXTENSION ByteString-    deriving (Show,Read,Eq,Ord,Typeable,Data)+    deriving (Show, Read, Eq, Ord, Data)  -- | Does the method support a message body? --@@ -177,7 +178,7 @@ -- | Result flags data RsFlags = RsFlags     { rsfLength :: Length-    } deriving (Show,Read,Typeable)+    } deriving (Show, Read)  -- | Default RsFlags: automatically use @Transfer-Encoding: Chunked@. nullRsFlags :: RsFlags@@ -202,7 +203,7 @@     { inputValue       :: Either FilePath L.ByteString     , inputFilename    :: Maybe FilePath     , inputContentType :: ContentType-    } deriving (Show, Read, Typeable)+    } deriving (Show, Read)  -- | hostname & port type Host = (String, Int) -- ^ (hostname, port)@@ -223,7 +224,6 @@                 , sfOffset    :: Integer   -- ^ offset to start at                 , sfCount     :: Integer    -- ^ number of bytes to send                 }-      deriving (Typeable)  instance Show Response where     showsPrec _ res@Response{}  =@@ -246,11 +246,13 @@ showRsValidator :: Maybe (Response -> IO Response) -> String showRsValidator = maybe "Nothing" (const "Just <function>") +#if !MIN_VERSION_transformers(0,6,0) -- what should the status code be ? instance Error Response where   strMsg str =       setHeader "Content-Type" "text/plain; charset=UTF-8" $        result 500 str+#endif  -- | an HTTP request data Request = Request@@ -266,7 +268,7 @@     , rqHeaders     :: Headers               -- ^ the HTTP request headers     , rqBody        :: MVar RqBody           -- ^ the raw, undecoded request body     , rqPeer        :: Host                  -- ^ (hostname, port) of the client making the request-    } deriving (Typeable)+    }  instance Show Request where     showsPrec _ rq =@@ -325,7 +327,7 @@     headers         = id  -- | The body of an HTTP 'Request'-newtype RqBody = Body { unBody :: L.ByteString } deriving (Read,Show,Typeable)+newtype RqBody = Body { unBody :: L.ByteString } deriving (Read, Show)  -- | Sets the Response status code to the provided Int and lifts the computation -- into a Monad.@@ -527,7 +529,6 @@ -- | Escape from the HTTP world and get direct access to the underlying 'TimeoutIO' functions data EscapeHTTP   = EscapeHTTP (TimeoutIO -> IO ())-    deriving (Typeable)  instance Exception EscapeHTTP
src/Happstack/Server/Monads.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, CPP #-} -- | This module provides four classes and some related functions -- which provide 'ServerPartT' with much of its web-centric behavior. --@@ -41,7 +41,9 @@  import Control.Applicative               (Alternative, Applicative) import Control.Monad                     (MonadPlus(mzero))-import Control.Monad.Error               (Error, ErrorT)+#if !MIN_VERSION_transformers(0,6,0)+import Control.Monad.Trans.Error         (Error, ErrorT)+#endif import Control.Monad.Trans               (MonadIO(..),MonadTrans(lift)) import Control.Monad.Trans.Except        (ExceptT) import Control.Monad.Reader              (ReaderT)@@ -71,7 +73,9 @@ instance (Happstack m, Monoid w) => Happstack (Strict.WriterT   w   m) instance (Happstack m, Monoid w) => Happstack (Lazy.RWST      r w s m) instance (Happstack m, Monoid w) => Happstack (Strict.RWST    r w s m)+#if !MIN_VERSION_transformers(0,6,0) instance (Happstack m, Error e)  => Happstack (ErrorT e m)+#endif instance (Happstack m, Monoid e) => Happstack (ExceptT e m)  -- | Get a header out of the request.
src/Happstack/Server/Response.hs view
@@ -26,6 +26,9 @@     , ifModifiedSince     ) where +#if MIN_VERSION_xhtml(3000,3,0)+import qualified Data.ByteString.Builder         as L+#endif import qualified Data.ByteString.Char8           as B import qualified Data.ByteString.Lazy.Char8      as L import qualified Data.ByteString.Lazy.UTF8       as LU (fromString)@@ -34,6 +37,7 @@ import qualified Data.Text.Encoding              as T import qualified Data.Text.Lazy                  as LT import qualified Data.Text.Lazy.Encoding         as LT+import Data.Time                                 (UTCTime, formatTime, defaultTimeLocale) import           Happstack.Server.Internal.Monads         (FilterMonad(composeFilter)) import           Happstack.Server.Internal.Types import           Happstack.Server.Types          (Response(..), Request(..), nullRsFlags, getHeader, noContentLength, redirect, result, setHeader, setHeaderBS)@@ -43,12 +47,6 @@ import           Text.Html                       (Html, renderHtml) import qualified Text.XHtml                      as XHtml (Html, renderHtml) -#if MIN_VERSION_time(1,5,0)-import Data.Time     (UTCTime, formatTime, defaultTimeLocale)-#else-import Data.Time     (UTCTime, formatTime)-import System.Locale (defaultTimeLocale)-#endif  -- | A low-level function to build a 'Response' from a content-type -- and a 'ByteString'.@@ -140,8 +138,11 @@  instance ToMessage XHtml.Html where     toContentType _ = B.pack "text/html; charset=UTF-8"+#if MIN_VERSION_xhtml(3000,3,0)+    toMessage = L.toLazyByteString . XHtml.renderHtml+#else     toMessage = LU.fromString . XHtml.renderHtml-+#endif instance ToMessage Blaze.Html where     toContentType _ = B.pack "text/html; charset=UTF-8"     toMessage       = Blaze.renderHtml
src/Happstack/Server/Routing.hs view
@@ -109,7 +109,7 @@ -- -- > handler :: ServerPart Response -- > handler =--- >     do methodOnly [GET, HEAD]+-- >     do method [GET, HEAD] -- >        ... method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m () method meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)
src/Happstack/Server/RqData.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} -- | Functions for extracting values from the query string, form data, cookies, etc. -- -- For in-depth documentation see the following section of the Happstack Crash Course:@@ -59,7 +59,7 @@     ) where  import Control.Applicative                      (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad))-import Control.Monad                            (MonadPlus(mzero))+import Control.Monad                            (MonadPlus(mzero, mplus)) import Control.Monad.Reader                     (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT) import qualified Control.Monad.State.Lazy as Lazy      (StateT, mapStateT) import qualified Control.Monad.State.Strict as Strict  (StateT, mapStateT)@@ -67,7 +67,10 @@ import qualified Control.Monad.Writer.Strict as Strict (WriterT, mapWriterT) import qualified Control.Monad.RWS.Lazy as Lazy        (RWST, mapRWST) import qualified Control.Monad.RWS.Strict as Strict    (RWST, mapRWST)-import Control.Monad.Error                      (Error(noMsg, strMsg), ErrorT, mapErrorT)+#if !MIN_VERSION_transformers(0,6,0)+import qualified Control.Monad.Trans.Error as DeprecatedError+#endif+import Control.Monad.Except                     (throwError) import Control.Monad.Trans                      (MonadIO(..), lift) import Control.Monad.Trans.Except               (ExceptT, mapExceptT) import qualified Data.ByteString.Char8          as P@@ -75,7 +78,7 @@ import qualified Data.ByteString.Lazy.UTF8      as LU import Data.Char                                (toLower) import Data.Either                              (partitionEithers)-import Data.Generics                            (Data, Typeable)+import Data.Generics                            (Data) import Data.Maybe                               (fromJust) import Data.Monoid                              (Monoid(mempty, mappend, mconcat)) import qualified Data.Semigroup                 as SG@@ -90,18 +93,36 @@ import Network.URI                              (unEscapeString)  newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a }-    deriving (Functor, Monad, MonadPlus)+    deriving (Functor, Monad) -instance (Error e, Monoid e) => MonadReader r (ReaderError r e) where+#if MIN_VERSION_transformers(0,6,0)+deriving instance (Monoid e, MonadPlus (Either e)) => MonadPlus (ReaderError r e)+#else+deriving instance (Monoid e, DeprecatedError.Error e, MonadPlus (Either e)) => MonadPlus (ReaderError r e)+#endif++#if MIN_VERSION_transformers(0,6,0)+instance (Monoid e) => MonadReader r (ReaderError r e) where+#else+instance (DeprecatedError.Error e, Monoid e) => MonadReader r (ReaderError r e) where+#endif     ask = ReaderError ask     local f m = ReaderError $ local f (unReaderError m) -instance (Monoid e, Error e) => Applicative (ReaderError r e) where+#if MIN_VERSION_transformers(0,6,0)+instance (Monoid e) => Applicative (ReaderError r e) where+#else+instance (Monoid e, DeprecatedError.Error e) => Applicative (ReaderError r e) where+#endif     pure = return     (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a))         = ReaderError $ ReaderT $ \env -> (f env) `apEither` (a env) -instance (Monoid e, Error e) => Alternative (ReaderError r e) where+#if MIN_VERSION_transformers(0,6,0)+instance (MonadPlus (Either e), Monoid e) => Alternative (ReaderError r e) where+#else+instance (Monoid e, DeprecatedError.Error e) => Alternative (ReaderError r e) where+#endif     empty = unwrapMonad empty     f <|> g = unwrapMonad $ (WrapMonad f) <|> (WrapMonad g) @@ -113,7 +134,7 @@  -- | a list of errors newtype Errors a = Errors { unErrors :: [a] }-    deriving (Eq, Ord, Show, Read, Data, Typeable)+    deriving (Eq, Ord, Show, Read, Data)  instance SG.Semigroup (Errors a) where     (Errors x) <> (Errors y) = Errors (x ++ y)@@ -123,10 +144,27 @@     mappend = (SG.<>)     mconcat errs = Errors $ concatMap unErrors errs -instance Error (Errors String) where+#if MIN_VERSION_transformers(0,6,0)+instance (Alternative (Either (Errors a))) => MonadPlus (Either (Errors a)) where+  mzero = Left (Errors [])+  (Left _) `mplus` n = n+  m        `mplus` _ = m++instance Alternative (Either (Errors a)) where+  empty = Left (Errors [])+  (Left _) <|> n = n+  m        <|> _ = m+#endif++#if !MIN_VERSION_transformers(0,6,0)+instance DeprecatedError.Error (Errors String) where     noMsg = Errors []     strMsg str = Errors [str]+#endif +strMsg :: a -> Errors a+strMsg errMsg = Errors [errMsg]+ {- commented out to avoid 'Defined but not used' warning. readerError :: (Monoid e, Error e) => e -> ReaderError r e b readerError e = mapReaderErrorT ((Left e) `apEither`) (return ())@@ -204,10 +242,12 @@     localRqEnv f  = Strict.mapRWST (localRqEnv f)     rqDataError e = lift (rqDataError e) -instance (Monad m, Error e, HasRqData m) => HasRqData (ErrorT e m) where+#if !MIN_VERSION_transformers(0,6,0)+instance (Monad m, DeprecatedError.Error e, HasRqData m) => HasRqData (DeprecatedError.ErrorT e m) where     askRqEnv      = lift askRqEnv-    localRqEnv f  = mapErrorT (localRqEnv f)+    localRqEnv f  = DeprecatedError.mapErrorT (localRqEnv f)     rqDataError e = lift (rqDataError e)+#endif  instance (Monad m, HasRqData m) => HasRqData (ExceptT e m) where     askRqEnv      = lift askRqEnv@@ -264,7 +304,6 @@       (Just a) -> Right a       _        -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val - -- | convert or validate a value -- -- This is similar to 'fmap' except that the function can fail by@@ -454,7 +493,7 @@            Nothing -> rqDataError $ strMsg $ "lookCookie: cookie not found: " ++ name            Just c  -> return c{cookieValue = f c}   where-    f = unEscapeString . cookieValue +    f = unEscapeString . cookieValue  -- | gets the named cookie as a string lookCookieValue :: (Functor m, Monad m, HasRqData m) => String -> m String
src/Happstack/Server/SURI.hs view
@@ -23,7 +23,7 @@ import Control.Arrow (first) import Data.Char     (chr, digitToInt, isHexDigit) import Data.Maybe    (fromJust, isJust)-import Data.Generics (Data, Typeable)+import Data.Generics (Data) import qualified Data.Text      as Text import qualified Data.Text.Lazy as LazyText import qualified Network.URI    as URI@@ -74,7 +74,7 @@ isAbs :: SURI -> Bool isAbs = not . null . URI.uriScheme . suri -newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable)+newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data) instance Show SURI where     showsPrec d (SURI uri) = showsPrec d $ show uri instance Read SURI where
src/Happstack/Server/SimpleHTTP.hs view
@@ -30,9 +30,9 @@ -- > import Happstack.Server -- > main = simpleHTTP nullConf $ ok "Hello World!" ----- By default the server will listen on port 8000. Run the app and point your browser at: <http://localhost:8000/>+-- By default the server will listen on port 8000. Run the app and point your browser at: <http:\/\/localhost:8000\/> ----- For FastCGI support see: <http://hackage.haskell.org/package/happstack-fastcgi>+-- For FastCGI support see: <http:\/\/hackage.haskell.org\/package\/happstack-fastcgi> ----------------------------------------------------------------------------- module Happstack.Server.SimpleHTTP     ( -- * SimpleHTTP@@ -44,6 +44,7 @@     , bindPort     , bindIPv4     , parseConfig+    , runWebT     , waitForTermination     -- * Re-exported modules     -- ** Basic ServerMonad functionality
tests/Happstack/Server/Tests.hs view
@@ -10,9 +10,11 @@ import Data.ByteString.Lazy.Char8     (pack, unpack) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy  as L+import Data.List (intercalate) import qualified Data.Map              as Map import Happstack.Server                      ( Request(..), Method(..), Response(..), ServerPart, Headers, RqBody(Body), HttpVersion(..)-                                             , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod)+                                             , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod+                                             , look, getDataFn) import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) import Happstack.Server.Cookie import Happstack.Server.Internal.Compression@@ -34,6 +36,7 @@                                 , matchMethodTest                                 , cookieHeaderOrderTest                                 , pContentDispositionFilename+                                , applicativeTest                                 ]  cookieParserTest :: Test@@ -41,24 +44,24 @@     "cookieParserTest" ~:     [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"         @?= (Right [-            Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False-          , Cookie "1" "" "" "cookie2" "value2" False False+            Cookie "1" "/testpath" "example.com" "cookie1" "value1" False False SameSiteNoValue False+          , Cookie "1" "" "" "cookie2" "value2" False False SameSiteNoValue False           ])     ,parseCookies "  \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/  "         @?= (Right [-            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False+            Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/|" False False SameSiteNoValue False           ])     ,parseCookies " cookie1 = value1  "         @?= (Right [-            Cookie "" "" "" "cookie1" "value1" False False+            Cookie "" "" "" "cookie1" "value1" False False SameSiteNoValue False           ])     ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe  "         @?= (Right [-            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False+            Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe" False False SameSiteNoValue False           ])     , parseCookies "foo=\"\\\"bar\\\"\""         @?= (Right [-              Cookie "" "" ""  "foo" "\"bar\"" False False+              Cookie "" "" ""  "foo" "\"bar\"" False False SameSiteNoValue False              ])     ] @@ -247,3 +250,13 @@     do let doesNotWorkWithOldParserButWithNew = "form-data; filename=\"file.pdf\"; name=\"file\"" :: String        c <- parseContentDisposition doesNotWorkWithOldParserButWithNew        assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")])++applicativeTest :: Test+applicativeTest =+  "applicativeTest" ~:+    do req <- mkRequest GET "/response" [] mempty L.empty+       res <- flip simpleHTTP'' req $ do+         Left errors <- getDataFn $ (++) <$> look "a" <*> look "b"+         pure $ intercalate "," errors+       let ref = "Parameter not found: a,Parameter not found: b"+       assertEqual "getDataFn/ReaderError doesn't short-circuit" ref (unpack (rsBody res))