{-# 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

import Control.Applicative                       (Applicative, pure, (<*>), Alternative(empty,(<|>)))

import Control.Concurrent                        (newMVar)
import Control.Exception                         (throwIO)

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
                                                 )
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail                        (MonadFail)
import qualified Control.Monad.Fail              as Fail
#endif
import Control.Monad.Reader                      ( ReaderT(ReaderT), runReaderT
                                                 , MonadReader, ask, local, mapReaderT
                                                 )
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 )
import Control.Monad.Trans                       ( MonadTrans, lift
                                                 , MonadIO, liftIO
                                                 )
import Control.Monad.Trans.Control               ( MonadTransControl(..)
                                                 , MonadBaseControl(..)
                                                 , ComposeSt, defaultLiftBaseWith, defaultRestoreM
                                                 )
import Control.Monad.Writer.Class                ( MonadWriter, tell, pass, listens )
import qualified Control.Monad.Writer.Lazy as Lazy     ( WriterT(WriterT), runWriterT, mapWriterT )
import qualified Control.Monad.Writer.Strict as Strict ( WriterT, mapWriterT )
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 Data.Semigroup                  as SG
import qualified Paths_happstack_server          as Cabal
import qualified Data.Version                    as DV
import Debug.Trace                               (trace)

import Happstack.Server.Internal.Cookie          (Cookie)
import Happstack.Server.Internal.RFC822Headers   (parseContentType)
import Happstack.Server.Internal.Types           (EscapeHTTP(..), canHaveBody)
import Happstack.Server.Internal.TimeoutIO       (TimeoutIO)
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

-- | An alias for @'ServerPartT' 'IO'@
type ServerPart a = ServerPartT IO a

--------------------------------------
-- HERE BEGINS ServerPartT definitions

-- | 'ServerPartT' is a rich, featureful monad for web development.
--
-- see also: 'simpleHTTP', 'ServerMonad', 'FilterMonad', 'WebMonad', and 'HasRqData'
newtype ServerPartT m a = ServerPartT { ServerPartT m a -> ReaderT Request (WebT m) a
unServerPartT :: ReaderT Request (WebT m) a }
#if MIN_VERSION_base(4,9,0)
    deriving (Applicative (ServerPartT m)
a -> ServerPartT m a
Applicative (ServerPartT m)
-> (forall a b.
    ServerPartT m a -> (a -> ServerPartT m b) -> ServerPartT m b)
-> (forall a b.
    ServerPartT m a -> ServerPartT m b -> ServerPartT m b)
-> (forall a. a -> ServerPartT m a)
-> Monad (ServerPartT m)
ServerPartT m a -> (a -> ServerPartT m b) -> ServerPartT m b
ServerPartT m a -> ServerPartT m b -> ServerPartT m b
forall a. a -> ServerPartT m a
forall a b. ServerPartT m a -> ServerPartT m b -> ServerPartT m b
forall a b.
ServerPartT m a -> (a -> ServerPartT m b) -> ServerPartT m b
forall (m :: * -> *). Monad m => Applicative (ServerPartT m)
forall (m :: * -> *) a. Monad m => a -> ServerPartT m a
forall (m :: * -> *) a b.
Monad m =>
ServerPartT m a -> ServerPartT m b -> ServerPartT m b
forall (m :: * -> *) a b.
Monad m =>
ServerPartT m a -> (a -> ServerPartT m b) -> ServerPartT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ServerPartT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> ServerPartT m a
>> :: ServerPartT m a -> ServerPartT m b -> ServerPartT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ServerPartT m a -> ServerPartT m b -> ServerPartT m b
>>= :: ServerPartT m a -> (a -> ServerPartT m b) -> ServerPartT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ServerPartT m a -> (a -> ServerPartT m b) -> ServerPartT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (ServerPartT m)
Monad, Monad (ServerPartT m)
Monad (ServerPartT m)
-> (forall a. String -> ServerPartT m a)
-> MonadFail (ServerPartT m)
String -> ServerPartT m a
forall a. String -> ServerPartT m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (ServerPartT m)
forall (m :: * -> *) a. MonadFail m => String -> ServerPartT m a
fail :: String -> ServerPartT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> ServerPartT m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (ServerPartT m)
MonadFail, Monad (ServerPartT m)
Alternative (ServerPartT m)
ServerPartT m a
Alternative (ServerPartT m)
-> Monad (ServerPartT m)
-> (forall a. ServerPartT m a)
-> (forall a.
    ServerPartT m a -> ServerPartT m a -> ServerPartT m a)
-> MonadPlus (ServerPartT m)
ServerPartT m a -> ServerPartT m a -> ServerPartT m a
forall a. ServerPartT m a
forall a. ServerPartT m a -> ServerPartT m a -> ServerPartT m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
forall (m :: * -> *). MonadPlus m => Monad (ServerPartT m)
forall (m :: * -> *). MonadPlus m => Alternative (ServerPartT m)
forall (m :: * -> *) a. MonadPlus m => ServerPartT m a
forall (m :: * -> *) a.
MonadPlus m =>
ServerPartT m a -> ServerPartT m a -> ServerPartT m a
mplus :: ServerPartT m a -> ServerPartT m a -> ServerPartT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
ServerPartT m a -> ServerPartT m a -> ServerPartT m a
mzero :: ServerPartT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => ServerPartT m a
$cp2MonadPlus :: forall (m :: * -> *). MonadPlus m => Monad (ServerPartT m)
$cp1MonadPlus :: forall (m :: * -> *). MonadPlus m => Alternative (ServerPartT m)
MonadPlus, a -> ServerPartT m b -> ServerPartT m a
(a -> b) -> ServerPartT m a -> ServerPartT m b
(forall a b. (a -> b) -> ServerPartT m a -> ServerPartT m b)
-> (forall a b. a -> ServerPartT m b -> ServerPartT m a)
-> Functor (ServerPartT m)
forall a b. a -> ServerPartT m b -> ServerPartT m a
forall a b. (a -> b) -> ServerPartT m a -> ServerPartT m b
forall (m :: * -> *) a b.
Functor m =>
a -> ServerPartT m b -> ServerPartT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ServerPartT m a -> ServerPartT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ServerPartT m b -> ServerPartT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ServerPartT m b -> ServerPartT m a
fmap :: (a -> b) -> ServerPartT m a -> ServerPartT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ServerPartT m a -> ServerPartT m b
Functor)
#else
    deriving (Monad, MonadPlus, Functor)
#endif

instance MonadCatch m => MonadCatch (ServerPartT m) where
    catch :: ServerPartT m a -> (e -> ServerPartT m a) -> ServerPartT m a
catch ServerPartT m a
action e -> ServerPartT m a
handle = ReaderT Request (WebT m) a -> ServerPartT m a
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) a -> ServerPartT m a)
-> ReaderT Request (WebT m) a -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ ReaderT Request (WebT m) a
-> (e -> ReaderT Request (WebT m) a) -> ReaderT Request (WebT m) a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (ServerPartT m a -> ReaderT Request (WebT m) a
forall (m :: * -> *) a.
ServerPartT m a -> ReaderT Request (WebT m) a
unServerPartT ServerPartT m a
action) (ServerPartT m a -> ReaderT Request (WebT m) a
forall (m :: * -> *) a.
ServerPartT m a -> ReaderT Request (WebT m) a
unServerPartT (ServerPartT m a -> ReaderT Request (WebT m) a)
-> (e -> ServerPartT m a) -> e -> ReaderT Request (WebT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ServerPartT m a
handle)

instance MonadThrow m => MonadThrow (ServerPartT m) where
    throwM :: e -> ServerPartT m a
throwM = ReaderT Request (WebT m) a -> ServerPartT m a
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) a -> ServerPartT m a)
-> (e -> ReaderT Request (WebT m) a) -> e -> ServerPartT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ReaderT Request (WebT m) a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM

instance MonadBase b m => MonadBase b (ServerPartT m) where
    liftBase :: b α -> ServerPartT m α
liftBase = m α -> ServerPartT m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> ServerPartT m α) -> (b α -> m α) -> b α -> ServerPartT m α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance (MonadIO m) => MonadIO (ServerPartT m) where
    liftIO :: IO a -> ServerPartT m a
liftIO = ReaderT Request (WebT m) a -> ServerPartT m a
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) a -> ServerPartT m a)
-> (IO a -> ReaderT Request (WebT m) a) -> IO a -> ServerPartT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT Request (WebT m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
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 :: (Run ServerPartT -> m a) -> ServerPartT m a
liftWith Run ServerPartT -> m a
f = ReaderT Request (WebT m) a -> ServerPartT m a
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) a -> ServerPartT m a)
-> ReaderT Request (WebT m) a -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ (Run (ReaderT Request) -> WebT m a) -> ReaderT Request (WebT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run (ReaderT Request) -> WebT m a) -> ReaderT Request (WebT m) a)
-> (Run (ReaderT Request) -> WebT m a)
-> ReaderT Request (WebT m) a
forall a b. (a -> b) -> a -> b
$ \Run (ReaderT Request)
runReader ->
                                 (Run WebT -> m a) -> WebT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run WebT -> m a) -> WebT m a) -> (Run WebT -> m a) -> WebT m a
forall a b. (a -> b) -> a -> b
$ \Run WebT
runWeb ->
                                   Run ServerPartT -> m a
f (Run ServerPartT -> m a) -> Run ServerPartT -> m a
forall a b. (a -> b) -> a -> b
$ WebT n b
-> n (Maybe (Either Response b, SetAppend (Dual (Endo Response))))
Run WebT
runWeb (WebT n b
 -> n (Maybe (Either Response b, SetAppend (Dual (Endo Response)))))
-> (ServerPartT n b -> WebT n b)
-> ServerPartT n b
-> n (Maybe (Either Response b, SetAppend (Dual (Endo Response))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Request (WebT n) b -> WebT n b
Run (ReaderT Request)
runReader (ReaderT Request (WebT n) b -> WebT n b)
-> (ServerPartT n b -> ReaderT Request (WebT n) b)
-> ServerPartT n b
-> WebT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerPartT n b -> ReaderT Request (WebT n) b
forall (m :: * -> *) a.
ServerPartT m a -> ReaderT Request (WebT m) a
unServerPartT
    restoreT :: m (StT ServerPartT a) -> ServerPartT m a
restoreT = ReaderT Request (WebT m) a -> ServerPartT m a
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) a -> ServerPartT m a)
-> (m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
    -> ReaderT Request (WebT m) a)
-> m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> ServerPartT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebT m a -> ReaderT Request (WebT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (WebT m a -> ReaderT Request (WebT m) a)
-> (m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
    -> WebT m a)
-> m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> ReaderT Request (WebT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> WebT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT

instance MonadBaseControl b m => MonadBaseControl b (ServerPartT m) where
    type StM (ServerPartT m) a = ComposeSt ServerPartT m a
    liftBaseWith :: (RunInBase (ServerPartT m) b -> b a) -> ServerPartT m a
liftBaseWith = (RunInBase (ServerPartT m) b -> b a) -> ServerPartT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
    restoreM :: StM (ServerPartT m) a -> ServerPartT m a
restoreM     = StM (ServerPartT m) a -> ServerPartT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
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
runServerPartT :: ServerPartT m a -> Request -> WebT m a
runServerPartT = ReaderT Request (WebT m) a -> Request -> WebT m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Request (WebT m) a -> Request -> WebT m a)
-> (ServerPartT m a -> ReaderT Request (WebT m) a)
-> ServerPartT m a
-> Request
-> WebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerPartT m a -> ReaderT Request (WebT m) a
forall (m :: * -> *) a.
ServerPartT m a -> ReaderT Request (WebT m) a
unServerPartT

-- | function for lifting WebT to ServerPartT
--
-- NOTE: This is mostly for internal use. If you want to access the
-- 'Request' in user-code see 'askRq' from 'ServerMonad'.
--
-- > do request <- askRq
-- >    ...
withRequest :: (Request -> WebT m a) -> ServerPartT m a
withRequest :: (Request -> WebT m a) -> ServerPartT m a
withRequest = ReaderT Request (WebT m) a -> ServerPartT m a
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) a -> ServerPartT m a)
-> ((Request -> WebT m a) -> ReaderT Request (WebT m) a)
-> (Request -> WebT m a)
-> ServerPartT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> WebT m a) -> ReaderT Request (WebT m) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT

