{-# 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
class (Monad m, MonadIO m, MonadBaseControl IO m, MonadPlus m, Functor m,
Applicative m, Alternative m) => MonadSnap m where
liftSnap :: Snap a -> m a
data SnapResult a = SnapValue a
| Zero Zero
type EscapeHttpHandler = ((Int -> Int) -> IO ())
-> InputStream ByteString
-> OutputStream Builder
-> IO ()
data EscapeSnap = TerminateConnection SomeException
| EscapeHttp EscapeHttpHandler
deriving (Typeable)
instance Exception EscapeSnap
instance Show EscapeSnap where
show :: EscapeSnap -> String
show (TerminateConnection e :: SomeException
e) = "<terminated: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ ">"
show (EscapeHttp _) = "<escape http>"
data Zero = PassOnProcessing
| EarlyTermination Response
| EscapeSnap EscapeSnap
newtype Snap a = Snap {
Snap a
-> forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap :: forall r . (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> 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 ()
}
instance Monad Snap where
>>= :: Snap a -> (a -> Snap b) -> Snap b
(>>=) = Snap a -> (a -> Snap b) -> Snap b
forall a b. Snap a -> (a -> Snap b) -> Snap b
snapBind
#if !MIN_VERSION_base(4,8,0)
return = pure
{-# INLINE return #-}
#endif
#if !MIN_VERSION_base(4,13,0)
fail = Fail.fail
#endif
instance Fail.MonadFail Snap where
fail :: String -> Snap a
fail = String -> Snap a
forall a. String -> Snap a
snapFail
snapBind :: Snap a -> (a -> Snap b) -> Snap b
snapBind :: Snap a -> (a -> Snap b) -> Snap b
snapBind m :: Snap a
m f :: a -> Snap b
f = (forall r.
(b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b)
-> (forall r.
(b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a b. (a -> b) -> a -> b
$ \sk :: b -> SnapState -> IO r
sk fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
m (\a :: a
a st' :: SnapState
st' -> Snap b
-> (b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap (a -> Snap b
f a
a) b -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st') Zero -> SnapState -> IO r
fk SnapState
st
{-# INLINE snapBind #-}
snapFail :: String -> Snap a
snapFail :: String -> Snap a
snapFail !String
_ = (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \_ fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> Zero -> SnapState -> IO r
fk Zero
PassOnProcessing SnapState
st
{-# INLINE snapFail #-}
instance MonadIO Snap where
liftIO :: IO a -> Snap a
liftIO m :: IO a
m = (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \sk :: a -> SnapState -> IO r
sk _ st :: SnapState
st -> do a
x <- IO a
m
a -> SnapState -> IO r
sk a
x SnapState
st
instance (MonadBase IO) Snap where
liftBase :: IO α -> Snap α
liftBase = IO α -> Snap α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
newtype StSnap a = StSnap {
StSnap a -> StM (StateT SnapState IO) (SnapResult a)
unStSnap :: StM (StateT SnapState IO) (SnapResult a)
}
instance (MonadBaseControl IO) Snap where
type StM Snap a = StSnap a
liftBaseWith :: (RunInBase Snap IO -> IO a) -> Snap a
liftBaseWith f :: RunInBase Snap IO -> IO a
f = StateT SnapState IO (SnapResult a) -> Snap a
forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap (StateT SnapState IO (SnapResult a) -> Snap a)
-> StateT SnapState IO (SnapResult a) -> Snap a
forall a b. (a -> b) -> a -> b
$ (a -> SnapResult a)
-> StateT SnapState IO a -> StateT SnapState IO (SnapResult a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> SnapResult a
forall a. a -> SnapResult a
SnapValue (StateT SnapState IO a -> StateT SnapState IO (SnapResult a))
-> StateT SnapState IO a -> StateT SnapState IO (SnapResult a)
forall a b. (a -> b) -> a -> b
$
(RunInBase (StateT SnapState IO) IO -> IO a)
-> StateT SnapState IO a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase (StateT SnapState IO) IO -> IO a)
-> StateT SnapState IO a)
-> (RunInBase (StateT SnapState IO) IO -> IO a)
-> StateT SnapState IO a
forall a b. (a -> b) -> a -> b
$ \g' :: RunInBase (StateT SnapState IO) IO
g' -> RunInBase Snap IO -> IO a
f (RunInBase Snap IO -> IO a) -> RunInBase Snap IO -> IO a
forall a b. (a -> b) -> a -> b
$ \m :: Snap a
m ->
((SnapResult a, SnapState) -> StSnap a)
-> IO (SnapResult a, SnapState) -> IO (StSnap a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (SnapResult a, SnapState) -> StSnap a
forall a. StM (StateT SnapState IO) (SnapResult a) -> StSnap a
StSnap (IO (SnapResult a, SnapState) -> IO (StM Snap a))
-> IO (SnapResult a, SnapState) -> IO (StM Snap a)
forall a b. (a -> b) -> a -> b
$ StateT SnapState IO (SnapResult a) -> IO (SnapResult a, SnapState)
RunInBase (StateT SnapState IO) IO
g' (StateT SnapState IO (SnapResult a)
-> IO (SnapResult a, SnapState))
-> StateT SnapState IO (SnapResult a)
-> IO (SnapResult a, SnapState)
forall a b. (a -> b) -> a -> b
$ Snap a -> StateT SnapState IO (SnapResult a)
forall a. Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT Snap a
m
{-# INLINE liftBaseWith #-}
restoreM :: StM Snap a -> Snap a
restoreM = StateT SnapState IO (SnapResult a) -> Snap a
forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap (StateT SnapState IO (SnapResult a) -> Snap a)
-> (StSnap a -> StateT SnapState IO (SnapResult a))
-> StSnap a
-> Snap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapResult a, SnapState) -> StateT SnapState IO (SnapResult a)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM ((SnapResult a, SnapState) -> StateT SnapState IO (SnapResult a))
-> (StSnap a -> (SnapResult a, SnapState))
-> StSnap a
-> StateT SnapState IO (SnapResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StSnap a -> (SnapResult a, SnapState)
forall a. StSnap a -> StM (StateT SnapState IO) (SnapResult a)
unStSnap
{-# INLINE restoreM #-}
snapToStateT :: Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT :: Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT m :: Snap a
m = (SnapState -> IO (SnapResult a, SnapState))
-> StateT SnapState IO (SnapResult a)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((SnapState -> IO (SnapResult a, SnapState))
-> StateT SnapState IO (SnapResult a))
-> (SnapState -> IO (SnapResult a, SnapState))
-> StateT SnapState IO (SnapResult a)
forall a b. (a -> b) -> a -> b
$ \st :: SnapState
st -> do
Snap a
-> (a -> SnapState -> IO (SnapResult a, SnapState))
-> (Zero -> SnapState -> IO (SnapResult a, SnapState))
-> SnapState
-> IO (SnapResult a, SnapState)
forall a.
Snap a
-> forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
m (\a :: a
a st' :: SnapState
st' -> (SnapResult a, SnapState) -> IO (SnapResult a, SnapState)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> SnapResult a
forall a. a -> SnapResult a
SnapValue a
a, SnapState
st'))
(\z :: Zero
z st' :: SnapState
st' -> (SnapResult a, SnapState) -> IO (SnapResult a, SnapState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Zero -> SnapResult a
forall a. Zero -> SnapResult a
Zero Zero
z, SnapState
st')) SnapState
st
{-# INLINE snapToStateT #-}
{-# INLINE stateTToSnap #-}
stateTToSnap :: StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap :: StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap m :: StateT SnapState IO (SnapResult a)
m = (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \sk :: a -> SnapState -> IO r
sk fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> do
(a :: SnapResult a
a, st' :: SnapState
st') <- StateT SnapState IO (SnapResult a)
-> SnapState -> IO (SnapResult a, SnapState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT SnapState IO (SnapResult a)
m SnapState
st
case SnapResult a
a of
SnapValue x :: a
x -> a -> SnapState -> IO r
sk a
x SnapState
st'
Zero z :: Zero
z -> Zero -> SnapState -> IO r
fk Zero
z SnapState
st'
instance MonadPlus Snap where
mzero :: Snap a
mzero = (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \_ fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> Zero -> SnapState -> IO r
fk Zero
PassOnProcessing SnapState
st
a :: Snap a
a mplus :: Snap a -> Snap a -> Snap a
`mplus` b :: Snap a
b =
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \sk :: a -> SnapState -> IO r
sk fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st ->
let fk' :: Zero -> SnapState -> IO r
fk' z :: Zero
z st' :: SnapState
st' = case Zero
z of
PassOnProcessing -> Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
b a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk SnapState
st'
_ -> Zero -> SnapState -> IO r
fk Zero
z SnapState
st'
in Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
a a -> SnapState -> IO r
sk Zero -> SnapState -> IO r
fk' SnapState
st
instance Functor Snap where
fmap :: (a -> b) -> Snap a -> Snap b
fmap f :: a -> b
f m :: Snap a
m = (forall r.
(b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b)
-> (forall r.
(b -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap b
forall a b. (a -> b) -> a -> b
$ \sk :: b -> SnapState -> IO r
sk fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> Snap a
-> (a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r)
-> SnapState
-> IO r
forall a.
Snap a
-> forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
unSnap Snap a
m (b -> SnapState -> IO r
sk (b -> SnapState -> IO r) -> (a -> b) -> a -> SnapState -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) Zero -> SnapState -> IO r
fk SnapState
st
instance Applicative Snap where
pure :: a -> Snap a
pure x :: a
x = (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \sk :: a -> SnapState -> IO r
sk _ st :: SnapState
st -> a -> SnapState -> IO r
sk a
x SnapState
st
<*> :: Snap (a -> b) -> Snap a -> Snap b
(<*>) = Snap (a -> b) -> Snap a -> Snap b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Alternative Snap where
empty :: Snap a
empty = Snap a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
<|> :: Snap a -> Snap a -> Snap a
(<|>) = Snap a -> Snap a -> Snap a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance MonadSnap Snap where
liftSnap :: Snap a -> Snap a
liftSnap = Snap a -> Snap a
forall a. a -> a
id
#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
runRequestBody :: MonadSnap m =>
(InputStream ByteString -> IO a)
-> m a
runRequestBody :: (InputStream ByteString -> IO a) -> m a
runRequestBody proc :: InputStream ByteString -> IO a
proc = do
IO ()
bumpTimeout <- (((Int -> Int) -> IO ()) -> IO ())
-> m ((Int -> Int) -> IO ()) -> m (IO ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((Int -> Int) -> IO ()) -> (Int -> Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 5) m ((Int -> Int) -> IO ())
forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
InputStream ByteString
body <- IO (InputStream ByteString) -> m (InputStream ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (InputStream ByteString) -> m (InputStream ByteString))
-> IO (InputStream ByteString) -> m (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ IO ()
-> Double
-> Int
-> InputStream ByteString
-> IO (InputStream ByteString)
Streams.throwIfTooSlow IO ()
bumpTimeout 500 5 (InputStream ByteString -> IO (InputStream ByteString))
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$
Request -> InputStream ByteString
rqBody Request
req
InputStream ByteString -> m a
run InputStream ByteString
body
where
skip :: InputStream a -> m ()
skip body :: InputStream a
body = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (InputStream a -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream a
body) m () -> (RateTooSlowException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` RateTooSlowException -> m ()
forall (m :: * -> *) a. MonadSnap m => RateTooSlowException -> m a
tooSlow
tooSlow :: RateTooSlowException -> m a
tooSlow (RateTooSlowException
e :: Streams.RateTooSlowException) =
RateTooSlowException -> m a
forall e (m :: * -> *) a. (Exception e, MonadSnap m) => e -> m a
terminateConnection RateTooSlowException
e
run :: InputStream ByteString -> m a
run body :: InputStream ByteString
body = (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
a
x <- InputStream ByteString -> IO a
proc InputStream ByteString
body
InputStream ByteString -> IO ()
forall a. InputStream a -> IO ()
Streams.skipToEof InputStream ByteString
body
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x) m a -> [Handler m a] -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> [Handler m a] -> m a
`catches` [Handler m a]
handlers
where
handlers :: [Handler m a]
handlers = [ (RateTooSlowException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler RateTooSlowException -> m a
forall (m :: * -> *) a. MonadSnap m => RateTooSlowException -> m a
tooSlow, (SomeException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler SomeException -> m a
other ]
other :: SomeException -> m a
other (SomeException
e :: SomeException) = InputStream ByteString -> m ()
forall (m :: * -> *) a. MonadSnap m => InputStream a -> m ()
skip InputStream ByteString
body m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO SomeException
e
readRequestBody :: MonadSnap m =>
Word64
-> m L.ByteString
readRequestBody :: Word64 -> m ByteString
readRequestBody sz :: Word64
sz = ([ByteString] -> ByteString) -> m [ByteString] -> m ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
L.fromChunks (m [ByteString] -> m ByteString) -> m [ByteString] -> m ByteString
forall a b. (a -> b) -> a -> b
$ (InputStream ByteString -> IO [ByteString]) -> m [ByteString]
forall (m :: * -> *) a.
MonadSnap m =>
(InputStream ByteString -> IO a) -> m a
runRequestBody InputStream ByteString -> IO [ByteString]
f
where
f :: InputStream ByteString -> IO [ByteString]
f str :: InputStream ByteString
str = Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.throwIfProducesMoreThan (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) InputStream ByteString
str IO (InputStream ByteString)
-> (InputStream ByteString -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList
transformRequestBody :: (InputStream ByteString -> IO (InputStream ByteString))
-> Snap ()
transformRequestBody :: (InputStream ByteString -> IO (InputStream ByteString)) -> Snap ()
transformRequestBody trans :: InputStream ByteString -> IO (InputStream ByteString)
trans = do
Request
req <- Snap Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
InputStream Builder
is <- IO (InputStream Builder) -> Snap (InputStream Builder)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((InputStream ByteString -> IO (InputStream ByteString)
trans (InputStream ByteString -> IO (InputStream ByteString))
-> InputStream ByteString -> IO (InputStream ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> InputStream ByteString
rqBody Request
req) IO (InputStream ByteString)
-> (InputStream ByteString -> IO (InputStream Builder))
-> IO (InputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(ByteString -> IO Builder)
-> InputStream ByteString -> IO (InputStream Builder)
forall a b. (a -> IO b) -> InputStream a -> IO (InputStream b)
Streams.mapM (Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> IO Builder)
-> (ByteString -> Builder) -> ByteString -> IO Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString))
Response
origRsp <- Snap Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse
let rsp :: Response
rsp = (OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
setResponseBody (\out :: OutputStream Builder
out -> InputStream Builder -> OutputStream Builder -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream Builder
is OutputStream Builder
out IO () -> IO (OutputStream Builder) -> IO (OutputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
out) (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
Response
origRsp { rspTransformingRqBody :: Bool
rspTransformingRqBody = Bool
True }
Response -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith Response
rsp
finishWith :: MonadSnap m => Response -> m a
finishWith :: Response -> m a
finishWith r :: Response
r = Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \_ fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> Zero -> SnapState -> IO r
fk (Response -> Zero
EarlyTermination Response
r) SnapState
st
{-# INLINE finishWith #-}
catchFinishWith :: Snap a -> Snap (Either Response a)
catchFinishWith :: Snap a -> Snap (Either Response a)
catchFinishWith (Snap m :: forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m) = (forall r.
(Either Response a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap (Either Response a)
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(Either Response a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap (Either Response a))
-> (forall r.
(Either Response a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap (Either Response a)
forall a b. (a -> b) -> a -> b
$ \sk :: Either Response a -> SnapState -> IO r
sk fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> do
let sk' :: a -> SnapState -> IO r
sk' v :: a
v s :: SnapState
s = Either Response a -> SnapState -> IO r
sk (a -> Either Response a
forall a b. b -> Either a b
Right a
v) SnapState
s
let fk' :: Zero -> SnapState -> IO r
fk' z :: Zero
z s :: SnapState
s = case Zero
z of
(EarlyTermination resp :: Response
resp) -> Either Response a -> SnapState -> IO r
sk (Response -> Either Response a
forall a b. a -> Either a b
Left Response
resp) SnapState
s
_ -> Zero -> SnapState -> IO r
fk Zero
z SnapState
s
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m a -> SnapState -> IO r
sk' Zero -> SnapState -> IO r
fk' SnapState
st
{-# INLINE catchFinishWith #-}
pass :: MonadSnap m => m a
pass :: m a
pass = m a
forall (f :: * -> *) a. Alternative f => f a
empty
method :: MonadSnap m => Method -> m a -> m a
method :: Method -> m a -> m a
method m :: Method
m action :: m a
action = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request -> Method
rqMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
m) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
m a
action
{-# INLINE method #-}
methods :: MonadSnap m => [Method] -> m a -> m a
methods :: [Method] -> m a -> m a
methods ms :: [Method]
ms action :: m a
action = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request -> Method
rqMethod Request
req Method -> [Method] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Method]
ms) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
m a
action
{-# INLINE methods #-}
updateContextPath :: Int -> Request -> Request
updateContextPath :: Int -> Request -> Request
updateContextPath n :: Int
n req :: Request
req | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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', "/"]
pinfo :: ByteString
pinfo = Int -> ByteString -> ByteString
S.drop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Request -> ByteString
rqPathInfo Request
req)
pathWith :: MonadSnap m
=> (ByteString -> ByteString -> Bool)
-> ByteString
-> m a
-> m a
pathWith :: (ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith c :: ByteString -> ByteString -> Bool
c p :: ByteString
p action :: m a
action = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> ByteString -> Bool
c ByteString
p (Request -> ByteString
rqPathInfo Request
req)) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
(Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath (Int -> Request -> Request) -> Int -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
p) m a
action
dir :: MonadSnap m
=> ByteString
-> m a
-> m a
dir :: ByteString -> m a -> m a
dir = (ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
forall (m :: * -> *) a.
MonadSnap m =>
(ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith ByteString -> ByteString -> Bool
f
where
f :: ByteString -> ByteString -> Bool
f dr :: ByteString
dr pinfo :: ByteString
pinfo = ByteString
dr ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
x
where
(x :: ByteString
x,_) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='/') ByteString
pinfo
{-# INLINE dir #-}
path :: MonadSnap m
=> ByteString
-> m a
-> m a
path :: ByteString -> m a -> m a
path = (ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
forall (m :: * -> *) a.
MonadSnap m =>
(ByteString -> ByteString -> Bool) -> ByteString -> m a -> m a
pathWith ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==)
{-# INLINE path #-}
pathArg :: (R.Readable a, MonadSnap m)
=> (a -> m b)
-> m b
pathArg :: (a -> m b) -> m b
pathArg f :: a -> m b
f = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let (p :: ByteString
p,_) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='/') (Request -> ByteString
rqPathInfo Request
req)
ByteString
p' <- m ByteString
-> (ByteString -> m ByteString) -> Maybe ByteString -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ByteString
forall (m :: * -> *) a. MonadPlus m => m a
mzero ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m ByteString)
-> Maybe ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
urlDecode ByteString
p
a
a <- ByteString -> m a
forall a (m :: * -> *).
(Readable a, MonadPlus m) =>
ByteString -> m a
R.fromBS ByteString
p'
(Request -> Request) -> m b -> m b
forall (m :: * -> *) a.
MonadSnap m =>
(Request -> Request) -> m a -> m a
localRequest (Int -> Request -> Request
updateContextPath (Int -> Request -> Request) -> Int -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
p) (a -> m b
f a
a)
ifTop :: MonadSnap m => m a -> m a
ifTop :: m a -> m a
ifTop = ByteString -> m a -> m a
forall (m :: * -> *) a. MonadSnap m => ByteString -> m a -> m a
path ""
{-# INLINE ifTop #-}
sget :: Snap SnapState
sget :: Snap SnapState
sget = (forall r.
(SnapState -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap SnapState
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(SnapState -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap SnapState)
-> (forall r.
(SnapState -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap SnapState
forall a b. (a -> b) -> a -> b
$ \sk :: SnapState -> SnapState -> IO r
sk _ st :: SnapState
st -> SnapState -> SnapState -> IO r
sk SnapState
st SnapState
st
{-# INLINE sget #-}
smodify :: (SnapState -> SnapState) -> Snap ()
smodify :: (SnapState -> SnapState) -> Snap ()
smodify f :: SnapState -> SnapState
f = (forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ())
-> (forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a b. (a -> b) -> a -> b
$ \sk :: () -> SnapState -> IO r
sk _ st :: SnapState
st -> () -> SnapState -> IO r
sk () (SnapState -> SnapState
f SnapState
st)
{-# INLINE smodify #-}
getRequest :: MonadSnap m => m Request
getRequest :: m Request
getRequest = Snap Request -> m Request
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap Request -> m Request) -> Snap Request -> m Request
forall a b. (a -> b) -> a -> b
$ (SnapState -> Request) -> Snap SnapState -> Snap Request
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SnapState -> Request
_snapRequest Snap SnapState
sget
{-# INLINE getRequest #-}
getsRequest :: MonadSnap m => (Request -> a) -> m a
getsRequest :: (Request -> a) -> m a
getsRequest f :: Request -> a
f = Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (SnapState -> a) -> Snap SnapState -> Snap a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Request -> a
f (Request -> a) -> (SnapState -> Request) -> SnapState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapState -> Request
_snapRequest) Snap SnapState
sget
{-# INLINE getsRequest #-}
getResponse :: MonadSnap m => m Response
getResponse :: m Response
getResponse = Snap Response -> m Response
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap Response -> m Response) -> Snap Response -> m Response
forall a b. (a -> b) -> a -> b
$ (SnapState -> Response) -> Snap SnapState -> Snap Response
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SnapState -> Response
_snapResponse Snap SnapState
sget
{-# INLINE getResponse #-}
getsResponse :: MonadSnap m => (Response -> a) -> m a
getsResponse :: (Response -> a) -> m a
getsResponse f :: Response -> a
f = Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (SnapState -> a) -> Snap SnapState -> Snap a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Response -> a
f (Response -> a) -> (SnapState -> Response) -> SnapState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapState -> Response
_snapResponse) Snap SnapState
sget
{-# INLINE getsResponse #-}
putResponse :: MonadSnap m => Response -> m ()
putResponse :: Response -> m ()
putResponse r :: Response
r = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \ss :: SnapState
ss -> SnapState
ss { _snapResponse :: Response
_snapResponse = Response
r }
{-# INLINE putResponse #-}
putRequest :: MonadSnap m => Request -> m ()
putRequest :: Request -> m ()
putRequest r :: Request
r = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \ss :: SnapState
ss -> SnapState
ss { _snapRequest :: Request
_snapRequest = Request
r }
{-# INLINE putRequest #-}
modifyRequest :: MonadSnap m => (Request -> Request) -> m ()
modifyRequest :: (Request -> Request) -> m ()
modifyRequest f :: Request -> Request
f = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$
(SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \ss :: SnapState
ss -> SnapState
ss { _snapRequest :: Request
_snapRequest = Request -> Request
f (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ SnapState -> Request
_snapRequest SnapState
ss }
{-# INLINE modifyRequest #-}
modifyResponse :: MonadSnap m => (Response -> Response) -> m ()
modifyResponse :: (Response -> Response) -> m ()
modifyResponse f :: Response -> Response
f = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$
(SnapState -> SnapState) -> Snap ()
smodify ((SnapState -> SnapState) -> Snap ())
-> (SnapState -> SnapState) -> Snap ()
forall a b. (a -> b) -> a -> b
$ \ss :: SnapState
ss -> SnapState
ss { _snapResponse :: Response
_snapResponse = Response -> Response
f (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ SnapState -> Response
_snapResponse SnapState
ss }
{-# INLINE modifyResponse #-}
redirect :: MonadSnap m => ByteString -> m a
redirect :: ByteString -> m a
redirect target :: ByteString
target = ByteString -> Int -> m a
forall (m :: * -> *) a. MonadSnap m => ByteString -> Int -> m a
redirect' ByteString
target 302
{-# INLINE redirect #-}
redirect' :: MonadSnap m => ByteString -> Int -> m a
redirect' :: ByteString -> Int -> m a
redirect' target :: ByteString
target status :: Int
status = do
Response
r <- m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse
Response -> m a
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith
(Response -> m a) -> Response -> m a
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
setResponseCode Int
status
(Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Word64 -> Response -> Response
setContentLength 0
(Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ ((OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
modifyResponseBody ((OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder
-> IO (OutputStream Builder)
forall a b. a -> b -> a
const ((OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder
-> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder
-> IO (OutputStream Builder)
forall a b. (a -> b) -> a -> b
$ OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> OutputStream Builder)
-> OutputStream Builder
-> IO (OutputStream Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputStream Builder -> OutputStream Builder
forall a. a -> a
id)
(Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader "Location" ByteString
target Response
r
{-# INLINE redirect' #-}
logError :: MonadSnap m => ByteString -> m ()
logError :: ByteString -> m ()
logError s :: ByteString
s = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ())
-> (forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a b. (a -> b) -> a -> b
$ \sk :: () -> SnapState -> IO r
sk _ st :: SnapState
st -> do
SnapState -> ByteString -> IO ()
_snapLogError SnapState
st ByteString
s
() -> SnapState -> IO r
sk () SnapState
st
{-# INLINE logError #-}
addToOutput :: MonadSnap m
=> (OutputStream Builder -> IO (OutputStream Builder))
-> m ()
addToOutput :: (OutputStream Builder -> IO (OutputStream Builder)) -> m ()
addToOutput enum :: OutputStream Builder -> IO (OutputStream Builder)
enum = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ ((OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
modifyResponseBody ((OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> IO (OutputStream Builder))
-> OutputStream Builder
-> IO (OutputStream Builder)
forall (m :: * -> *) a b t.
Monad m =>
(a -> m b) -> (t -> m a) -> t -> m b
c OutputStream Builder -> IO (OutputStream Builder)
enum)
where
c :: (a -> m b) -> (t -> m a) -> t -> m b
c a :: a -> m b
a b :: t -> m a
b = \out :: t
out -> t -> m a
b t
out m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
a
writeBuilder :: MonadSnap m => Builder -> m ()
writeBuilder :: Builder -> m ()
writeBuilder b :: Builder
b = (OutputStream Builder -> IO (OutputStream Builder)) -> m ()
forall (m :: * -> *).
MonadSnap m =>
(OutputStream Builder -> IO (OutputStream Builder)) -> m ()
addToOutput OutputStream Builder -> IO (OutputStream Builder)
f
where
f :: OutputStream Builder -> IO (OutputStream Builder)
f str :: OutputStream Builder
str = Maybe Builder -> OutputStream Builder -> IO ()
forall a. Maybe a -> OutputStream a -> IO ()
Streams.write (Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
b) OutputStream Builder
str IO () -> IO (OutputStream Builder) -> IO (OutputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
str
{-# INLINE writeBuilder #-}
writeBS :: MonadSnap m => ByteString -> m ()
writeBS :: ByteString -> m ()
writeBS = Builder -> m ()
forall (m :: * -> *). MonadSnap m => Builder -> m ()
writeBuilder (Builder -> m ()) -> (ByteString -> Builder) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString
{-# INLINE writeBS #-}
writeLBS :: MonadSnap m => L.ByteString -> m ()
writeLBS :: ByteString -> m ()
writeLBS = Builder -> m ()
forall (m :: * -> *). MonadSnap m => Builder -> m ()
writeBuilder (Builder -> m ()) -> (ByteString -> Builder) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
lazyByteString
{-# INLINE writeLBS #-}
writeText :: MonadSnap m => T.Text -> m ()
writeText :: Text -> m ()
writeText = ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS (ByteString -> m ()) -> (Text -> ByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
{-# INLINE writeText #-}
writeLazyText :: MonadSnap m => LT.Text -> m ()
writeLazyText :: Text -> m ()
writeLazyText = ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS (ByteString -> m ()) -> (Text -> ByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
LT.encodeUtf8
{-# INLINE writeLazyText #-}
sendFile :: (MonadSnap m) => FilePath -> m ()
sendFile :: String -> m ()
sendFile f :: String
f = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \r :: Response
r -> Response
r { rspBody :: ResponseBody
rspBody = String -> Maybe (Word64, Word64) -> ResponseBody
SendFile String
f Maybe (Word64, Word64)
forall a. Maybe a
Nothing }
sendFilePartial :: (MonadSnap m) => FilePath -> (Word64, Word64) -> m ()
sendFilePartial :: String -> (Word64, Word64) -> m ()
sendFilePartial f :: String
f rng :: (Word64, Word64)
rng = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \r :: Response
r ->
Response
r { rspBody :: ResponseBody
rspBody = String -> Maybe (Word64, Word64) -> ResponseBody
SendFile String
f ((Word64, Word64) -> Maybe (Word64, Word64)
forall a. a -> Maybe a
Just (Word64, Word64)
rng) }
localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a
localRequest :: (Request -> Request) -> m a -> m a
localRequest f :: Request -> Request
f m :: m a
m = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
Request -> m a
runAct Request
req m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Request -> m ()
forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest Request
req m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
forall (m :: * -> *) a. MonadSnap m => m a
pass)
where
runAct :: Request -> m a
runAct req :: Request
req = do
(Request -> Request) -> m ()
forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest Request -> Request
f
a
result <- m a
m
Request -> m ()
forall (m :: * -> *). MonadSnap m => Request -> m ()
putRequest Request
req
a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
{-# INLINE localRequest #-}
withRequest :: MonadSnap m => (Request -> m a) -> m a
withRequest :: (Request -> m a) -> m a
withRequest = (m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
{-# INLINE withRequest #-}
withResponse :: MonadSnap m => (Response -> m a) -> m a
withResponse :: (Response -> m a) -> m a
withResponse = (m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse m Response -> (Response -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
{-# INLINE withResponse #-}
ipHeaderFilter :: MonadSnap m => m ()
= CI ByteString -> m ()
forall (m :: * -> *). MonadSnap m => CI ByteString -> m ()
ipHeaderFilter' "x-forwarded-for"
ipHeaderFilter' :: MonadSnap m => CI ByteString -> m ()
header :: CI ByteString
header = do
Maybe ByteString
headerContents <- CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
header (Request -> Maybe ByteString) -> m Request -> m (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let whitespace :: String
whitespace = [ ' ', '\t', '\r', '\n' ]
ipChrs :: String
ipChrs = '.' Char -> ShowS
forall a. a -> [a] -> [a]
: "0123456789"
trim :: ((a -> Bool) -> t) -> t a -> t
trim f :: (a -> Bool) -> t
f s :: t a
s = (a -> Bool) -> t
f (a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
s)
clean :: ByteString -> ByteString
clean = ((Char -> Bool) -> ByteString -> ByteString)
-> String -> ByteString -> ByteString
forall (t :: * -> *) a t.
(Foldable t, Eq a) =>
((a -> Bool) -> t) -> t a -> t
trim (Char -> Bool) -> ByteString -> ByteString
S.takeWhile String
ipChrs (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Bool) -> ByteString -> ByteString)
-> String -> ByteString -> ByteString
forall (t :: * -> *) a t.
(Foldable t, Eq a) =>
((a -> Bool) -> t) -> t a -> t
trim (Char -> Bool) -> ByteString -> ByteString
S.dropWhile String
whitespace
setIP :: ByteString -> m ()
setIP ip :: ByteString
ip = (Request -> Request) -> m ()
forall (m :: * -> *). MonadSnap m => (Request -> Request) -> m ()
modifyRequest ((Request -> Request) -> m ()) -> (Request -> Request) -> m ()
forall a b. (a -> b) -> a -> b
$ \rq :: Request
rq -> Request
rq { rqClientAddr :: ByteString
rqClientAddr = ByteString -> ByteString
clean ByteString
ip }
m () -> (ByteString -> m ()) -> Maybe ByteString -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()) ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
setIP Maybe ByteString
headerContents
bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c
bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c
bracketSnap before :: IO a
before after :: a -> IO b
after thing :: a -> Snap c
thing = ((forall a. Snap a -> Snap a) -> Snap c) -> Snap c
forall (m :: * -> *) b.
MonadBaseControl IO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. Snap a -> Snap a) -> Snap c) -> Snap c)
-> ((forall a. Snap a -> Snap a) -> Snap c) -> Snap c
forall a b. (a -> b) -> a -> b
$ \restore :: forall a. Snap a -> Snap a
restore ->
StateT SnapState IO (SnapResult c) -> Snap c
forall a. StateT SnapState IO (SnapResult a) -> Snap a
stateTToSnap (StateT SnapState IO (SnapResult c) -> Snap c)
-> StateT SnapState IO (SnapResult c) -> Snap c
forall a b. (a -> b) -> a -> b
$ do
a
a <- IO a -> StateT SnapState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
before
let after' :: StateT SnapState IO b
after' = IO b -> StateT SnapState IO b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> StateT SnapState IO b) -> IO b -> StateT SnapState IO b
forall a b. (a -> b) -> a -> b
$ a -> IO b
after a
a
SnapResult c
r <- Snap c -> StateT SnapState IO (SnapResult c)
forall a. Snap a -> StateT SnapState IO (SnapResult a)
snapToStateT (Snap c -> Snap c
forall a. Snap a -> Snap a
restore (Snap c -> Snap c) -> Snap c -> Snap c
forall a b. (a -> b) -> a -> b
$ a -> Snap c
thing a
a) StateT SnapState IO (SnapResult c)
-> StateT SnapState IO b -> StateT SnapState IO (SnapResult c)
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`onException` StateT SnapState IO b
after'
b
_ <- StateT SnapState IO b
after'
SnapResult c -> StateT SnapState IO (SnapResult c)
forall (m :: * -> *) a. Monad m => a -> m a
return SnapResult c
r
data NoHandlerException = NoHandlerException String
deriving (NoHandlerException -> NoHandlerException -> Bool
(NoHandlerException -> NoHandlerException -> Bool)
-> (NoHandlerException -> NoHandlerException -> Bool)
-> Eq NoHandlerException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoHandlerException -> NoHandlerException -> Bool
$c/= :: NoHandlerException -> NoHandlerException -> Bool
== :: NoHandlerException -> NoHandlerException -> Bool
$c== :: NoHandlerException -> NoHandlerException -> Bool
Eq, Typeable)
instance Show NoHandlerException where
show :: NoHandlerException -> String
show (NoHandlerException e :: String
e) = "No handler for request: failure was " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
instance Exception NoHandlerException
terminateConnection :: (Exception e, MonadSnap m) => e -> m a
terminateConnection :: e -> m a
terminateConnection e :: e
e =
Snap a -> m a
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap a -> m a) -> Snap a -> m a
forall a b. (a -> b) -> a -> b
$ (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a)
-> (forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
forall a b. (a -> b) -> a -> b
$ \_ fk :: Zero -> SnapState -> IO r
fk -> Zero -> SnapState -> IO r
fk (Zero -> SnapState -> IO r) -> Zero -> SnapState -> IO r
forall a b. (a -> b) -> a -> b
$ EscapeSnap -> Zero
EscapeSnap (EscapeSnap -> Zero) -> EscapeSnap -> Zero
forall a b. (a -> b) -> a -> b
$ SomeException -> EscapeSnap
TerminateConnection
(SomeException -> EscapeSnap) -> SomeException -> EscapeSnap
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
SomeException e
e
escapeHttp :: MonadSnap m =>
EscapeHttpHandler
-> m ()
escapeHttp :: EscapeHttpHandler -> m ()
escapeHttp h :: EscapeHttpHandler
h = Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ (forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a.
(forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap a
Snap ((forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ())
-> (forall r.
(() -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r)
-> Snap ()
forall a b. (a -> b) -> a -> b
$ \_ fk :: Zero -> SnapState -> IO r
fk st :: SnapState
st -> Zero -> SnapState -> IO r
fk (EscapeSnap -> Zero
EscapeSnap (EscapeSnap -> Zero) -> EscapeSnap -> Zero
forall a b. (a -> b) -> a -> b
$ EscapeHttpHandler -> EscapeSnap
EscapeHttp EscapeHttpHandler
h) SnapState
st
runSnap :: Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap :: Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO (Request, Response)
runSnap (Snap m :: forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m) logerr :: ByteString -> IO ()
logerr timeoutAction :: (Int -> Int) -> IO ()
timeoutAction req :: Request
req =
(a -> SnapState -> IO (Request, Response))
-> (Zero -> SnapState -> IO (Request, Response))
-> SnapState
-> IO (Request, Response)
forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m a -> SnapState -> IO (Request, Response)
forall (m :: * -> *) p.
Monad m =>
p -> SnapState -> m (Request, Response)
ok Zero -> SnapState -> IO (Request, Response)
diediedie SnapState
ss
where
ok :: p -> SnapState -> m (Request, Response)
ok _ st :: SnapState
st = (Request, Response) -> m (Request, Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapState -> Request
_snapRequest SnapState
st, SnapState -> Response
_snapResponse SnapState
st)
diediedie :: Zero -> SnapState -> IO (Request, Response)
diediedie z :: Zero
z !SnapState
st = do
Response
resp <- case Zero
z of
PassOnProcessing -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
fourohfour
(EarlyTermination x :: Response
x) -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
x
(EscapeSnap e :: EscapeSnap
e) -> EscapeSnap -> IO Response
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO EscapeSnap
e
(Request, Response) -> IO (Request, Response)
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapState -> Request
_snapRequest SnapState
st, Response
resp)
fourohfour :: Response
fourohfour = do
Response -> Response
clearContentLength (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
Int -> ByteString -> Response -> Response
setResponseStatus 404 "Not Found" (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
(OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
setResponseBody OutputStream Builder -> IO (OutputStream Builder)
enum404 (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
Response
emptyResponse
enum404 :: OutputStream Builder -> IO (OutputStream Builder)
enum404 out :: OutputStream Builder
out = do
InputStream Builder
is <- [Builder] -> IO (InputStream Builder)
forall c. [c] -> IO (InputStream c)
Streams.fromList [Builder]
html
InputStream Builder -> OutputStream Builder -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream Builder
is OutputStream Builder
out
OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
out
html :: [Builder]
html = (ByteString -> Builder) -> [ByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Builder
byteString [ "<!DOCTYPE html>\n"
, "<html>\n"
, "<head>\n"
, "<title>Not found</title>\n"
, "</head>\n"
, "<body>\n"
, "<code>No handler accepted \""
, Request -> ByteString
rqURI Request
req
, "\"</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 #-}
{-# INLINE fixupResponse #-}
fixupResponse :: Request -> Response -> IO Response
fixupResponse :: Request -> Response -> IO Response
fixupResponse req :: Request
req rsp :: Response
rsp = {-# SCC "fixupResponse" #-} do
Response
rsp' <- case Response -> ResponseBody
rspBody Response
rsp of
(Stream _) -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
rsp
(SendFile f :: String
f Nothing) -> String -> Response -> IO Response
setFileSize String
f Response
rsp
(SendFile _ (Just (s :: Word64
s,e :: Word64
e))) -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$! Word64 -> Response -> Response
setContentLength (Word64
eWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-Word64
s) Response
rsp
let !cl :: Maybe Word64
cl = if Bool
noBody then Maybe Word64
forall a. Maybe a
Nothing else Response -> Maybe Word64
rspContentLength Response
rsp'
let rsp'' :: Response
rsp'' = if Bool
noBody
then Response
rsp' { rspBody :: ResponseBody
rspBody = (OutputStream Builder -> IO (OutputStream Builder)) -> ResponseBody
Stream ((OutputStream Builder -> IO (OutputStream Builder))
-> ResponseBody)
-> (OutputStream Builder -> IO (OutputStream Builder))
-> ResponseBody
forall a b. (a -> b) -> a -> b
$ OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> OutputStream Builder)
-> OutputStream Builder
-> IO (OutputStream Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputStream Builder -> OutputStream Builder
forall a. a -> a
id
, rspContentLength :: Maybe Word64
rspContentLength = Maybe Word64
forall a. Maybe a
Nothing
}
else Response
rsp'
Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$! (Headers -> Headers) -> Response -> Response
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders ([(CI ByteString, ByteString)] -> Headers
H.fromList ([(CI ByteString, ByteString)] -> Headers)
-> (Headers -> [(CI ByteString, ByteString)]) -> Headers -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Word64
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a.
IsString a =>
Maybe Word64 -> [(a, ByteString)] -> [(a, ByteString)]
addCL Maybe Word64
cl ([(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)])
-> (Headers -> [(CI ByteString, ByteString)])
-> Headers
-> [(CI ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup ([(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)])
-> (Headers -> [(CI ByteString, ByteString)])
-> Headers
-> [(CI ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> [(CI ByteString, ByteString)]
H.toList) Response
rsp''
where
addCL :: Maybe Word64 -> [(a, ByteString)] -> [(a, ByteString)]
addCL Nothing xs :: [(a, ByteString)]
xs = [(a, ByteString)]
xs
addCL (Just cl :: Word64
cl) xs :: [(a, ByteString)]
xs = ("content-length", Word64 -> ByteString
word64ToByteString Word64
cl)(a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
:[(a, ByteString)]
xs
setFileSize :: FilePath -> Response -> IO Response
setFileSize :: String -> Response -> IO Response
setFileSize fp :: String
fp r :: Response
r = {-# SCC "setFileSize" #-} do
Word64
fs <- (FileOffset -> Word64) -> IO FileOffset -> IO Word64
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FileOffset -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO FileOffset -> IO Word64) -> IO FileOffset -> IO Word64
forall a b. (a -> b) -> a -> b
$ String -> IO FileOffset
getFileSize String
fp
Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$! Response
r { rspContentLength :: Maybe Word64
rspContentLength = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
fs }
getFileSize :: FilePath -> IO FileOffset
getFileSize :: String -> IO FileOffset
getFileSize fp :: String
fp = (FileStatus -> FileOffset) -> IO FileStatus -> IO FileOffset
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM FileStatus -> FileOffset
fileSize (IO FileStatus -> IO FileOffset) -> IO FileStatus -> IO FileOffset
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus String
fp
code :: Int
code = Response -> Int
rspStatus Response
rsp
noBody :: Bool
noBody = Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 204 Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 304 Bool -> Bool -> Bool
|| Request -> Method
rqMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
HEAD
fixup :: [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [] = []
fixup (("date",_):xs :: [(CI ByteString, ByteString)]
xs) = [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
fixup (("content-length",_):xs :: [(CI ByteString, ByteString)]
xs) = [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
fixup (x :: (CI ByteString, ByteString)
x@("transfer-encoding",_):xs :: [(CI ByteString, ByteString)]
xs) = if Bool
noBody
then [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
else (CI ByteString, ByteString)
x (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
fixup (x :: (CI ByteString, ByteString)
x:xs :: [(CI ByteString, ByteString)]
xs) = (CI ByteString, ByteString)
x (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
fixup [(CI ByteString, ByteString)]
xs
{-# INLINE countDigits #-}
countDigits :: Word64 -> Int
countDigits :: Word64 -> Int
countDigits v0 :: Word64
v0 = Int -> Word64 -> Int
forall t t. (Num t, Integral t) => t -> t -> t
go 1 Word64
v0
where go :: t -> t -> t
go !t
k v :: t
v
| t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< 10 = t
k
| t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< 100 = t
k t -> t -> t
forall a. Num a => a -> a -> a
+ 1
| t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< 1000 = t
k t -> t -> t
forall a. Num a => a -> a -> a
+ 2
| t
v t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< 10000 = t
k t -> t -> t
forall a. Num a => a -> a -> a
+ 3
| Bool
otherwise = t -> t -> t
go (t
kt -> t -> t
forall a. Num a => a -> a -> a
+4) (t
v t -> t -> t
forall a. Integral a => a -> a -> a
`quot` 10000)
{-# INLINE word64ToByteString #-}
word64ToByteString :: Word64 -> ByteString
word64ToByteString :: Word64 -> ByteString
word64ToByteString d :: Word64
d =
#if !MIN_VERSION_bytestring(0,10,6)
S.inlinePerformIO $
#else
IO ByteString -> ByteString
forall a. IO a -> a
S.accursedUnutterablePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
#endif
if Word64
d Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< 10
then Int -> (Ptr Word8 -> IO ()) -> IO ByteString
S.create 1 ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p -> Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
p (Word64 -> Word8
i2w Word64
d)
else let !n :: Int
n = Word64 -> Int
countDigits Word64
d
in Int -> (Ptr Word8 -> IO ()) -> IO ByteString
S.create Int
n ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word64 -> Ptr Word8 -> IO ()
posDecimal Int
n Word64
d
{-# INLINE posDecimal #-}
posDecimal :: Int -> Word64 -> Ptr Word8 -> IO ()
posDecimal :: Int -> Word64 -> Ptr Word8 -> IO ()
posDecimal !Int
n0 !Word64
v0 !Ptr Word8
op0 = Int -> Ptr Word8 -> Word64 -> IO ()
forall t. (Eq t, Num t) => t -> Ptr Word8 -> Word64 -> IO ()
go Int
n0 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op0 (Int
n0Int -> Int -> Int
forall a. Num a => a -> a -> a
-1)) Word64
v0
where go :: t -> Ptr Word8 -> Word64 -> IO ()
go !t
n !Ptr Word8
op !Word64
v
| t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$! Word64 -> Word8
i2w Word64
v
| Bool
otherwise = do
let (!Word64
v', !Word64
d) = Word64 -> Word64 -> (Word64, Word64)
forall a. Integral a => a -> a -> (a, a)
divMod Word64
v 10
Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$! Word64 -> Word8
i2w Word64
d
t -> Ptr Word8 -> Word64 -> IO ()
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
op (-1)) Word64
v'
{-# INLINE i2w #-}
i2w :: Word64 -> Word8
i2w :: Word64 -> Word8
i2w v :: Word64
v = 48 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v
evalSnap :: Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
evalSnap :: Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> IO a
evalSnap (Snap m :: forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m) logerr :: ByteString -> IO ()
logerr timeoutAction :: (Int -> Int) -> IO ()
timeoutAction req :: Request
req =
(a -> SnapState -> IO a)
-> (Zero -> SnapState -> IO a) -> SnapState -> IO a
forall r.
(a -> SnapState -> IO r)
-> (Zero -> SnapState -> IO r) -> SnapState -> IO r
m (\v :: a
v _ -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v) Zero -> SnapState -> IO a
forall (m :: * -> *) p a. MonadBase IO m => Zero -> p -> m a
diediedie SnapState
ss
where
diediedie :: Zero -> p -> m a
diediedie z :: Zero
z _ = case Zero
z of
PassOnProcessing -> NoHandlerException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (NoHandlerException -> m a) -> NoHandlerException -> m a
forall a b. (a -> b) -> a -> b
$ String -> NoHandlerException
NoHandlerException "pass"
(EarlyTermination _) -> ErrorCall -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (ErrorCall -> m a) -> ErrorCall -> m a
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall "no value"
(EscapeSnap e :: EscapeSnap
e) -> EscapeSnap -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO EscapeSnap
e
dresp :: Response
dresp = Response
emptyResponse
ss :: SnapState
ss = Request
-> Response
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> SnapState
SnapState Request
req Response
dresp ByteString -> IO ()
logerr (Int -> Int) -> IO ()
timeoutAction
{-# INLINE evalSnap #-}
getParamFrom :: MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString
-> m (Maybe ByteString)
getParamFrom :: (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom f :: ByteString -> Request -> Maybe [ByteString]
f k :: ByteString
k = do
Request
rq <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
Maybe ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m (Maybe ByteString))
-> Maybe ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$! ([ByteString] -> ByteString)
-> Maybe [ByteString] -> Maybe ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> [ByteString] -> ByteString
S.intercalate " ") (Maybe [ByteString] -> Maybe ByteString)
-> Maybe [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Maybe [ByteString]
f ByteString
k Request
rq
{-# INLINE getParamFrom #-}
getParam :: MonadSnap m
=> ByteString
-> m (Maybe ByteString)
getParam :: ByteString -> m (Maybe ByteString)
getParam = (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
rqParam
{-# INLINE getParam #-}
getPostParam :: MonadSnap m
=> ByteString
-> m (Maybe ByteString)
getPostParam :: ByteString -> m (Maybe ByteString)
getPostParam = (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
rqPostParam
{-# INLINE getPostParam #-}
getQueryParam :: MonadSnap m
=> ByteString
-> m (Maybe ByteString)
getQueryParam :: ByteString -> m (Maybe ByteString)
getQueryParam = (ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString -> m (Maybe ByteString)
getParamFrom ByteString -> Request -> Maybe [ByteString]
rqQueryParam
{-# INLINE getQueryParam #-}
getParams :: MonadSnap m => m Params
getParams :: m Params
getParams = m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m Params) -> m Params
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Params -> m Params
forall (m :: * -> *) a. Monad m => a -> m a
return (Params -> m Params) -> (Request -> Params) -> Request -> m Params
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Params
rqParams
getPostParams :: MonadSnap m => m Params
getPostParams :: m Params
getPostParams = m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m Params) -> m Params
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Params -> m Params
forall (m :: * -> *) a. Monad m => a -> m a
return (Params -> m Params) -> (Request -> Params) -> Request -> m Params
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Params
rqPostParams
getQueryParams :: MonadSnap m => m Params
getQueryParams :: m Params
getQueryParams = m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest m Request -> (Request -> m Params) -> m Params
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Params -> m Params
forall (m :: * -> *) a. Monad m => a -> m a
return (Params -> m Params) -> (Request -> Params) -> Request -> m Params
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Params
rqQueryParams
getCookie :: MonadSnap m
=> ByteString
-> m (Maybe Cookie)
getCookie :: ByteString -> m (Maybe Cookie)
getCookie name :: ByteString
name = (Request -> m (Maybe Cookie)) -> m (Maybe Cookie)
forall (m :: * -> *) a. MonadSnap m => (Request -> m a) -> m a
withRequest ((Request -> m (Maybe Cookie)) -> m (Maybe Cookie))
-> (Request -> m (Maybe Cookie)) -> m (Maybe Cookie)
forall a b. (a -> b) -> a -> b
$
Maybe Cookie -> m (Maybe Cookie)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Cookie -> m (Maybe Cookie))
-> (Request -> Maybe Cookie) -> Request -> m (Maybe Cookie)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cookie] -> Maybe Cookie
forall a. [a] -> Maybe a
listToMaybe ([Cookie] -> Maybe Cookie)
-> (Request -> [Cookie]) -> Request -> Maybe Cookie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cookie -> Bool) -> [Cookie] -> [Cookie]
forall a. (a -> Bool) -> [a] -> [a]
filter (\c :: Cookie
c -> Cookie -> ByteString
cookieName Cookie
c ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
name) ([Cookie] -> [Cookie])
-> (Request -> [Cookie]) -> Request -> [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Cookie]
rqCookies
readCookie :: (MonadSnap m, R.Readable a)
=> ByteString
-> m a
readCookie :: ByteString -> m a
readCookie name :: ByteString
name = m a -> (Cookie -> m a) -> Maybe Cookie -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. MonadSnap m => m a
pass (ByteString -> m a
forall a (m :: * -> *).
(Readable a, MonadPlus m) =>
ByteString -> m a
R.fromBS (ByteString -> m a) -> (Cookie -> ByteString) -> Cookie -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> ByteString
cookieValue) (Maybe Cookie -> m a) -> m (Maybe Cookie) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> m (Maybe Cookie)
forall (m :: * -> *). MonadSnap m => ByteString -> m (Maybe Cookie)
getCookie ByteString
name
expireCookie :: (MonadSnap m) => Cookie -> m ()
expireCookie :: Cookie -> m ()
expireCookie cookie :: Cookie
cookie = do
let old :: UTCTime
old = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay 0) 0
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Cookie -> Response -> Response
addResponseCookie
(Cookie -> Response -> Response) -> Cookie -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Cookie
cookie { cookieValue :: ByteString
cookieValue = ""
, cookieExpires :: Maybe UTCTime
cookieExpires = (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
old) }
setTimeout :: MonadSnap m => Int -> m ()
setTimeout :: Int -> m ()
setTimeout = (Int -> Int) -> m ()
forall (m :: * -> *). MonadSnap m => (Int -> Int) -> m ()
modifyTimeout ((Int -> Int) -> m ()) -> (Int -> Int -> Int) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a b. a -> b -> a
const
extendTimeout :: MonadSnap m => Int -> m ()
extendTimeout :: Int -> m ()
extendTimeout = (Int -> Int) -> m ()
forall (m :: * -> *). MonadSnap m => (Int -> Int) -> m ()
modifyTimeout ((Int -> Int) -> m ()) -> (Int -> Int -> Int) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max
modifyTimeout :: MonadSnap m => (Int -> Int) -> m ()
modifyTimeout :: (Int -> Int) -> m ()
modifyTimeout f :: Int -> Int
f = do
(Int -> Int) -> IO ()
m <- m ((Int -> Int) -> IO ())
forall (m :: * -> *). MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> IO ()
m Int -> Int
f
getTimeoutModifier :: MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier :: m ((Int -> Int) -> IO ())
getTimeoutModifier = Snap ((Int -> Int) -> IO ()) -> m ((Int -> Int) -> IO ())
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap ((Int -> Int) -> IO ()) -> m ((Int -> Int) -> IO ()))
-> Snap ((Int -> Int) -> IO ()) -> m ((Int -> Int) -> IO ())
forall a b. (a -> b) -> a -> b
$ (SnapState -> (Int -> Int) -> IO ())
-> Snap SnapState -> Snap ((Int -> Int) -> IO ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SnapState -> (Int -> Int) -> IO ()
_snapModifyTimeout Snap SnapState
sget