{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeSynonymInstances       #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE StandaloneDeriving         #-}
#endif

module Snap.Internal.Core
  ( MonadSnap(..)
  , SnapResult(..)
  , EscapeHttpHandler
  , EscapeSnap(..)
  , Zero(..)
  , Snap(..)
  , SnapState(..)
  , runRequestBody
  , readRequestBody
  , transformRequestBody
  , finishWith
  , catchFinishWith
  , pass
  , method
  , methods
  , updateContextPath
  , pathWith
  , dir
  , path
  , pathArg
  , ifTop
  , sget
  , smodify
  , getRequest
  , getResponse
  , getsRequest
  , getsResponse
  , putRequest
  , putResponse
  , modifyRequest
  , modifyResponse
  , redirect
  , redirect'
  , logError
  , addToOutput
  , writeBuilder
  , writeBS
  , writeLBS
  , writeText
  , writeLazyText
  , sendFile
  , sendFilePartial
  , localRequest
  , withRequest
  , withResponse
  , ipHeaderFilter
  , ipHeaderFilter'
  , bracketSnap
  , NoHandlerException(..)
  , terminateConnection
  , escapeHttp
  , runSnap
  , fixupResponse
  , evalSnap
  , getParamFrom
  , getParam
  , getPostParam
  , getQueryParam
  , getParams
  , getPostParams
  , getQueryParams
  , getCookie
  , readCookie
  , expireCookie
  , setTimeout
  , extendTimeout
  , modifyTimeout
  , getTimeoutModifier
  , module Snap.Internal.Http.Types
  ) where

------------------------------------------------------------------------------
import           Control.Applicative                (Alternative ((<|>), empty), Applicative ((<*>), pure), (<$>))
import           Control.Exception.Lifted           (ErrorCall (..), Exception, Handler (..), SomeException (..), catch, catches, mask, onException, throwIO)
import           Control.Monad                      (Functor (..), Monad (..), MonadPlus (..), ap, liftM, unless, (=<<))
import qualified Control.Monad.Fail                 as Fail
import           Control.Monad.Base                 (MonadBase (..))
import           Control.Monad.IO.Class             (MonadIO (..))
import           Control.Monad.Trans.Control        (MonadBaseControl (..))
import           Control.Monad.Trans.State          (StateT (..))
import           Data.ByteString.Builder            (Builder, byteString, lazyByteString)
import           Data.ByteString.Char8              (ByteString)
import qualified Data.ByteString.Char8              as S (break, concat, drop, dropWhile, intercalate, length, take, takeWhile)
import qualified Data.ByteString.Internal           as S (create)
import qualified Data.ByteString.Lazy.Char8         as L (ByteString, fromChunks)
import           Data.CaseInsensitive               (CI)
import           Data.Maybe                         (Maybe (..), listToMaybe, maybe)
import qualified Data.Text                          as T (Text)
import qualified Data.Text.Encoding as T (encodeUtf8)
import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8)
import qualified Data.Text.Lazy                     as LT (Text)
import           Data.Time                          (Day (ModifiedJulianDay), UTCTime (UTCTime))
#if __GLASGOW_HASKELL__ < 708
import           Data.Typeable                      (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp)
#else
import           Data.Typeable                      (Typeable)
#endif
import           Data.Word                          (Word64, Word8)
import           Foreign.Ptr                        (Ptr, plusPtr)
import           Foreign.Storable                   (poke)
import           Prelude                            (Bool (..), Either (..), Eq (..), FilePath, IO, Int, Num (..), Ord (..), Show (..), String, const, divMod, elem, filter, fromIntegral, id, map, max, otherwise, quot, ($), ($!), (++), (.), (||))
import           System.IO.Streams                  (InputStream, OutputStream)
import qualified System.IO.Streams                  as Streams
import           System.Posix.Types                 (FileOffset)
import           System.PosixCompat.Files           (fileSize, getFileStatus)
#if !MIN_VERSION_bytestring(0,10,6)
import qualified Data.ByteString.Internal           as S (inlinePerformIO)
#else
import qualified Data.ByteString.Internal           as S (accursedUnutterablePerformIO)
#endif
------------------------------------------------------------------------------
import qualified Data.Readable                      as R
import           Snap.Internal.Http.Types           (Cookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (..), Response (..), ResponseBody (..), StreamProc, addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, formatLogTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, normalizeMethod, parseHttpTime, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqSetParam, rspBodyMap, rspBodyToEnum, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus, statusReasonMap)
import           Snap.Internal.Parsing              (urlDecode)
import qualified Snap.Types.Headers                 as H
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes it
-- easy to wrap 'Snap' inside monad transformers.
class (Monad m, MonadIO m, MonadBaseControl IO m, MonadPlus m, Functor m,
       Applicative m, Alternative m) => MonadSnap m where
  -- | Lift a computation from the 'Snap' monad.
  liftSnap :: Snap a -> m a


------------------------------------------------------------------------------
data SnapResult a = SnapValue a
                  | Zero Zero


------------------------------------------------------------------------------
-- | Type of external handler passed to 'escapeHttp'.
type EscapeHttpHandler =  ((Int -> Int) -> IO ())    -- ^ timeout modifier
                       -> InputStream ByteString     -- ^ socket read end
                       -> OutputStream Builder       -- ^ socket write end
                       -> IO ()


------------------------------------------------------------------------------
-- | Used internally to implement 'escapeHttp'.
data EscapeSnap = TerminateConnection SomeException
                | EscapeHttp EscapeHttpHandler
  deriving (Typeable)

instance Exception EscapeSnap

instance Show EscapeSnap where
    show :: EscapeSnap -> String
show (TerminateConnection SomeException
e) = String
"<terminated: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
    show (EscapeHttp EscapeHttpHandler
_)          = String
"<escape http>"


------------------------------------------------------------------------------
data Zero = PassOnProcessing
          | EarlyTermination Response
          | EscapeSnap EscapeSnap

                             --------------------
                             -- The Snap Monad --
                             --------------------
{-|
'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you:

1. Stateful access to fetch or modify an HTTP 'Request'.

    @
    printRqContextPath :: Snap ()
    printRqContextPath = 'writeBS' . 'rqContextPath' =<< 'getRequest'
    @

2. Stateful access to fetch or modify an HTTP 'Response'.

    @
    printRspStatusReason :: Snap ()
    printRspStatusReason = 'writeBS' . 'rspStatusReason' =<< 'getResponse'
    @

3. Failure \/ 'Alternative' \/ 'MonadPlus' semantics: a 'Snap' handler can
choose not to handle a given request, using 'empty' or its synonym 'pass', and
you can try alternative handlers with the '<|>' operator:

    @
    a :: Snap String
    a = 'pass'

    b :: Snap String
    b = return \"foo\"

    c :: Snap String
    c = a '<|>' b             -- try running a, if it fails then try b
    @

4. Convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText',
'addToOutput') for queueing output to be written to the 'Response', or for
streaming to the response using
<http://hackage.haskell.org/package/io-streams io-streams>:

    @
    example :: ('OutputStream' 'Builder' -> IO ('OutputStream' 'Builder')) -> Snap ()
    example streamProc = do
        'writeBS'   \"I\'m a strict bytestring\"
        'writeLBS'  \"I\'m a lazy bytestring\"
        'writeText' \"I\'m strict text\"
        'addToOutput' streamProc
    @

5. Early termination: if you call 'finishWith':

    @
    a :: Snap ()
    a = do
        'modifyResponse' $ 'setResponseStatus' 500 \"Internal Server Error\"
        'writeBS' \"500 error\"
        r <- 'getResponse'
        'finishWith' r
    @

    then any subsequent processing will be skipped and the supplied 'Response'
    value will be returned from 'runSnap' as-is.

6. Access to the 'IO' monad through a 'MonadIO' instance:

    @
    a :: Snap ()
    a = 'liftIO' fireTheMissiles
    @

7. The ability to set or extend a timeout which will kill the handler thread
after @N@ seconds of inactivity (the default is 20 seconds):

    @
    a :: Snap ()
    a = 'setTimeout' 30
    @

