{-# 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: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e 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 {
      forall a.
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
    >>= :: forall a 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 :: forall a. String -> Snap a
fail   = forall a. String -> Snap a
snapFail

------------------------------------------------------------------------------
snapBind :: Snap a -> (a -> Snap b) -> Snap b
snapBind :: forall a b. Snap a -> (a -> Snap b) -> Snap b
snapBind Snap a
m a -> Snap b
f = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap forall a b. (a -> b) -> a -> b
$ \b -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st -> 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' -> 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 :: forall a. String -> Snap a
snapFail !String
_ = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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 :: forall a. IO a -> Snap a
liftIO IO a
m = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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 :: forall a. IO a -> Snap a
liftBase = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO


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

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

------------------------------------------------------------------------------
snapToStateT :: Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT :: forall a. Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT Snap a
m = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \SnapState
st -> do
    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' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> SnapResult a
SnapValue a
a, SnapState
st'))
             (\Zero
z SnapState
st' -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap StateT SnapState IO (SnapResult a)
m = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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') <- 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 :: forall a. Snap a
mzero = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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 :: forall a. Snap a -> Snap a -> Snap a
`mplus` Snap a
b =
        forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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 -> 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 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 :: forall a b. (a -> b) -> Snap a -> Snap b
fmap a -> b
f Snap a
m = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap forall a b. (a -> b) -> a -> b
$ \b -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st -> 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 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 :: forall a. a -> Snap a
pure a
x  = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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
    <*> :: forall a 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 :: forall a. Snap a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: forall a. Snap a -> Snap a -> Snap a
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus


------------------------------------------------------------------------------
instance MonadSnap Snap where
    liftSnap :: forall a. Snap a -> Snap a
liftSnap = 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 :: forall (m :: * -> *) a.
MonadSnap m =>
(InputStream ByteString -> IO a) -> m a
runRequestBody InputStream ByteString -> IO a
proc = do
    IO ()
bumpTimeout <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
5) forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
    Request
req         <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
    InputStream ByteString
body        <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ()
-> Double
-> Int
-> InputStream ByteString
-> IO (InputStream ByteString)
Streams.throwIfTooSlow IO ()
bumpTimeout Double
500 Int
5 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. InputStream a -> IO ()
Streams.skipToEof InputStream a
body) forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall {m :: * -> *} {a}.
MonadSnap m =>
RateTooSlowException -> m a
tooSlow

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

    run :: InputStream ByteString -> m a
run InputStream ByteString
body = (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        a
x <- InputStream ByteString -> IO a
proc InputStream ByteString
body
        forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
body
        forall (m :: * -> *) a. Monad m => a -> m a
return a
x) forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
`catches` [Handler m a]
handlers
      where
        handlers :: [Handler m a]
handlers = [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall {m :: * -> *} {a}.
MonadSnap m =>
RateTooSlowException -> m a
tooSlow, 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) = forall {m :: * -> *} {a}. MonadSnap m => InputStream a -> m ()
skip InputStream ByteString
body forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 :: forall (m :: * -> *). MonadSnap m => Word64 -> m ByteString
readRequestBody Word64
sz = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
L.fromChunks forall a b. (a -> b) -> a -> b
$ 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) InputStream ByteString
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            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     <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
    InputStream Builder
is      <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((InputStream ByteString -> IO (InputStream ByteString)
trans forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
req) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         forall a b. (a -> IO b) -> InputStream a -> IO (InputStream b)
Streams.mapM (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString))
    Response
origRsp <- forall (m :: * -> *). MonadSnap m => m Response
getResponse
    let rsp :: Response