-- | A constructor for a 'ServerPartT' when you don't care about the request.
--
-- NOTE: This is mostly for internal use. If you think you need to use
-- it in your own code, you might consider asking on the mailing list
-- or IRC to find out if there is an alternative solution.
anyRequest :: Monad m => WebT m a -> ServerPartT m a
anyRequest :: WebT m a -> ServerPartT m a
anyRequest WebT m a
x = (Request -> WebT m a) -> ServerPartT m a
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m a) -> ServerPartT m a)
-> (Request -> WebT m a) -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ \Request
_ -> WebT m a
x

-- | Apply a function to transform the inner monad of
-- @'ServerPartT' m@.
--
-- Often used when transforming a monad with 'ServerPartT', since
-- 'simpleHTTP' requires a @'ServerPartT' 'IO' a@.  Refer to 'UnWebT'
-- for an explanation of the structure of the monad.
--
-- Here is an example.  Suppose you want to embed an 'ErrorT' into your
-- 'ServerPartT' to enable 'throwError' and 'catchError' in your 'Monad'.
--
-- > type MyServerPartT e m a = ServerPartT (ErrorT e m) a
--
-- Now suppose you want to pass @MyServerPartT@ into a function that
-- demands a @'ServerPartT' 'IO' a@ (e.g. 'simpleHTTP').  You can
-- provide the function:
--
-- >   unpackErrorT :: (Monad m, Show e) => UnWebT (ErrorT e m) a -> UnWebT m a
-- >   unpackErrorT et = do
-- >      eitherV <- runErrorT et
-- >      return $ case eitherV of
-- >          Left err -> Just (Left $ toResponse $
-- >                                   "Catastrophic failure " ++ show err
-- >                           , filterFun $ \r -> r{rsCode = 500})
-- >          Right x -> x
--
-- With @unpackErrorT@ you can now call 'simpleHTTP'. Just wrap your
-- 'ServerPartT' list.
--
-- >  simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart `catchError` myHandler)
--
-- Or alternatively:
--
-- >  simpleHTTP' unpackErrorT nullConf (myPart `catchError` myHandler)
--
-- Also see 'Happstack.Server.Error.spUnwrapErrorT' for a more sophisticated version of this
-- function.
--
mapServerPartT :: (     UnWebT m a ->      UnWebT n b)
               -> (ServerPartT m a -> ServerPartT n b)
mapServerPartT :: (UnWebT m a -> UnWebT n b) -> ServerPartT m a -> ServerPartT n b
mapServerPartT UnWebT m a -> UnWebT n b
f ServerPartT m a
ma = (Request -> WebT n b) -> ServerPartT n b
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT n b) -> ServerPartT n b)
-> (Request -> WebT n b) -> ServerPartT n b
forall a b. (a -> b) -> a -> b
$ \Request
rq -> (UnWebT m a -> UnWebT n b) -> WebT m a -> WebT n b
forall (m :: * -> *) a (n :: * -> *) b.
(UnWebT m a -> UnWebT n b) -> WebT m a -> WebT n b
mapWebT UnWebT m a -> UnWebT n b
f (ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m a
ma Request
rq)

-- | A variant of 'mapServerPartT' where the first argument also takes
-- a 'Request'.  Useful if you want to 'runServerPartT' on a different
-- 'ServerPartT' inside your monad (see 'spUnwrapErrorT').
mapServerPartT' :: (Request -> UnWebT m a ->      UnWebT n b)
                -> (      ServerPartT m a -> ServerPartT n b)
mapServerPartT' :: (Request -> UnWebT m a -> UnWebT n b)
-> ServerPartT m a -> ServerPartT n b
mapServerPartT' Request -> UnWebT m a -> UnWebT n b
f ServerPartT m a
ma = (Request -> WebT n b) -> ServerPartT n b
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT n b) -> ServerPartT n b)
-> (Request -> WebT n b) -> ServerPartT n b
forall a b. (a -> b) -> a -> b
$ \Request
rq -> (UnWebT m a -> UnWebT n b) -> WebT m a -> WebT n b
forall (m :: * -> *) a (n :: * -> *) b.
(UnWebT m a -> UnWebT n b) -> WebT m a -> WebT n b
mapWebT (Request -> UnWebT m a -> UnWebT n b
f Request
rq) (ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m a
ma Request
rq)

instance MonadTrans (ServerPartT) where
    lift :: m a -> ServerPartT m a
lift m a
m = (Request -> WebT m a) -> ServerPartT m a
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest (\Request
_ -> m a -> WebT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
m)

instance (Monad m, MonadPlus m) => SG.Semigroup (ServerPartT m a) where
    <> :: ServerPartT m a -> ServerPartT m a -> ServerPartT m a
(<>) = ServerPartT m a -> ServerPartT m a -> ServerPartT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance (Monad m, MonadPlus m) => Monoid (ServerPartT m a) where
    mempty :: ServerPartT m a
mempty  = ServerPartT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    mappend :: ServerPartT m a -> ServerPartT m a -> ServerPartT m a
mappend = ServerPartT m a -> ServerPartT m a -> ServerPartT m a
forall a. Semigroup a => a -> a -> a
(SG.<>)

instance (Monad m, Functor m) => Applicative (ServerPartT m) where
    pure :: a -> ServerPartT m a
pure = a -> ServerPartT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: ServerPartT m (a -> b) -> ServerPartT m a -> ServerPartT m b
(<*>) = ServerPartT m (a -> b) -> ServerPartT m a -> ServerPartT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Functor m, MonadPlus m) => Alternative (ServerPartT m) where
    empty :: ServerPartT m a
empty = ServerPartT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: ServerPartT m a -> ServerPartT m a -> ServerPartT m a
(<|>) = ServerPartT m a -> ServerPartT m a -> ServerPartT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where
    tell :: w -> ServerPartT m ()
tell = m () -> ServerPartT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ServerPartT m ()) -> (w -> m ()) -> w -> ServerPartT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
    listen :: ServerPartT m a -> ServerPartT m (a, w)
listen ServerPartT m a
m = (Request -> WebT m (a, w)) -> ServerPartT m (a, w)
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m (a, w)) -> ServerPartT m (a, w))
-> (Request -> WebT m (a, w)) -> ServerPartT m (a, w)
forall a b. (a -> b) -> a -> b
$ \Request
rq ->  WebT m a -> WebT m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
Writer.listen (ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m a
m Request
rq) WebT m (a, w) -> ((a, w) -> WebT m (a, w)) -> WebT m (a, w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a, w) -> WebT m (a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return
    pass :: ServerPartT m (a, w -> w) -> ServerPartT m a
pass ServerPartT m (a, w -> w)
m = (Request -> WebT m a) -> ServerPartT m a
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m a) -> ServerPartT m a)
-> (Request -> WebT m a) -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ \Request
rq -> WebT m (a, w -> w) -> WebT m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (ServerPartT m (a, w -> w) -> Request -> WebT m (a, w -> w)
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m (a, w -> w)
m Request
rq) WebT m a -> (a -> WebT m a) -> WebT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> WebT m a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where
    throwError :: e -> ServerPartT m a
throwError e
e = m a -> ServerPartT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ServerPartT m a) -> m a -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
    catchError :: ServerPartT m a -> (e -> ServerPartT m a) -> ServerPartT m a
catchError ServerPartT m a
action e -> ServerPartT m a
handler = (Request -> WebT m a) -> ServerPartT m a
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m a) -> ServerPartT m a)
-> (Request -> WebT m a) -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ \Request
rq -> (ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m a
action Request
rq) WebT m a -> (e -> WebT m a) -> WebT m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (((ServerPartT m a -> Request -> WebT m a)
-> Request -> ServerPartT m a -> WebT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT (Request -> ServerPartT m a -> WebT m a)
-> Request -> ServerPartT m a -> WebT m a
forall a b. (a -> b) -> a -> b
$ Request
rq) (ServerPartT m a -> WebT m a)
-> (e -> ServerPartT m a) -> e -> WebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ServerPartT m a
handler)

instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where
    ask :: ServerPartT m r
ask = m r -> ServerPartT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: (r -> r) -> ServerPartT m a -> ServerPartT m a
local r -> r
fn ServerPartT m a
m = (Request -> WebT m a) -> ServerPartT m a
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m a) -> ServerPartT m a)
-> (Request -> WebT m a) -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ \Request
rq-> (r -> r) -> WebT m a -> WebT m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
fn (ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m a
m Request
rq)

instance (Monad m, MonadState s m) => MonadState s (ServerPartT m) where
    get :: ServerPartT m s
get = m s -> ServerPartT m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
    put :: s -> ServerPartT m ()
put = m () -> ServerPartT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ServerPartT m ()) -> (s -> m ()) -> s -> ServerPartT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance Monad m => FilterMonad Response (ServerPartT m) where
    setFilter :: (Response -> Response) -> ServerPartT m ()
setFilter = WebT m () -> ServerPartT m ()
forall (m :: * -> *) a. Monad m => WebT m a -> ServerPartT m a
anyRequest (WebT m () -> ServerPartT m ())
-> ((Response -> Response) -> WebT m ())
-> (Response -> Response)
-> ServerPartT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> Response) -> WebT m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter
    composeFilter :: (Response -> Response) -> ServerPartT m ()
composeFilter = WebT m () -> ServerPartT m ()
forall (m :: * -> *) a. Monad m => WebT m a -> ServerPartT m a
anyRequest (WebT m () -> ServerPartT m ())
-> ((Response -> Response) -> WebT m ())
-> (Response -> Response)
-> ServerPartT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> Response) -> WebT m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: ServerPartT m b -> ServerPartT m (b, Response -> Response)
getFilter ServerPartT m b
m = (Request -> WebT m (b, Response -> Response))
-> ServerPartT m (b, Response -> Response)
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m (b, Response -> Response))
 -> ServerPartT m (b, Response -> Response))
-> (Request -> WebT m (b, Response -> Response))
-> ServerPartT m (b, Response -> Response)
forall a b. (a -> b) -> a -> b
$ \Request
rq -> WebT m b -> WebT m (b, Response -> Response)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter (ServerPartT m b -> Request -> WebT m b
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m b
m Request
rq)

instance Monad m => WebMonad Response (ServerPartT m) where
    finishWith :: Response -> ServerPartT m b
finishWith Response
r = WebT m b -> ServerPartT m b
forall (m :: * -> *) a. Monad m => WebT m a -> ServerPartT m a
anyRequest (WebT m b -> ServerPartT m b) -> WebT m b -> ServerPartT m b
forall a b. (a -> b) -> a -> b
$ Response -> WebT m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith Response
r

-- | The 'ServerMonad' class provides methods for reading or locally
-- modifying the 'Request'. It is essentially a specialized version of
-- the 'MonadReader' class. Providing the unique names, 'askRq' and
-- 'localRq' makes it easier to use 'ServerPartT' and 'ReaderT'
-- together.
class Monad m => ServerMonad m where
    askRq   :: m Request
    localRq :: (Request -> Request) -> m a -> m a

instance (Monad m) => ServerMonad (ServerPartT m) where
    askRq :: ServerPartT m Request
askRq = ReaderT Request (WebT m) Request -> ServerPartT m Request
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) Request -> ServerPartT m Request)
-> ReaderT Request (WebT m) Request -> ServerPartT m Request
forall a b. (a -> b) -> a -> b
$ ReaderT Request (WebT m) Request
forall r (m :: * -> *). MonadReader r m => m r
ask
    localRq :: (Request -> Request) -> ServerPartT m a -> ServerPartT m a
localRq Request -> Request
f ServerPartT m a
m = ReaderT Request (WebT m) a -> ServerPartT m a
forall (m :: * -> *) a.
ReaderT Request (WebT m) a -> ServerPartT m a
ServerPartT (ReaderT Request (WebT m) a -> ServerPartT m a)
-> ReaderT Request (WebT m) a -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ (Request -> Request)
-> ReaderT Request (WebT m) a -> ReaderT Request (WebT m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local Request -> Request
f (ServerPartT m a -> ReaderT Request (WebT m) a
forall (m :: * -> *) a.
ServerPartT m a -> ReaderT Request (WebT m) a
unServerPartT ServerPartT m a
m)

-- | Implementation of 'askRqEnv' for arbitrary 'ServerMonad'.
smAskRqEnv :: (ServerMonad m, MonadIO m) => m ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
smAskRqEnv :: m ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
smAskRqEnv = do
    Request
rq  <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    Maybe [(String, Input)]
mbi <- IO (Maybe [(String, Input)]) -> m (Maybe [(String, Input)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [(String, Input)]) -> m (Maybe [(String, Input)]))
-> IO (Maybe [(String, Input)]) -> m (Maybe [(String, Input)])
forall a b. (a -> b) -> a -> b
$ if (Method -> Bool
canHaveBody (Request -> Method
rqMethod Request
rq)) Bool -> Bool -> Bool
&& (Maybe ContentType -> Bool
isDecodable (Request -> Maybe ContentType
ctype Request
rq))
      then Request -> IO (Maybe [(String, Input)])
readInputsBody Request
rq
      else Maybe [(String, Input)] -> IO (Maybe [(String, Input)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Input)] -> Maybe [(String, Input)]
forall a. a -> Maybe a
Just [])
    ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