8. Throw and catch exceptions using a 'MonadBaseControl' instance:

    @
    import "Control.Exception.Lifted" ('SomeException', 'throwIO', 'catch')

    foo :: Snap ()
    foo = bar \`catch\` \(e::'SomeException') -> baz
      where
        bar = 'throwIO' FooException
    @

9. Log a message to the error log:

    @
    foo :: Snap ()
    foo = 'logError' \"grumble.\"
    @
-}

-- Haddock comment broken in two to work around https://github.com/haskell/haddock/issues/313

-- | You may notice that most of the type signatures in this module contain a
-- @('MonadSnap' m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass
-- which, in essence, says \"you can get back to the 'Snap' monad from
-- here\". Using 'MonadSnap' you can extend the 'Snap' monad with additional
-- functionality and still have access to most of the 'Snap' functions without
-- writing 'Control.Monad.Trans.Class.lift' everywhere. Instances are already
-- provided for most of the common monad transformers
-- ('Control.Monad.Trans.Reader.ReaderT', 'Control.Monad.Trans.Writer.WriterT',
-- 'Control.Monad.Trans.State.StateT', etc.).
newtype Snap a = Snap {
      Snap a
-> forall r.
   (a -> SnapState -> IO r)
   -> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap :: forall r . (a -> SnapState -> IO r)   -- success continuation
             -> (Zero -> SnapState -> IO r)           -- mzero continuation
             -> SnapState                             -- state for the monad
             -> IO r
    }


------------------------------------------------------------------------------
data SnapState = SnapState
    { SnapState -> Request
_snapRequest       :: Request
    , SnapState -> Response
_snapResponse      :: Response
    , SnapState -> ByteString -> IO ()
_snapLogError      :: ByteString -> IO ()
    , SnapState -> (Int -> Int) -> IO ()
_snapModifyTimeout :: (Int -> Int) -> IO ()
    }

-- TODO(greg): error log action and timeout modifier are never modified.
-- Splitting them out into their own datatype would save 16 bytes of allocation
-- every time you modify the request or response, but would gobble a register.
-- Benchmark it both ways.

------------------------------------------------------------------------------
instance Monad Snap where
    >>= :: Snap a -> (a -> Snap b) -> Snap b
(>>=)  = Snap a -> (a -> Snap b) -> Snap b
forall a b. Snap a -> (a -> Snap b) -> Snap b
snapBind
#if !MIN_VERSION_base(4,8,0)
    -- pre-AMP
    return = pure
    {-# INLINE return #-}
#endif
#if !MIN_VERSION_base(4,13,0)
    fail   = Fail.fail
#endif

instance Fail.MonadFail Snap where
    fail :: String -> Snap a
fail   = String -> Snap a
forall a. String -> Snap a
snapFail

------------------------------------------------------------------------------
snapBind :: Snap a -> (a -> Snap b) -> Snap b
snapBind :: Snap a -> (a -> Snap b) -> Snap b
snapBind Snap a
m a -> Snap b
f = (forall r.
 (b -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (b -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap b)
-> (forall r.
    (b -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a b. (a -> b) -> a -> b
$ \b -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st -> Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
   (a -> SnapState -> IO r)
   -> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
m (\a
a SnapState
st' -> Snap b
-> (b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
   (a -> SnapState -> IO r)
   -> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap (a -> Snap b
f a
a) b -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st') Zero -> SnapState -> IO r
fk SnapState
st
{-# INLINE snapBind #-}

snapFail :: String -> Snap a
snapFail :: String -> Snap a
snapFail !String
_ = (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
_ Zero -> SnapState -> IO r
fk SnapState
st -> Zero -> SnapState -> IO r
fk Zero
PassOnProcessing SnapState
st
{-# INLINE snapFail #-}


------------------------------------------------------------------------------
instance MonadIO Snap where
    liftIO :: IO a -> Snap a
liftIO IO a
m = (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
_ SnapState
st -> do a
x <- IO a
m
                                     a -> SnapState -> IO r
sk a
x SnapState
st


------------------------------------------------------------------------------
instance (MonadBase IO) Snap where
    liftBase :: IO α -> Snap α
liftBase = IO α -> Snap α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO


------------------------------------------------------------------------------
newtype StSnap a = StSnap {
      StSnap a -> StM (StateT SnapState IO) (SnapResult a)
unStSnap :: StM (StateT SnapState IO) (SnapResult a)
    }

instance (MonadBaseControl IO) Snap where
    type StM Snap a = StSnap a

    liftBaseWith :: (RunInBase Snap IO -> IO a) -> Snap a
liftBaseWith RunInBase Snap IO -> IO a
f = StateT SnapState IO (SnapResult a) -> Snap a
forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap (StateT SnapState IO (SnapResult a) -> Snap a)
-> StateT SnapState IO (SnapResult a) -> Snap a
forall a b. (a -> b) -> a -> b
$ (a -> SnapResult a)
-> StateT SnapState IO a -> StateT SnapState IO (SnapResult a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> SnapResult a
forall a. a -> SnapResult a
SnapValue (StateT SnapState IO a -> StateT SnapState IO (SnapResult a))
-> StateT SnapState IO a -> StateT SnapState IO (SnapResult a)
forall a b. (a -> b) -> a -> b
$
                     (RunInBase (StateT SnapState IO) IO -> IO a)
-> StateT SnapState IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase (StateT SnapState IO) IO -> IO a)
 -> StateT SnapState IO a)
-> (RunInBase (StateT SnapState IO) IO -> IO a)
-> StateT SnapState IO a
forall a b. (a -> b) -> a -> b
$ \RunInBase (StateT SnapState IO) IO
g' -> RunInBase Snap IO -> IO a
f (RunInBase Snap IO -> IO a) -> RunInBase Snap IO -> IO a
forall a b. (a -> b) -> a -> b
$ \Snap a
m ->
                     ((SnapResult a, SnapState) -> StSnap a)
-> IO (SnapResult a, SnapState) -> IO (StSnap a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SnapResult a, SnapState) -> StSnap a
forall a. StM (StateT SnapState IO) (SnapResult a) -> StSnap a
StSnap (IO (SnapResult a, SnapState) -> IO (StSnap a))
-> IO (SnapResult a, SnapState) -> IO (StSnap a)
forall a b. (a -> b) -> a -> b
$ StateT SnapState IO (SnapResult a)
-> IO (StM (StateT SnapState IO) (SnapResult a))
RunInBase (StateT SnapState IO) IO
g' (StateT SnapState IO (SnapResult a)
 -> IO (StM (StateT SnapState IO) (SnapResult a)))
-> StateT SnapState IO (SnapResult a)
-> IO (StM (StateT SnapState IO) (SnapResult a))
forall a b. (a -> b) -> a -> b
$ Snap a -> StateT SnapState IO (SnapResult a)
forall a. Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT Snap a
m
    {-# INLINE liftBaseWith #-}

    restoreM :: StM Snap a -> Snap a
restoreM = StateT SnapState IO (SnapResult a) -> Snap a
forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap (StateT SnapState IO (SnapResult a) -> Snap a)
-> (StSnap a -> StateT SnapState IO (SnapResult a))
-> StSnap a
-> Snap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapResult a, SnapState) -> StateT SnapState IO (SnapResult a)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM ((SnapResult a, SnapState) -> StateT SnapState IO (SnapResult a))
-> (StSnap a -> (SnapResult a, SnapState))
-> StSnap a
-> StateT SnapState IO (SnapResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StSnap a -> (SnapResult a, SnapState)
forall a. StSnap a -> StM (StateT SnapState IO) (SnapResult a)
unStSnap
    {-# INLINE restoreM #-}

------------------------------------------------------------------------------
snapToStateT :: Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT :: Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT Snap a
m = (SnapState -> IO (SnapResult a, SnapState))
-> StateT SnapState IO (SnapResult a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((SnapState -> IO (SnapResult a, SnapState))
 -> StateT SnapState IO (SnapResult a))
-> (SnapState -> IO (SnapResult a, SnapState))
-> StateT SnapState IO (SnapResult a)
forall a b. (a -> b) -> a -> b
$ \SnapState
st -> do
    Snap a
-> (a -> SnapState -> IO (SnapResult a, SnapState))
-> (Zero -> SnapState -> IO (SnapResult a, SnapState))
-> SnapState
-> IO (SnapResult a, SnapState)
forall a.
Snap a
-> forall r.
   (a -> SnapState -> IO r)
   -> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
m (\a
a SnapState
st' -> (SnapResult a, SnapState) -> IO (SnapResult a, SnapState)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> SnapResult a
forall a. a -> SnapResult a
SnapValue a
a, SnapState
st'))
             (\Zero
z SnapState
st' -> (SnapResult a, SnapState) -> IO (SnapResult a, SnapState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Zero -> SnapResult a
forall a. Zero -> SnapResult a
Zero Zero
z, SnapState
st')) SnapState
st
{-# INLINE snapToStateT #-}


------------------------------------------------------------------------------
{-# INLINE stateTToSnap #-}
stateTToSnap :: StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap :: StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap StateT SnapState IO (SnapResult a)
m = (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st -> do
    (SnapResult a
a, SnapState
st') <- StateT SnapState IO (SnapResult a)
-> SnapState -> IO (SnapResult a, SnapState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT SnapState IO (SnapResult a)
m SnapState
st
    case SnapResult a
a of
      SnapValue a
x -> a -> SnapState -> IO r
sk a
x SnapState
st'
      Zero Zero
z      -> Zero -> SnapState -> IO r
fk Zero
z SnapState
st'


------------------------------------------------------------------------------
instance MonadPlus Snap where
    mzero :: Snap a
mzero = (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
_ Zero -> SnapState -> IO r
fk SnapState
st -> Zero -> SnapState -> IO r
fk Zero
PassOnProcessing SnapState
st

    Snap a
a mplus :: Snap a -> Snap a -> Snap a
`mplus` Snap a
b =
        (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st ->
            let fk' :: Zero -> SnapState -> IO r
fk' Zero
z SnapState
st' = case Zero
z of
                              Zero
PassOnProcessing -> Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
   (a -> SnapState -> IO r)
   -> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
b a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st'
                              Zero
_                -> Zero -> SnapState -> IO r
fk Zero
z SnapState
st'
            in Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
   (a -> SnapState -> IO r)
   -> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
a a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk' SnapState
st


------------------------------------------------------------------------------
instance Functor Snap where
    fmap :: (a -> b) -> Snap a -> Snap b
fmap a -> b
f Snap a
m = (forall r.
 (b -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (b -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap b)
-> (forall r.
    (b -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a b. (a -> b) -> a -> b
$ \b -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st -> Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
   (a -> SnapState -> IO r)
   -> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
m (b -> SnapState -> IO r
sk (b -> SnapState -> IO r) -> (a -> b) -> a -> SnapState -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) Zero -> SnapState -> IO r
fk SnapState
st

------------------------------------------------------------------------------
instance Applicative Snap where
    pure :: a -> Snap a
pure a
x  = (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
_ SnapState
st -> a -> SnapState -> IO r
sk a
x SnapState
st
    <*> :: Snap (a -> b) -> Snap a -> Snap b
(<*>)   = Snap (a -> b) -> Snap a -> Snap b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap


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


------------------------------------------------------------------------------
instance MonadSnap Snap where
    liftSnap :: Snap a -> Snap a
liftSnap = Snap a -> Snap a
forall a. a -> a
id


------------------------------------------------------------------------------
-- | The Typeable instance is here so Snap can be dynamically executed with
-- Hint.
#if __GLASGOW_HASKELL__ < 708
snapTyCon :: TyCon
#if MIN_VERSION_base(4,4,0)
snapTyCon = mkTyCon3 "snap-core" "Snap.Core" "Snap"
#else
snapTyCon = mkTyCon "Snap.Core.Snap"
#endif
{-# NOINLINE snapTyCon #-}

instance Typeable1 Snap where
    typeOf1 _ = mkTyConApp snapTyCon []
#else
deriving instance Typeable Snap
#endif

------------------------------------------------------------------------------
-- | Pass the request body stream to a consuming procedure, returning the
-- result.
--
-- If the consuming procedure you pass in here throws an exception, Snap will
-- attempt to clear the rest of the unread request body (using
-- 'System.IO.Streams.Combinators.skipToEof') before rethrowing the
-- exception. If you used 'terminateConnection', however, Snap will give up and
-- immediately close the socket.
--
-- To prevent slowloris attacks, the connection will be also terminated if the
-- input socket produces data too slowly (500 bytes per second is the default
-- limit).
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> import qualified "Data.ByteString.Lazy" as L
-- ghci> import "Data.Char" (toUpper)
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "System.IO.Streams" as Streams
-- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\"
-- ghci> :{
-- ghci| let f s = do u \<- Streams.map (B8.map toUpper) s
-- ghci|              l \<- Streams.toList u
-- ghci|              return $ L.fromChunks l
-- ghci| :}
-- ghci> T.runHandler r ('runRequestBody' f >>= 'writeLBS')
-- HTTP/1.1 200 OK
-- server: Snap/test
-- date: Thu, 07 Aug 2014 20:48:40 GMT
--
-- SOME TEXT
-- @
runRequestBody :: MonadSnap m =>
                  (InputStream ByteString -> IO a)
               -> m a
runRequestBody :: (InputStream ByteString -> IO a) -> m a
runRequestBody InputStream ByteString -> IO a
proc = do
    IO ()
bumpTimeout <- (((Int -> Int) -> IO ()) -> IO ())
-> m ((Int -> Int) -> IO ()) -> m (IO ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int -> Int) -> IO ()) -> (Int -> Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
5) m ((Int -> Int) -> IO ())
forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
    Request
req         <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    InputStream ByteString
body        <- IO (InputStream ByteString) -> m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString) -> m (InputStream ByteString))
-> IO (InputStream ByteString) -> m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ IO ()
-> Double
-> Int
-> InputStream ByteString
-> IO (InputStream ByteString)
Streams.throwIfTooSlow IO ()
bumpTimeout Double
500 Int
5 (InputStream ByteString -> IO (InputStream ByteString))
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$
                            Request -> InputStream ByteString
rqBody Request
req
    InputStream ByteString -> m a
run InputStream ByteString
body

  where
    skip :: InputStream a -> m ()
skip InputStream a
body = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (InputStream a -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream a
body) m () -> (RateTooSlowException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` RateTooSlowException -> m ()
forall (m :: * -> *) a. MonadSnap m => RateTooSlowException -> m a
tooSlow

    tooSlow :: RateTooSlowException -> m a
