module Snap.Internal.Http.Types where
import Blaze.ByteString.Builder
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.Time.Clock
import Data.Word
import Foreign hiding (new)
import Foreign.C.Types
import Prelude hiding (take)
#ifdef PORTABLE
import Data.Time.Format
import Data.Time.LocalTime
import Data.Time.Clock.POSIX
import System.Locale (defaultTimeLocale)
#else
import Data.Time.Format ()
import Foreign.C.String
#endif
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Snap.Iteratee (Enumerator)
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 Headers = Map (CI ByteString) [ByteString]
class HasHeaders a where
updateHeaders :: (Headers -> Headers) -> a -> a
headers :: a -> Headers
addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
addHeader k v = updateHeaders $ Map.insertWith' (++) k [v]
setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
setHeader k v = updateHeaders $ Map.insert k [v]
getHeaders :: (HasHeaders a) => CI ByteString -> a -> Maybe [ByteString]
getHeaders k a = Map.lookup k $ headers a
getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString
getHeader k a = liftM (S.intercalate " ") (Map.lookup k $ headers a)
deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a
deleteHeader k = updateHeaders $ Map.delete k
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 ByteString IO 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 $ CI.original 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 Builder IO a)
| SendFile FilePath (Maybe (Int64,Int64))
rspBodyMap :: (forall a .
Enumerator Builder IO a -> Enumerator Builder IO a)
-> ResponseBody
-> ResponseBody
rspBodyMap f b = Enum $ f $ rspBodyToEnum b
rspBodyToEnum :: ResponseBody -> Enumerator Builder IO a
rspBodyToEnum (Enum e) = e
rspBodyToEnum (SendFile fp Nothing) =
I.mapEnum toByteString fromByteString $ I.enumFile fp
rspBodyToEnum (SendFile fp (Just s)) =
I.mapEnum toByteString fromByteString $ I.enumFilePartial fp s
data Response = Response
{ rspHeaders :: Headers
, rspCookies :: Map ByteString Cookie
, rspHttpVersion :: !HttpVersion
, rspContentLength :: !(Maybe Int64)
, rspBody :: ResponseBody
, rspStatus :: !Int
, rspStatusReason :: !ByteString
, rspTransformingRqBody :: !Bool
}
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 Map.empty (1,1) Nothing
(Enum (I.enumBuilder mempty))
200 "OK" False
setResponseBody :: (forall a . Enumerator Builder IO 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 Builder IO a
-> Enumerator Builder IO 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 = addResponseCookie
addResponseCookie :: Cookie
-> Response
-> Response
addResponseCookie ck@(Cookie k _ _ _ _) r = r { rspCookies = cks' }
where
cks'= Map.insert k ck $ rspCookies r
getResponseCookie :: ByteString
-> Response
-> Maybe Cookie
getResponseCookie cn r = Map.lookup cn $ rspCookies r
getResponseCookies :: Response
-> [Cookie]
getResponseCookies = Map.elems . rspCookies
deleteResponseCookie :: ByteString
-> Response
-> Response
deleteResponseCookie cn r = r { rspCookies = cks' }
where
cks'= Map.delete cn $ rspCookies r
modifyResponseCookie :: ByteString
-> (Cookie -> Cookie)
-> Response
-> Response
modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r
where
modify ck = addResponseCookie (f ck) r
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 . prs . toStr
where
prs :: String -> Maybe UTCTime
prs = 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 mempty
where
f b c =
if c == c2w ' '
then b `mappend` fromWord8 (c2w '+')
else if isKosher c
then b `mappend` fromWord8 c
else b `mappend` hexd c
isKosher w = any ($ c) [ isAlphaNum
, flip elem ['$', '-', '.', '!', '*'
, '\'', '(', ')', ',' ]]
where
c = w2c w
hexd :: Word8 -> Builder
hexd c = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 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")
]