-> m ([(String, Input)], Maybe [(String, Input)],
      [(String, Cookie)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> [(String, Input)]
rqInputsQuery Request
rq, Maybe [(String, Input)]
mbi, Request -> [(String, Cookie)]
rqCookies Request
rq)
    where
        ctype :: Request -> Maybe ContentType
        ctype :: Request -> Maybe ContentType
ctype Request
req = String -> Maybe ContentType
forall (m :: * -> *). MonadFail m => String -> m ContentType
parseContentType (String -> Maybe ContentType)
-> (ByteString -> String) -> ByteString -> Maybe ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
P.unpack (ByteString -> Maybe ContentType)
-> Maybe ByteString -> Maybe ContentType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"content-type" Request
req

        isDecodable :: Maybe ContentType -> Bool
        isDecodable :: Maybe ContentType -> Bool
isDecodable Maybe ContentType
Nothing                                                      = Bool
True -- assume it is application/x-www-form-urlencoded
        isDecodable (Just (ContentType String
"application" String
"x-www-form-urlencoded" [(String, String)]
_)) = Bool
True
        isDecodable (Just (ContentType String
"multipart" String
"form-data" [(String, String)]
_ps))             = Bool
True
        isDecodable (Just ContentType
_)                                                     = Bool
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 :: (([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
 -> ([(String, Input)], Maybe [(String, Input)],
     [(String, Cookie)]))
-> m b -> m b
smLocalRqEnv ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
-> ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
f m b
m = do
    Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    Maybe [(String, Input)]
b  <- IO (Maybe [(String, Input)]) -> m (Maybe [(String, Input)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [(String, Input)]) -> m (Maybe [(String, Input)]))
-> IO (Maybe [(String, Input)]) -> m (Maybe [(String, Input)])
forall a b. (a -> b) -> a -> b
$ Request -> IO (Maybe [(String, Input)])
readInputsBody Request
rq
    let ([(String, Input)]
q', Maybe [(String, Input)]
b', [(String, Cookie)]
c') = ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
-> ([(String, Input)], Maybe [(String, Input)], [(String, Cookie)])
f (Request -> [(String, Input)]
rqInputsQuery Request
rq, Maybe [(String, Input)]
b, Request -> [(String, Cookie)]
rqCookies Request
rq)
    MVar [(String, Input)]
bv <- IO (MVar [(String, Input)]) -> m (MVar [(String, Input)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar [(String, Input)]) -> m (MVar [(String, Input)]))
-> IO (MVar [(String, Input)]) -> m (MVar [(String, Input)])
forall a b. (a -> b) -> a -> b
$ [(String, Input)] -> IO (MVar [(String, Input)])
forall a. a -> IO (MVar a)
newMVar ([(String, Input)] -> Maybe [(String, Input)] -> [(String, Input)]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(String, Input)]
b')
    let rq' :: Request
rq' = Request
rq { rqInputsQuery :: [(String, Input)]
rqInputsQuery = [(String, Input)]
q'
                 , rqInputsBody :: MVar [(String, Input)]
rqInputsBody = MVar [(String, Input)]
bv
                 , rqCookies :: [(String, Cookie)]
rqCookies = [(String, Cookie)]
c'
                 }
    (Request -> Request) -> m b -> m b
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (Request -> Request -> Request
forall a b. a -> b -> a
const Request
rq') m b
m

-------------------------------
-- HERE BEGINS WebT definitions

-- | A monoid operation container.  If @a@ is a monoid, then
-- 'SetAppend' is a monoid with the following behaviors:
--
-- >  Set    x `mappend` Append y = Set    (x `mappend` y)
-- >  Append x `mappend` Append y = Append (x `mappend` y)
-- >  _        `mappend` Set y    = Set y
--
-- A simple way of summarizing this is, if the right side is 'Append',
-- then the right is appended to the left.  If the right side is
-- 'Set', then the left side is ignored.

data SetAppend a = Set a | Append a
    deriving (SetAppend a -> SetAppend a -> Bool
(SetAppend a -> SetAppend a -> Bool)
-> (SetAppend a -> SetAppend a -> Bool) -> Eq (SetAppend a)
forall a. Eq a => SetAppend a -> SetAppend a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SetAppend a -> SetAppend a -> Bool
$c/= :: forall a. Eq a => SetAppend a -> SetAppend a -> Bool
== :: SetAppend a -> SetAppend a -> Bool
$c== :: forall a. Eq a => SetAppend a -> SetAppend a -> Bool
Eq, Int -> SetAppend a -> ShowS
[SetAppend a] -> ShowS
SetAppend a -> String
(Int -> SetAppend a -> ShowS)
-> (SetAppend a -> String)
-> ([SetAppend a] -> ShowS)
-> Show (SetAppend a)
forall a. Show a => Int -> SetAppend a -> ShowS
forall a. Show a => [SetAppend a] -> ShowS
forall a. Show a => SetAppend a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetAppend a] -> ShowS
$cshowList :: forall a. Show a => [SetAppend a] -> ShowS
show :: SetAppend a -> String
$cshow :: forall a. Show a => SetAppend a -> String
showsPrec :: Int -> SetAppend a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> SetAppend a -> ShowS
Show)

instance Monoid a => SG.Semigroup (SetAppend a) where
   Set    a
x <> :: SetAppend a -> SetAppend a -> SetAppend a
<> Append a
y = a -> SetAppend a
forall a. a -> SetAppend a
Set    (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
y)
   Append a
x <> Append a
y = a -> SetAppend a
forall a. a -> SetAppend a
Append (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
y)
   SetAppend a
_        <> Set a
y    = a -> SetAppend a
forall a. a -> SetAppend a
Set a
y

instance Monoid a => Monoid (SetAppend a) where
   mempty :: SetAppend a
mempty  = a -> SetAppend a
forall a. a -> SetAppend a
Append a
forall a. Monoid a => a
mempty
   mappend :: SetAppend a -> SetAppend a -> SetAppend a
mappend = SetAppend a -> SetAppend a -> SetAppend a
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | Extract the value from a 'SetAppend'.
-- Note that a 'SetAppend' is actually a @CoPointed@ from:
-- <http://hackage.haskell.org/packages/archive/category-extras/latest/doc/html/Control-Functor-Pointed.html>
-- But lets not drag in that dependency. yet...
extract :: SetAppend t -> t
extract :: SetAppend t -> t
extract (Set    t
x) = t
x
extract (Append t
x) = t
x

instance Functor (SetAppend) where
    fmap :: (a -> b) -> SetAppend a -> SetAppend b
fmap a -> b
f (Set    a
x) = b -> SetAppend b
forall a. a -> SetAppend a
Set    (b -> SetAppend b) -> b -> SetAppend b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
    fmap a -> b
f (Append a
x) = b -> SetAppend b
forall a. a -> SetAppend a
Append (b -> SetAppend b) -> b -> SetAppend b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x

-- | 'FilterFun' is a lot more fun to type than @'SetAppend' ('Dual'
-- ('Endo' a))@.
type FilterFun a = SetAppend (Dual (Endo a))

unFilterFun :: FilterFun a -> (a -> a)
unFilterFun :: FilterFun a -> a -> a
unFilterFun = Endo a -> a -> a
forall a. Endo a -> a -> a
appEndo (Endo a -> a -> a)
-> (FilterFun a -> Endo a) -> FilterFun a -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dual (Endo a) -> Endo a
forall a. Dual a -> a
getDual (Dual (Endo a) -> Endo a)
-> (FilterFun a -> Dual (Endo a)) -> FilterFun a -> Endo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterFun a -> Dual (Endo a)
forall t. SetAppend t -> t
extract

-- | turn a function into a 'FilterFun'. Primarily used with 'mapServerPartT'
filterFun :: (a -> a) -> FilterFun a
filterFun :: (a -> a) -> FilterFun a
filterFun = Dual (Endo a) -> FilterFun a
forall a. a -> SetAppend a
Set (Dual (Endo a) -> FilterFun a)
-> ((a -> a) -> Dual (Endo a)) -> (a -> a) -> FilterFun a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo a -> Dual (Endo a)
forall a. a -> Dual a
Dual (Endo a -> Dual (Endo a))
-> ((a -> a) -> Endo a) -> (a -> a) -> Dual (Endo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo

newtype FilterT a m b = FilterT { FilterT a m b -> WriterT (FilterFun a) m b
unFilterT :: Lazy.WriterT (FilterFun a) m b }
   deriving (a -> FilterT a m b -> FilterT a m a
(a -> b) -> FilterT a m a -> FilterT a m b
(forall a b. (a -> b) -> FilterT a m a -> FilterT a m b)
-> (forall a b. a -> FilterT a m b -> FilterT a m a)
-> Functor (FilterT a m)
forall a b. a -> FilterT a m b -> FilterT a m a
forall a b. (a -> b) -> FilterT a m a -> FilterT a m b
forall a (m :: * -> *) a b.
Functor m =>
a -> FilterT a m b -> FilterT a m a
forall a (m :: * -> *) a b.
Functor m =>
(a -> b) -> FilterT a m a -> FilterT a m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FilterT a m b -> FilterT a m a
$c<$ :: forall a (m :: * -> *) a b.
Functor m =>
a -> FilterT a m b -> FilterT a m a
fmap :: (a -> b) -> FilterT a m a -> FilterT a m b
$cfmap :: forall a (m :: * -> *) a b.
Functor m =>
(a -> b) -> FilterT a m a -> FilterT a m b
Functor, Functor (FilterT a m)
a -> FilterT a m a
Functor (FilterT a m)
-> (forall a. a -> FilterT a m a)
-> (forall a b.
    FilterT a m (a -> b) -> FilterT a m a -> FilterT a m b)
-> (forall a b c.
    (a -> b -> c) -> FilterT a m a -> FilterT a m b -> FilterT a m c)
-> (forall a b. FilterT a m a -> FilterT a m b -> FilterT a m b)
-> (forall a b. FilterT a m a -> FilterT a m b -> FilterT a m a)
-> Applicative (FilterT a m)
FilterT a m a -> FilterT a m b -> FilterT a m b
FilterT a m a -> FilterT a m b -> FilterT a m a
FilterT a m (a -> b) -> FilterT a m a -> FilterT a m b
(a -> b -> c) -> FilterT a m a -> FilterT a m b -> FilterT a m c
forall a. a -> FilterT a m a
forall a b. FilterT a m a -> FilterT a m b -> FilterT a m a
forall a b. FilterT a m a -> FilterT a m b -> FilterT a m b
forall a b. FilterT a m (a -> b) -> FilterT a m a -> FilterT a m b
forall a b c.
(a -> b -> c) -> FilterT a m a -> FilterT a m b -> FilterT a m c
forall a (m :: * -> *). Applicative m => Functor (FilterT a m)
forall a (m :: * -> *) a. Applicative m => a -> FilterT a m a
forall a (m :: * -> *) a b.
Applicative m =>
FilterT a m a -> FilterT a m b -> FilterT a m a
forall a (m :: * -> *) a b.
Applicative m =>
FilterT a m a -> FilterT a m b -> FilterT a m b
forall a (m :: * -> *) a b.
Applicative m =>
FilterT a m (a -> b) -> FilterT a m a -> FilterT a m b
forall a (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> FilterT a m a -> FilterT a m b -> FilterT a m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: FilterT a m a -> FilterT a m b -> FilterT a m a
$c<* :: forall a (m :: * -> *) a b.
Applicative m =>
FilterT a m a -> FilterT a m b -> FilterT a m a
*> :: FilterT a m a -> FilterT a m b -> FilterT a m b
$c*> :: forall a (m :: * -> *) a b.
Applicative m =>
FilterT a m a -> FilterT a m b -> FilterT a m b
liftA2 :: (a -> b -> c) -> FilterT a m a -> FilterT a m b -> FilterT a m c
$cliftA2 :: forall a (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> FilterT a m a -> FilterT a m b -> FilterT a m c
<*> :: FilterT a m (a -> b) -> FilterT a m a -> FilterT a m b
$c<*> :: forall a (m :: * -> *) a b.
Applicative m =>
FilterT a m (a -> b) -> FilterT a m a -> FilterT a m b
pure :: a -> FilterT a m a
$cpure :: forall a (m :: * -> *) a. Applicative m => a -> FilterT a m a
$cp1Applicative :: forall a (m :: * -> *). Applicative m => Functor (FilterT a m)
Applicative, Applicative (FilterT a m)
a -> FilterT a m a
Applicative (FilterT a m)
-> (forall a b.
    FilterT a m a -> (a -> FilterT a m b) -> FilterT a m b)
-> (forall a b. FilterT a m a -> FilterT a m b -> FilterT a m b)
-> (forall a. a -> FilterT a m a)
-> Monad (FilterT a m)
FilterT a m a -> (a -> FilterT a m b) -> FilterT a m b
FilterT a m a -> FilterT a m b -> FilterT a m b
forall a. a -> FilterT a m a
forall a b. FilterT a m a -> FilterT a m b -> FilterT a m b
forall a b. FilterT a m a -> (a -> FilterT a m b) -> FilterT a m b
forall a (m :: * -> *). Monad m => Applicative (FilterT a m)
forall a (m :: * -> *) a. Monad m => a -> FilterT a m a
forall a (m :: * -> *) a b.
Monad m =>
FilterT a m a -> FilterT a m b -> FilterT a m b
forall a (m :: * -> *) a b.
Monad m =>
FilterT a m a -> (a -> FilterT a m b) -> FilterT a m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> FilterT a m a
$creturn :: forall a (m :: * -> *) a. Monad m => a -> FilterT a m a
>> :: FilterT a m a -> FilterT a m b -> FilterT a m b
$c>> :: forall a (m :: * -> *) a b.
Monad m =>
FilterT a m a -> FilterT a m b -> FilterT a m b
>>= :: FilterT a m a -> (a -> FilterT a m b) -> FilterT a m b
$c>>= :: forall a (m :: * -> *) a b.
Monad m =>
FilterT a m a -> (a -> FilterT a m b) -> FilterT a m b
$cp1Monad :: forall a (m :: * -> *). Monad m => Applicative (FilterT a m)
Monad, m a -> FilterT a m a
(forall (m :: * -> *) a. Monad m => m a -> FilterT a m a)
-> MonadTrans (FilterT a)
forall a (m :: * -> *) a. Monad m => m a -> FilterT a m a
forall (m :: * -> *) a. Monad m => m a -> FilterT a m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> FilterT a m a
$clift :: forall a (m :: * -> *) a. Monad m => m a -> FilterT a m a
MonadTrans)

instance MonadCatch m => MonadCatch (FilterT a m) where
    catch :: FilterT a m a -> (e -> FilterT a m a) -> FilterT a m a
catch FilterT a m a
action e -> FilterT a m a
handle = WriterT (FilterFun a) m a -> FilterT a m a
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m a -> FilterT a m a)
-> WriterT (FilterFun a) m a -> FilterT a m a
forall a b. (a -> b) -> a -> b
$ WriterT (FilterFun a) m a
-> (e -> WriterT (FilterFun a) m a) -> WriterT (FilterFun a) m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (FilterT a m a -> WriterT (FilterFun a) m a
forall a (m :: * -> *) b.
FilterT a m b -> WriterT (FilterFun a) m b
unFilterT FilterT a m a
action) (FilterT a m a -> WriterT (FilterFun a) m a
forall a (m :: * -> *) b.
FilterT a m b -> WriterT (FilterFun a) m b
unFilterT (FilterT a m a -> WriterT (FilterFun a) m a)
-> (e -> FilterT a m a) -> e -> WriterT (FilterFun a) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> FilterT a m a
handle)

instance MonadThrow m => MonadThrow (FilterT a m) where
    throwM :: e -> FilterT a m a
throwM = WriterT (FilterFun a) m a -> FilterT a m a
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m a -> FilterT a m a)
-> (e -> WriterT (FilterFun a) m a) -> e -> FilterT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> WriterT (FilterFun a) m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM

instance MonadBase b m => MonadBase b (FilterT a m) where
    liftBase :: b α -> FilterT a m α
liftBase = m α -> FilterT a m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> FilterT a m α) -> (b α -> m α) -> b α -> FilterT a m α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance (MonadIO m) => MonadIO (FilterT a m) where
    liftIO :: IO a -> FilterT a m a
liftIO = WriterT (FilterFun a) m a -> FilterT a m a
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m a -> FilterT a m a)
-> (IO a -> WriterT (FilterFun a) m a) -> IO a -> FilterT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> WriterT (FilterFun a) m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
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 :: (Run (FilterT a) -> m a) -> FilterT a m a
liftWith Run (FilterT a) -> m a
f = WriterT (FilterFun a) m a -> FilterT a m a
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m a -> FilterT a m a)
-> WriterT (FilterFun a) m a -> FilterT a m a
forall a b. (a -> b) -> a -> b
$ (Run (WriterT (FilterFun a)) -> m a) -> WriterT (FilterFun a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run (WriterT (FilterFun a)) -> m a) -> WriterT (FilterFun a) m a)
-> (Run (WriterT (FilterFun a)) -> m a)
-> WriterT (FilterFun a) m a
forall a b. (a -> b) -> a -> b
$ \Run (WriterT (FilterFun a))
run -> Run (FilterT a) -> m a
f (Run (FilterT a) -> m a) -> Run (FilterT a) -> m a
forall a b. (a -> b) -> a -> b
$ WriterT (FilterFun a) n b -> n (b, FilterFun a)
Run (WriterT (FilterFun a))
run (WriterT (FilterFun a) n b -> n (b, FilterFun a))
-> (FilterT a n b -> WriterT (FilterFun a) n b)
-> FilterT a n b
-> n (b, FilterFun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterT a n b -> WriterT (FilterFun a) n b
forall a (m :: * -> *) b.
FilterT a m b -> WriterT (FilterFun a) m b
unFilterT
    restoreT :: m (StT (FilterT a) a) -> FilterT a m a
restoreT = WriterT (FilterFun a) m a -> FilterT a m a
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m a -> FilterT a m a)
-> (m (a, FilterFun a) -> WriterT (FilterFun a) m a)
-> m (a, FilterFun a)
-> FilterT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, FilterFun a) -> WriterT (FilterFun a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT

instance MonadBaseControl b m => MonadBaseControl b (FilterT a m) where
    type StM (FilterT a m) c = ComposeSt (FilterT a) m c
    liftBaseWith :: (RunInBase (FilterT a m) b -> b a) -> FilterT a m a
liftBaseWith = (RunInBase (FilterT a m) b -> b a) -> FilterT a m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
    restoreM :: StM (FilterT a m) a -> FilterT a m a
restoreM     = StM (FilterT a m) a -> FilterT a m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
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
-- are the fundamental ways of manipulating 'Response' values.
class Monad m => FilterMonad a m | m->a where
    -- | Ignores all previous alterations to your filter
    --
    -- As an example:
    --
    -- > do
    -- >   composeFilter f
    -- >   setFilter g
    -- >   return "Hello World"
    --
    -- The @'setFilter' g@ will cause the first @'composeFilter' f@ to
    -- be ignored.
    setFilter :: (a->a) -> m ()
    -- | Composes your filter function with the existing filter
    -- function.
    composeFilter :: (a->a) -> m ()
    -- | Retrieves the filter from the environment.
    getFilter :: m b -> m (b, a->a)

-- | Resets all your filters. An alias for @'setFilter' 'id'@.
ignoreFilters :: (FilterMonad a m) => m ()
ignoreFilters :: m ()
ignoreFilters = (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter a -> a
forall a. a -> a
id

instance (Monad m) => FilterMonad a (FilterT a m) where
    setFilter :: (a -> a) -> FilterT a m ()
setFilter     = WriterT (FilterFun a) m () -> FilterT a m ()
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m () -> FilterT a m ())
-> ((a -> a) -> WriterT (FilterFun a) m ())
-> (a -> a)
-> FilterT a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterFun a -> WriterT (FilterFun a) m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell                (FilterFun a -> WriterT (FilterFun a) m ())
-> ((a -> a) -> FilterFun a)
-> (a -> a)
-> WriterT (FilterFun a) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dual (Endo a) -> FilterFun a
forall a. a -> SetAppend a
Set    (Dual (Endo a) -> FilterFun a)
-> ((a -> a) -> Dual (Endo a)) -> (a -> a) -> FilterFun a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo a -> Dual (Endo a)
forall a. a -> Dual a
Dual (Endo a -> Dual (Endo a))
-> ((a -> a) -> Endo a) -> (a -> a) -> Dual (Endo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo
    composeFilter :: (a -> a) -> FilterT a m ()
composeFilter = WriterT (FilterFun a) m () -> FilterT a m ()
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m () -> FilterT a m ())
-> ((a -> a) -> WriterT (FilterFun a) m ())
-> (a -> a)
-> FilterT a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterFun a -> WriterT (FilterFun a) m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell                (FilterFun a -> WriterT (FilterFun a) m ())
-> ((a -> a) -> FilterFun a)
-> (a -> a)
-> WriterT (FilterFun a) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dual (Endo a) -> FilterFun a
forall a. a -> SetAppend a
Append (Dual (Endo a) -> FilterFun a)
-> ((a -> a) -> Dual (Endo a)) -> (a -> a) -> FilterFun a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo a -> Dual (Endo a)
forall a. a -> Dual a
Dual (Endo a -> Dual (Endo a))
-> ((a -> a) -> Endo a) -> (a -> a) -> Dual (Endo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo
    getFilter :: FilterT a m b -> FilterT a m (b, a -> a)
getFilter     = WriterT (FilterFun a) m (b, a -> a) -> FilterT a m (b, a -> a)
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT (FilterFun a) m (b, a -> a) -> FilterT a m (b, a -> a))
-> (FilterT a m b -> WriterT (FilterFun a) m (b, a -> a))
-> FilterT a m b
-> FilterT a m (b, a -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilterFun a -> a -> a)
-> WriterT (FilterFun a) m b -> WriterT (FilterFun a) m (b, a -> a)
forall w (m :: * -> *) b a.
MonadWriter w m =>
(w -> b) -> m a -> m (a, b)
listens FilterFun a -> a -> a
forall a. FilterFun a -> a -> a
unFilterFun (WriterT (FilterFun a) m b -> WriterT (FilterFun a) m (b, a -> a))
-> (FilterT a m b -> WriterT (FilterFun a) m b)
-> FilterT a m b
-> WriterT (FilterFun a) m (b, a -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterT a m b -> WriterT (FilterFun a) m b
forall a (m :: * -> *) b.
FilterT a m b -> WriterT (FilterFun a) m b
unFilterT

-- | The basic 'Response' building object.
newtype WebT m a = WebT { WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }
    deriving (a -> WebT m b -> WebT m a
(a -> b) -> WebT m a -> WebT m b
(forall a b. (a -> b) -> WebT m a -> WebT m b)
-> (forall a b. a -> WebT m b -> WebT m a) -> Functor (WebT m)
forall a b. a -> WebT m b -> WebT m a
forall a b. (a -> b) -> WebT m a -> WebT m b
forall (m :: * -> *) a b. Functor m => a -> WebT m b -> WebT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> WebT m a -> WebT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> WebT m b -> WebT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> WebT m b -> WebT m a
fmap :: (a -> b) -> WebT m a -> WebT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> WebT m a -> WebT m b
Functor)

instance MonadCatch m => MonadCatch (WebT m) where
    catch :: WebT m a -> (e -> WebT m a) -> WebT m a
catch WebT m a
action e -> WebT m a
handle = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall a b. (a -> b) -> a -> b
$ ErrorT Response (FilterT Response (MaybeT m)) a
-> (e -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT WebT m a
action) (WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT (WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> (e -> WebT m a)
-> e
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> WebT m a
handle)

instance MonadThrow m => MonadThrow (WebT m) where
    throwM :: e -> WebT m a
throwM = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> (e -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> e
-> WebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM

instance MonadBase b m => MonadBase b (WebT m) where
    liftBase :: b α -> WebT m α
liftBase = m α -> WebT m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> WebT m α) -> (b α -> m α) -> b α -> WebT m α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance (MonadIO m) => MonadIO (WebT m) where
    liftIO :: IO a -> WebT m a
liftIO = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> (IO a -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> IO a
-> WebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
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))
    liftWith :: (Run WebT -> m a) -> WebT m a
liftWith Run WebT -> m a
f = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall a b. (a -> b) -> a -> b
$ (Run (ErrorT Response) -> FilterT Response (MaybeT m) a)
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run (ErrorT Response) -> FilterT Response (MaybeT m) a)
 -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> (Run (ErrorT Response) -> FilterT Response (MaybeT m) a)
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall a b. (a -> b) -> a -> b
$ \Run (ErrorT Response)
runError ->
                          (Run (FilterT Response) -> MaybeT m a)
-> FilterT Response (MaybeT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run (FilterT Response) -> MaybeT m a)
 -> FilterT Response (MaybeT m) a)
