happstack-server 7.4.0 → 7.4.1

raw patch · 4 files changed

+97/−6 lines, 4 filesdep +exceptionsdep +transformers-compatdep ~basedep ~monad-controldep ~utf8-stringPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, transformers-compat

Dependency ranges changed: base, monad-control, utf8-string

API changes (from Hackage documentation)

Files

• happstack-server.cabal +5/−3
• src/Happstack/Server/Internal/Monads.hs +84/−1
• src/Happstack/Server/Monads.hs +2/−2
• src/Happstack/Server/RqData.hs +6/−0

@@ -1,5 +1,5 @@ Name:                happstack-server-Version:             7.4.0+Version:             7.4.1 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@@ -78,11 +78,12 @@                        bytestring,                        containers,                        directory,+                       exceptions,                        extensible-exceptions,                        filepath,                        hslogger               >= 1.0.2,                        html,-                       monad-control          >= 1.0  && < 1.1,+                       monad-control          >= 0.3  && < 1.1,                        mtl                    >= 2    && < 2.3,                        old-locale,                        parsec                            < 4,@@ -96,7 +97,8 @@                        threads                >= 0.5,                        transformers           >= 0.1.3 && < 0.5,                        transformers-base      >= 0.4   && < 0.5,-                       utf8-string            >= 0.3.4 && < 0.4,+                       transformers-compat    >= 0.3   && < 0.5,+                       utf8-string            >= 0.3.4 && < 1.1,                        xhtml,                        zlib 

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances  #-}+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, UndecidableInstances  #-} {-| This module defines the Monad stack used by Happstack. You mostly don't want to be looking in here. Look in "Happstack.Server.Monads" instead. -} module Happstack.Server.Internal.Monads where@@ -8,6 +8,7 @@ import Control.Monad                             ( MonadPlus(mzero, mplus), ap, liftM, msum                                                  ) import Control.Monad.Base                        ( MonadBase, liftBase )+import Control.Monad.Catch                       ( MonadCatch(..), MonadThrow(..) ) import Control.Monad.Error                       ( ErrorT(ErrorT), runErrorT                                                  , Error, MonadError, throwError                                                  , catchError, mapErrorT@@ -18,6 +19,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.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 )@@ -58,6 +60,12 @@ newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a }     deriving (Monad, MonadPlus, Functor) +instance MonadCatch m => MonadCatch (ServerPartT m) where+    catch action handle = ServerPartT $ catch (unServerPartT action) (unServerPartT . handle)++instance MonadThrow m => MonadThrow (ServerPartT m) where+    throwM = ServerPartT . throwM+ instance MonadBase b m => MonadBase b (ServerPartT m) where     liftBase = lift . liftBase @@ -65,6 +73,7 @@     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 ->@@ -76,7 +85,20 @@     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@@ -251,6 +273,12 @@ newtype FilterT a m b = FilterT { unFilterT :: Lazy.WriterT (FilterFun a) m b }    deriving (Functor, Applicative, Monad, MonadTrans) +instance MonadCatch m => MonadCatch (FilterT a m) where+    catch action handle = FilterT $ catch (unFilterT action) (unFilterT . handle)++instance MonadThrow m => MonadThrow (FilterT a m) where+    throwM = FilterT . throwM+ instance MonadBase b m => MonadBase b (FilterT a m) where     liftBase = lift . liftBase @@ -258,6 +286,7 @@     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@@ -267,7 +296,18 @@     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@@ -304,6 +344,12 @@ newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }     deriving (Functor) +instance MonadCatch m => MonadCatch (WebT m) where+    catch action handle = WebT $ catch (unWebT action) (unWebT . handle)++instance MonadThrow m => MonadThrow (WebT m) where+    throwM = WebT . throwM+ instance MonadBase b m => MonadBase b (WebT m) where     liftBase = lift . liftBase @@ -311,6 +357,7 @@     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)@@ -327,7 +374,24 @@     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@@ -685,4 +749,23 @@                   ) m  instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where+    finishWith    = lift . finishWith++-- ExceptT++instance ServerMonad m => ServerMonad (ExceptT e m) where+    askRq     = lift askRq+    localRq f = mapExceptT $ localRq f++instance (FilterMonad a m) => FilterMonad a (ExceptT e m) where+    setFilter f   = lift $ setFilter f+    composeFilter = lift . composeFilter+    getFilter m = mapExceptT (\m' ->+                                 do (eb, f) <- getFilter m'+                                    case eb of+                                      (Left e)  -> return (Left e)+                                      (Right b) -> return $ Right (b, f)+                  ) m++instance WebMonad a m => WebMonad a (ExceptT e m) where     finishWith    = lift . finishWith

@@ -41,6 +41,7 @@ import Control.Monad                     (MonadPlus(mzero)) import Control.Monad.Error               (Error, ErrorT) import Control.Monad.Trans               (MonadIO(..),MonadTrans(lift))+import Control.Monad.Trans.Except        (ExceptT) import Control.Monad.Reader              (ReaderT) import qualified Control.Monad.Writer.Lazy   as Lazy   (WriterT) import qualified Control.Monad.Writer.Strict as Strict (WriterT)@@ -69,6 +70,7 @@ instance (Happstack m, Monoid w) => Happstack (Lazy.RWST      r w s m) instance (Happstack m, Monoid w) => Happstack (Strict.RWST    r w s m) instance (Happstack m, Error e)  => Happstack (ErrorT e m)+instance (Happstack m, Monoid e) => Happstack (ExceptT e m)  -- | Get a header out of the request. getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)@@ -107,5 +109,3 @@     case mbVal of         Nothing -> mzero         Just a -> handle a--

@@ -70,6 +70,7 @@ import qualified Control.Monad.RWS.Strict as Strict    (RWST, mapRWST) import Control.Monad.Error                      (Error(noMsg, strMsg), ErrorT, mapErrorT) import Control.Monad.Trans                      (MonadIO(..), lift)+import Control.Monad.Trans.Except               (ExceptT, mapExceptT) import qualified Data.ByteString.Char8          as P import qualified Data.ByteString.Lazy.Char8     as L import qualified Data.ByteString.Lazy.UTF8      as LU@@ -226,6 +227,11 @@ instance (Monad m, Error e, HasRqData m) => HasRqData (ErrorT e m) where     askRqEnv      = lift askRqEnv     localRqEnv f  = mapErrorT (localRqEnv f)+    rqDataError e = lift (rqDataError e)++instance (Monad m, HasRqData m) => HasRqData (ExceptT e m) where+    askRqEnv      = lift askRqEnv+    localRqEnv f  = mapExceptT (localRqEnv f)     rqDataError e = lift (rqDataError e)  -- | apply 'RqData a' to a 'RqEnv'