No handler accepted \""
]
, rqURI req
, "\"\n"
]
--------------------------------------------------------------------------
dresp = emptyResponse { rspHttpVersion = rqVersion req }
--------------------------------------------------------------------------
ss = SnapState req dresp logerr 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.
fixupResponse :: Request -> Response -> IO Response
fixupResponse req rsp = {-# SCC "fixupResponse" #-} do
let code = rspStatus rsp
let rsp' = if code == 204 || code == 304
then handle304 rsp
else rsp
rsp'' <- do
z <- case rspBody rsp' of
(Enum _) -> return rsp'
(SendFile f Nothing) -> setFileSize f rsp'
(SendFile _ (Just (s,e))) -> return $!
setContentLength (e-s) rsp'
return $!
case rspContentLength z of
Nothing -> deleteHeader "Content-Length" z
(Just sz) -> setHeader "Content-Length"
(toByteString $ fromShow sz)
z
-- HEAD requests cannot have bodies per RFC 2616 sec. 9.4
if rqMethod req == HEAD
then return $! deleteHeader "Transfer-Encoding" $
rsp'' { rspBody = Enum $ enumBuilder mempty }
else return $! rsp''
where
--------------------------------------------------------------------------
setFileSize :: FilePath -> Response -> IO Response
setFileSize fp r = {-# SCC "setFileSize" #-} do
fs <- liftM fromIntegral $ getFileSize fp
return $! r { rspContentLength = Just fs }
------------------------------------------------------------------------------
getFileSize :: FilePath -> IO FileOffset
getFileSize fp = liftM fileSize $ getFileStatus fp
--------------------------------------------------------------------------
handle304 :: Response -> Response
handle304 r = setResponseBody (enumBuilder mempty) $
updateHeaders (H.delete "Transfer-Encoding") $
clearContentLength r
{-# INLINE fixupResponse #-}
------------------------------------------------------------------------------
evalSnap :: Snap a
-> (ByteString -> IO ())
-> ((Int -> Int) -> IO ())
-> Request
-> Iteratee ByteString IO a
evalSnap (Snap m) logerr timeoutAction req = do
(r, _) <- runStateT m ss
case r of
SnapValue x -> return x
PassOnProcessing e -> liftIO $ throwIO $ NoHandlerException e
EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value"
where
dresp = emptyResponse { rspHttpVersion = rqVersion req }
ss = SnapState req dresp logerr timeoutAction
{-# INLINE evalSnap #-}
------------------------------------------------------------------------------
getParamFrom :: MonadSnap m =>
(ByteString -> Request -> Maybe [ByteString])
-> ByteString
-> m (Maybe ByteString)
getParamFrom f k = do
rq <- getRequest
return $! liftM (S.intercalate " ") $ f k 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' \" \"@
--
getParam :: MonadSnap m
=> ByteString -- ^ parameter name to look up
-> m (Maybe ByteString)
getParam = getParamFrom 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' \" \"@
--
getPostParam :: MonadSnap m
=> ByteString -- ^ parameter name to look up
-> m (Maybe ByteString)
getPostParam = getParamFrom 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' \" \"@
--
getQueryParam :: MonadSnap m
=> ByteString -- ^ parameter name to look up
-> m (Maybe ByteString)
getQueryParam = getParamFrom rqQueryParam
{-# INLINE getQueryParam #-}
------------------------------------------------------------------------------
-- | See 'rqParams'. Convenience function to return 'Params' from the
-- 'Request' inside of a 'MonadSnap' instance.
getParams :: MonadSnap m => m Params
getParams = getRequest >>= return . rqParams
------------------------------------------------------------------------------
-- | See 'rqParams'. Convenience function to return 'Params' from the
-- 'Request' inside of a 'MonadSnap' instance.
getPostParams :: MonadSnap m => m Params
getPostParams = getRequest >>= return . rqPostParams
------------------------------------------------------------------------------
-- | See 'rqParams'. Convenience function to return 'Params' from the
-- 'Request' inside of a 'MonadSnap' instance.
getQueryParams :: MonadSnap m => m Params
getQueryParams = getRequest >>= return . rqQueryParams
------------------------------------------------------------------------------
-- | Gets the HTTP 'Cookie' with the specified name.
getCookie :: MonadSnap m
=> ByteString
-> m (Maybe Cookie)
getCookie name = withRequest $
return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies
------------------------------------------------------------------------------
-- | Gets the HTTP 'Cookie' with the specified name and decodes it. If the
-- decoding fails, the handler calls pass.
readCookie :: (MonadSnap m, Readable a)
=> ByteString
-> m a
readCookie name = maybe pass (fromBS . cookieValue) =<< getCookie name
------------------------------------------------------------------------------
-- | Expire the given 'Cookie' in client's browser.
expireCookie :: (MonadSnap m)
=> ByteString
-- ^ Cookie name
-> Maybe ByteString
-- ^ Cookie domain
-> m ()
expireCookie nm dm = do
let old = UTCTime (ModifiedJulianDay 0) 0
modifyResponse $ addResponseCookie
$ Cookie nm "" (Just old) Nothing dm False False
------------------------------------------------------------------------------
-- | Causes the handler thread to be killed @n@ seconds from now.
setTimeout :: MonadSnap m => Int -> m ()
setTimeout = modifyTimeout . const
------------------------------------------------------------------------------
-- | Causes the handler thread to be killed at least @n@ seconds from now.
extendTimeout :: MonadSnap m => Int -> m ()
extendTimeout = modifyTimeout . max
------------------------------------------------------------------------------
-- | Modifies the amount of time remaining before the request times out.
modifyTimeout :: MonadSnap m => (Int -> Int) -> m ()
modifyTimeout f = do
m <- getTimeoutModifier
liftIO $ m f
------------------------------------------------------------------------------
-- | Returns an 'IO' action which you can use to set the handling thread's
-- timeout value.
getTimeoutAction :: MonadSnap m => m (Int -> IO ())
getTimeoutAction = do
modifier <- liftSnap $ liftM _snapModifyTimeout sget
return $! modifier . const
{-# DEPRECATED getTimeoutAction
"use getTimeoutModifier instead. Since 0.8." #-}
------------------------------------------------------------------------------
-- | Returns an 'IO' action which you can use to modify the timeout value.
getTimeoutModifier :: MonadSnap m => m ((Int -> Int) -> IO ())
getTimeoutModifier = liftSnap $ liftM _snapModifyTimeout sget
snap-core-0.9.8.0/src/Snap/Internal/Http/ 0000755 0000000 0000000 00000000000 12565252520 016132 5 ustar 00 0000000 0000000 snap-core-0.9.8.0/src/Snap/Internal/Http/Types.hs 0000644 0000000 0000000 00000074735 12565252520 017612 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeSynonymInstances #-}
------------------------------------------------------------------------------
-- | An internal Snap module containing HTTP types.
--
-- /N.B./ this is an internal interface, please don't write user code that
-- depends on it. Most of these declarations (except for the
-- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Core".
--
module Snap.Internal.Http.Types where
------------------------------------------------------------------------------
import Blaze.ByteString.Builder
import Control.Monad (liftM)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w,w2c)
import qualified Data.ByteString as S
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Int
import qualified Data.IntMap as IM
import Data.IORef
import Data.List hiding (take)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Time.Clock
import Foreign.C.Types
import Prelude hiding (take)
------------------------------------------------------------------------------
#ifdef PORTABLE
import Data.Time.Format
import Data.Time.LocalTime
import Data.Time.Clock.POSIX
import Data.Time.Locale.Compat (defaultTimeLocale)
#else
import Data.Time.Format ()
import Foreign
import qualified Data.ByteString.Unsafe as S
import Foreign.C.String
#endif
------------------------------------------------------------------------------
import Snap.Iteratee (Enumerator)
import qualified Snap.Iteratee as I
import Snap.Types.Headers (Headers)
import qualified Snap.Types.Headers as H
#ifndef PORTABLE
------------------------------------------------------------------------------
-- foreign imports from cbits
foreign import ccall unsafe "set_c_locale"
set_c_locale :: IO ()
foreign import ccall unsafe "c_parse_http_time"
c_parse_http_time :: CString -> IO CTime
foreign import ccall unsafe "c_format_http_time"
c_format_http_time :: CTime -> CString -> IO ()
foreign import ccall unsafe "c_format_log_time"
c_format_log_time :: CTime -> CString -> IO ()
#endif
------------------------------------------------------------------------------
-- | A typeclass for datatypes which contain HTTP headers.
class HasHeaders a where
-- | Modify the datatype's headers.
updateHeaders :: (Headers -> Headers) -> a -> a
-- | Retrieve the headers from a datatype that has headers.
headers :: a -> Headers
------------------------------------------------------------------------------
-- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header
-- with the same name already exists, the new value is appended to the headers
-- list.
addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
addHeader k v = updateHeaders $ H.insert k v
------------------------------------------------------------------------------
-- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with
-- the same name already exists, it is overwritten with the new value.
setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
setHeader k v = updateHeaders $ H.set k v
------------------------------------------------------------------------------
-- | Gets all of the values for a given header.
getHeaders :: (HasHeaders a) => CI ByteString -> a -> Maybe [ByteString]
getHeaders k a = H.lookup k $ headers a
------------------------------------------------------------------------------
-- | Gets a header value out of a 'HasHeaders' datatype. If many headers came
-- in with the same name, they will be catenated together.
getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString
getHeader k a = liftM (S.intercalate ",") (H.lookup k $ headers a)
------------------------------------------------------------------------------
-- | Lists all the headers out of a 'HasHeaders' datatype. If many
-- headers came in with the same name, they will be catenated together.
listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)]
listHeaders = H.toList . headers
------------------------------------------------------------------------------
-- | Clears a header value from a 'HasHeaders' datatype.
deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a
deleteHeader k = updateHeaders $ H.delete k
------------------------------------------------------------------------------
-- | Enumerates the HTTP method values (see
-- | File Name | Type | Last Modified" writeBS " |
|---|---|---|
| .. | DIR | |
| " writeBS f writeBS " | DIR | |
| " writeBS f writeBS " | " writeBS (fileType mm f0) writeBS " | " writeBS tm writeBS " |