rsp = (OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
setResponseBody (\OutputStream Builder
out -> forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream Builder
is OutputStream Builder
out forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
out) forall a b. (a -> b) -> a -> b
$
              Response
origRsp { rspTransformingRqBody :: Bool
rspTransformingRqBody = Bool
True }
    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 :: forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith Response
r = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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 :: forall a. Snap a -> Snap (Either Response a)
catchFinishWith (Snap forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m) = forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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 (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 (forall a b. a -> Either a b
Left Response
resp) SnapState
s
                    Zero
_                       -> Zero -> SnapState -> IO r
fk Zero
z SnapState
s
    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 :: forall (m :: * -> *) a. MonadSnap m => m a
pass = 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 :: forall (m :: * -> *) a. MonadSnap m => Method -> m a -> m a
method Method
m m a
action = do
    Request
req <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request -> Method
rqMethod Request
req forall a. Eq a => a -> a -> Bool
== Method
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 :: forall (m :: * -> *) a. MonadSnap m => [Method] -> m a -> m a
methods [Method]
ms m a
action = do
    Request
req <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request -> Method
rqMethod Request
req forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Method]
ms) 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 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
nforall 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 :: forall (m :: * -> *) a.
MonadSnap m =>
(ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith ByteString -> ByteString -> Bool
c ByteString
p m a
action = do
    Request
req <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> ByteString -> Bool
c ByteString
p (Request -> ByteString
rqPathInfo Request
req)) forall (m :: * -> *) a. MonadSnap m => m a
pass
    forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath 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 :: forall (m :: * -> *) a. MonadSnap m => ByteString -> m a -> m a
dir = 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 forall a. Eq a => a -> a -> Bool
== ByteString
x
      where
        (ByteString
x,ByteString
_) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (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 :: forall (m :: * -> *) a. MonadSnap m => ByteString -> m a -> m a
path = forall (m :: * -> *) a.
MonadSnap m =>
(ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith 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 :: forall a (m :: * -> *) b.
(Readable a, MonadSnap m) =>
(a -> m b) -> m b
pathArg a -> m b
f = do
    Request
req <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
    let (ByteString
p,ByteString
_) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (forall a. Eq a => a -> a -> Bool
==Char
'/') (Request -> ByteString
rqPathInfo Request
req)
    ByteString
p' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
urlDecode ByteString
p
    a
a <- forall a (m :: * -> *).
(Readable a, MonadPlus m) =>
ByteString -> m a
R.fromBS ByteString
p'
    forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath 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 :: forall (m :: * -> *) a. MonadSnap m => m a -> m a
ifTop = 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 a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap 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 a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
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 :: forall (m :: * -> *). MonadSnap m => m Request
getRequest = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) a. MonadSnap m => (Request -> a) -> m a
getsRequest Request -> a
f = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Request -> a
f 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 :: forall (m :: * -> *). MonadSnap m => m Response
getResponse = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) a. MonadSnap m => (Response -> a) -> m a
getsResponse Response -> a
f = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Response -> a
f 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 :: forall (m :: * -> *). MonadSnap m => Response -> m ()
putResponse Response
r = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ (SnapState -> SnapState) -> Snap ()
smodify 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 :: forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest Request
r = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ (SnapState -> SnapState) -> Snap ()
smodify 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 :: forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest Request -> Request
f = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$
    (SnapState -> SnapState) -> Snap ()
