{-# LANGUAGE FlexibleContexts #-}
-- | This module provides four classes and some related functions
-- which provide 'ServerPartT' with much of its web-centric behavior.
--
--  1. 'ServerMonad' provides access to the HTTP 'Request'
--
--  2. 'FilterMonad' provides the ability to apply filters and transformations to a 'Response'
--
--  3. 'WebMonad' provides a way to escape a computation early and return a 'Response'
--
--  4. 'HasRqData' which provides access to the decoded QUERY_STRING and request body/form data
module Happstack.Server.Monads
    ( -- * ServerPartT
      ServerPartT
    , ServerPart
      -- * Happstack class
    , Happstack
      -- * ServerMonad
    , ServerMonad(..)
    , mapServerPartT
    , mapServerPartT'
    , UnWebT
    , filterFun
      -- * FilterMonad
    , FilterMonad(..)
    , ignoreFilters
    , addHeaderM
    , getHeaderM
    , setHeaderM
    , neverExpires
      -- * WebMonad
    , WebMonad(..)
    , escape
    , escape'
      -- * MonadPlus helpers
    , require
    , requireM
    -- * escapeHTTP
    , escapeHTTP
    ) where

import Control.Applicative               (Alternative, Applicative)
import Control.Monad                     (MonadPlus(mzero))
import Control.Monad.Error               (Error, ErrorT)
import Control.Monad.Trans               (MonadIO(..),MonadTrans(lift))
import Control.Monad.Trans.Except        (ExceptT)
import Control.Monad.Reader              (ReaderT)
import qualified Control.Monad.Writer.Lazy   as Lazy   (WriterT)
import qualified Control.Monad.Writer.Strict as Strict (WriterT)
import qualified Control.Monad.State.Lazy    as Lazy   (StateT)
import qualified Control.Monad.State.Strict  as Strict (StateT)
import qualified Control.Monad.RWS.Lazy      as Lazy   (RWST)
import qualified Control.Monad.RWS.Strict    as Strict (RWST)
import qualified Data.ByteString.Char8       as B
import Data.Monoid                       (Monoid)
import Happstack.Server.Internal.Monads
import Happstack.Server.Types            (Response, addHeader, getHeader, setHeader)
import Happstack.Server.RqData           (HasRqData)

-- | A class alias for all the classes a standard server monad (such as 'ServerPartT') is expected to have instances for. This allows you to keep your type signatures shorter and easier to understand.
class ( ServerMonad m, WebMonad Response m, FilterMonad Response m
      , MonadIO m, MonadPlus m, HasRqData m, Monad m, Functor m
      , Applicative m, Alternative m) => Happstack m

instance (Functor m, Monad m, MonadPlus m
         , MonadIO m)            => Happstack (ServerPartT m)
instance (Happstack m)           => Happstack (Lazy.StateT        s m)
instance (Happstack m)           => Happstack (Strict.StateT      s m)
instance (Happstack m)           => Happstack (ReaderT        r     m)
instance (Happstack m, Monoid w) => Happstack (Lazy.WriterT   w     m)
instance (Happstack m, Monoid w) => Happstack (Strict.WriterT   w   m)
instance (Happstack m, Monoid w) => Happstack (Lazy.RWST      r w s m)
instance (Happstack m, Monoid w) => Happstack (Strict.RWST    r w s m)
instance (Happstack m, Error e)  => Happstack (ErrorT e m)
instance (Happstack m, Monoid e) => Happstack (ExceptT e m)

-- | Get a header out of the request.
getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)
getHeaderM :: String -> m (Maybe ByteString)
getHeaderM String
a = m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq m Request
-> (Request -> m (Maybe ByteString)) -> m (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m (Maybe ByteString))
-> (Request -> Maybe ByteString) -> Request -> m (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
a)

-- | Add headers into the response.  This method does not overwrite
-- any existing header of the same name, hence the name 'addHeaderM'.
-- If you want to replace a header use 'setHeaderM'.
addHeaderM :: (FilterMonad Response m) => String -> String -> m ()
addHeaderM :: String -> String -> m ()
addHeaderM String
a String
v = (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \Response
res-> String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
addHeader String
a String
v Response
res

-- | Set a header into the response.  This will replace an existing
-- header of the same name.  Use 'addHeaderM' if you want to add more
-- than one header of the same name.
setHeaderM :: (FilterMonad Response m) => String -> String -> m ()
setHeaderM :: String -> String -> m ()
setHeaderM String
a String
v = (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \Response
res -> String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
a String
v Response
res

-- | Set a far-future Expires header.  Useful for static resources.  If the
-- browser has the resource cached, no extra request is spent.
neverExpires :: (FilterMonad Response m) => m ()
neverExpires :: m ()
neverExpires = String -> String -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
String -> String -> m ()
setHeaderM String
"Expires" String
"Mon, 31 Dec 2035 12:00:00 GMT"

-- | Run an 'IO' action and, if it returns 'Just', pass it to the
-- second argument.
require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r
require :: IO (Maybe a) -> (a -> m r) -> m r
require IO (Maybe a)
fn a -> m r
handle = do
    Maybe a
mbVal <- IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe a)
fn
    case Maybe a
mbVal of
        Maybe a
Nothing -> m r
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just a
a -> a -> m r
handle a
a

-- | A variant of require that can run in any monad, not just 'IO'.
requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r
requireM :: m (Maybe a) -> (a -> t m r) -> t m r
requireM m (Maybe a)
fn a -> t m r
handle = do
    Maybe a
mbVal <- m (Maybe a) -> t m (Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe a)
fn
    case Maybe a
mbVal of
        Maybe a
Nothing -> t m r
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just a
a -> a -> t m r
handle a
a