module Snap.Internal.Http.Types where
import Control.Applicative hiding (empty)
import Control.Monad (liftM, when)
import qualified Data.Attoparsec as Atto
import Data.Attoparsec hiding (many, Result(..))
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w,w2c)
import qualified Data.ByteString.Nums.Careless.Hex as Cvt
import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe as S
import Data.Char
import Data.DList (DList)
import qualified Data.DList as DL
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.Serialize.Builder
import Data.Time.Clock
import Data.Time.Format
import Data.Word
import Foreign hiding (new)
import Foreign.C.Types
import Prelude hiding (take)
import System.Locale (defaultTimeLocale)
#ifdef PORTABLE
import Data.Time.LocalTime
import Data.Time.Clock.POSIX
#else
import Foreign.C.String
#endif
import Data.CIByteString
import qualified Snap.Iteratee as I
#ifndef PORTABLE
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
type Enumerator a = I.Enumerator IO a
type Headers = Map CIByteString [ByteString]
class HasHeaders a where
updateHeaders :: (Headers -> Headers) -> a -> a
headers :: a -> Headers
addHeader :: (HasHeaders a) => CIByteString -> ByteString -> a -> a
addHeader k v = updateHeaders $ Map.insertWith' (++) k [v]
setHeader :: (HasHeaders a) => CIByteString -> ByteString -> a -> a
setHeader k v = updateHeaders $ Map.insert k [v]
getHeaders :: (HasHeaders a) => CIByteString -> a -> Maybe [ByteString]
getHeaders k a = Map.lookup k $ headers a
getHeader :: (HasHeaders a) => CIByteString -> a -> Maybe ByteString
getHeader k a = liftM (S.intercalate " ") (Map.lookup k $ headers a)
data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT
deriving(Show,Read,Ord,Eq)
type HttpVersion = (Int,Int)
data Cookie = Cookie {
cookieName :: !ByteString
, cookieValue :: !ByteString
, cookieExpires :: !(Maybe UTCTime)
, cookieDomain :: !(Maybe ByteString)
, cookiePath :: !(Maybe ByteString)
} deriving (Eq, Show)
type Params = Map ByteString [ByteString]
data SomeEnumerator = SomeEnumerator (forall a . Enumerator a)
data Request = Request
{
rqServerName :: !ByteString
, rqServerPort :: !Int
, rqRemoteAddr :: !ByteString
, rqRemotePort :: !Int
, rqLocalAddr :: !ByteString
, rqLocalPort :: !Int
, rqLocalHostname :: !ByteString
, rqIsSecure :: !Bool
, rqHeaders :: Headers
, rqBody :: IORef SomeEnumerator
, rqContentLength :: !(Maybe Int)
, rqMethod :: !Method
, rqVersion :: !HttpVersion
, rqCookies :: [Cookie]
, rqSnapletPath :: !ByteString
, rqPathInfo :: !ByteString
, rqContextPath :: !ByteString
, rqURI :: !ByteString
, rqQueryString :: !ByteString
, rqParams :: Params
}
instance Show Request where
show r = concat [ "Request <\n"
, body
, ">" ]
where
body = concat $ map ((" "++) . (++ "\n")) [
sname
, remote
, local
, beginheaders
, hdrs
, endheaders
, contentlength
, method
, version
, cookies
, pathinfo
, contextpath
, snapletpath
, uri
, params
]
sname = concat [ "server-name: ", toStr $ rqServerName r ]
remote = concat [ "remote: "
, toStr $ rqRemoteAddr r
, ":"
, show (rqRemotePort r)
]
local = concat [ "local: "
, toStr $ rqLocalAddr r
, ":"
, show $ rqServerPort r
]
beginheaders = "Headers:\n ========================================"
endheaders = " ========================================"
hdrs' (a,b) = (B.unpack $ unCI a) ++ ": " ++ (show (map B.unpack b))
hdrs = " " ++ (concat $ intersperse "\n " $
map hdrs' (Map.toAscList $ rqHeaders r))
contentlength = concat [ "content-length: "
, show $ rqContentLength r
]
method = concat [ "method: "
, show $ rqMethod r
]
version = concat [ "version: "
, show $ rqVersion r
]
cookies' = " " ++ (concat $ intersperse "\n " $
map show $ rqCookies r)
cookies = concat [ "cookies:\n"
, " ========================================\n"
, cookies'
, "\n ========================================"
]
pathinfo = concat [ "pathinfo: ", toStr $ rqPathInfo r ]
contextpath = concat [ "contextpath: ", toStr $ rqContextPath r ]
snapletpath = concat [ "snapletpath: ", toStr $ rqSnapletPath r ]
uri = concat [ "URI: ", toStr $ rqURI r ]
params' = " " ++
(concat $ intersperse "\n " $
map (\ (a,b) -> B.unpack a ++ ": " ++ show b) $
Map.toAscList $ rqParams r)
params = concat [ "params:\n"
, " ========================================\n"
, params'
, "\n ========================================"
]
instance HasHeaders Request where
headers = rqHeaders
updateHeaders f r = r { rqHeaders = f (rqHeaders r) }
instance HasHeaders Headers where
headers = id
updateHeaders = id
data ResponseBody = Enum (forall a . Enumerator a)
| SendFile FilePath
rspBodyMap :: (forall a . Enumerator a -> Enumerator a)
-> ResponseBody
-> ResponseBody
rspBodyMap f b = Enum $ f $ rspBodyToEnum b
rspBodyToEnum :: ResponseBody -> Enumerator a
rspBodyToEnum (Enum e) = e
rspBodyToEnum (SendFile fp) = I.enumFile fp
data Response = Response
{ rspHeaders :: Headers
, rspHttpVersion :: !HttpVersion
, rspContentLength :: !(Maybe Int64)
, rspBody :: ResponseBody
, rspStatus :: !Int
, rspStatusReason :: !ByteString
}
instance Show Response where
show r = concat [ "Response <\n"
, body
, ">" ]
where
body = concat $ map ((" "++) . (++ "\n")) [
hdrs
, version
, status
, reason
]
hdrs = concat [ "headers:\n"
, " ==============================\n "
, show $ rspHeaders r
, "\n ==============================" ]
version = concat [ "version: ", show $ rspHttpVersion r ]
status = concat [ "status: ", show $ rspStatus r ]
reason = concat [ "reason: ", toStr $ rspStatusReason r ]
instance HasHeaders Response where
headers = rspHeaders
updateHeaders f r = r { rspHeaders = f (rspHeaders r) }
rqParam :: ByteString
-> Request
-> Maybe [ByteString]
rqParam k rq = Map.lookup k $ rqParams rq
rqModifyParams :: (Params -> Params) -> Request -> Request
rqModifyParams f r = r { rqParams = p }
where
p = f $ rqParams r
rqSetParam :: ByteString
-> [ByteString]
-> Request
-> Request
rqSetParam k v = rqModifyParams $ Map.insert k v
emptyResponse :: Response
emptyResponse = Response Map.empty (1,1) Nothing (Enum return) 200 "OK"
setResponseBody :: (forall a . Enumerator a)
-> Response
-> Response
setResponseBody e r = r { rspBody = Enum e }
setResponseStatus :: Int
-> ByteString
-> Response
-> Response
setResponseStatus s reason r = r { rspStatus=s, rspStatusReason=reason }
setResponseCode :: Int
-> Response
-> Response
setResponseCode s r = setResponseStatus s reason r
where
reason = fromMaybe "Unknown" (IM.lookup s statusReasonMap)
modifyResponseBody :: (forall a . Enumerator a -> Enumerator a)
-> Response
-> Response
modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) }
setContentType :: ByteString -> Response -> Response
setContentType = setHeader "Content-Type"
addCookie :: Cookie
-> Response
-> Response
addCookie (Cookie k v mbExpTime mbDomain mbPath) = updateHeaders f
where
f = Map.insertWith' (++) "Set-Cookie" [cookie]
cookie = S.concat [k, "=", v, path, exptime, domain]
path = maybe "" (S.append "; path=") mbPath
domain = maybe "" (S.append "; domain=") mbDomain
exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime
fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"
setContentLength :: Int64 -> Response -> Response
setContentLength l r = r { rspContentLength = Just l }
clearContentLength :: Response -> Response
clearContentLength r = r { rspContentLength = Nothing }
formatHttpTime :: CTime -> IO ByteString
formatLogTime :: CTime -> IO ByteString
parseHttpTime :: ByteString -> IO CTime
#ifdef PORTABLE
formatHttpTime = return . format . toUTCTime
where
format :: UTCTime -> ByteString
format = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"
toUTCTime :: CTime -> UTCTime
toUTCTime = posixSecondsToUTCTime . realToFrac
formatLogTime ctime = do
t <- utcToLocalZonedTime $ toUTCTime ctime
return $ format t
where
format :: ZonedTime -> ByteString
format = fromStr . formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z"
toUTCTime :: CTime -> UTCTime
toUTCTime = posixSecondsToUTCTime . realToFrac
parseHttpTime = return . toCTime . parse . toStr
where
parse :: String -> Maybe UTCTime
parse = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
toCTime :: Maybe UTCTime -> CTime
toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t
toCTime Nothing = fromInteger 0
#else
formatLogTime t = do
ptr <- mallocBytes 40
c_format_log_time t ptr
S.unsafePackMallocCString ptr
formatHttpTime t = do
ptr <- mallocBytes 40
c_format_http_time t ptr
S.unsafePackMallocCString ptr
parseHttpTime s = S.unsafeUseAsCString s $ \ptr ->
c_parse_http_time ptr
#endif
parseToCompletion :: Parser a -> ByteString -> Maybe a
parseToCompletion p s = toResult $ finish r
where
r = parse p s
toResult (Atto.Done _ c) = Just c
toResult _ = Nothing
pUrlEscaped :: Parser ByteString
pUrlEscaped = do
sq <- nextChunk DL.empty
return $ S.concat $ DL.toList sq
where
nextChunk :: DList ByteString -> Parser (DList ByteString)
nextChunk s = (endOfInput *> pure s) <|> do
c <- anyWord8
case w2c 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 . w2c) hx)) $
fail "bad hex in url"
let code = (Cvt.hex hx) :: Word8
nextChunk $ DL.snoc l (S.singleton code)
unEncoded :: Word8 -> DList ByteString -> Parser (DList ByteString)
unEncoded c l' = do
let l = DL.snoc l' (S.singleton c)
bs <- takeTill (flip elem (map c2w "%+"))
if S.null bs
then nextChunk l
else nextChunk $ DL.snoc l bs
plusSpace :: DList ByteString -> Parser (DList ByteString)
plusSpace l = nextChunk (DL.snoc l (S.singleton $ c2w ' '))
urlDecode :: ByteString -> Maybe ByteString
urlDecode = parseToCompletion pUrlEscaped
urlEncode :: ByteString -> ByteString
urlEncode = toByteString . S.foldl' f empty
where
f b c =
if c == c2w ' '
then b `mappend` singleton (c2w '+')
else if isKosher c
then b `mappend` singleton c
else b `mappend` hexd c
isKosher w = any ($ c) [ isAlphaNum
, flip elem ['$', '-', '.', '!', '*'
, '\'', '(', ')', ',' ]]
where
c = w2c w
hexd :: Word8 -> Builder
hexd c = singleton (c2w '%') `mappend` singleton hi `mappend` singleton low
where
d = c2w . intToDigit
low = d $ fromEnum $ c .&. 0xf
hi = d $ fromEnum $ (c .&. 0xf0) `shift` (4)
finish :: Atto.Result a -> Atto.Result a
finish (Atto.Partial f) = flip feed "" $ f ""
finish x = x
fromStr :: String -> ByteString
fromStr = S.pack . map c2w
toStr :: ByteString -> String
toStr = map w2c . S.unpack
statusReasonMap :: IM.IntMap ByteString
statusReasonMap = IM.fromList [
(100, "Continue"),
(101, "Switching Protocols"),
(200, "OK"),
(201, "Created"),
(202, "Accepted"),
(203, "Non-Authoritative Information"),
(204, "No Content"),
(205, "Reset Content"),
(206, "Partial Content"),
(300, "Multiple Choices"),
(301, "Moved Permanently"),
(302, "Found"),
(303, "See Other"),
(304, "Not Modified"),
(305, "Use Proxy"),
(307, "Temporary Redirect"),
(400, "Bad Request"),
(401, "Unauthorized"),
(402, "Payment Required"),
(403, "Forbidden"),
(404, "Not Found"),
(405, "Method Not Allowed"),
(406, "Not Acceptable"),
(407, "Proxy Authentication Required"),
(408, "Request Time-out"),
(409, "Conflict"),
(410, "Gone"),
(411, "Length Required"),
(412, "Precondition Failed"),
(413, "Request Entity Too Large"),
(414, "Request-URI Too Large"),
(415, "Unsupported Media Type"),
(416, "Requested range not satisfiable"),
(417, "Expectation Failed"),
(500, "Internal Server Error"),
(501, "Not Implemented"),
(502, "Bad Gateway"),
(503, "Service Unavailable"),
(504, "Gateway Time-out"),
(505, "HTTP Version not supported")
]