-> (Run (FilterT Response) -> MaybeT m a)
-> FilterT Response (MaybeT m) a
forall a b. (a -> b) -> a -> b
$ \Run (FilterT Response)
runFilter ->
                            (Run MaybeT -> m a) -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run MaybeT -> m a) -> MaybeT m a)
-> (Run MaybeT -> m a) -> MaybeT m a
forall a b. (a -> b) -> a -> b
$ \Run MaybeT
runMaybe ->
                              Run WebT -> m a
f (Run WebT -> m a) -> Run WebT -> m a
forall a b. (a -> b) -> a -> b
$ MaybeT n (Either Response b, SetAppend (Dual (Endo Response)))
-> n (Maybe (Either Response b, SetAppend (Dual (Endo Response))))
Run MaybeT
runMaybe (MaybeT n (Either Response b, SetAppend (Dual (Endo Response)))
 -> n (Maybe (Either Response b, SetAppend (Dual (Endo Response)))))
-> (WebT n b
    -> MaybeT n (Either Response b, SetAppend (Dual (Endo Response))))
-> WebT n b
-> n (Maybe (Either Response b, SetAppend (Dual (Endo Response))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   FilterT Response (MaybeT n) (Either Response b)
-> MaybeT n (Either Response b, SetAppend (Dual (Endo Response)))
Run (FilterT Response)
runFilter (FilterT Response (MaybeT n) (Either Response b)
 -> MaybeT n (Either Response b, SetAppend (Dual (Endo Response))))
-> (WebT n b -> FilterT Response (MaybeT n) (Either Response b))
-> WebT n b
-> MaybeT n (Either Response b, SetAppend (Dual (Endo Response)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                    ErrorT Response (FilterT Response (MaybeT n)) b
-> FilterT Response (MaybeT n) (Either Response b)
Run (ErrorT Response)
runError (ErrorT Response (FilterT Response (MaybeT n)) b
 -> FilterT Response (MaybeT n) (Either Response b))
-> (WebT n b -> ErrorT Response (FilterT Response (MaybeT n)) b)
-> WebT n b
-> FilterT Response (MaybeT n) (Either Response b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebT n b -> ErrorT Response (FilterT Response (MaybeT n)) b
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT
    restoreT :: m (StT WebT a) -> WebT m a
restoreT = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> (m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
    -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> WebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterT Response (MaybeT m) (Either Response a)
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (FilterT Response (MaybeT m) (Either Response a)
 -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> (m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
    -> FilterT Response (MaybeT m) (Either Response a))
-> m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
-> FilterT Response (MaybeT m) (Either Response a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
 -> FilterT Response (MaybeT m) (Either Response a))
-> (m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
    -> MaybeT m (Either Response a, SetAppend (Dual (Endo Response))))
-> m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> FilterT Response (MaybeT m) (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT

instance MonadBaseControl b m => MonadBaseControl b (WebT m) where
    type StM (WebT m) a = ComposeSt WebT m a
    liftBaseWith :: (RunInBase (WebT m) b -> b a) -> WebT m a
liftBaseWith = (RunInBase (WebT m) b -> b a) -> WebT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
    restoreM :: StM (WebT m) a -> WebT m a
restoreM     = StM (WebT m) a -> WebT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
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
-- it first appears.
--
-- It is worth discussing the unpacked structure of 'WebT' a bit as
-- it's exposed in 'mapServerPartT' and 'mapWebT'.
--
--  A fully unpacked 'WebT' has a structure that looks like:
--
--  > ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response))
--
--  So, ignoring @m@, as it is just the containing 'Monad', the
--  outermost layer is a 'Maybe'.  This is 'Nothing' if 'mzero' was
--  called or @'Just' ('Either' 'Response' a, 'SetAppend' ('Endo'
--  'Response'))@ if 'mzero' wasn't called.  Inside the 'Maybe', there
--  is a pair.  The second element of the pair is our filter function
--  @'FilterFun' 'Response'@.  @'FilterFun' 'Response'@ is a type
--  alias for @'SetAppend' ('Dual' ('Endo' 'Response'))@.  This is
--  just a wrapper for a @'Response' -> 'Response'@ function with a
--  particular 'Monoid' behavior.  The value
--
--  >  Append (Dual (Endo f))
--
--  Causes @f@ to be composed with the previous filter.
--
--  >  Set (Dual (Endo f))
--
--  Causes @f@ to not be composed with the previous filter.
--
--  Finally, the first element of the pair is either @'Left'
--  'Response'@ or @'Right' a@.
--
--  Another way of looking at all these pieces is from the behaviors
--  they control.  The 'Maybe' controls the 'mzero' behavior.  @'Set'
--  ('Endo' f)@ comes from the 'setFilter' behavior.  Likewise,
--  @'Append' ('Endo' f)@ is from 'composeFilter'.  @'Left'
--  'Response'@ is what you get when you call 'finishWith' and
--  @'Right' a@ is the normal exit.
--
--  An example case statement looks like:
--
--  >  ex1 webt = do
--  >    val <- ununWebT webt
--  >    case val of
--  >        Nothing -> Nothing  -- this is the interior value when mzero was used
--  >        Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"
--  >                                             -- f is our filter function
--  >        Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value
--  >                                               -- f is still our filter function
--
type UnWebT m a = m (Maybe (Either Response a, FilterFun Response))

instance Monad m => Monad (WebT m) where
    WebT m a
m >>= :: WebT m a -> (a -> WebT m b) -> WebT m b
>>= a -> WebT m b
f = ErrorT Response (FilterT Response (MaybeT m)) b -> WebT m b
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) b -> WebT m b)
-> ErrorT Response (FilterT Response (MaybeT m)) b -> WebT m b
forall a b. (a -> b) -> a -> b
$ WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT WebT m a
m ErrorT Response (FilterT Response (MaybeT m)) a
-> (a -> ErrorT Response (FilterT Response (MaybeT m)) b)
-> ErrorT Response (FilterT Response (MaybeT m)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WebT m b -> ErrorT Response (FilterT Response (MaybeT m)) b
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT (WebT m b -> ErrorT Response (FilterT Response (MaybeT m)) b)
-> (a -> WebT m b)
-> a
-> ErrorT Response (FilterT Response (MaybeT m)) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> WebT m b
f
    {-# INLINE (>>=) #-}
    return :: a -> WebT m a
return a
a = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall a b. (a -> b) -> a -> b
$ a -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    {-# INLINE return #-}

#if MIN_VERSION_base(4,9,0)
instance MonadFail m => MonadFail (WebT m) where
#endif

    fail :: String -> WebT m a
fail String
s = m a -> WebT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s)

-- | 'WebMonad' provides a means to end the current computation
-- and return a 'Response' immediately.  This provides an
-- alternate escape route.  In particular it has a monadic value
-- of any type.  And unless you call @'setFilter' 'id'@ first your
-- response filters will be applied normally.
--
-- Extremely useful when you're deep inside a monad and decide
-- that you want to return a completely different content type,
-- since it doesn't force you to convert all your return types to
-- 'Response' early just to accommodate this.
--
-- see also: 'escape' and 'escape''
class Monad m => WebMonad a m | m->a where
    -- abort the current computation and return a value
    finishWith :: a -- ^ value to return (For 'ServerPart', 'a' will always be the type 'Response')
               -> m b

-- | Used to ignore all your filters and immediately end the
-- computation.  A combination of 'ignoreFilters' and 'finishWith'.
escape :: (WebMonad a m, FilterMonad a m) => m a -> m b
escape :: m a -> m b
escape m a
gen = m ()
forall a (m :: * -> *). FilterMonad a m => m ()
ignoreFilters m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
gen m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

-- | An alternate form of 'escape' that can be easily used within a do
-- block.
escape' :: (WebMonad a m, FilterMonad a m) => a -> m b
escape' :: a -> m b
escape' a
a = m ()
forall a (m :: * -> *). FilterMonad a m => m ()
ignoreFilters m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith a
a


instance (Monad m) => WebMonad Response (WebT m) where
    finishWith :: Response -> WebT m b
finishWith Response
r = ErrorT Response (FilterT Response (MaybeT m)) b -> WebT m b
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) b -> WebT m b)
-> ErrorT Response (FilterT Response (MaybeT m)) b -> WebT m b
forall a b. (a -> b) -> a -> b
$ Response -> ErrorT Response (FilterT Response (MaybeT m)) b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Response
r

instance MonadTrans WebT where
    lift :: m a -> WebT m a
lift = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> (m a -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> m a
-> WebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterT Response (MaybeT m) a
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FilterT Response (MaybeT m) a
 -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> (m a -> FilterT Response (MaybeT m) a)
-> m a
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m a -> FilterT Response (MaybeT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT m a -> FilterT Response (MaybeT m) a)
-> (m a -> MaybeT m a) -> m a -> FilterT Response (MaybeT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance (Monad m, MonadPlus m) => MonadPlus (WebT m) where
    -- | Aborts a computation.
    --
    -- This is primarily useful because 'msum' will take an array of
    -- 'MonadPlus' and return the first one that isn't 'mzero', which
    -- is exactly the semantics expected from objects that take lists
    -- of 'ServerPartT'.
    mzero :: WebT m a
mzero = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall a b. (a -> b) -> a -> b
$ FilterT Response (MaybeT m) a
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FilterT Response (MaybeT m) a
 -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> FilterT Response (MaybeT m) a
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall a b. (a -> b) -> a -> b
$ MaybeT m a -> FilterT Response (MaybeT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT m a -> FilterT Response (MaybeT m) a)
-> MaybeT m a -> FilterT Response (MaybeT m) a
forall a b. (a -> b) -> a -> b
$ MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    mplus :: WebT m a -> WebT m a -> WebT m a
mplus WebT m a
x WebT m a
y =  ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall a b. (a -> b) -> a -> b
$ FilterT Response (MaybeT m) (Either Response a)
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT (FilterT Response (MaybeT m) (Either Response a)
 -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> FilterT Response (MaybeT m) (Either Response a)
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall a b. (a -> b) -> a -> b
$ WriterT
  (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
-> FilterT Response (MaybeT m) (Either Response a)
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT
   (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
 -> FilterT Response (MaybeT m) (Either Response a))
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
-> FilterT Response (MaybeT m) (Either Response a)
forall a b. (a -> b) -> a -> b
$ (WebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall (m :: * -> *) a.
WebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
lower WebT m a
x) WriterT
  (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (WebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall (m :: * -> *) a.
WebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
lower WebT m a
y)
        where lower :: WebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
lower = (FilterT Response (MaybeT m) (Either Response a)
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall a (m :: * -> *) b.
FilterT a m b -> WriterT (FilterFun a) m b
unFilterT (FilterT Response (MaybeT m) (Either Response a)
 -> WriterT
      (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a))
-> (WebT m a -> FilterT Response (MaybeT m) (Either Response a))
-> WebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorT Response (FilterT Response (MaybeT m)) a
-> FilterT Response (MaybeT m) (Either Response a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT Response (FilterT Response (MaybeT m)) a
 -> FilterT Response (MaybeT m) (Either Response a))
-> (WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> WebT m a
-> FilterT Response (MaybeT m) (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT)

instance (Monad m) => FilterMonad Response (WebT m) where
    setFilter :: (Response -> Response) -> WebT m ()
setFilter Response -> Response
f = ErrorT Response (FilterT Response (MaybeT m)) () -> WebT m ()
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) () -> WebT m ())
-> ErrorT Response (FilterT Response (MaybeT m)) () -> WebT m ()
forall a b. (a -> b) -> a -> b
$ FilterT Response (MaybeT m) ()
-> ErrorT Response (FilterT Response (MaybeT m)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FilterT Response (MaybeT m) ()
 -> ErrorT Response (FilterT Response (MaybeT m)) ())
-> FilterT Response (MaybeT m) ()
-> ErrorT Response (FilterT Response (MaybeT m)) ()
forall a b. (a -> b) -> a -> b
$ (Response -> Response) -> FilterT Response (MaybeT m) ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter ((Response -> Response) -> FilterT Response (MaybeT m) ())
-> (Response -> Response) -> FilterT Response (MaybeT m) ()
forall a b. (a -> b) -> a -> b
$ Response -> Response
f
    composeFilter :: (Response -> Response) -> WebT m ()
composeFilter Response -> Response
f = ErrorT Response (FilterT Response (MaybeT m)) () -> WebT m ()
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) () -> WebT m ())
-> ((Response -> Response)
    -> ErrorT Response (FilterT Response (MaybeT m)) ())
-> (Response -> Response)
-> WebT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterT Response (MaybeT m) ()
-> ErrorT Response (FilterT Response (MaybeT m)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FilterT Response (MaybeT m) ()
 -> ErrorT Response (FilterT Response (MaybeT m)) ())
-> ((Response -> Response) -> FilterT Response (MaybeT m) ())
-> (Response -> Response)
-> ErrorT Response (FilterT Response (MaybeT m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> Response) -> FilterT Response (MaybeT m) ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter ((Response -> Response) -> WebT m ())
-> (Response -> Response) -> WebT m ()
forall a b. (a -> b) -> a -> b
$ Response -> Response
f
    getFilter :: WebT m b -> WebT m (b, Response -> Response)
getFilter     WebT m b
m = ErrorT
  Response (FilterT Response (MaybeT m)) (b, Response -> Response)
-> WebT m (b, Response -> Response)
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT
   Response (FilterT Response (MaybeT m)) (b, Response -> Response)
 -> WebT m (b, Response -> Response))
-> ErrorT
     Response (FilterT Response (MaybeT m)) (b, Response -> Response)
-> WebT m (b, Response -> Response)
forall a b. (a -> b) -> a -> b
$ FilterT
  Response (MaybeT m) (Either Response (b, Response -> Response))
-> ErrorT
     Response (FilterT Response (MaybeT m)) (b, Response -> Response)
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT (FilterT
   Response (MaybeT m) (Either Response (b, Response -> Response))
 -> ErrorT
      Response (FilterT Response (MaybeT m)) (b, Response -> Response))
-> FilterT
     Response (MaybeT m) (Either Response (b, Response -> Response))
-> ErrorT
     Response (FilterT Response (MaybeT m)) (b, Response -> Response)
forall a b. (a -> b) -> a -> b
$ ((Either Response b, Response -> Response)
 -> Either Response (b, Response -> Response))
-> FilterT
     Response (MaybeT m) (Either Response b, Response -> Response)
-> FilterT
     Response (MaybeT m) (Either Response (b, Response -> Response))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Either Response b, Response -> Response)
-> Either Response (b, Response -> Response)
forall a a b. (Either a a, b) -> Either a (a, b)
lft (FilterT
   Response (MaybeT m) (Either Response b, Response -> Response)
 -> FilterT
      Response (MaybeT m) (Either Response (b, Response -> Response)))
-> FilterT
     Response (MaybeT m) (Either Response b, Response -> Response)
-> FilterT
     Response (MaybeT m) (Either Response (b, Response -> Response))
forall a b. (a -> b) -> a -> b
$ FilterT Response (MaybeT m) (Either Response b)
-> FilterT
     Response (MaybeT m) (Either Response b, Response -> Response)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter (ErrorT Response (FilterT Response (MaybeT m)) b
-> FilterT Response (MaybeT m) (Either Response b)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT Response (FilterT Response (MaybeT m)) b
 -> FilterT Response (MaybeT m) (Either Response b))
-> ErrorT Response (FilterT Response (MaybeT m)) b
-> FilterT Response (MaybeT m) (Either Response b)
forall a b. (a -> b) -> a -> b
$ WebT m b -> ErrorT Response (FilterT Response (MaybeT m)) b
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT WebT m b
m)
        where
          lft :: (Either a a, b) -> Either a (a, b)
lft (Left  a
r, b
_) = a -> Either a (a, b)
forall a b. a -> Either a b
Left a
r
          lft (Right a
a, b
f) = (a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
a, b
f)

instance (Monad m, MonadPlus m) => SG.Semigroup (WebT m a) where
    <> :: WebT m a -> WebT m a -> WebT m a
(<>) = WebT m a -> WebT m a -> WebT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance (Monad m, MonadPlus m) => Monoid (WebT m a) where
    mempty :: WebT m a
mempty  = WebT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    mappend :: WebT m a -> WebT m a -> WebT m a
mappend = WebT m a -> WebT m a -> WebT m a
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | 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 :: WebT m a -> UnWebT m a
ununWebT = MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
-> UnWebT m a
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
 -> UnWebT m a)
-> (WebT m a
    -> MaybeT m (Either Response a, SetAppend (Dual (Endo Response))))
-> WebT m a
-> UnWebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT
  (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
-> MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Lazy.runWriterT (WriterT
   (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
 -> MaybeT m (Either Response a, SetAppend (Dual (Endo Response))))
-> (WebT m a
    -> WriterT
         (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a))
-> WebT m a
-> MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterT Response (MaybeT m) (Either Response a)
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall a (m :: * -> *) b.
FilterT a m b -> WriterT (FilterFun a) m b
unFilterT (FilterT Response (MaybeT m) (Either Response a)
 -> WriterT
      (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a))
-> (WebT m a -> FilterT Response (MaybeT m) (Either Response a))
-> WebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorT Response (FilterT Response (MaybeT m)) a
-> FilterT Response (MaybeT m) (Either Response a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT Response (FilterT Response (MaybeT m)) a
 -> FilterT Response (MaybeT m) (Either Response a))
-> (WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> WebT m a
-> FilterT Response (MaybeT m) (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
forall (m :: * -> *) a.
WebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a
unWebT

-- | For wrapping a 'WebT' back up.  @'mkWebT' . 'ununWebT' = 'id'@
mkWebT :: UnWebT m a -> WebT m a
mkWebT :: UnWebT m a -> WebT m a
mkWebT = ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
forall (m :: * -> *) a.
ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a
WebT (ErrorT Response (FilterT Response (MaybeT m)) a -> WebT m a)
-> (UnWebT m a -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> UnWebT m a
-> WebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilterT Response (MaybeT m) (Either Response a)
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT (FilterT Response (MaybeT m) (Either Response a)
 -> ErrorT Response (FilterT Response (MaybeT m)) a)
-> (UnWebT m a -> FilterT Response (MaybeT m) (Either Response a))
-> UnWebT m a
-> ErrorT Response (FilterT Response (MaybeT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT
  (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
-> FilterT Response (MaybeT m) (Either Response a)
forall a (m :: * -> *) b.
WriterT (FilterFun a) m b -> FilterT a m b
FilterT (WriterT
   (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
 -> FilterT Response (MaybeT m) (Either Response a))
-> (UnWebT m a
    -> WriterT
         (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a))
-> UnWebT m a
-> FilterT Response (MaybeT m) (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Lazy.WriterT (MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
 -> WriterT
      (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a))
-> (UnWebT m a
    -> MaybeT m (Either Response a, SetAppend (Dual (Endo Response))))
-> UnWebT m a
-> WriterT
     (SetAppend (Dual (Endo Response))) (MaybeT m) (Either Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnWebT m a
-> MaybeT m (Either Response a, SetAppend (Dual (Endo Response)))
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT

-- | See 'mapServerPartT' for a discussion of this function.
mapWebT :: (UnWebT m a -> UnWebT n b)
        -> (  WebT m a ->   WebT n b)
mapWebT :: (UnWebT m a -> UnWebT n b) -> WebT m a -> WebT n b
mapWebT UnWebT m a -> UnWebT n b
f WebT m a
ma = UnWebT n b -> WebT n b
forall (m :: * -> *) a. UnWebT m a -> WebT m a
mkWebT (UnWebT n b -> WebT n b) -> UnWebT n b -> WebT n b
forall a b. (a -> b) -> a -> b
$ UnWebT m a -> UnWebT n b
f (WebT m a -> UnWebT m a
forall (m :: * -> *) a. WebT m a -> UnWebT m a
ununWebT WebT m a
ma)

-- | This is kinda like a very oddly shaped 'mapServerPartT' or 'mapWebT'.
-- You probably want one or the other of those.
localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a
localContext :: (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a
localContext WebT m a -> WebT m' a
fn ServerPartT m a
hs
    = (Request -> WebT m' a) -> ServerPartT m' a
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m' a) -> ServerPartT m' a)
-> (Request -> WebT m' a) -> ServerPartT m' a
forall a b. (a -> b) -> a -> b
$ \Request
rq -> WebT m a -> WebT m' a
fn (ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m a
hs Request
rq)

instance (Monad m, Functor m) => Applicative (WebT m) where
    pure :: a -> WebT m a
pure = a -> WebT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: WebT m (a -> b) -> WebT m a -> WebT m b
(<*>) = WebT m (a -> b) -> WebT m a -> WebT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Functor m, MonadPlus m) => Alternative (WebT m) where
    empty :: WebT m a
empty = WebT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: WebT m a -> WebT m a -> WebT m a
(<|>) = WebT m a -> WebT m a -> WebT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadReader r m => MonadReader r (WebT m) where
    ask :: WebT m r
ask = m r -> WebT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: (r -> r) -> WebT m a -> WebT m a
local r -> r
fn WebT m a
m = UnWebT m a -> WebT m a
forall (m :: * -> *) a. UnWebT m a -> WebT m a
mkWebT (UnWebT m a -> WebT m a) -> UnWebT m a -> WebT m a
forall a b. (a -> b) -> a -> b
$ (r -> r) -> UnWebT m a -> UnWebT m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
fn (WebT m a -> UnWebT m a
forall (m :: * -> *) a. WebT m a -> UnWebT m a
ununWebT WebT m a
m)

instance MonadState st m => MonadState st (WebT m) where
    get :: WebT m st
get = m st -> WebT m st
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m st
forall s (m :: * -> *). MonadState s m => m s
get
    put :: st -> WebT m ()
put = m () -> WebT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WebT m ()) -> (st -> m ()) -> st -> WebT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. st -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance MonadError e m => MonadError e (WebT m) where
        throwError :: e -> WebT m a
throwError e
err = m a -> WebT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> WebT m a) -> m a -> WebT m a
forall a b. (a -> b) -> a -> b
$ e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
err
        catchError :: WebT m a -> (e -> WebT m a) -> WebT m a
catchError WebT m a
action e -> WebT m a
handler = UnWebT m a -> WebT m a
forall (m :: * -> *) a. UnWebT m a -> WebT m a
mkWebT (UnWebT m a -> WebT m a) -> UnWebT m a -> WebT m a
forall a b. (a -> b) -> a -> b
$ UnWebT m a -> (e -> UnWebT m a) -> UnWebT m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (WebT m a -> UnWebT m a
forall (m :: * -> *) a. WebT m a -> UnWebT m a
ununWebT WebT m a
action) (WebT m a -> UnWebT m a
forall (m :: * -> *) a. WebT m a -> UnWebT m a
ununWebT (WebT m a -> UnWebT m a) -> (e -> WebT m a) -> e -> UnWebT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> WebT m a
handler)

instance MonadWriter w m => MonadWriter w (WebT m) where
    tell :: w -> WebT m ()
tell = m () -> WebT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WebT m ()) -> (w -> m ()) -> w -> WebT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
    listen :: WebT m a -> WebT m (a, w)
listen WebT m a
m = UnWebT m (a, w) -> WebT m (a, w)
forall (m :: * -> *) a. UnWebT m a -> WebT m a
mkWebT (UnWebT m (a, w) -> WebT m (a, w))
-> UnWebT m (a, w) -> WebT m (a, w)
forall a b. (a -> b) -> a -> b
$ m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
-> m (Maybe (Either Response a, SetAppend (Dual (Endo Response))),
      w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
Writer.listen (WebT m a
-> m (Maybe (Either Response a, SetAppend (Dual (Endo Response))))
forall (m :: * -> *) a. WebT m a -> UnWebT m a
ununWebT WebT m a
m) m (Maybe (Either Response a, SetAppend (Dual (Endo Response))), w)
-> ((Maybe (Either Response a, SetAppend (Dual (Endo Response))),
     w)
    -> UnWebT m (a, w))
-> UnWebT m (a, w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe (Either Response (a, w), SetAppend (Dual (Endo Response)))
-> UnWebT m (a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Response (a, w), SetAppend (Dual (Endo Response)))
 -> UnWebT m (a, w))
-> ((Maybe (Either Response a, SetAppend (Dual (Endo Response))),
     w)
    -> Maybe
         (Either Response (a, w), SetAppend (Dual (Endo Response))))
-> (Maybe (Either Response a, SetAppend (Dual (Endo Response))), w)
-> UnWebT m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Either Response a, SetAppend (Dual (Endo Response))), w)
-> Maybe (Either Response (a, w), SetAppend (Dual (Endo Response)))
forall a a b b.
(Maybe (Either a a, b), b) -> Maybe (Either a (a, b), b)
liftWebT)
        where liftWebT :: (Maybe (Either a a, b), b) -> Maybe (Either a (a, b), b)
liftWebT (Maybe (Either a a, b)
Nothing, b
_) = Maybe (Either a (a, b), b)
forall a. Maybe a
Nothing
              liftWebT (Just (Left a
x,b
f), b
_) = (Either a (a, b), b) -> Maybe (Either a (a, b), b)
forall a. a -> Maybe a
Just (a -> Either a (a, b)
forall a b. a -> Either a b
Left a
x,b
f)
              liftWebT (Just (Right a
x,b
f),b
w) = (Either a (a, b), b) -> Maybe (Either a (a, b), b)
forall a. a -> Maybe a
Just ((a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
x,b
w),b
f)
    pass :: WebT m (a, w -> w) -> WebT m a
pass WebT m (a, w -> w)
m = UnWebT m a -> WebT m a
forall (m :: * -> *) a. UnWebT m a -> WebT m a
mkWebT (UnWebT m a -> WebT m a) -> UnWebT m a -> WebT m a
forall a b. (a -> b) -> a -> b
$ WebT m (a, w -> w) -> UnWebT m (a, w -> w)
forall (m :: * -> *) a. WebT m a -> UnWebT m a
ununWebT WebT m (a, w -> w)
m UnWebT m (a, w -> w)
-> (Maybe
      (Either Response (a, w -> w), SetAppend (Dual (Endo Response)))
    -> UnWebT m a)
-> UnWebT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe
  (Either Response (a, w -> w), SetAppend (Dual (Endo Response)))
-> UnWebT m a
forall (m :: * -> *) w a b b.
MonadWriter w m =>
Maybe (Either a (b, w -> w), b) -> m (Maybe (Either a b, b))
liftWebT
        where liftWebT :: Maybe (Either a (b, w -> w), b) -> m (Maybe (Either a b, b))
liftWebT Maybe (Either a (b, w -> w), b)
Nothing = Maybe (Either a b, b) -> m (Maybe (Either a b, b))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either a b, b)
forall a. Maybe a
Nothing
              liftWebT (Just (Left a
x,b
f)) = Maybe (Either a b, b) -> m (Maybe (Either a b, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either a b, b) -> m (Maybe (Either a b, b)))
-> Maybe (Either a b, b) -> m (Maybe (Either a b, b))
forall a b. (a -> b) -> a -> b
$ (Either a b, b) -> Maybe (Either a b, b)
forall a. a -> Maybe a
Just (a -> Either a b
forall a b. a -> Either a b
Left a
x, b
f)
              liftWebT (Just (Right (b, w -> w)
x,b
f)) = m (b, w -> w) -> m b
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass ((b, w -> w) -> m (b, w -> w)
forall (m :: * -> *) a. Monad m => a -> m a
return (b, w -> w)
x)m b
-> (b -> m (Maybe (Either a b, b))) -> m (Maybe (Either a b, b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\b
a -> Maybe (Either a b, b) -> m (Maybe (Either a b, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either a b, b) -> m (Maybe (Either a b, b)))
-> Maybe (Either a b, b) -> m (Maybe (Either a b, b))
forall a b. (a -> b) -> a -> b
$ (Either a b, b) -> Maybe (Either a b, b)
forall a. a -> Maybe a
Just (b -> Either a b
forall a b. b -> Either a b
Right b
a,b
f))

-- | Deprecated: use 'msum'.
multi :: (Monad m, MonadPlus m) => [ServerPartT m a] -> ServerPartT m a
multi :: [ServerPartT m a] -> ServerPartT m a
multi = [ServerPartT m a] -> ServerPartT m a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
{-# DEPRECATED multi "Use msum instead" #-}

-- | What is this for, exactly?  I don't understand why @Show a@ is
-- even in the context Deprecated: This function appears to do nothing
-- at all. If it use it, let us know why.
debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a
debugFilter :: ServerPartT m a -> ServerPartT m a
debugFilter ServerPartT m a
handle =
    (Request -> WebT m a) -> ServerPartT m a
forall (m :: * -> *) a. (Request -> WebT m a) -> ServerPartT m a
withRequest ((Request -> WebT m a) -> ServerPartT m a)
-> (Request -> WebT m a) -> ServerPartT m a
forall a b. (a -> b) -> a -> b
$ \Request
rq -> do
                    a
r <- ServerPartT m a -> Request -> WebT m a
forall (m :: * -> *) a. ServerPartT m a -> Request -> WebT m a
runServerPartT ServerPartT m a
handle Request
rq
                    a -> WebT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
{-# DEPRECATED debugFilter "This function appears to do nothing." #-}


-- "Pattern match failure in do expression at src\AppControl.hs:43:24"
-- is converted to:
-- "src\AppControl.hs:43:24: Pattern match failure in do expression"
-- Then we output this to stderr. Help debugging under Emacs console when using GHCi.
-- This is GHC specific, but you may add your favourite compiler here also.
outputTraceMessage :: String -> a -> a
outputTraceMessage :: String -> a -> a
outputTraceMessage String
s a
c | String
"Pattern match failure " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s =
    let w :: [(String, String)]
w = [(String
k,String
p) | (String
i,String
p) <- [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [String]
forall a. [a] -> [[a]]
tails String
s) (String -> [String]
forall a. [a] -> [[a]]
inits String
s), Just String
k <- [String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
" at " String
i]]
        v :: String
v = ((String, String) -> String) -> [(String, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(String
k,String
p) -> String
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p) [(String, String)]
w
    in String -> a -> a
forall a. String -> a -> a
trace String
v a
c
outputTraceMessage String
s a
c = String -> a -> a
forall a. String -> a -> a
trace String
s a
c


mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b
mkFailMessage :: String -> m b
mkFailMessage String
s = do
    m ()
forall a (m :: * -> *). FilterMonad a m => m ()
ignoreFilters
    Response -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith (String -> Response
failResponse String
s)

failResponse :: String -> Response
failResponse :: String -> Response
failResponse String
s =
    String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Content-Type" String
"text/html; charset=UTF-8" (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
     Int -> ByteString -> Response
resultBS Int
500 (String -> ByteString
LU.fromString (ShowS
failHtml String
s))

failHtml:: String->String
failHtml :: ShowS
failHtml String
errString =
   String
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"<html><head><title>Happstack "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Internal Server Error</title></head>"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"<body><h1>Happstack " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</h1>"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"<p>Something went wrong here<br>"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Internal server error<br>"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Everything has stopped</p>"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"<p>The error was \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ShowS
escapeString String
errString) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"</p></body></html>"
    where ver :: String
ver = Version -> String
DV.showVersion Version
Cabal.version

escapeString :: String -> String
escapeString :: ShowS
escapeString String
str = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
encodeEntity String
str
    where
      encodeEntity :: Char -> String
      encodeEntity :: Char -> String
encodeEntity Char
'<' = String
"&lt;"
      encodeEntity Char
'>' = String
"&gt;"
      encodeEntity Char
'&' = String
"&amp;"
      encodeEntity Char
'"' = String
"&quot;"
      encodeEntity Char
c
          | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
127 = String
"&#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";"
          | Bool
otherwise = [Char
c]

------------------------------------------------------------------------------
-- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT,
-- WriterT, RWST, and ErrorT
------------------------------------------------------------------------------

-- ReaderT

instance (ServerMonad m) => ServerMonad (ReaderT r m) where
    askRq :: ReaderT r m Request
askRq         = m Request -> ReaderT r m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> ReaderT r m a -> ReaderT r m a
localRq Request -> Request
f     = (m a -> m a) -> ReaderT r m a -> ReaderT r m a
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT ((Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f)

instance (FilterMonad res m) => FilterMonad res (ReaderT r m) where
    setFilter :: (res -> res) -> ReaderT r m ()
setFilter res -> res
f   = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ()) -> m () -> ReaderT r m ()
forall a b. (a -> b) -> a -> b
$ (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter res -> res
f
    composeFilter :: (res -> res) -> ReaderT r m ()
composeFilter = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT r m ())
-> ((res -> res) -> m ()) -> (res -> res) -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: ReaderT r m b -> ReaderT r m (b, res -> res)
getFilter     = (m b -> m (b, res -> res))
-> ReaderT r m b -> ReaderT r m (b, res -> res)
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT m b -> m (b, res -> res)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter

instance (WebMonad a m) => WebMonad a (ReaderT r m) where
    finishWith :: a -> ReaderT r m b
finishWith    = m b -> ReaderT r m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> ReaderT r m b) -> (a -> m b) -> a -> ReaderT r m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

-- StateT

instance (ServerMonad m) => ServerMonad (Lazy.StateT s m) where
    askRq :: StateT s m Request
askRq         = m Request -> StateT s m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> StateT s m a -> StateT s m a
localRq Request -> Request
f     = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Lazy.mapStateT ((Request -> Request) -> m (a, s) -> m (a, s)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f)

instance (ServerMonad m) => ServerMonad (Strict.StateT s m) where
    askRq :: StateT s m Request
askRq         = m Request -> StateT s m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> StateT s m a -> StateT s m a
localRq Request -> Request
f     = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Strict.mapStateT ((Request -> Request) -> m (a, s) -> m (a, s)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f)

instance (FilterMonad res m) => FilterMonad res (Lazy.StateT s m) where
    setFilter :: (res -> res) -> StateT s m ()
setFilter res -> res
f   = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ()) -> m () -> StateT s m ()
forall a b. (a -> b) -> a -> b
$ (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter res -> res
f
    composeFilter :: (res -> res) -> StateT s m ()
composeFilter = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> ((res -> res) -> m ()) -> (res -> res) -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: StateT s m b -> StateT s m (b, res -> res)
getFilter   StateT s m b
m = (m (b, s) -> m ((b, res -> res), s))
-> StateT s m b -> StateT s m (b, res -> res)
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Lazy.mapStateT (\m (b, s)
m' ->
                                   do ((b
b,s
s), res -> res
f) <- m (b, s) -> m ((b, s), res -> res)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (b, s)
m'
                                      ((b, res -> res), s) -> m ((b, res -> res), s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, res -> res
f), s
s)) StateT s m b
m

instance (FilterMonad res m) => FilterMonad res (Strict.StateT s m) where
    setFilter :: (res -> res) -> StateT s m ()
setFilter res -> res
f   = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ()) -> m () -> StateT s m ()
forall a b. (a -> b) -> a -> b
$ (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter res -> res
f
    composeFilter :: (res -> res) -> StateT s m ()
composeFilter = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> ((res -> res) -> m ()) -> (res -> res) -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: StateT s m b -> StateT s m (b, res -> res)
getFilter   StateT s m b
m = (m (b, s) -> m ((b, res -> res), s))
-> StateT s m b -> StateT s m (b, res -> res)
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Strict.mapStateT (\m (b, s)
m' ->
                                   do ((b
b,s
s), res -> res
f) <- m (b, s) -> m ((b, s), res -> res)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (b, s)
m'
                                      ((b, res -> res), s) -> m ((b, res -> res), s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, res -> res
f), s
s)) StateT s m b
m

instance (WebMonad a m) => WebMonad a (Lazy.StateT s m) where
    finishWith :: a -> StateT s m b
finishWith    = m b -> StateT s m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> StateT s m b) -> (a -> m b) -> a -> StateT s m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

instance (WebMonad a m) => WebMonad a (Strict.StateT s m) where
    finishWith :: a -> StateT s m b
finishWith    = m b -> StateT s m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> StateT s m b) -> (a -> m b) -> a -> StateT s m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

-- WriterT

instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.WriterT w m) where
    askRq :: WriterT w m Request
askRq         = m Request -> WriterT w m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> WriterT w m a -> WriterT w m a
localRq Request -> Request
f     = (m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Lazy.mapWriterT ((Request -> Request) -> m (a, w) -> m (a, w)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f)

instance (ServerMonad m, Monoid w) => ServerMonad (Strict.WriterT w m) where
    askRq :: WriterT w m Request
askRq         = m Request -> WriterT w m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> WriterT w m a -> WriterT w m a
localRq Request -> Request
f     = (m (a, w) -> m (a, w)) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Strict.mapWriterT ((Request -> Request) -> m (a, w) -> m (a, w)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f)

instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.WriterT w m) where
    setFilter :: (res -> res) -> WriterT w m ()
setFilter res -> res
f   = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ()) -> m () -> WriterT w m ()
forall a b. (a -> b) -> a -> b
$ (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter res -> res
f
    composeFilter :: (res -> res) -> WriterT w m ()
composeFilter = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ())
-> ((res -> res) -> m ()) -> (res -> res) -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: WriterT w m b -> WriterT w m (b, res -> res)
getFilter   WriterT w m b
m = (m (b, w) -> m ((b, res -> res), w))
-> WriterT w m b -> WriterT w m (b, res -> res)
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Lazy.mapWriterT (\m (b, w)
m' ->
                                   do ((b
b,w
w), res -> res
f) <- m (b, w) -> m ((b, w), res -> res)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (b, w)
m'
                                      ((b, res -> res), w) -> m ((b, res -> res), w)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, res -> res
f), w
w)) WriterT w m b
m

instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.WriterT w m) where
    setFilter :: (res -> res) -> WriterT w m ()
setFilter res -> res
f   = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ()) -> m () -> WriterT w m ()
forall a b. (a -> b) -> a -> b
$ (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter res -> res
f
    composeFilter :: (res -> res) -> WriterT w m ()
composeFilter = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> WriterT w m ())
-> ((res -> res) -> m ()) -> (res -> res) -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: WriterT w m b -> WriterT w m (b, res -> res)
getFilter   WriterT w m b
m = (m (b, w) -> m ((b, res -> res), w))
-> WriterT w m b -> WriterT w m (b, res -> res)
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Strict.mapWriterT (\m (b, w)
m' ->
                                   do ((b
b,w
w), res -> res
f) <- m (b, w) -> m ((b, w), res -> res)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (b, w)
m'
                                      ((b, res -> res), w) -> m ((b, res -> res), w)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, res -> res
f), w
w)) WriterT w m b
m

instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.WriterT w m) where
    finishWith :: a -> WriterT w m b
