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") $
setContentLength 0 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.5.0/src/Snap/Internal/Parsing.hs 0000644 0000000 0000000 00000041644 12236240457 017161 0 ustar 00 0000000 0000000 {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.Internal.Parsing where
------------------------------------------------------------------------------
import Blaze.ByteString.Builder
import Control.Applicative
import Control.Arrow (first, second)
import Control.Monad
import Data.Attoparsec.Char8
import Data.Bits
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Char hiding (isDigit, isSpace)
import Data.Int
import Data.List (intersperse)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Word
import GHC.Exts
import GHC.Word (Word8 (..))
import Prelude hiding (head, take, takeWhile)
------------------------------------------------------------------------------
import Snap.Internal.Http.Types
import Snap.Internal.Parsing.FastSet (FastSet)
import qualified Snap.Internal.Parsing.FastSet as FS
------------------------------------------------------------------------------
{-# INLINE fullyParse #-}
fullyParse :: ByteString -> Parser a -> Either String a
fullyParse s p =
case r' of
(Fail _ _ e) -> Left e
(Partial _) -> Left "parse failed"
(Done _ x) -> Right x
where
r = parse p s
r' = feed r ""
------------------------------------------------------------------------------
parseNum :: Parser Int64
parseNum = decimal
------------------------------------------------------------------------------
-- | Parsers for different tokens in an HTTP request.
sp, digit, letter :: Parser Char
sp = char ' '
digit = satisfy isDigit
letter = satisfy isAlpha
------------------------------------------------------------------------------
untilEOL :: Parser ByteString
untilEOL = takeWhile notend
where
notend c = not $ c == '\r' || c == '\n'
------------------------------------------------------------------------------
crlf :: Parser ByteString
crlf = string "\r\n"
------------------------------------------------------------------------------
generateFS :: (Word8 -> Bool) -> FastSet
generateFS f = FS.fromList $ filter f [0..255]
------------------------------------------------------------------------------
-- | Parser for zero or more spaces.
spaces :: Parser [Char]
spaces = many sp
------------------------------------------------------------------------------
pSpaces :: Parser ByteString
pSpaces = takeWhile isSpace
------------------------------------------------------------------------------
fieldChars :: Parser ByteString
fieldChars = takeWhile isFieldChar
where
isFieldChar = flip FS.memberChar fieldCharSet
------------------------------------------------------------------------------
fieldCharSet :: FastSet
fieldCharSet = generateFS f
where
f d = let c = (toEnum $ fromEnum d)
in (isDigit c) || (isAlpha c) || c == '-' || c == '_'
------------------------------------------------------------------------------
-- | Parser for request headers.
pHeaders :: Parser [(ByteString, ByteString)]
pHeaders = many header
where
--------------------------------------------------------------------------
header = {-# SCC "pHeaders/header" #-}
liftA2 (,)
fieldName
(char ':' *> spaces *> contents)
--------------------------------------------------------------------------
fieldName = {-# SCC "pHeaders/fieldName" #-}
liftA2 S.cons letter fieldChars
--------------------------------------------------------------------------
contents = {-# SCC "pHeaders/contents" #-}
liftA2 S.append
(untilEOL <* crlf)
(continuation <|> pure S.empty)
--------------------------------------------------------------------------
isLeadingWS w = {-# SCC "pHeaders/isLeadingWS" #-}
w == ' ' || w == '\t'
--------------------------------------------------------------------------
leadingWhiteSpace = {-# SCC "pHeaders/leadingWhiteSpace" #-}
takeWhile1 isLeadingWS
--------------------------------------------------------------------------
continuation = {-# SCC "pHeaders/continuation" #-}
liftA2 S.cons
(leadingWhiteSpace *> pure ' ')
contents
------------------------------------------------------------------------------
-- unhelpfully, the spec mentions "old-style" cookies that don't have quotes
-- around the value. wonderful.
pWord :: Parser ByteString
pWord = pQuotedString <|> (takeWhile (/= ';'))
------------------------------------------------------------------------------
pQuotedString :: Parser ByteString
pQuotedString = q *> quotedText <* q
where
quotedText = (S.concat . reverse) <$> f []
f soFar = do
t <- takeWhile qdtext
let soFar' = t:soFar
-- RFC says that backslash only escapes for <">
choice [ string "\\\"" *> f ("\"" : soFar')
, pure soFar' ]
q = char '\"'
qdtext = matchAll [ isRFCText, (/= '\"'), (/= '\\') ]
------------------------------------------------------------------------------
{-# INLINE isRFCText #-}
isRFCText :: Char -> Bool
isRFCText = not . isControl
------------------------------------------------------------------------------
{-# INLINE matchAll #-}
matchAll :: [ Char -> Bool ] -> Char -> Bool
matchAll x c = and $ map ($ c) x
------------------------------------------------------------------------------
pAvPairs :: Parser [(ByteString, ByteString)]
pAvPairs = do
a <- pAvPair
b <- many (pSpaces *> char ';' *> pSpaces *> pAvPair)
return $! a:b
------------------------------------------------------------------------------
{-# INLINE pAvPair #-}
pAvPair :: Parser (ByteString, ByteString)
pAvPair = do
key <- pToken <* pSpaces
val <- liftM trim (option "" $ char '=' *> pSpaces *> pWord)
return $! (key, val)
------------------------------------------------------------------------------
pParameter :: Parser (ByteString, ByteString)
pParameter = do
key <- pToken <* pSpaces
val <- liftM trim (char '=' *> pSpaces *> pWord)
return $! (trim key, val)
------------------------------------------------------------------------------
{-# INLINE trim #-}
trim :: ByteString -> ByteString
trim = snd . S.span isSpace . fst . S.spanEnd isSpace
------------------------------------------------------------------------------
pValueWithParameters :: Parser (ByteString, [(CI ByteString, ByteString)])
pValueWithParameters = do
value <- liftM trim (pSpaces *> takeWhile (/= ';'))
params <- many pParam
return (value, map (first CI.mk) params)
where
pParam = pSpaces *> char ';' *> pSpaces *> pParameter
------------------------------------------------------------------------------
pContentTypeWithParameters :: Parser ( ByteString
, [(CI ByteString, ByteString)] )
pContentTypeWithParameters = do
value <- liftM trim (pSpaces *> takeWhile (not . isSep))
params <- many (pSpaces *> satisfy isSep *> pSpaces *> pParameter)
return $! (value, map (first CI.mk) params)
where
isSep c = c == ';' || c == ','
------------------------------------------------------------------------------
{-# INLINE pToken #-}
pToken :: Parser ByteString
pToken = takeWhile isToken
------------------------------------------------------------------------------
{-# INLINE isToken #-}
isToken :: Char -> Bool
isToken c = FS.memberChar c tokenTable
------------------------------------------------------------------------------
tokenTable :: FastSet
tokenTable = generateFS (f . toEnum . fromEnum)
where
f = matchAll [ isAscii
, not . isControl
, not . isSpace
, not . flip elem [ '(', ')', '<', '>', '@', ',', ';'
, ':', '\\', '\"', '/', '[', ']'
, '?', '=', '{', '}' ]
]
------------------
-- Url encoding --
------------------
------------------------------------------------------------------------------
{-# INLINE parseToCompletion #-}
parseToCompletion :: Parser a -> ByteString -> Maybe a
parseToCompletion p s = toResult $ finish r
where
r = parse p s
toResult (Done _ c) = Just c
toResult _ = Nothing
------------------------------------------------------------------------------
type DList a = [a] -> [a]
pUrlEscaped :: Parser ByteString
pUrlEscaped = do
sq <- nextChunk id
return $! S.concat $ sq []
where
--------------------------------------------------------------------------
nextChunk :: DList ByteString -> Parser (DList ByteString)
nextChunk !s = (endOfInput *> pure s) <|> do
c <- anyChar
case c of
'+' -> plusSpace s
'%' -> percentEncoded s
_ -> unEncoded c s
--------------------------------------------------------------------------
percentEncoded :: DList ByteString -> Parser (DList ByteString)
percentEncoded !l = do
hx <- take 2
when (S.length hx /= 2 || (not $ S.all isHexDigit hx)) $
fail "bad hex in url"
let code = w2c ((unsafeFromHex hx) :: Word8)
nextChunk $ l . ((S.singleton code) :)
--------------------------------------------------------------------------
unEncoded :: Char -> DList ByteString -> Parser (DList ByteString)
unEncoded !c !l' = do
let l = l' . ((S.singleton c) :)
bs <- takeTill (flip elem "%+")
if S.null bs
then nextChunk l
else nextChunk $ l . (bs :)
--------------------------------------------------------------------------
plusSpace :: DList ByteString -> Parser (DList ByteString)
plusSpace l = nextChunk (l . ((S.singleton ' ') :))
------------------------------------------------------------------------------
-- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'(),"
-- [not including the quotes - ed], and reserved characters used for their
-- reserved purposes may be used unencoded within a URL."
------------------------------------------------------------------------------
-- | Decodes an URL-escaped string (see
-- | File Name | Type | Last Modified" writeBS " |
|---|---|---|
| .. | DIR | |
| " writeBS f writeBS " | DIR | |
| " writeBS f writeBS " | " writeBS (fileType mm f0) writeBS " | " writeBS tm writeBS " |