happstack-server 7.7.2 → 7.8.0

raw patch · 9 files changed

+101/−81 lines, 9 filesdep ~monad-controldep ~mtlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: monad-control, mtl

API changes (from Hackage documentation)

Files

• README.md +1/−1
• happstack-server.cabal +4/−4
• src/Happstack/Server/Error.hs +5/−5
• src/Happstack/Server/Internal/Monads.hs +16/−56
• src/Happstack/Server/Internal/Types.hs +5/−1
• src/Happstack/Server/Monads.hs +5/−1
• src/Happstack/Server/Routing.hs +1/−1
• src/Happstack/Server/RqData.hs +50/−11
• tests/Happstack/Server/Tests.hs +14/−1

@@ -1,4 +1,4 @@-# happstack-server [![Hackage Status](https://img.shields.io/hackage/v/happstack-server.svg)][hackage] [![Build Status](https://travis-ci.com/Happstack/happstack-server.svg?branch=master)](https://travis-ci.com/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 

@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             7.7.2+Version:             7.8.0 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,7 +11,7 @@ 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, GHC==9.0.1+tested-with:         GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2  source-repository head     type:     git@@ -77,8 +77,8 @@                        filepath,                        hslogger               >= 1.0.2,                        html,-                       monad-control          >= 0.3  && < 1.1,-                       mtl                    >= 2    && < 2.3,+                       monad-control          >= 1.0  && < 1.1,+                       mtl                    >= 2.2  && < 2.4,                        old-locale,                        parsec                            < 4,                        process,

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

@@ -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_mtl(2,3,0)+import Control.Monad.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_mtl(2,3,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 

@@ -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)+#if !MIN_VERSION_mtl(2,3,0) import Control.Monad.Error (Error(strMsg))+#endif import Control.Monad.Fail (MonadFail) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Control.Concurrent.Thread.Group as TG@@ -246,11 +248,13 @@ showRsValidator :: Maybe (Response -> IO Response) -> String showRsValidator = maybe "Nothing" (const "Just <function>") +#if !MIN_VERSION_mtl(2,3,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

@@ -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))+#if !MIN_VERSION_mtl(2,3,0) import Control.Monad.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_mtl(2,3,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.

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

@@ -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_mtl(2,3,0)+import qualified Control.Monad.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@@ -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_mtl(2,3,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_mtl(2,3,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_mtl(2,3,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_mtl(2,3,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) @@ -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_mtl(2,3,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_mtl(2,3,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@@ -263,7 +303,6 @@     case fromReqURI val of       (Just a) -> Right a       _        -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val-  -- | convert or validate a value --

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