finishWith    = m b -> WriterT w m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> WriterT w m b) -> (a -> m b) -> a -> WriterT w m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

instance (WebMonad a m, Monoid w) => WebMonad a (Strict.WriterT w m) where
    finishWith :: a -> WriterT w m b
finishWith    = m b -> WriterT w m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> WriterT w m b) -> (a -> m b) -> a -> WriterT w m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

-- RWST

instance (ServerMonad m, Monoid w) => ServerMonad (Lazy.RWST r w s m) where
    askRq :: RWST r w s m Request
askRq         = m Request -> RWST r w s m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> RWST r w s m a -> RWST r w s m a
localRq Request -> Request
f     = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Lazy.mapRWST ((Request -> Request) -> m (a, s, w) -> m (a, s, w)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f)

instance (ServerMonad m, Monoid w) => ServerMonad (Strict.RWST r w s m) where
    askRq :: RWST r w s m Request
askRq         = m Request -> RWST r w s m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> RWST r w s m a -> RWST r w s m a
localRq Request -> Request
f     = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Strict.mapRWST ((Request -> Request) -> m (a, s, w) -> m (a, s, w)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f)

instance (FilterMonad res m, Monoid w) => FilterMonad res (Lazy.RWST r w s m) where
    setFilter :: (res -> res) -> RWST r w s m ()