tooSlow (RateTooSlowException
e :: Streams.RateTooSlowException) =
        RateTooSlowException -> m a
forall e (m :: * -> *) a. (Exception e, MonadSnap m) => e -> m a
terminateConnection RateTooSlowException
e

    run :: InputStream ByteString -> m a
run InputStream ByteString
body = (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
        a
x <- InputStream ByteString -> IO a
proc InputStream ByteString
body
        InputStream ByteString -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
body
        a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x) m a -> [Handler m a] -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
`catches` [Handler m a]
handlers
      where
        handlers :: [Handler m a]
handlers = [ (RateTooSlowException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler RateTooSlowException -> m a
forall (m :: * -> *) a. MonadSnap m => RateTooSlowException -> m a
tooSlow, (SomeException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler SomeException -> m a
other ]
        other :: SomeException -> m a
other (SomeException
e :: SomeException) = InputStream ByteString -> m ()
forall (m :: * -> *) a. MonadSnap m => InputStream a -> m ()
skip InputStream ByteString
body m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO SomeException
e


------------------------------------------------------------------------------
-- | Returns the request body as a lazy bytestring. /Note that the request is
-- not actually provided lazily!/
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\"
-- ghci> T.runHandler r ('readRequestBody' 2048 >>= 'writeLBS')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 20:08:44 GMT
--
-- some text
-- @
--
-- /Since: 0.6/
readRequestBody :: MonadSnap m =>
                   Word64  -- ^ size of the largest request body we're willing
                           -- to accept. If a request body longer than this is
                           -- received, a 'TooManyBytesReadException' is
                           -- thrown. See 'takeNoMoreThan'.
                -> m L.ByteString
readRequestBody :: Word64 -> m ByteString
readRequestBody Word64
sz = ([ByteString] -> ByteString) -> m [ByteString] -> m ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
L.fromChunks (m [ByteString] -> m ByteString) -> m [ByteString] -> m ByteString
forall a b. (a -> b) -> a -> b
$ (InputStream ByteString -> IO [ByteString]) -> m [ByteString]
forall (m :: * -> *) a.
MonadSnap m =>
(InputStream ByteString -> IO a) -> m a
runRequestBody InputStream ByteString -> IO [ByteString]
f
  where
    f :: InputStream ByteString -> IO [ByteString]
f InputStream ByteString
str = Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) InputStream ByteString
str IO (InputStream ByteString)
-> (InputStream ByteString -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList


------------------------------------------------------------------------------
-- | Normally Snap is careful to ensure that the request body is fully
-- consumed after your web handler runs, but before the 'Response' body
-- is streamed out the socket. If you want to transform the request body into
-- some output in O(1) space, you should use this function.
--
-- Take care: in order for this to work, the HTTP client must be written with
-- input-to-output streaming in mind.
--
-- Note that upon calling this function, response processing finishes early as
-- if you called 'finishWith'. Make sure you set any content types, headers,
-- cookies, etc. before you call this function.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> import "Data.Char" (toUpper)
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "System.IO.Streams" as Streams
-- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\"
-- ghci> let f = Streams.map (B8.map toUpper)
-- ghci> T.runHandler r ('transformRequestBody' f >> 'readRequestBody' 2048 >>= 'writeLBS')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 20:30:15 GMT
--
-- SOME TEXT
-- @
transformRequestBody :: (InputStream ByteString -> IO (InputStream ByteString))
                         -- ^ the 'InputStream' from the 'Request' is passed to
                         -- this function, and then the resulting 'InputStream'
                         -- is fed to the output.
                     -> Snap ()
transformRequestBody :: (InputStream ByteString -> IO (InputStream ByteString)) -> Snap ()
transformRequestBody InputStream ByteString -> IO (InputStream ByteString)
trans = do
    Request
req     <- Snap Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    InputStream Builder
is      <- IO (InputStream Builder) -> Snap (InputStream Builder)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((InputStream ByteString -> IO (InputStream ByteString)
trans (InputStream ByteString -> IO (InputStream ByteString))
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
req) IO (InputStream ByteString)
-> (InputStream ByteString -> IO (InputStream Builder))
-> IO (InputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         (ByteString -> IO Builder)
-> InputStream ByteString -> IO (InputStream Builder)
forall a b. (a -> IO b) -> InputStream a -> IO (InputStream b)
Streams.mapM (Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> IO Builder)
-> (ByteString -> Builder) -> ByteString -> IO Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString))
    Response
origRsp <- Snap Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse
    let rsp :: Response
rsp = (OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
setResponseBody (\OutputStream Builder
out -> InputStream Builder -> OutputStream Builder -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream Builder
is OutputStream Builder
out IO () -> IO (OutputStream Builder) -> IO (OutputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
out) (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
              Response
origRsp { rspTransformingRqBody :: Bool
rspTransformingRqBody = Bool
True }
    Response -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith Response
rsp


------------------------------------------------------------------------------
-- | Short-circuits a 'Snap' monad action early, storing the given
-- 'Response' value in its state.
--
-- IMPORTANT: Be vary careful when using this with things like a DB library's
-- `withTransaction` function or any other kind of setup/teardown block, as it
-- can prevent the cleanup from being called and result in resource leaks.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import "Control.Applicative"
-- ghci> let r = T.get \"\/\" M.empty
-- ghci> T.runHandler r (('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 16:58:57 GMT
--
-- TOP
-- ghci> let r\' = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r\' (('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 17:50:50 GMT
--
--
-- @
finishWith :: MonadSnap m => Response -> m a
finishWith :: Response -> m a
finishWith Response
r = Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
_ Zero -> SnapState -> IO r
fk SnapState
st -> Zero -> SnapState -> IO r
fk (Response -> Zero
EarlyTermination Response
r) SnapState
st
{-# INLINE finishWith #-}


------------------------------------------------------------------------------
-- | Capture the flow of control in case a handler calls 'finishWith'.
--
-- /WARNING/: in the event of a call to 'transformRequestBody' it is possible
-- to violate HTTP protocol safety when using this function. If you call
-- 'catchFinishWith' it is suggested that you do not modify the body of the
-- 'Response' which was passed to the 'finishWith' call.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import "Control.Applicative"
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> let h = ('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse'
-- ghci> T.runHandler r ('catchFinishWith' h >>= 'writeBS' . B8.pack . show)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 18:35:42 GMT
--
-- Left HTTP\/1.1 200 OK
--
--
-- @
catchFinishWith :: Snap a -> Snap (Either Response a)
catchFinishWith :: Snap a -> Snap (Either Response a)
catchFinishWith (Snap forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m) = (forall r.
 (Either Response a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap (Either Response a)
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (Either Response a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap (Either Response a))
-> (forall r.
    (Either Response a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap (Either Response a)
forall a b. (a -> b) -> a -> b
$ \Either Response a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st -> do
    let sk' :: a -> SnapState -> IO r
sk' a
v SnapState
s = Either Response a -> SnapState -> IO r
sk (a -> Either Response a
forall a b. b -> Either a b
Right a
v) SnapState
s
    let fk' :: Zero -> SnapState -> IO r
fk' Zero
z SnapState
s = case Zero
z of
                    (EarlyTermination Response
resp) -> Either Response a -> SnapState -> IO r
sk (Response -> Either Response a
forall a b. a -> Either a b
Left Response
resp) SnapState
s
                    Zero
_                       -> Zero -> SnapState -> IO r
fk Zero
z SnapState
s
    (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m a -> SnapState -> IO r
sk' Zero -> SnapState -> IO r
fk' SnapState
st
{-# INLINE catchFinishWith #-}


------------------------------------------------------------------------------
-- | Fails out of a 'Snap' monad action.  This is used to indicate
-- that you choose not to handle the given request within the given
-- handler.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r 'pass'
-- HTTP\/1.1 404 Not Found
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 13:35:42 GMT
--
-- \<!DOCTYPE html>
-- \<html>
-- \<head>
-- \<title>Not found\<\/title>
-- \<\/head>
-- \<body>
-- \<code>No handler accepted \"\/foo\/bar\"<\/code>
-- \<\/body>\<\/html>
-- @
pass :: MonadSnap m => m a
pass :: m a
pass = m a
forall (f :: * -> *) a. Alternative f => f a
empty


------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only if the request's HTTP method matches
-- the given method.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('method' 'GET' $ 'writeBS' \"OK\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 13:38:48 GMT
--
-- OK
-- ghci> T.runHandler r ('method' 'POST' $ 'writeBS' \"OK\")
-- HTTP\/1.1 404 Not Found
-- ...
-- @
method :: MonadSnap m => Method -> m a -> m a
method :: Method -> m a -> m a
method Method
m m a
action = do
    Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request -> Method
rqMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
m) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
    m a
action
{-# INLINE method #-}


------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only if the request's HTTP method matches
-- one of the given methods.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('methods' ['GET', 'POST'] $ 'writeBS' \"OK\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 13:38:48 GMT
--
-- OK
-- ghci> T.runHandler r ('methods' ['POST'] $ 'writeBS' \"OK\")
-- HTTP\/1.1 404 Not Found
-- ...
-- @
methods :: MonadSnap m => [Method] -> m a -> m a
methods :: [Method] -> m a -> m a
methods [Method]
ms m a
action = do
    Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request -> Method
rqMethod Request
req Method -> [Method] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Method]
ms) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
    m a
action
{-# INLINE methods #-}


------------------------------------------------------------------------------
-- Appends n bytes of the path info to the context path with a
-- trailing slash.
updateContextPath :: Int -> Request -> Request
updateContextPath :: Int -> Request -> Request
updateContextPath Int
n Request
req | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     = Request
req { rqContextPath :: ByteString
rqContextPath = ByteString
ctx
                                          , rqPathInfo :: ByteString
rqPathInfo    = ByteString
pinfo }
                        | Bool
otherwise = Request
req
  where
    ctx' :: ByteString
ctx'  = Int -> ByteString -> ByteString
S.take Int
n (Request -> ByteString
rqPathInfo Request
req)
    ctx :: ByteString
ctx   = [ByteString] -> ByteString
S.concat [Request -> ByteString
rqContextPath Request
req, ByteString
ctx', ByteString
"/"]
    pinfo :: ByteString
pinfo = Int -> ByteString -> ByteString
S.drop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Request -> ByteString
rqPathInfo Request
req)


------------------------------------------------------------------------------
-- Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given
-- predicate.
pathWith :: MonadSnap m
         => (ByteString -> ByteString -> Bool)
         -> ByteString
         -> m a
         -> m a
pathWith :: (ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith ByteString -> ByteString -> Bool
c ByteString
p m a
action = do
    Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> ByteString -> Bool
c ByteString
p (Request -> ByteString
rqPathInfo Request
req)) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
    (Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath (Int -> Request -> Request) -> Int -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
p) m a
action


------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request
-- starts with the given path. For example,
--
-- > dir "foo" handler
--
-- Will fail if 'rqPathInfo' is not \"@\/foo@\" or \"@\/foo\/...@\", and will
-- add @\"foo\/\"@ to the handler's local 'rqContextPath'.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('dir' \"foo\" $ 'writeBS' \"OK\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 14:52:24 GMT
--
-- OK
-- ghci> T.runHandler r ('dir' \"baz\" $ 'writeBS' \"OK\")
-- HTTP\/1.1 404 Not Found
-- ...
-- @
dir :: MonadSnap m
    => ByteString  -- ^ path component to match
    -> m a         -- ^ handler to run
    -> m a
dir :: ByteString -> m a -> m a
dir = (ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
forall (m :: * -> *) a.
MonadSnap m =>
(ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith ByteString -> ByteString -> Bool
f
  where
    f :: ByteString -> ByteString -> Bool
f ByteString
dr ByteString
pinfo = ByteString
dr ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
x
      where
        (ByteString
x,ByteString
_) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') ByteString
pinfo
{-# INLINE dir #-}


------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is
-- exactly equal to the given string. If the path matches, locally sets
-- 'rqContextPath' to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\",
-- and runs the given handler.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> T.runHandler (T.get \"\/foo\" M.empty) ('path' \"foo\" $ 'writeBS' \"bar\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 14:15:42 GMT
--
-- bar
-- ghci> T.runHandler (T.get \"\/foo\" M.empty) ('path' \"bar\" $ 'writeBS' \"baz\")
-- HTTP\/1.1 404 Not Found
-- ...
-- @
path :: MonadSnap m
     => ByteString  -- ^ path to match against
     -> m a         -- ^ handler to run
     -> m a
path :: ByteString -> m a -> m a
path = (ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
forall (m :: * -> *) a.
MonadSnap m =>
(ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==)
{-# INLINE path #-}


------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only when the first path component is
-- successfully parsed as the argument to the supplied handler function.
--
-- Note that the path segment is url-decoded prior to being passed to 'fromBS';
-- this is new as of snap-core 0.10.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/11\/foo\/bar\" M.empty
-- ghci> let f = (\\i -> if i == 11 then 'writeBS' \"11\" else 'writeBS' \"???\")
-- ghci> T.runHandler r ('pathArg' f)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 14:27:10 GMT
--
-- 11
-- ghci> let r\' = T.get \"\/foo\/11\/bar\" M.empty
-- ghci> T.runHandler r\' ('pathArg' f)
-- HTTP\/1.1 404 Not Found
-- ...
-- @
pathArg :: (R.Readable a, MonadSnap m)
        => (a -> m b)
        -> m b
pathArg :: (a -> m b) -> m b
pathArg a -> m b
f = do
    Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    let (ByteString
p,ByteString
_) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') (Request -> ByteString
rqPathInfo Request
req)
    ByteString
p' <- m ByteString
-> (ByteString -> m ByteString) -> Maybe ByteString -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ByteString
forall (m :: * -> *) a. MonadPlus m => m a
mzero ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m ByteString)
-> Maybe ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
urlDecode ByteString
p
    a
a <- ByteString -> m a
forall a (m :: * -> *).
(Readable a, MonadPlus m) =>
ByteString -> m a
R.fromBS ByteString
p'
    (Request -> Request) -> m b -> m b
forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath (Int -> Request -> Request) -> Int -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
p) (a -> m b
f a
a)


------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/\" M.empty
-- ghci> T.runHandler r ('ifTop' $ 'writeBS' "OK")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 14:56:39 GMT
--
-- OK
-- ghci> let r\' = T.get \"\/foo\" M.empty
-- ghci> T.runHandler r\' ('ifTop' $ 'writeBS' \"OK\")
-- HTTP\/1.1 404 Not Found
-- ...
-- @
ifTop :: MonadSnap m => m a -> m a
ifTop :: m a -> m a
ifTop = ByteString -> m a -> m a
forall (m :: * -> *) a. MonadSnap m => ByteString -> m a -> m a
path ByteString
""
{-# INLINE ifTop #-}


------------------------------------------------------------------------------
-- | Local Snap version of 'get'.
sget :: Snap SnapState
sget :: Snap SnapState
sget = (forall r.
 (SnapState -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap SnapState
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (SnapState -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap SnapState)
-> (forall r.
    (SnapState -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap SnapState
forall a b. (a -> b) -> a -> b
$ \SnapState -> SnapState -> IO r
sk Zero -> SnapState -> IO r
_ SnapState
st -> SnapState -> SnapState -> IO r
sk SnapState
st SnapState
st
{-# INLINE sget #-}


------------------------------------------------------------------------------
-- | Local Snap monad version of 'modify'.
smodify :: (SnapState -> SnapState) -> Snap ()
smodify :: (SnapState -> SnapState) -> Snap ()
smodify SnapState -> SnapState
f = (forall r.
 (() -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (() -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap ())
-> (forall r.
    (() -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a b. (a -> b) -> a -> b
$ \() -> SnapState -> IO r
sk Zero -> SnapState -> IO r
_ SnapState
st -> () -> SnapState -> IO r
sk () (SnapState -> SnapState
f SnapState
st)
{-# INLINE smodify #-}


------------------------------------------------------------------------------
-- | Grabs the 'Request' object out of the 'Snap' monad.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeBS' . 'rqURI' =\<\< 'getRequest')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Sat, 02 Aug 2014 07:51:54 GMT
--
-- \/foo\/bar
-- @
getRequest :: MonadSnap m => m Request
getRequest :: m Request
getRequest = Snap Request -> m Request
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap Request -> m Request) -> Snap Request -> m Request
forall a b. (a -> b) -> a -> b
$ (SnapState -> Request) -> Snap SnapState -> Snap Request
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SnapState -> Request
_snapRequest Snap SnapState
sget
{-# INLINE getRequest #-}


------------------------------------------------------------------------------
-- | Grabs something out of the 'Request' object, using the given projection
-- function. See 'gets'.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeBS' =\<\< 'getsRequest' 'rqURI')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Sat, 02 Aug 2014 07:51:54 GMT
--
-- \/foo\/bar
-- @
getsRequest :: MonadSnap m => (Request -> a) -> m a
getsRequest :: (Request -> a) -> m a
getsRequest Request -> a
f = Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (SnapState -> a) -> Snap SnapState -> Snap a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Request -> a
f (Request -> a) -> (SnapState -> Request) -> SnapState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapState -> Request
_snapRequest) Snap SnapState
sget
{-# INLINE getsRequest #-}


------------------------------------------------------------------------------
-- | Grabs the 'Response' object out of the 'Snap' monad.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeBS' . 'rspStatusReason' =\<\< 'getResponse')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Sat, 02 Aug 2014 15:06:00 GMT
--
-- OK
-- @
getResponse :: MonadSnap m => m Response
getResponse :: m Response
getResponse = Snap Response -> m Response
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap Response -> m Response) -> Snap Response -> m Response
forall a b. (a -> b) -> a -> b
$ (SnapState -> Response) -> Snap SnapState -> Snap Response
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SnapState -> Response
_snapResponse Snap SnapState
sget
{-# INLINE getResponse #-}


------------------------------------------------------------------------------
-- | Grabs something out of the 'Response' object, using the given projection
-- function. See 'gets'.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeBS' =\<\< 'getsResponse' 'rspStatusReason')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 13:35:45 GMT
--
-- OK
-- @
getsResponse :: MonadSnap m => (Response -> a) -> m a
getsResponse :: (Response -> a) -> m a
getsResponse Response -> a
f = Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (SnapState -> a) -> Snap SnapState -> Snap a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Response -> a
f (Response -> a) -> (SnapState -> Response) -> SnapState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapState -> Response
_snapResponse) Snap SnapState
sget
{-# INLINE getsResponse #-}


------------------------------------------------------------------------------
-- | Puts a new 'Response' object into the 'Snap' monad.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let rsp = 'setResponseCode' 404 'emptyResponse'
-- ghci> let req = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler req ('putResponse' rsp)
-- HTTP\/1.1 404 Not Found
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 13:59:58 GMT
--
--
-- @
putResponse :: MonadSnap m => Response -> m ()
putResponse :: Response -> m ()
putResponse Response
r = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \SnapState
ss -> SnapState
ss { _snapResponse :: Response
_snapResponse = Response
r }
{-# INLINE putResponse #-}


------------------------------------------------------------------------------
-- | Puts a new 'Request' object into the 'Snap' monad.
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> :{
-- ghci| let hndlr = do rq \<- T.buildRequest (T.get \"\/bar\/foo\" M.empty)
-- ghci|                'putRequest' rq
-- ghci|                uri\' \<- 'getsRequest' 'rqURI'
-- ghci|                'writeBS' uri\'
-- ghci| :}
-- ghci> T.runHandler (T.get \"\/foo\/bar\" M.empty) hndlr
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 15:13:46 GMT
--
-- \/bar\/foo
-- @
putRequest :: MonadSnap m => Request -> m ()
putRequest :: Request -> m ()
putRequest Request
r = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \SnapState
ss -> SnapState
ss { _snapRequest :: Request
_snapRequest = Request
r }
{-# INLINE putRequest #-}


------------------------------------------------------------------------------
-- | Modifies the 'Request' object stored in a 'Snap' monad.
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> r\' \<- T.buildRequest $ T.get \"\/bar\/foo\" M.empty
-- ghci> T.runHandler r ('modifyRequest' (const r\') >> 'getsRequest' 'rqURI' >>= 'writeBS')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 15:24:25 GMT
--
-- \/bar\/foo
-- @
modifyRequest :: MonadSnap m => (Request -> Request) -> m ()
modifyRequest :: (Request -> Request) -> m ()
modifyRequest Request -> Request
f = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$
    (SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \SnapState
ss -> SnapState
ss { _snapRequest :: Request
_snapRequest = Request -> Request
f (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ SnapState -> Request
_snapRequest SnapState
ss }
{-# INLINE modifyRequest #-}


------------------------------------------------------------------------------
-- | Modifes the 'Response' object stored in a 'Snap' monad.
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('modifyResponse' $ 'setResponseCode' 404)
-- HTTP\/1.1 404 Not Found
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 15:27:11 GMT
--
--
-- @
modifyResponse :: MonadSnap m => (Response -> Response) -> m ()
modifyResponse :: (Response -> Response) -> m ()
modifyResponse Response -> Response
f = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$
     (SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \SnapState
ss -> SnapState
ss { _snapResponse :: Response
_snapResponse = Response -> Response
f (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ SnapState -> Response
_snapResponse SnapState
ss }
{-# INLINE modifyResponse #-}


------------------------------------------------------------------------------
-- | Performs a redirect by setting the @Location@ header to the given target
-- URL/path and the status code to 302 in the 'Response' object stored in a
-- 'Snap' monad. Note that the target URL is not validated in any way.
-- Consider using 'redirect'' instead, which allows you to choose the correct
-- status code.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('redirect' \"http:\/\/snapframework.com\")
-- HTTP\/1.1 302 Found
-- content-length: 0
-- location: http:\/\/snapframework.com
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 08:52:11 GMT
-- Content-Length: 0
--
--
-- @
redirect :: MonadSnap m => ByteString -> m a
redirect :: ByteString -> m a
redirect ByteString
target = ByteString -> Int -> m a
forall (m :: * -> *) a. MonadSnap m => ByteString -> Int -> m a
redirect' ByteString
target Int
302
{-# INLINE redirect #-}


------------------------------------------------------------------------------
-- | Performs a redirect by setting the @Location@ header to the given target
-- URL/path and the status code (should be one of 301, 302, 303 or 307) in the
-- 'Response' object stored in a 'Snap' monad. Note that the target URL is not
-- validated in any way.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('redirect'' \"http:\/\/snapframework.com\" 301)
-- HTTP\/1.1 307 Temporary Redirect
-- content-length: 0
-- location: http:\/\/snapframework.com
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 08:55:51 GMT
-- Content-Length: 0
--
--
-- @
redirect' :: MonadSnap m => ByteString -> Int -> m a
redirect' :: ByteString -> Int -> m a
redirect' ByteString
target Int
status = do
    Response
r <- m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse

    Response -> m a
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith
        (Response -> m a) -> Response -> m a
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
setResponseCode Int
status
        (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Word64 -> Response -> Response
setContentLength Word64
0
        (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ ((OutputStream Builder -> IO (OutputStream Builder))
 -> OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
modifyResponseBody ((OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder
-> IO (OutputStream Builder)
forall a b. a -> b -> a
const ((OutputStream Builder -> IO (OutputStream Builder))
 -> (OutputStream Builder -> IO (OutputStream Builder))
 -> OutputStream Builder
 -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder
-> IO (OutputStream Builder)
forall a b. (a -> b) -> a -> b
$ OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> OutputStream Builder)
-> OutputStream Builder
-> IO (OutputStream Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputStream Builder -> OutputStream Builder
forall a. a -> a
id)
        (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Location" ByteString
target Response
r

{-# INLINE redirect' #-}


------------------------------------------------------------------------------
-- | Log an error message in the 'Snap' monad.
--
-- Example:
--
-- @
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> 'runSnap' ('logError' \"fatal error!\") ('error' . B8.unpack) undefined undefined
-- *** Exception: fatal error!
-- @
logError :: MonadSnap m => ByteString -> m ()
logError :: ByteString -> m ()
logError ByteString
s = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (forall r.
 (() -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (() -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap ())
-> (forall r.
    (() -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a b. (a -> b) -> a -> b
$ \() -> SnapState -> IO r
sk Zero -> SnapState -> IO r
_ SnapState
st -> do
    SnapState -> ByteString -> IO ()
_snapLogError SnapState
st ByteString
s
    () -> SnapState -> IO r
sk () SnapState
st
{-# INLINE logError #-}


------------------------------------------------------------------------------
-- | Run the given stream procedure, adding its output to the 'Response' stored
-- in the 'Snap' monad state.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Builder" as B
-- ghci> import qualified "System.IO.Streams" as Streams
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> :{
-- ghci| let f str = do {
-- ghci|   Streams.write (Just $ B.byteString \"Hello, streams world\") str;
-- ghci|   return str }
-- ghci| :}
-- ghci> T.runHandler r ('addToOutput' f)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:55:47 GMT
--
-- Hello, streams world
-- @
addToOutput :: MonadSnap m
            => (OutputStream Builder -> IO (OutputStream Builder))
                    -- ^ output to add
            -> m ()
addToOutput :: (OutputStream Builder -> IO (OutputStream Builder)) -> m ()
addToOutput OutputStream Builder -> IO (OutputStream Builder)
enum = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ ((OutputStream Builder -> IO (OutputStream Builder))
 -> OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
modifyResponseBody ((OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder
-> IO (OutputStream Builder)
forall (m :: * -> *) a b t.
Monad m =>
(a -> m b) -> (t -> m a) -> t -> m b
c OutputStream Builder -> IO (OutputStream Builder)
enum)
  where
    c :: (a -> m b) -> (t -> m a) -> t -> m b
c a -> m b
a t -> m a
b = \t
out -> t -> m a
b t
out m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
a

------------------------------------------------------------------------------
-- | Adds the given 'Builder' to the body of the 'Response' stored in the
-- | 'Snap' monad state.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Builder" as B
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeBuilder' $ B.byteString \"Hello, world\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:33:33 GMT
--
-- Hello, world
-- @
writeBuilder :: MonadSnap m => Builder -> m ()
writeBuilder :: Builder -> m ()
writeBuilder Builder
b = (OutputStream Builder -> IO (OutputStream Builder)) -> m ()
forall (m :: * -> *).
MonadSnap m =>
(OutputStream Builder -> IO (OutputStream Builder)) -> m ()
addToOutput OutputStream Builder -> IO (OutputStream Builder)
f
  where
    f :: OutputStream Builder -> IO (OutputStream Builder)
f OutputStream Builder
str = Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
str IO () -> IO (OutputStream Builder) -> IO (OutputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
str
{-# INLINE writeBuilder #-}


------------------------------------------------------------------------------
-- | Adds the given strict 'ByteString' to the body of the 'Response' stored
-- in the 'Snap' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeBS' \"Hello, bytestring world\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:34:27 GMT
--
-- Hello, bytestring world
-- @
writeBS :: MonadSnap m => ByteString -> m ()
writeBS :: ByteString -> m ()
writeBS = Builder -> m ()
forall (m :: * -> *). MonadSnap m => Builder -> m ()
writeBuilder (Builder -> m ()) -> (ByteString -> Builder) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString
{-# INLINE writeBS #-}


------------------------------------------------------------------------------
-- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored
-- in the 'Snap' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeLBS' \"Hello, lazy bytestring world\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:35:15 GMT
--
-- Hello, lazy bytestring world
-- @
writeLBS :: MonadSnap m => L.ByteString -> m ()
writeLBS :: ByteString -> m ()
writeLBS = Builder -> m ()
forall (m :: * -> *). MonadSnap m => Builder -> m ()
writeBuilder (Builder -> m ()) -> (ByteString -> Builder) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
lazyByteString
{-# INLINE writeLBS #-}


------------------------------------------------------------------------------
-- | Adds the given strict 'T.Text' to the body of the 'Response' stored in
-- the 'Snap' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeText' \"Hello, text world\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:36:38 GMT
--
-- Hello, text world
-- @
writeText :: MonadSnap m => T.Text -> m ()
writeText :: Text -> m ()
writeText = ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS (ByteString -> m ()) -> (Text -> ByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
  -- it's inefficient, but we don't have bytestring builder text functions for
  -- 0.9-era bytestring
{-# INLINE writeText #-}


------------------------------------------------------------------------------
-- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the
-- 'Snap' monad state.
--
-- Warning: This function is intentionally non-strict. If any pure
-- exceptions are raised by the expression creating the 'ByteString',
-- the exception won't actually be raised within the Snap handler.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('writeLazyText' \"Hello, lazy text world\")
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:37:41 GMT
--
-- Hello, lazy text world
-- @
writeLazyText :: MonadSnap m => LT.Text -> m ()
writeLazyText :: Text -> m ()
writeLazyText = ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS (ByteString -> m ()) -> (Text -> ByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
LT.encodeUtf8
{-# INLINE writeLazyText #-}


------------------------------------------------------------------------------
-- | Sets the output to be the contents of the specified file.
--
-- Calling 'sendFile' will overwrite any output queued to be sent in the
-- 'Response'. If the response body is not modified after the call to
-- 'sendFile', Snap will use the efficient @sendfile()@ system call on
-- platforms that support it.
--
-- If the response body is modified (using 'modifyResponseBody'), the file
-- will be read using @mmap()@.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> 'writeFile' \"\/tmp\/snap-file\" \"Hello, sendFile world\"
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('sendFile' \"\/tmp\/snap-file\")
-- HTTP\/1.1 200 OK
-- content-length: 21
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:45:10 GMT
-- Content-Length: 21
--
-- Hello, sendFile world
-- @
sendFile :: (MonadSnap m) => FilePath -> m ()
sendFile :: String -> m ()
sendFile String
f = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \Response
r -> Response
r { rspBody :: ResponseBody
rspBody = String -> Maybe (Word64, Word64) -> ResponseBody
SendFile String
f Maybe (Word64, Word64)
forall a. Maybe a
Nothing }


------------------------------------------------------------------------------
-- | Sets the output to be the contents of the specified file, within the
-- given (start,end) range.
--
-- Calling 'sendFilePartial' will overwrite any output queued to be sent in
-- the 'Response'. If the response body is not modified after the call to
-- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on
-- platforms that support it.
--
-- If the response body is modified (using 'modifyResponseBody'), the file
-- will be read using @mmap()@.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> 'writeFile' \"\/tmp\/snap-file\" \"Hello, sendFilePartial world\"
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('sendFilePartial' \"\/tmp\/snap-file\" (7, 28))
-- HTTP\/1.1 200 OK
-- content-length: 21
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 17:47:20 GMT
-- Content-Length: 21
--
-- sendFilePartial world
-- @
sendFilePartial :: (MonadSnap m) => FilePath -> (Word64, Word64) -> m ()
sendFilePartial :: String -> (Word64, Word64) -> m ()
sendFilePartial String
f (Word64, Word64)
rng = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \Response
r ->
                        Response
r { rspBody :: ResponseBody
rspBody = String -> Maybe (Word64, Word64) -> ResponseBody
SendFile String
f ((Word64, Word64) -> Maybe (Word64, Word64)
forall a. a -> Maybe a
Just (Word64, Word64)
rng) }


------------------------------------------------------------------------------
-- | Runs a 'Snap' action with a locally-modified 'Request' state
-- object. The 'Request' object in the Snap monad state after the call
-- to localRequest will be unchanged.
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> r\' \<- T.buildRequest $ T.get \"\/bar\/foo\" M.empty
-- ghci> let printRqURI = 'getsRequest' 'rqURI' >>= 'writeBS' >> 'writeBS' \"\\n\"
-- ghci> T.runHandler r (printRqURI >> 'localRequest' (const r\') printRqURI)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 15:34:12 GMT
--
-- \/foo\/bar
-- \/bar\/foo
--
-- @
localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a
localRequest :: (Request -> Request) -> m a -> m a
localRequest Request -> Request
f m a
m = do
    Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest

    Request -> m a
runAct Request
req m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Request -> m ()
forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest Request
req m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
forall (m :: * -> *) a. MonadSnap m => m a
pass)

  where
    runAct :: Request -> m a
runAct Request
req = do
        (Request -> Request) -> m ()
forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest Request -> Request
f
        a
result <- m a
m
        Request -> m ()
forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest Request
req
        a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
{-# INLINE localRequest #-}


------------------------------------------------------------------------------
-- | Fetches the 'Request' from state and hands it to the given action.
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import "Control.Monad.IO.Class"
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> let h = 'withRequest' (\\rq -> 'liftIO' (T.requestToString rq) >>= 'writeBS')
-- ghci> T.runHandler r h
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 15:44:24 GMT
--
-- GET \/foo\/bar HTTP\/1.1
-- host: localhost
--
--
-- @
withRequest :: MonadSnap m => (Request -> m a) -> m a
withRequest :: (Request -> m a) -> m a
withRequest = (m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
{-# INLINE withRequest #-}


------------------------------------------------------------------------------
-- | Fetches the 'Response' from state and hands it to the given action.
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r ('withResponse' $ 'writeBS' . 'rspStatusReason')
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Wed, 06 Aug 2014 15:48:45 GMT
--
-- OK
-- @
withResponse :: MonadSnap m => (Response -> m a) -> m a
withResponse :: (Response -> m a) -> m a
withResponse = (m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse m Response -> (Response -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
{-# INLINE withResponse #-}


------------------------------------------------------------------------------
-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'
-- field to the value in the X-Forwarded-For header. If the header is
-- not present, this action has no effect.
--
-- This action should be used only when working behind a reverse http
-- proxy that sets the X-Forwarded-For header. This is the only way to
-- ensure the value in the X-Forwarded-For header can be trusted.
--
-- This is provided as a filter so actions that require the remote
-- address can get it in a uniform manner. It has specifically limited
-- functionality to ensure that its transformation can be trusted,
-- when used correctly.
ipHeaderFilter :: MonadSnap m => m ()
ipHeaderFilter :: m ()
ipHeaderFilter = CI ByteString -> m ()
forall (m :: * -> *). MonadSnap m => CI ByteString -> m ()
ipHeaderFilter' CI ByteString
"x-forwarded-for"


------------------------------------------------------------------------------
-- | Modifies the 'Request' in the state to set the 'rqRemoteAddr'
-- field to the value from the header specified.  If the header
-- specified is not present, this action has no effect.
--
-- This action should be used only when working behind a reverse http
-- proxy that sets the header being looked at. This is the only way to
-- ensure the value in the header can be trusted.
--
-- This is provided as a filter so actions that require the remote
-- address can get it in a uniform manner. It has specifically limited
-- functionality to ensure that its transformation can be trusted,
-- when used correctly.
ipHeaderFilter' :: MonadSnap m => CI ByteString -> m ()
ipHeaderFilter' :: CI ByteString -> m ()
ipHeaderFilter' CI ByteString
header = do
    Maybe ByteString
headerContents <- CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
header (Request -> Maybe ByteString) -> m Request -> m (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest

    let whitespace :: String
whitespace = [ Char
' ', Char
'\t', Char
'\r', Char
'\n' ]
        ipChrs :: String
ipChrs = Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: String
"0123456789"
        trim :: ((a -> Bool) -> t) -> t a -> t
trim (a -> Bool) -> t
f t a
s = (a -> Bool) -> t
f (a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
s)

        clean :: ByteString -> ByteString
clean = ((Char -> Bool) -> ByteString -> ByteString)
-> String -> ByteString -> ByteString
forall (t :: * -> *) a t.
(Foldable t, Eq a) =>
((a -> Bool) -> t) -> t a -> t
trim (Char -> Bool) -> ByteString -> ByteString
S.takeWhile String
ipChrs (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Bool) -> ByteString -> ByteString)
-> String -> ByteString -> ByteString
forall (t :: * -> *) a t.
(Foldable t, Eq a) =>
((a -> Bool) -> t) -> t a -> t
trim (Char -> Bool) -> ByteString -> ByteString
S.dropWhile String
whitespace
        setIP :: ByteString -> m ()
setIP ByteString
ip = (Request -> Request) -> m ()
forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest ((Request -> Request) -> m ()) -> (Request -> Request) -> m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqClientAddr :: ByteString
rqClientAddr = ByteString -> ByteString
clean ByteString
ip }
    m () -> (ByteString -> m ()) -> Maybe ByteString -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()) ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
setIP Maybe ByteString
headerContents


------------------------------------------------------------------------------
-- | This function brackets a Snap action in resource acquisition and
-- release. This is provided because MonadCatchIO's 'bracket' function
-- doesn't work properly in the case of a short-circuit return from
-- the action being bracketed.
--
-- In order to prevent confusion regarding the effects of the
-- aquisition and release actions on the Snap state, this function
-- doesn't accept Snap actions for the acquire or release actions.
--
-- This function will run the release action in all cases where the
-- acquire action succeeded.  This includes the following behaviors
-- from the bracketed Snap action.
--
-- 1. Normal completion
--
-- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'
--
-- 3. An exception being thrown.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let br = 'bracketSnap' (putStrLn \"before\") (const $ putStrLn \"after\")
-- ghci> T.runHandler (T.get \"/\" M.empty) (br $ const $ writeBS \"OK\")
-- before
-- after
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Thu, 07 Aug 2014 18:41:50 GMT
--
-- OK
-- @
bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c
bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c
bracketSnap IO a
before a -> IO b
after a -> Snap c
thing = ((forall a. Snap a -> Snap a) -> Snap c) -> Snap c
forall (m :: * -> *) b.
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. Snap a -> Snap a) -> Snap c) -> Snap c)
-> ((forall a. Snap a -> Snap a) -> Snap c) -> Snap c
forall a b. (a -> b) -> a -> b
$ \forall a. Snap a -> Snap a
restore ->
                                 StateT SnapState IO (SnapResult c) -> Snap c
forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap (StateT SnapState IO (SnapResult c) -> Snap c)
-> StateT SnapState IO (SnapResult c) -> Snap c
forall a b. (a -> b) -> a -> b
$ do
    a
a <- IO a -> StateT SnapState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
before
    let after' :: StateT SnapState IO b
after' = IO b -> StateT SnapState IO b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> StateT SnapState IO b) -> IO b -> StateT SnapState IO b
forall a b. (a -> b) -> a -> b
$ a -> IO b
after a
a
    SnapResult c
r <- Snap c -> StateT SnapState IO (SnapResult c)
forall a. Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT (Snap c -> Snap c
forall a. Snap a -> Snap a
restore (Snap c -> Snap c) -> Snap c -> Snap c
forall a b. (a -> b) -> a -> b
$ a -> Snap c
thing a
a) StateT SnapState IO (SnapResult c)
-> StateT SnapState IO b -> StateT SnapState IO (SnapResult c)
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`onException` StateT SnapState IO b
after'
    b
_ <- StateT SnapState IO b
after'
    SnapResult c -> StateT SnapState IO (SnapResult c)
forall (m :: * -> *) a. Monad m => a -> m a
return SnapResult c
r


------------------------------------------------------------------------------
-- | This exception is thrown if the handler you supply to 'runSnap' fails.
data NoHandlerException = NoHandlerException String
   deriving (NoHandlerException -> NoHandlerException -> Bool
(NoHandlerException -> NoHandlerException -> Bool)
-> (NoHandlerException -> NoHandlerException -> Bool)
-> Eq NoHandlerException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoHandlerException -> NoHandlerException -> Bool
$c/= :: NoHandlerException -> NoHandlerException -> Bool
== :: NoHandlerException -> NoHandlerException -> Bool
$c== :: NoHandlerException -> NoHandlerException -> Bool
Eq, Typeable)


------------------------------------------------------------------------------
instance Show NoHandlerException where
    show :: NoHandlerException -> String
show (NoHandlerException String
e) = String
"No handler for request: failure was " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e


------------------------------------------------------------------------------
instance Exception NoHandlerException


------------------------------------------------------------------------------
-- | Terminate the HTTP session with the given exception.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Control.Exception" as E
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> T.runHandler r (terminateConnection $ E.AssertionFailed \"Assertion failed!\")
-- *** Exception: \<terminated: Assertion failed!>
-- @
terminateConnection :: (Exception e, MonadSnap m) => e -> m a
terminateConnection :: e -> m a
terminateConnection e
e =
    Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (a -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap a)
-> (forall r.
    (a -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
_ Zero -> SnapState -> IO r
fk -> Zero -> SnapState -> IO r
fk (Zero -> SnapState -> IO r) -> Zero -> SnapState -> IO r
forall a b. (a -> b) -> a -> b
$ EscapeSnap -> Zero
EscapeSnap (EscapeSnap -> Zero) -> EscapeSnap -> Zero
forall a b. (a -> b) -> a -> b
$ SomeException -> EscapeSnap
TerminateConnection
                                  (SomeException -> EscapeSnap) -> SomeException -> EscapeSnap
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
SomeException e
e


------------------------------------------------------------------------------
-- | Terminate the HTTP session and hand control to some external handler,
-- escaping all further HTTP traffic.
--
-- The external handler takes three arguments: a function to modify the thread's
-- timeout, and a read and a write ends to the socket.
escapeHttp :: MonadSnap m =>
              EscapeHttpHandler
           -> m ()
escapeHttp :: EscapeHttpHandler -> m ()
escapeHttp EscapeHttpHandler
h = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (forall r.
 (() -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
  (() -> SnapState -> IO r)
  -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
 -> Snap ())
-> (forall r.
    (() -> SnapState -> IO r)
    -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a b. (a -> b) -> a -> b
$ \() -> SnapState -> IO r
_ Zero -> SnapState -> IO r
fk SnapState
st -> Zero -> SnapState -> IO r
fk (EscapeSnap -> Zero
EscapeSnap (EscapeSnap -> Zero) -> EscapeSnap -> Zero
forall a b. (a -> b) -> a -> b
$ EscapeHttpHandler -> EscapeSnap
EscapeHttp EscapeHttpHandler
h) SnapState
st


------------------------------------------------------------------------------
-- | Runs a 'Snap' monad action.
--
-- This function is mostly intended for library writers; instead of invoking
-- 'runSnap' directly, use 'Snap.Http.Server.httpServe' or
-- 'Snap.Test.runHandler' (for testing).
runSnap :: Snap a                   -- ^ Action to run.
        -> (ByteString -> IO ())    -- ^ Error logging action.
        -> ((Int -> Int) -> IO ())  -- ^ Timeout action.
        -> Request                  -- ^ HTTP request.
        -> IO (Request, Response)
runSnap :: Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap (Snap forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m) ByteString -> IO ()
logerr (Int -> Int) -> IO ()
timeoutAction Request
req =
    (a -> SnapState -> IO (Request, Response))
-> (Zero -> SnapState -> IO (Request, Response))
-> SnapState
-> IO (Request, Response)
forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m a -> SnapState -> IO (Request, Response)
forall (m :: * -> *) p.
Monad m =>
p -> SnapState -> m (Request, Response)
ok Zero -> SnapState -> IO (Request, Response)
diediedie SnapState
ss
  where
    ok :: p -> SnapState -> m (Request, Response)
ok p
_ SnapState
st = (Request, Response) -> m (Request, Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapState -> Request
_snapRequest SnapState
st, SnapState -> Response
_snapResponse SnapState
st)

    diediedie :: Zero -> SnapState -> IO (Request, Response)
diediedie Zero
z !SnapState
st = do
        Response
resp <- case Zero
z of
                  Zero
PassOnProcessing     -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
fourohfour
                  (EarlyTermination Response
x) -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
x
                  (EscapeSnap EscapeSnap
e)       -> EscapeSnap -> IO Response
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO EscapeSnap
e
        (Request, Response) -> IO (Request, Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapState -> Request
_snapRequest SnapState
st, Response
resp)

    --------------------------------------------------------------------------
    fourohfour :: Response
fourohfour = do
        Response -> Response
clearContentLength                  (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
          Int -> ByteString -> Response -> Response
setResponseStatus Int
404 ByteString
"Not Found" (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
          (OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
setResponseBody OutputStream Builder -> IO (OutputStream Builder)
enum404           (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
          Response
emptyResponse

    --------------------------------------------------------------------------
    enum404 :: OutputStream Builder -> IO (OutputStream Builder)
enum404 OutputStream Builder
out = do
        InputStream Builder
is <- [Builder] -> IO (InputStream Builder)
forall c. [c] -> IO (InputStream c)
Streams.fromList [Builder]
html
        InputStream Builder -> OutputStream Builder -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream Builder
is OutputStream Builder
out
        OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
out

    --------------------------------------------------------------------------
    html :: [Builder]
html = (ByteString -> Builder) -> [ByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Builder
byteString [ ByteString
"<!DOCTYPE html>\n"
                          , ByteString
"<html>\n"
                          , ByteString
"<head>\n"
                          , ByteString
"<title>Not found</title>\n"
                          , ByteString
"</head>\n"
                          , ByteString
"<body>\n"
                          , ByteString
"<code>No handler accepted \""
                          , Request -> ByteString
rqURI Request
req
                          , ByteString
"\"</code>\n</body></html>"
                          ]

    --------------------------------------------------------------------------
    dresp :: Response
dresp = Response
emptyResponse

    --------------------------------------------------------------------------
    ss :: SnapState
ss = Request
-> Response
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> SnapState
SnapState Request
req Response
dresp ByteString -> IO ()
logerr (Int -> Int) -> IO ()
timeoutAction
{-# INLINE runSnap #-}



--------------------------------------------------------------------------
-- | Post-process a finalized HTTP response:
--
-- * fixup content-length header
-- * properly handle 204/304 responses
-- * if request was HEAD, remove response body
--
-- Note that we do NOT deal with transfer-encoding: chunked or "connection:
-- close" here.
--
{-# INLINE fixupResponse #-}
fixupResponse :: Request -> Response -> IO Response
fixupResponse :: Request -> Response -> IO Response
fixupResponse Request
req Response
rsp = {-# SCC "fixupResponse" #-} do
    Response
rsp' <- case Response -> ResponseBody
rspBody Response
rsp of
              (Stream OutputStream Builder -> IO (OutputStream Builder)
_)                -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
rsp
              (SendFile String
f Maybe (Word64, Word64)
Nothing)      -> String -> Response -> IO Response
setFileSize String
f Response
rsp
              (SendFile String
_ (Just (Word64
s,Word64
e))) -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$! Word64 -> Response -> Response
setContentLength (Word64
eWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-Word64
s) Response
rsp
    let !cl :: Maybe Word64
cl = if Bool
noBody then Maybe Word64
forall a. Maybe a
Nothing else Response -> Maybe Word64
rspContentLength Response
rsp'
    let rsp'' :: Response
rsp'' = if Bool
noBody
                  then Response
rsp' { rspBody :: ResponseBody
rspBody          = (OutputStream Builder -> IO (OutputStream Builder)) -> ResponseBody
Stream ((OutputStream Builder -> IO (OutputStream Builder))
 -> ResponseBody)
-> (OutputStream Builder -> IO (OutputStream Builder))
-> ResponseBody
forall a b. (a -> b) -> a -> b
$ OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> OutputStream Builder)
-> OutputStream Builder
-> IO (OutputStream Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputStream Builder -> OutputStream Builder
forall a. a -> a
id
                            , rspContentLength :: Maybe Word64
rspContentLength = Maybe Word64
forall a. Maybe a
Nothing
                            }
                  else Response
rsp'
    Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$! (Headers -> Headers) -> Response -> Response
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders ([(CI ByteString, ByteString)] -> Headers
H.fromList ([(CI ByteString, ByteString)] -> Headers)
-> (Headers -> [(CI ByteString, ByteString)]) -> Headers -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Word64
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a.
IsString a =>
Maybe Word64 -> [(a, ByteString)] -> [(a, ByteString)]
addCL Maybe Word64
cl ([(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)])
-> (Headers -> [(CI ByteString, ByteString)])
-> Headers
-> [(CI ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup ([(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)])
-> (Headers -> [(CI ByteString, ByteString)])
-> Headers
-> [(CI ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(CI ByteString, ByteString)]
H.toList) Response
rsp''

  where
    --------------------------------------------------------------------------
    addCL :: Maybe Word64 -> [(a, ByteString)] -> [(a, ByteString)]
addCL Maybe Word64
Nothing [(a, ByteString)]
xs   = [(a, ByteString)]
xs
    addCL (Just Word64
cl) [(a, ByteString)]
xs = (a
"content-length", Word64 -> ByteString
word64ToByteString Word64
cl)(a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
:[(a, ByteString)]
xs

    --------------------------------------------------------------------------
    setFileSize :: FilePath -> Response -> IO Response
    setFileSize :: String -> Response -> IO Response
setFileSize String
fp Response
r = {-# SCC "setFileSize" #-} do
        Word64
fs <- (FileOffset -> Word64) -> IO FileOffset -> IO Word64
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FileOffset -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO FileOffset -> IO Word64) -> IO FileOffset -> IO Word64
forall a b. (a -> b) -> a -> b
$ String -> IO FileOffset
getFileSize String
fp
        Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$! Response
r { rspContentLength :: Maybe Word64
rspContentLength = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
fs }

    ------------------------------------------------------------------------------
    getFileSize :: FilePath -> IO FileOffset
    getFileSize :: String -> IO FileOffset
getFileSize String
fp = (FileStatus -> FileOffset) -> IO FileStatus -> IO FileOffset
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FileStatus -> FileOffset
fileSize (IO FileStatus -> IO FileOffset) -> IO FileStatus -> IO FileOffset
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus String
fp

    code :: Int
code   = Response -> Int
rspStatus Response
rsp
    noBody :: Bool
noBody = Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
204 Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
304 Bool -> Bool -> Bool
|| Request -> Method
rqMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
HEAD

    ------------------------------------------------------------------------------
    fixup :: [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [] = []
    fixup ((CI ByteString
"date",ByteString
_):[(CI ByteString, ByteString)]
xs)           = [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
    fixup ((CI ByteString
"content-length",ByteString
_):[(CI ByteString, ByteString)]
xs) = [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
    fixup (x :: (CI ByteString, ByteString)
x@(CI ByteString
"transfer-encoding",ByteString
_):[(CI ByteString, ByteString)]
xs) = if Bool
noBody
                                             then [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
                                             else (CI ByteString, ByteString)
x (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
    fixup ((CI ByteString, ByteString)
x:[(CI ByteString, ByteString)]
xs) = (CI ByteString, ByteString)
x (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs


------------------------------------------------------------------------------
-- This number code stolen and massaged from Bryan's blog post:
-- http://www.serpentine.com/blog/2013/03/20/whats-good-for-c-is-good-for-haskell/

{-# INLINE countDigits #-}
countDigits :: Word64 -> Int
countDigits :: Word64 -> Int
countDigits Word64
v0 = Int -> Word64 -> Int
forall t t. (Num t, Integral t) => t -> t -> t
go Int
1 Word64
v0
  where go :: t -> t -> t
go !t
k t
v
           | t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
10    = t
k
           | t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
100   = t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
1
           | t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
1000  = t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
2
           | t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
10000 = t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
3
           | Bool
otherwise = t -> t -> t
go (t
kt -> t -> t
forall a. Num a => a -> a -> a
+t
4) (t
v t -> t -> t
forall a. Integral a => a -> a -> a
`quot` t
10000)


------------------------------------------------------------------------------
{-# INLINE word64ToByteString #-}
word64ToByteString :: Word64 -> ByteString
word64ToByteString :: Word64 -> ByteString
word64ToByteString Word64
d =
#if !MIN_VERSION_bytestring(0,10,6)
    S.inlinePerformIO $
#else
    IO ByteString -> ByteString
forall a. IO a -> a
S.accursedUnutterablePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
#endif
    if Word64
d Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
10
       then Int -> (Ptr Word8 -> IO ()) -> IO ByteString
S.create Int
1 ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p (Word64 -> Word8
i2w Word64
d)
       else let !n :: Int
n = Word64 -> Int
countDigits Word64
d
            in Int -> (Ptr Word8 -> IO ()) -> IO ByteString
S.create Int
n ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word64 -> Ptr Word8 -> IO ()
posDecimal Int
n Word64
d


{-# INLINE posDecimal #-}
posDecimal :: Int -> Word64 -> Ptr Word8 -> IO ()
posDecimal :: Int -> Word64 -> Ptr Word8 -> IO ()
posDecimal !Int
n0 !Word64
v0 !Ptr Word8
op0 = Int -> Ptr Word8 -> Word64 -> IO ()
forall t. (Eq t, Num t) => t -> Ptr Word8 -> Word64 -> IO ()
go Int
n0 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op0 (Int
n0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Word64
v0
  where go :: t -> Ptr Word8 -> Word64 -> IO ()
go !t
n !Ptr Word8
op !Word64
v
          | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
1 = Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$! Word64 -> Word8
i2w Word64
v
          | Bool
otherwise = do
              let (!Word64
v', !Word64
d) = Word64 -> Word64 -> (Word64, Word64)
forall a. Integral a => a -> a -> (a, a)
divMod Word64
v Word64
10
              Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$! Word64 -> Word8
i2w Word64
d
              t -> Ptr Word8 -> Word64 -> IO ()
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op (-Int
1)) Word64
v'


{-# INLINE i2w #-}
i2w :: Word64 -> Word8
i2w :: Word64 -> Word8
i2w Word64
v = Word8
48 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v


------------------------------------------------------------------------------
evalSnap :: Snap a
         -> (ByteString -> IO ())
         -> ((Int -> Int) -> IO ())
         -> Request
         -> IO a
evalSnap :: Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
evalSnap (Snap forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m) ByteString -> IO ()
logerr (Int -> Int) -> IO ()
timeoutAction Request
req =
    (a -> SnapState -> IO a)
-> (Zero -> SnapState -> IO a) -> SnapState -> IO a
forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m (\a
v SnapState
_ -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v) Zero -> SnapState -> IO a
forall (m :: * -> *) p a. MonadBase IO m => Zero -> p -> m a
diediedie SnapState
ss
  where
    diediedie :: Zero -> p -> m a
diediedie Zero
z p
_ = case Zero
z of
      Zero
PassOnProcessing     -> NoHandlerException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (NoHandlerException -> m a) -> NoHandlerException -> m a
forall a b. (a -> b) -> a -> b
$ String -> NoHandlerException
NoHandlerException String
"pass"
      (EarlyTermination Response
_) -> ErrorCall -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (ErrorCall -> m a) -> ErrorCall -> m a
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"no value"
      (EscapeSnap EscapeSnap
e)       -> EscapeSnap -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO EscapeSnap
e

    dresp :: Response
dresp = Response
emptyResponse
    ss :: SnapState
ss = Request
-> Response
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> SnapState
SnapState Request
req Response
dresp ByteString -> IO ()
logerr (Int -> Int) -> IO ()
timeoutAction
{-# INLINE evalSnap #-}


------------------------------------------------------------------------------
getParamFrom :: MonadSnap m =>
                (ByteString -> Request -> Maybe [ByteString])
             -> ByteString
             -> m (Maybe ByteString)
getParamFrom :: (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
f ByteString
k = do
    Request
rq <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
    Maybe ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m (Maybe ByteString))
-> Maybe ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! ([ByteString] -> ByteString)
-> Maybe [ByteString] -> Maybe ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
" ") (Maybe [ByteString] -> Maybe ByteString)
-> Maybe [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Maybe [ByteString]
f ByteString
k Request
rq
{-# INLINE getParamFrom #-}


------------------------------------------------------------------------------
-- | See 'rqParam'. Looks up a value for the given named parameter in the
-- 'Request'. If more than one value was entered for the given parameter name,
-- 'getParam' gloms the values together with @'S.intercalate' \" \"@.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> let r = T.get \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]
-- ghci> T.runHandler r ('getParam' \"foo\" >>= 'writeBS' . B8.pack . show)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Mon, 11 Aug 2014 12:57:20 GMT
--
-- Just \"bar\"
-- @
getParam :: MonadSnap m
         => ByteString          -- ^ parameter name to look up
         -> m (Maybe ByteString)
getParam :: ByteString -> m (Maybe ByteString)
getParam = (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
rqParam
{-# INLINE getParam #-}


------------------------------------------------------------------------------
-- | See 'rqPostParam'. Looks up a value for the given named parameter in the
-- POST form parameters mapping in 'Request'. If more than one value was
-- entered for the given parameter name, 'getPostParam' gloms the values
-- together with: @'S.intercalate' \" \"@.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]
-- ghci> T.runHandler r ('getPostParam' \"foo\" >>= 'writeBS' . B8.pack . show)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Mon, 11 Aug 2014 13:01:04 GMT
--
-- Just \"bar\"
-- @
getPostParam :: MonadSnap m
             => ByteString          -- ^ parameter name to look up
             -> m (Maybe ByteString)
getPostParam :: ByteString -> m (Maybe ByteString)
getPostParam = (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
rqPostParam
{-# INLINE getPostParam #-}


------------------------------------------------------------------------------
-- | See 'rqQueryParam'. Looks up a value for the given named parameter in the
-- query string parameters mapping in 'Request'. If more than one value was
-- entered for the given parameter name, 'getQueryParam' gloms the values
-- together with  @'S.intercalate' \" \"@.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" M.empty >> T.setQueryStringRaw \"foo=bar&foo=baz\"
-- ghci> T.runHandler r ('getQueryParam' \"foo\" >>= 'writeBS' . B8.pack . show)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Mon, 11 Aug 2014 13:06:50 GMT
--
-- Just \"bar baz\"
-- @
getQueryParam :: MonadSnap m
              => ByteString          -- ^ parameter name to look up
              -> m (Maybe ByteString)
getQueryParam :: ByteString -> m (Maybe ByteString)
getQueryParam = (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
rqQueryParam
{-# INLINE getQueryParam #-}


------------------------------------------------------------------------------
-- | See 'rqParams'. Convenience function to return 'Params' from the
-- 'Request' inside of a 'MonadSnap' instance.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> let r = T.get \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]
-- ghci> T.runHandler r ('getParams' >>= 'writeBS' . B8.pack . show)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Mon, 11 Aug 2014 13:02:54 GMT
--
-- fromList [(\"foo\",[\"bar\"])]
-- @
getParams :: MonadSnap m => m Params
getParams :: m Params
getParams = m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m Params) -> m Params
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Params -> m Params
forall (m :: * -> *) a. Monad m => a -> m a
return (Params -> m Params) -> (Request -> Params) -> Request -> m Params
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Params
rqParams


------------------------------------------------------------------------------
-- | See 'rqParams'. Convenience function to return 'Params' from the
-- 'Request' inside of a 'MonadSnap' instance.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])]
-- ghci> T.runHandler r ('getPostParams' >>= 'writeBS' . B8.pack . show)
-- HTTP/1.1 200 OK
-- server: Snap/test
-- date: Mon, 11 Aug 2014 13:04:34 GMT
--
-- fromList [("foo",["bar"])]
-- @
getPostParams :: MonadSnap m => m Params
getPostParams :: m Params
getPostParams = m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m Params) -> m Params
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Params -> m Params
forall (m :: * -> *) a. Monad m => a -> m a
return (Params -> m Params) -> (Request -> Params) -> Request -> m Params
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Params
rqPostParams


------------------------------------------------------------------------------
-- | See 'rqParams'. Convenience function to return 'Params' from the
-- 'Request' inside of a 'MonadSnap' instance.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" M.empty >> T.setQueryStringRaw \"foo=bar&foo=baz\"
-- ghci> T.runHandler r ('getQueryParams' >>= 'writeBS' . B8.pack . show)
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Mon, 11 Aug 2014 13:10:17 GMT
--
-- fromList [(\"foo\",[\"bar\",\"baz\"])]
-- @
getQueryParams :: MonadSnap m => m Params
getQueryParams :: m Params
getQueryParams = m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m Params) -> m Params
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Params -> m Params
forall (m :: * -> *) a. Monad m => a -> m a
return (Params -> m Params) -> (Request -> Params) -> Request -> m Params
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Params
rqQueryParams


------------------------------------------------------------------------------
-- | Gets the HTTP 'Cookie' with the specified name.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False
-- ghci> let r = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie]
-- ghci> T.runHandler r ('getCookie' \"name\" >>= 'writeBS' . B8.pack . show)
-- HTTP/1.1 200 OK
-- server: Snap/test
-- date: Thu, 07 Aug 2014 12:16:58 GMT
--
-- Just (Cookie {cookieName = "name", cookieValue = "value", ...})
-- @
getCookie :: MonadSnap m
          => ByteString
          -> m (Maybe Cookie)
getCookie :: ByteString -> m (Maybe Cookie)
getCookie ByteString
name = (Request -> m (Maybe Cookie)) -> m (Maybe Cookie)
forall (m :: * -> *) a. MonadSnap m => (Request -> m a) -> m a
withRequest ((Request -> m (Maybe Cookie)) -> m (Maybe Cookie))
-> (Request -> m (Maybe Cookie)) -> m (Maybe Cookie)
forall a b. (a -> b) -> a -> b
$
    Maybe Cookie -> m (Maybe Cookie)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Cookie -> m (Maybe Cookie))
-> (Request -> Maybe Cookie) -> Request -> m (Maybe Cookie)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cookie] -> Maybe Cookie
forall a. [a] -> Maybe a
listToMaybe ([Cookie] -> Maybe Cookie)
-> (Request -> [Cookie]) -> Request -> Maybe Cookie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cookie -> Bool) -> [Cookie] -> [Cookie]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Cookie
c -> Cookie -> ByteString
cookieName Cookie
c ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name) ([Cookie] -> [Cookie])
-> (Request -> [Cookie]) -> Request -> [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Cookie]
rqCookies


------------------------------------------------------------------------------
-- | Gets the HTTP 'Cookie' with the specified name and decodes it.  If the
-- decoding fails, the handler calls pass.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False
-- ghci> let r = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie]
-- ghci> T.runHandler r ('readCookie' \"name\" >>= 'writeBS')
-- HTTP/1.1 200 OK
-- server: Snap/test
-- date: Thu, 07 Aug 2014 12:20:09 GMT
--
-- value
-- @
readCookie :: (MonadSnap m, R.Readable a)
           => ByteString
           -> m a
readCookie :: ByteString -> m a
readCookie ByteString
name = m a -> (Cookie -> m a) -> Maybe Cookie -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadSnap m => m a
pass (ByteString -> m a
forall a (m :: * -> *).
(Readable a, MonadPlus m) =>
ByteString -> m a
R.fromBS (ByteString -> m a) -> (Cookie -> ByteString) -> Cookie -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> ByteString
cookieValue) (Maybe Cookie -> m a) -> m (Maybe Cookie) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> m (Maybe Cookie)
forall (m :: * -> *). MonadSnap m => ByteString -> m (Maybe Cookie)
getCookie ByteString
name


------------------------------------------------------------------------------
-- | Expire given 'Cookie' in client's browser.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Snap.Test" as T
-- ghci> let r = T.get \"\/foo\/bar\" M.empty
-- ghci> let cookie = Cookie "name" "" Nothing (Just "/subsite") Nothing True False
-- ghci> T.runHandler r ('expireCookie' cookie)
-- HTTP/1.1 200 OK
-- set-cookie: name=; path=/subsite; expires=Sat, 24 Dec 1994 06:28:16 GMT; Secure
-- server: Snap/test
--
-- date: Thu, 07 Aug 2014 12:21:27 GMT
-- ghci> let cookie = Cookie "name" "value" Nothing Nothing Nothing False False
-- ghci> let r2 = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie]
-- ghci> T.runHandler r ('getCookie' "name" >>= maybe (return ()) 'expireCookie')
-- HTTP/1.1 200 OK
-- set-cookie: name=; expires=Sat, 24 Dec 1994 06:28:16 GMT
-- server: Snap/test
--
--
-- @
expireCookie :: (MonadSnap m) => Cookie -> m ()
expireCookie :: Cookie -> m ()
expireCookie Cookie
cookie = do
  let old :: UTCTime
old = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0
  (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Cookie -> Response -> Response
addResponseCookie
                 (Cookie -> Response -> Response) -> Cookie -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Cookie
cookie { cookieValue :: ByteString
cookieValue = ByteString
""
                          , cookieExpires :: Maybe UTCTime
cookieExpires = (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
old) }

------------------------------------------------------------------------------
-- | Causes the handler thread to be killed @n@ seconds from now.
setTimeout :: MonadSnap m => Int -> m ()
setTimeout :: Int -> m ()
setTimeout = (Int -> Int) -> m ()
forall (m :: * -> *). MonadSnap m => (Int -> Int) -> m ()
modifyTimeout ((Int -> Int) -> m ()) -> (Int -> Int -> Int) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a b. a -> b -> a
const


------------------------------------------------------------------------------
-- | Causes the handler thread to be killed at least @n@ seconds from now.
extendTimeout :: MonadSnap m => Int -> m ()
extendTimeout :: Int -> m ()
extendTimeout = (Int -> Int) -> m ()
forall (m :: * -> *). MonadSnap m => (Int -> Int) -> m ()
modifyTimeout ((Int -> Int) -> m ()) -> (Int -> Int -> Int) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max


------------------------------------------------------------------------------
-- | Modifies the amount of time remaining before the request times out.
modifyTimeout :: MonadSnap m => (Int -> Int) -> m ()
modifyTimeout :: (Int -> Int) -> m ()
modifyTimeout Int -> Int
f = do
    (Int -> Int) -> IO ()
m <- m ((Int -> Int) -> IO ())
forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
m Int -> Int
f


------------------------------------------------------------------------------
-- | Returns an 'IO' action which you can use to modify the timeout value.
getTimeoutModifier :: MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier :: m ((Int -> Int) -> IO ())
getTimeoutModifier = Snap ((Int -> Int) -> IO ()) -> m ((Int -> Int) -> IO ())
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap ((Int -> Int) -> IO ()) -> m ((Int -> Int) -> IO ()))
-> Snap ((Int -> Int) -> IO ()) -> m ((Int -> Int) -> IO ())
forall a b. (a -> b) -> a -> b
$ (SnapState -> (Int -> Int) -> IO ())
-> Snap SnapState -> Snap ((Int -> Int) -> IO ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SnapState -> (Int -> Int) -> IO ()
_snapModifyTimeout Snap SnapState
sget