smodify forall a b. (a -> b) -> a -> b
$ \SnapState
ss -> SnapState
ss { _snapRequest :: Request
_snapRequest = Request -> Request
f 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 :: forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse Response -> Response
f = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$
     (SnapState -> SnapState) -> Snap ()
smodify forall a b. (a -> b) -> a -> b
$ \SnapState
ss -> SnapState
ss { _snapResponse :: Response
_snapResponse = Response -> Response
f 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 :: forall (m :: * -> *) a. MonadSnap m => ByteString -> m a
redirect ByteString
target = 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' :: forall (m :: * -> *) a. MonadSnap m => ByteString -> Int -> m a
redirect' ByteString
target Int
status = do
    Response
r <- forall (m :: * -> *). MonadSnap m => m Response
getResponse

    forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith
        forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
setResponseCode Int
status
        forall a b. (a -> b) -> a -> b
$ Word64 -> Response -> Response
setContentLength Word64
0
        forall a b. (a -> b) -> a -> b
$ ((OutputStream Builder -> IO (OutputStream Builder))
 -> OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
modifyResponseBody (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a
id)
        forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *). MonadSnap m => ByteString -> m ()
logError ByteString
s = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
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 :: forall (m :: * -> *).
MonadSnap m =>
(OutputStream Builder -> IO (OutputStream Builder)) -> m ()
addToOutput OutputStream Builder -> IO (OutputStream Builder)
enum = forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ ((OutputStream Builder -> IO (OutputStream Builder))
 -> OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
modifyResponseBody (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 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 :: forall (m :: * -> *). MonadSnap m => Builder -> m ()
writeBuilder Builder
b = 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 = forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
str forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 :: forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS = forall (m :: * -> *). MonadSnap m => Builder -> m ()
writeBuilder 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 :: forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS = forall (m :: * -> *). MonadSnap m => Builder -> m ()
writeBuilder 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 :: forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText = forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS 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 :: forall (m :: * -> *). MonadSnap m => Text -> m ()
writeLazyText = forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS 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 :: forall (m :: * -> *). MonadSnap m => String -> m ()
sendFile String
f = forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ \Response
r -> Response
r { rspBody :: ResponseBody
rspBody = String -> Maybe (Word64, Word64) -> ResponseBody
SendFile String
f 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 :: forall (m :: * -> *).
MonadSnap m =>
String -> (Word64, Word64) -> m ()
sendFilePartial String
f (Word64, Word64)
rng = forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ \Response
r ->
                        Response
r { rspBody :: ResponseBody
rspBody = String -> Maybe (Word64, Word64) -> ResponseBody
SendFile String
f (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 :: forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest Request -> Request
f m a
m = do
    Request
req <- forall (m :: * -> *). MonadSnap m => m Request
getRequest

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

  where
    runAct :: Request -> m a
runAct Request
req = do
        forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest Request -> Request
f
        a
result <- m a
m
        forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest Request
req
        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 :: forall (m :: * -> *) a. MonadSnap m => (Request -> m a) -> m a
withRequest = (forall (m :: * -> *). MonadSnap m => m Request
getRequest 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 :: forall (m :: * -> *) a. MonadSnap m => (Response -> m a) -> m a
withResponse = (forall (m :: * -> *). MonadSnap m => m Response
getResponse 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 :: forall (m :: * -> *). MonadSnap m => m ()
ipHeaderFilter = 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' :: forall (m :: * -> *). MonadSnap m => CI ByteString -> m ()
ipHeaderFilter' CI ByteString
header = do
    Maybe ByteString
headerContents <- forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
header forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSnap m => m Request
getRequest

    let whitespace :: String
whitespace = [ Char
' ', Char
'\t', Char
'\r', Char
'\n' ]
        ipChrs :: String
ipChrs = Char
'.' 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 (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
s)

        clean :: ByteString -> ByteString
clean = forall {t :: * -> *} {a} {t}.
(Foldable t, Eq a) =>
((a -> Bool) -> t) -> t a -> t
trim (Char -> Bool) -> ByteString -> ByteString
S.takeWhile String
ipChrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest forall a b. (a -> b) -> a -> b
$ \Request
rq -> Request
rq { rqClientAddr :: ByteString
rqClientAddr = ByteString -> ByteString
clean ByteString
ip }
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ()) 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 :: forall a b c. IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c
bracketSnap IO a
before a -> IO b
after a -> Snap c
thing = forall (m :: * -> *) b.
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. Snap a -> Snap a
restore ->
                                 forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap forall a b. (a -> b) -> a -> b
$ do
    a
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
before
    let after' :: StateT SnapState IO b
after' = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ a -> IO b
after a
a
    SnapResult c
r <- forall a. Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT (forall a. Snap a -> Snap a
restore forall a b. (a -> b) -> a -> b
$ a -> Snap c
thing a
a) 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'
    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
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 " 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 :: forall e (m :: * -> *) a. (Exception e, MonadSnap m) => e -> m a
terminateConnection e
e =
    forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap forall a b. (a -> b) -> a -> b
$ \a -> SnapState -> IO r
_ Zero -> SnapState -> IO r
fk -> Zero -> SnapState -> IO r
fk forall a b. (a -> b) -> a -> b
$ EscapeSnap -> Zero
EscapeSnap forall a b. (a -> b) -> a -> b
$ SomeException -> EscapeSnap
TerminateConnection
                                  forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *). MonadSnap m => EscapeHttpHandler -> m ()
escapeHttp EscapeHttpHandler
h = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall a.
(forall r.
 (a -> SnapState -> IO r)
 -> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
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 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 :: forall a.
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 =
    forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m 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 = 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     -> forall (m :: * -> *) a. Monad m => a -> m a
return Response
fourohfour
                  (EarlyTermination Response
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return Response
x
                  (EscapeSnap EscapeSnap
e)       -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO EscapeSnap
e
        forall (m :: * -> *) a. Monad m => a -> m a
return (SnapState -> Request
_snapRequest SnapState
st, Response
resp)

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

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

    --------------------------------------------------------------------------
    html :: [Builder]
html = 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)
_)                -> 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))) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Word64 -> Response -> Response
setContentLength (Word64
eforall a. Num a => a -> a -> a
-Word64
s) Response
rsp
    let !cl :: Maybe Word64
cl = if Bool
noBody then 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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a
id
                            , rspContentLength :: Maybe Word64
rspContentLength = forall a. Maybe a
Nothing
                            }
                  else Response
rsp'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders ([(CI ByteString, ByteString)] -> Headers
H.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
IsString a =>
Maybe Word64 -> [(a, ByteString)] -> [(a, ByteString)]
addCL Maybe Word64
cl forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup 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)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 <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ String -> IO FileOffset
getFileSize String
fp
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Response
r { rspContentLength :: Maybe Word64
rspContentLength = forall a. a -> Maybe a
Just Word64
fs }

    ------------------------------------------------------------------------------
    getFileSize :: FilePath -> IO FileOffset
    getFileSize :: String -> IO FileOffset
getFileSize String
fp = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FileStatus -> FileOffset
fileSize 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 forall a. Eq a => a -> a -> Bool
== Int
204 Bool -> Bool -> Bool
|| Int
code forall a. Eq a => a -> a -> Bool
== Int
304 Bool -> Bool -> Bool
|| Request -> Method
rqMethod Request
req 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 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 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 = 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 forall a. Ord a => a -> a -> Bool
< t
10    = t
k
           | t
v forall a. Ord a => a -> a -> Bool
< t
100   = t
k forall a. Num a => a -> a -> a
+ t
1
           | t
v forall a. Ord a => a -> a -> Bool
< t
1000  = t
k forall a. Num a => a -> a -> a
+ t
2
           | t
v forall a. Ord a => a -> a -> Bool
< t
10000 = t
k forall a. Num a => a -> a -> a
+ t
3
           | Bool
otherwise = t -> t -> t
go (t
kforall a. Num a => a -> a -> a
+t
4) (t
v 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
    forall a. IO a -> a
S.accursedUnutterablePerformIO forall a b. (a -> b) -> a -> b
$
#endif
    if Word64
d forall a. Ord a => a -> a -> Bool
< Word64
10
       then Int -> (Ptr Word8 -> IO ()) -> IO ByteString
S.create Int
1 forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> 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 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 = forall {t}. (Eq t, Num t) => t -> Ptr Word8 -> Word64 -> IO ()
go Int
n0 (forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op0 (Int
n0forall 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 forall a. Eq a => a -> a -> Bool
== t
1 = forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op forall a b. (a -> b) -> a -> b
$! Word64 -> Word8
i2w Word64
v
          | Bool
otherwise = do
              let (!Word64
v', !Word64
d) = forall a. Integral a => a -> a -> (a, a)
divMod Word64
v Word64
10
              forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op forall a b. (a -> b) -> a -> b
$! Word64 -> Word8
i2w Word64
d
              t -> Ptr Word8 -> Word64 -> IO ()
go (t
nforall a. Num a => a -> a -> a
-t
1) (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 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v


------------------------------------------------------------------------------
-- | Evaluates a 'Snap' monad action.
--
-- Unlike 'runSnap', 'evalSnap' evaluates to the value, not the 'Response'.
-- Like 'runSnap', 'evalSnap' is intended for library writers.
-- Note that there is no meaningful way of evaluating a 'Snap' monad action
-- that contains 'pass' without alternative (i.e. failure), 'finishWith'
-- (i.e. early termination), or 'escapeHttp' (i.e. escaping Snap).
-- In all of those three cases 'evalSnap' throws an IO exception.
evalSnap :: Snap a                  -- ^ Action to run.
         -> (ByteString -> IO ())   -- ^ Error logging action.
         -> ((Int -> Int) -> IO ()) -- ^ Timeout action.
         -> Request                 -- ^ HTTP request.
         -> IO a
evalSnap :: forall a.
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 =
    forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m (\a
v SnapState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v) 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     -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> NoHandlerException
NoHandlerException String
"pass"
      (EarlyTermination Response
_) -> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"no value"
      (EscapeSnap EscapeSnap
e)       -> 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 :: forall (m :: * -> *).
MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
f ByteString
k = do
    Request
rq <- forall (m :: * -> *). MonadSnap m => m Request
getRequest
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> [ByteString] -> ByteString
S.intercalate 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 :: forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getParam = 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 :: forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getPostParam = 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 :: forall (m :: * -> *).
MonadSnap m =>
ByteString -> m (Maybe ByteString)
getQueryParam = 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 :: forall (m :: * -> *). MonadSnap m => m Params
getParams = forall (m :: * -> *). MonadSnap m => m Request
getRequest forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall (m :: * -> *). MonadSnap m => m Params
getPostParams = forall (m :: * -> *). MonadSnap m => m Request
getRequest forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall (m :: * -> *). MonadSnap m => m Params
getQueryParams = forall (m :: * -> *). MonadSnap m => m Request
getRequest forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall (m :: * -> *). MonadSnap m => ByteString -> m (Maybe Cookie)
getCookie ByteString
name = forall (m :: * -> *) a. MonadSnap m => (Request -> m a) -> m a
withRequest forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\Cookie
c -> Cookie -> ByteString
cookieName Cookie
c forall a. Eq a => a -> a -> Bool
== ByteString
name) 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 :: forall (m :: * -> *) a.
(MonadSnap m, Readable a) =>
ByteString -> m a
readCookie ByteString
name = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadSnap m => m a
pass (forall a (m :: * -> *).
(Readable a, MonadPlus m) =>
ByteString -> m a
R.fromBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> ByteString
cookieValue) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 :: forall (m :: * -> *). MonadSnap m => Cookie -> m ()
expireCookie Cookie
cookie = do
  let old :: UTCTime
old = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0
  forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ Cookie -> Response -> Response
addResponseCookie
                 forall a b. (a -> b) -> a -> b
$ Cookie
cookie { cookieValue :: ByteString
cookieValue = ByteString
""
                          , cookieExpires :: Maybe UTCTime
cookieExpires = (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 :: forall (m :: * -> *). MonadSnap m => Int -> m ()
setTimeout = forall (m :: * -> *). MonadSnap m => (Int -> Int) -> m ()
modifyTimeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *). MonadSnap m => Int -> m ()
extendTimeout = forall (m :: * -> *). MonadSnap m => (Int -> Int) -> m ()
modifyTimeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *). MonadSnap m => (Int -> Int) -> m ()
modifyTimeout Int -> Int
f = do
    (Int -> Int) -> IO ()
m <- forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier = forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SnapState -> (Int -> Int) -> IO ()
_snapModifyTimeout Snap SnapState
sget