setFilter res -> res
f   = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RWST r w s m ()) -> m () -> RWST r w s m ()
forall a b. (a -> b) -> a -> b
$ (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter res -> res
f
    composeFilter :: (res -> res) -> RWST r w s m ()
composeFilter = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RWST r w s m ())
-> ((res -> res) -> m ()) -> (res -> res) -> RWST r w s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: RWST r w s m b -> RWST r w s m (b, res -> res)
getFilter   RWST r w s m b
m = (m (b, s, w) -> m ((b, res -> res), s, w))
-> RWST r w s m b -> RWST r w s m (b, res -> res)
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Lazy.mapRWST (\m (b, s, w)
m' ->
                                   do ((b
b,s
s,w
w), res -> res
f) <- m (b, s, w) -> m ((b, s, w), res -> res)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (b, s, w)
m'
                                      ((b, res -> res), s, w) -> m ((b, res -> res), s, w)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, res -> res
f), s
s, w
w)) RWST r w s m b
m

instance (FilterMonad res m, Monoid w) => FilterMonad res (Strict.RWST r w s m) where
    setFilter :: (res -> res) -> RWST r w s m ()
setFilter res -> res
f   = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RWST r w s m ()) -> m () -> RWST r w s m ()
forall a b. (a -> b) -> a -> b
$ (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter res -> res
f
    composeFilter :: (res -> res) -> RWST r w s m ()
composeFilter = m () -> RWST r w s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> RWST r w s m ())
-> ((res -> res) -> m ()) -> (res -> res) -> RWST r w s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (res -> res) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: RWST r w s m b -> RWST r w s m (b, res -> res)
getFilter   RWST r w s m b
m = (m (b, s, w) -> m ((b, res -> res), s, w))
-> RWST r w s m b -> RWST r w s m (b, res -> res)
forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Strict.mapRWST (\m (b, s, w)
m' ->
                                   do ((b
b,s
s,w
w), res -> res
f) <- m (b, s, w) -> m ((b, s, w), res -> res)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (b, s, w)
m'
                                      ((b, res -> res), s, w) -> m ((b, res -> res), s, w)
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, res -> res
f), s
s, w
w)) RWST r w s m b
m

instance (WebMonad a m, Monoid w) => WebMonad a (Lazy.RWST r w s m) where
    finishWith :: a -> RWST r w s m b
finishWith     = m b -> RWST r w s m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> RWST r w s m b) -> (a -> m b) -> a -> RWST r w s m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

instance (WebMonad a m, Monoid w) => WebMonad a (Strict.RWST r w s m) where
    finishWith :: a -> RWST r w s m b
finishWith     = m b -> RWST r w s m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> RWST r w s m b) -> (a -> m b) -> a -> RWST r w s m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

-- ErrorT

instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where
    askRq :: ErrorT e m Request
askRq     = m Request -> ErrorT e m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> ErrorT e m a -> ErrorT e m a
localRq Request -> Request
f = (m (Either e a) -> m (Either e a)) -> ErrorT e m a -> ErrorT e m a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ErrorT e m a -> ErrorT e' n b
mapErrorT ((m (Either e a) -> m (Either e a))
 -> ErrorT e m a -> ErrorT e m a)
-> (m (Either e a) -> m (Either e a))
-> ErrorT e m a
-> ErrorT e m a
forall a b. (a -> b) -> a -> b
$ (Request -> Request) -> m (Either e a) -> m (Either e a)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f

instance (Error e, FilterMonad a m) => FilterMonad a (ErrorT e m) where
    setFilter :: (a -> a) -> ErrorT e m ()
setFilter a -> a
f   = m () -> ErrorT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ErrorT e m ()) -> m () -> ErrorT e m ()
forall a b. (a -> b) -> a -> b
$ (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter a -> a
f
    composeFilter :: (a -> a) -> ErrorT e m ()
composeFilter = m () -> ErrorT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ErrorT e m ())
-> ((a -> a) -> m ()) -> (a -> a) -> ErrorT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: ErrorT e m b -> ErrorT e m (b, a -> a)
getFilter ErrorT e m b
m = (m (Either e b) -> m (Either e (b, a -> a)))
-> ErrorT e m b -> ErrorT e m (b, a -> a)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ErrorT e m a -> ErrorT e' n b
mapErrorT (\m (Either e b)
m' ->
                                 do (Either e b
eb, a -> a
f) <- m (Either e b) -> m (Either e b, a -> a)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (Either e b)
m'
                                    case Either e b
eb of
                                      (Left e
e)  -> Either e (b, a -> a) -> m (Either e (b, a -> a))
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e (b, a -> a)
forall a b. a -> Either a b
Left e
e)
                                      (Right b
b) -> Either e (b, a -> a) -> m (Either e (b, a -> a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e (b, a -> a) -> m (Either e (b, a -> a)))
-> Either e (b, a -> a) -> m (Either e (b, a -> a))
forall a b. (a -> b) -> a -> b
$ (b, a -> a) -> Either e (b, a -> a)
forall a b. b -> Either a b
Right (b
b, a -> a
f)
                  ) ErrorT e m b
m

instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where
    finishWith :: a -> ErrorT e m b
finishWith    = m b -> ErrorT e m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> ErrorT e m b) -> (a -> m b) -> a -> ErrorT e m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

-- ExceptT

instance ServerMonad m => ServerMonad (ExceptT e m) where
    askRq :: ExceptT e m Request
askRq     = m Request -> ExceptT e m Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    localRq :: (Request -> Request) -> ExceptT e m a -> ExceptT e m a
localRq Request -> Request
f = (m (Either e a) -> m (Either e a))
-> ExceptT e m a -> ExceptT e m a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((m (Either e a) -> m (Either e a))
 -> ExceptT e m a -> ExceptT e m a)
-> (m (Either e a) -> m (Either e a))
-> ExceptT e m a
-> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ (Request -> Request) -> m (Either e a) -> m (Either e a)
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq Request -> Request
f

instance (FilterMonad a m) => FilterMonad a (ExceptT e m) where
    setFilter :: (a -> a) -> ExceptT e m ()
setFilter a -> a
f   = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ()) -> m () -> ExceptT e m ()
forall a b. (a -> b) -> a -> b
$ (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
setFilter a -> a
f
    composeFilter :: (a -> a) -> ExceptT e m ()
composeFilter = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT e m ())
-> ((a -> a) -> m ()) -> (a -> a) -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
    getFilter :: ExceptT e m b -> ExceptT e m (b, a -> a)
getFilter ExceptT e m b
m = (m (Either e b) -> m (Either e (b, a -> a)))
-> ExceptT e m b -> ExceptT e m (b, a -> a)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT (\m (Either e b)
m' ->
                                 do (Either e b
eb, a -> a
f) <- m (Either e b) -> m (Either e b, a -> a)
forall a (m :: * -> *) b. FilterMonad a m => m b -> m (b, a -> a)
getFilter m (Either e b)
m'
                                    case Either e b
eb of
                                      (Left e
e)  -> Either e (b, a -> a) -> m (Either e (b, a -> a))
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e (b, a -> a)
forall a b. a -> Either a b
Left e
e)
                                      (Right b
b) -> Either e (b, a -> a) -> m (Either e (b, a -> a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e (b, a -> a) -> m (Either e (b, a -> a)))
-> Either e (b, a -> a) -> m (Either e (b, a -> a))
forall a b. (a -> b) -> a -> b
$ (b, a -> a) -> Either e (b, a -> a)
forall a b. b -> Either a b
Right (b
b, a -> a
f)
                  ) ExceptT e m b
m

instance WebMonad a m => WebMonad a (ExceptT e m) where
    finishWith :: a -> ExceptT e m b
finishWith    = m b -> ExceptT e m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> ExceptT e m b) -> (a -> m b) -> a -> ExceptT e m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith

escapeHTTP :: (ServerMonad m, MonadIO m) =>
              (TimeoutIO -> IO ())
           -> m a
escapeHTTP :: (TimeoutIO -> IO ()) -> m a
escapeHTTP TimeoutIO -> IO ()
h = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (EscapeHTTP -> IO a
forall e a. Exception e => e -> IO a
throwIO ((TimeoutIO -> IO ()) -> EscapeHTTP
EscapeHTTP TimeoutIO -> IO ()
h))