module Network.MiniHTTP.Marshal
( Request(..)
, Reply(..)
, Range(..)
, Headers(..)
, Cookie(..)
, emptyHeaders
, emptyCookie
, statusToMessage
, Method(..)
, MediaType
, putRequest
, putReply
, parseRequest
, parseReply
, parseChunkHeader
) where
import Prelude hiding (putChar)
import Control.Applicative ((<|>), liftA, liftA2, (*>))
import Control.Monad (when, forM_)
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.Binary.Put as P
import qualified Data.Binary.Strict.ByteSet as BSet
import qualified Data.Binary.Strict.Class as C
import qualified Data.Binary.Strict.Get as G
import Data.Int (Int64)
import Data.List (intersperse, foldl')
import qualified Data.Map as Map
import Data.Maybe (isJust, maybe)
import Data.String (fromString)
import Data.Time (UTCTime(..))
import Data.Time.Calendar (fromGregorian)
import Data.Time.Format (formatTime)
import Data.Time.LocalTime (TimeOfDay(..), timeOfDayToTime)
import GHC.Exts()
import System.Locale (TimeLocale(..))
import qualified Network.MiniHTTP.URL as URL
data Request =
Request { reqMethod :: Method
, reqUrl :: URL.RelativeURL
, reqMajor :: Int
, reqMinor :: Int
, reqHeaders :: Headers
} deriving (Show)
data Reply =
Reply { replyMajor :: Int
, replyMinor :: Int
, replyStatus :: Int
, replyMessage :: String
, replyHeaders :: Headers
} deriving (Show)
data Range = RangeFrom Int64
| RangeOf Int64 Int64
| RangeSuffix Int64
deriving (Show)
data Headers =
Headers { httpAccept :: Maybe [(MediaType, Int)]
, httpAcceptCharset :: Maybe [(String, Int)]
, httpAcceptEncoding :: Maybe [(String, Int)]
, httpAcceptLanguage :: Maybe [(String, Int)]
, httpAcceptRanges :: Bool
, httpAge :: Maybe Int64
, httpAllow :: Maybe [Method]
, httpAuthorization :: Maybe B.ByteString
, httpCookie :: [Cookie]
, httpConnectionClose :: Bool
, httpConnection :: [String]
, httpContentEncodings :: [String]
, httpContentLanguage :: Maybe [String]
, httpContentLength :: Maybe Int64
, httpContentLocation :: Maybe B.ByteString
, httpContentRange :: Maybe (Maybe (Int64, Int64), Maybe Int64)
, httpContentType :: Maybe MediaType
, httpDate :: Maybe UTCTime
, httpETag :: Maybe (Bool, B.ByteString)
, httpExpires :: Maybe UTCTime
, httpHost :: Maybe B.ByteString
, httpIfMatch :: Maybe (Either () [B.ByteString])
, httpIfModifiedSince :: Maybe UTCTime
, httpIfNoneMatch :: Maybe (Either () [(Bool, B.ByteString)])
, httpIfRange :: Maybe (Either B.ByteString UTCTime)
, httpIfUnmodifiedSince :: Maybe UTCTime
, httpKeepAlive :: Maybe Int
, httpLastModified :: Maybe UTCTime
, httpLocation :: Maybe B.ByteString
, httpPragma :: Maybe [(String, Maybe String)]
, httpProxyAuthenticate :: Maybe B.ByteString
, httpProxyAuthorization :: Maybe B.ByteString
, httpRange :: Maybe [Range]
, httpReferer :: Maybe B.ByteString
, httpRetryAfter :: Maybe Int64
, httpServer :: Maybe B.ByteString
, httpSetCookie :: [Cookie]
, httpTrailer :: Maybe [String]
, httpTransferEncoding :: [String]
, httpUserAgent :: Maybe B.ByteString
, httpWWWAuthenticate :: Maybe B.ByteString
, httpOtherHeaders :: Map.Map B.ByteString B.ByteString
} deriving (Show)
data Cookie = Cookie { cookieName :: B.ByteString
, cookieValue :: B.ByteString
, cookiePath :: Maybe String
, cookieDomain :: Maybe String
, cookieExpires :: Maybe UTCTime
, cookieSecure :: Bool
} deriving (Show, Eq, Ord)
emptyHeaders :: Headers
emptyHeaders =
Headers Nothing Nothing Nothing Nothing
False Nothing Nothing Nothing [] False [] [] Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing Nothing []
Nothing [] Nothing Nothing Map.empty
data Method = OPTIONS
| GET
| HEAD
| POST
| PUT
| DELETE
| TRACE
| CONNECT
deriving (Ord, Enum, Show, Eq)
type MediaType = ((String, String), [(String, String)])
reasonPhrases :: Map.Map Int String
reasonPhrases = Map.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")
]
statusToMessage :: Int -> String
statusToMessage status = Map.findWithDefault "Unknown" status reasonPhrases
char = C.word8 . c2w
urlSet = BSet.full `BSet.difference` (BSet.singleton 0x20)
upAlphas = BSet.range (c2w 'A') (c2w 'Z')
loAlphas = BSet.range (c2w 'a') (c2w 'z')
alphas = upAlphas `BSet.union` loAlphas
digits = BSet.range (c2w '0') (c2w '9')
chars = BSet.range 0 127
ctls = BSet.range 0 31 `BSet.union` BSet.singleton 127
hs = BSet.fromList [32, 9]
texts = (chars `BSet.difference` ctls) `BSet.union` hs
hexes = BSet.range (c2w 'a') (c2w 'f') `BSet.union`
BSet.range (c2w 'A') (c2w 'F') `BSet.union`
digits
separators = BSet.fromList $ map c2w "()<>@,;:\\\"/[]?={} \t"
qdtexts = texts `BSet.difference` (BSet.fromList $ map c2w "\"\\")
toString = map w2c . B.unpack
lws = do
C.optional crlf
C.spanOf1 $ BSet.member hs
token = C.spanOf1 $ BSet.member (texts `BSet.difference` (ctls `BSet.union` separators))
qvalue = qOne <|> qFractional
qOne = do
char '1'
(((char '.') >> C.many (char '0') >> return ()) <|> return ())
return 1000
qFractional = do
char '0'
r <- (((char '.') >> C.spanOf (BSet.member digits)) <|> return "")
if B.null r
then return 0
else return $ read $ toString r ++ replicate (3 B.length r) '0'
quotedPair = (char '\\') >> (C.getWord8 >>= return . B.singleton)
quotedString = do
char '"'
text <- C.many ((C.spanOf1 $ BSet.member qdtexts) <|> quotedPair) >>= return . B.concat
char '"'
return text
list p = do
let f = C.optional lws *> char ',' *> C.optional lws *> p
v <- p
rest <- C.many f
return $ v : rest
crlf = C.word8 13 >> C.word8 10 >> return ()
headerQualityTaggedList parseElement = do
let acceptParams = do
char ';'
C.optional lws
C.string "q="
q <- qvalue
C.many $ acceptExtension
return q
acceptExtension = do
char ';'
token
C.optional (char '=' >> (token <|> quotedString))
listElement = do
mr <- parseElement
params <- C.optional acceptParams
case params of
Nothing -> return (mr, 1000)
Just x -> return (mr, x)
list listElement
stringToken = liftA toString token
mediaType = liftA2 (,) ty params where
ty = liftA2 (,) stringToken (char '/' *> stringToken)
params = C.many (char ';' *> (liftA2 (,) notq (char '=' *> (stringToken <|> (liftA toString quotedString)))))
notq = do
s <- stringToken
if s == "q"
then fail ""
else return s
date :: (C.BinaryParser m) => m UTCTime
date = do
C.optional (token *> char ',' *> C.optional lws)
day <- int64
lws
monthstr <- token
lws
year <- int64
lws
hour <- int64
char ':'
min <- int64
char ':'
sec <- int64
lws
zone <- token
month <-
case monthstr of
"Jan" -> return 1
"Feb" -> return 2
"Mar" -> return 3
"Apr" -> return 4
"May" -> return 5
"Jun" -> return 6
"Jul" -> return 7
"Aug" -> return 8
"Sep" -> return 9
"Oct" -> return 10
"Nov" -> return 11
"Dec" -> return 12
_ -> fail ""
(hoffset, moffset) <-
case zone of
"UT" -> return (0, 0)
"UTC" -> return (0, 0)
"GMT" -> return (0, 0)
"EST" -> return (5, 0)
"EDT" -> return (4, 0)
"CST" -> return (6, 0)
"CDT" -> return (5, 0)
"MST" -> return (7, 0)
"MDT" -> return (6, 0)
"PST" -> return (8, 0)
"PDT" -> return (7, 0)
x -> return (sign * hours, sign * mins) where
(signchar:rest) = toString x
n = read rest
(hours, mins) = (n `div` 100, n `mod` 100)
sign = case signchar of
'+' -> (1)
_ -> 1
let yday = fromGregorian (fromIntegral year) month (fromIntegral day)
time = timeOfDayToTime $ TimeOfDay (fromIntegral $ hour + hoffset) (fromIntegral $ min + moffset) (fromIntegral sec)
utc = UTCTime yday time
return utc
int64 :: (C.BinaryParser c) => c Int64
int64 = C.spanOf1 (BSet.member digits) >>= return . readOrZero . toString
hexInt64 :: (C.BinaryParser c) => c Int64
hexInt64 = C.spanOf1 (BSet.member hexes) >>= return . readOrZero . ((++) "0x") . toString
readOrZero "" = 0
readOrZero x = read x
headerAccept req = do
accepts <- headerQualityTaggedList mediaType
return $ req { httpAccept = Just accepts }
headerAcceptCharset req = do
charsets <- headerQualityTaggedList (token >>= return . toString)
return $ req { httpAcceptCharset = Just charsets }
headerAcceptEncoding req = do
encodings <- headerQualityTaggedList (token >>= return . toString)
return $ req { httpAcceptEncoding = Just encodings }
headerAcceptLanguage req = do
langs <- headerQualityTaggedList (token >>= return . toString)
return $ req { httpAcceptLanguage = Just langs }
headerAcceptRanges req = do
v <- C.optional $ C.string "bytes"
case v of
Nothing -> return req
Just _ -> return $ req { httpAcceptRanges = True }
headerAge req = do
v <- int64
return $ req { httpAge = Just v }
headerAllow req = do
methods <- list (C.spanOf (BSet.member upAlphas) >>= parseMethod)
return $ req { httpAllow = Just methods }
headerAuth req = do
remaining <- C.remaining
d <- C.getByteString remaining
return $ req { httpAuthorization = Just d }
headerConnection req = do
tokens <- list (token >>= return . toString)
return $ req { httpConnection = tokens,
httpConnectionClose = "close" `elem` tokens }
headerContentEncoding req = do
tokens <- list (token >>= return . toString)
return $ req { httpContentEncodings = tokens }
headerContentLanguage req = do
tokens <- list (token >>= return . toString)
return $ req { httpContentLanguage = Just tokens }
headerContentLength req = do
v <- int64
return $ req { httpContentLength = Just v }
headerContentLocation req = do
remaining <- C.remaining
d <- C.getByteString remaining
return $ req { httpContentLocation = Just d }
headerContentRange req = do
C.string "bytes "
a <- (char '*' *> return Nothing) <|> (liftA Just (liftA2 (,) int64 (char '-' *> int64)))
char '/'
b <- (char '*' *> return Nothing) <|> (liftA Just int64)
return $ req { httpContentRange = Just (a, b) }
headerContentType req = do
ct <- mediaType
return $ req { httpContentType = Just ct }
etag = do
weakness <- C.optional $ C.string "W/"
etag <- quotedString
return (isJust weakness, etag)
headerETag req = do
etag >>= \tag -> return $ req { httpETag = Just tag }
headerDate req = date >>= \date -> return $ req { httpDate = Just date }
headerExpires req = date >>= \date -> return $ req { httpExpires = Just date }
headerHost req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpHost = Just x }
headerIfMatch req =
(char '*' *> return (Left ())) <|> (liftA Right $ list quotedString) >>=
\a -> return $ req { httpIfMatch = Just a }
headerIfModifiedSince req = date >>= \date -> return $ req { httpIfModifiedSince = Just date }
headerIfNoneMatch req =
(char '*' *> return (Left ())) <|> (liftA Right $ list etag) >>=
\a -> return $ req { httpIfNoneMatch = Just a }
headerIfRange req = (liftA Left quotedString) <|> (liftA Right date) >>=
\a -> return $ req { httpIfRange = Just a }
headerIfUnmodifiedSince req = date >>= \date -> return $ req { httpIfUnmodifiedSince = Just date }
headerKeepAlive req = int64 >>= \v -> return $ req { httpKeepAlive = Just $ fromIntegral v }
headerLastModified req = date >>= \date -> return $ req { httpLastModified = Just date }
headerLocation req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpLocation = Just x }
headerPragma req =
list (liftA2 (,) stringToken (C.optional $ char '=' *> (liftA toString (token <|> quotedString)))) >>=
\a -> return $ req { httpPragma = Just a }
headerProxyAuthenticate req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpProxyAuthenticate = Just x }
headerProxyAuthorization req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpProxyAuthorization = Just x }
checkRanges :: [Range] -> Maybe [Range]
checkRanges ranges = r where
r = if any invalid ranges
then Nothing
else Just ranges
invalid (RangeOf a b) = a > b
invalid _ = False
headerRange req = (C.string "bytes=" *> list f) >>= \a -> return $ req { httpRange = checkRanges a } where
f = a <|> b <|> c where
a = char '-' *> liftA RangeSuffix int64
b = int64 >>= (\start -> char '-' *> liftA (RangeOf start) int64)
c = int64 >>= (\start -> char '-' *> return (RangeFrom start))
headerReferer req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpReferer = Just x }
headerRetryAfter req = int64 >>= \i -> return $ req { httpRetryAfter = Just i }
headerServer req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpServer = Just x }
headerTransferEncoding req = list stringToken >>= \xs -> return $ req { httpTransferEncoding = xs }
headerTrailer req = list stringToken >>= \xs -> return $ req { httpTrailer = Just xs }
headerUserAgent req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpUserAgent = Just x }
headerWWWAuthenticate req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpWWWAuthenticate = Just x }
emptyCookie = Cookie B.empty B.empty Nothing Nothing Nothing False
mergeCookie a b =
Cookie { cookieName = bs cookieName
, cookieValue = bs cookieValue
, cookiePath = m cookiePath
, cookieDomain = m cookieDomain
, cookieExpires = m cookieExpires
, cookieSecure = cookieSecure a || cookieSecure b } where
bs f = if B.null $ f a then f b else f a
m f = case f a of
Nothing -> f b
x -> x
cookie = do
name <- C.spanOf1 (/= 0x3d )
C.word8 0x3d
value <- C.spanOf1 (/= 0x3b )
options <- C.many $ do
C.word8 0x3b
lws
key <- C.spanOf1 (BSet.member alphas)
let value = C.spanOf1 (/= 0x3b)
case key of
"secure" -> return $ emptyCookie { cookieSecure = True }
"path" -> value >>= \v -> (return $ emptyCookie { cookiePath = Just $ toString v })
"domain" -> value >>= \v ->(return $ emptyCookie { cookieDomain = Just $ toString v })
"expires" -> date >>= \v -> (return $ emptyCookie { cookieExpires = Just v})
_ -> C.spanOf1 (/= 0x3d) >> return emptyCookie
return $ foldl mergeCookie (emptyCookie { cookieName = name, cookieValue = value }) options
headerSetCookie req = cookie >>= \c -> return $ req { httpSetCookie = c : httpSetCookie req }
headerCookie req = cookie >>= \c -> return $ req { httpCookie = c : httpCookie req }
messageHeader = do
name <- token
char ':'
C.optional lws
value <- C.spanOf $ BSet.member texts
crlf
return (name, value)
requestLine = do
method <- C.spanOf $ BSet.member upAlphas
C.word8 0x20
url <- C.spanOf $ BSet.member urlSet
C.word8 0x20
C.string "HTTP/"
major <- C.spanOf $ BSet.member digits
char '.'
minor <- C.spanOf $ BSet.member digits
crlf
return (method, url, (readOrZero $ toString major) :: Int
, (readOrZero $ toString minor) :: Int)
replyLine = do
C.string "HTTP/"
major <- C.spanOf $ BSet.member digits
char '.'
minor <- C.spanOf $ BSet.member digits
char ' '
status <- C.spanOf $ BSet.member digits
char ' '
message <- C.spanOf $ BSet.member texts
crlf
return (readOrZero $ toString major, readOrZero $ toString minor,
readOrZero $ toString status, toString message)
headerParsers = Map.fromList
[ ("Accept", headerAccept)
, ("Accept-Charset", headerAcceptCharset)
, ("Accept-Encoding", headerAcceptEncoding)
, ("Accept-Language", headerAcceptLanguage)
, ("Accept-Ranges", headerAcceptRanges)
, ("Age", headerAge)
, ("Allow", headerAllow)
, ("Authorization", headerAuth)
, ("Connection", headerConnection )
, ("Content-Encoding", headerContentEncoding)
, ("Content-Language", headerContentLanguage)
, ("Content-Length", headerContentLength)
, ("Content-Location", headerContentLocation)
, ("Content-Range", headerContentRange)
, ("Content-Type", headerContentType)
, ("ETag", headerETag)
, ("Date", headerDate)
, ("Expires", headerExpires)
, ("Host", headerHost)
, ("If-Match", headerIfMatch)
, ("If-Modified-Since", headerIfModifiedSince)
, ("If-None-Match", headerIfNoneMatch)
, ("If-Range", headerIfRange)
, ("If-Unmodified-Since", headerIfUnmodifiedSince)
, ("Keep-Alive", headerKeepAlive)
, ("Last-Modified", headerLastModified)
, ("Location", headerLocation)
, ("Pragma", headerPragma)
, ("Proxy-Authenticate", headerProxyAuthenticate)
, ("Proxy-Authorization", headerProxyAuthorization)
, ("Range", headerRange)
, ("Referer", headerReferer)
, ("Retry-After", headerRetryAfter)
, ("Server", headerServer)
, ("Transfer-Encoding", headerTransferEncoding)
, ("Trailer", headerTrailer)
, ("User-Agent", headerUserAgent)
, ("WWW-Authenticate", headerWWWAuthenticate)
, ("Cookie", headerCookie)
, ("Set-Cookie", headerSetCookie)
]
parseMethod :: (Monad m) => B.ByteString -> m Method
parseMethod strmethod =
case strmethod of
"OPTIONS" -> return OPTIONS
"GET" -> return GET
"HEAD" -> return HEAD
"POST" -> return POST
"PUT" -> return PUT
"DELETE" -> return DELETE
"TRACE" -> return TRACE
"CONNECT" -> return CONNECT
_ -> fail "Bad method"
parseRequest :: (C.BinaryParser m) => m Request
parseRequest = do
(strmethod, url, major, minor) <- requestLine
uri <- case URL.parseRelative url of
Just uri -> return uri
Nothing -> fail "Failed to parse URL"
method <- parseMethod strmethod
headers <- parseHeaders
return $ Request method uri major minor headers
parseReply :: (C.BinaryParser m) => m Reply
parseReply = do
(major, minor, status, message) <- replyLine
headers <- parseHeaders
return $ Reply major minor status message headers
parseHeaders = do
headers <- C.many $ messageHeader
crlf
let req = emptyHeaders
req' = foldl' tryHeader req headers
tryHeader req (header, value) =
case Map.lookup header headerParsers of
Nothing -> req { httpOtherHeaders = Map.insert header value $ httpOtherHeaders req }
Just p -> case G.runGet (p req) value of
(Left _, _) -> req { httpOtherHeaders = Map.insert header value $ httpOtherHeaders req }
(Right req', _) -> req'
return req'
parseChunkHeader :: (C.BinaryParser m) => m Int64
parseChunkHeader = do
length <- hexInt64
C.optional lws
C.many $ char ';' >> token >> char '=' >> (token <|> quotedString)
crlf
return length
putString = P.putByteString . fromString
putChar = P.putWord8 . c2w
putShow = putString . show
putQualityList :: (a -> P.Put) -> [(a, Int)] -> P.Put
putQualityList _ [] = return ()
putQualityList f ((v, q):xs) = do
f v
when (q /= 1000) $ do
P.putByteString ";q=0."
putQuality q
putChar ','
putQualityList f xs
putQuality x
| x `mod` 10 == 0 = putQuality $ div x 10
| otherwise = putString $ show x
putHeaderM :: Maybe a -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderM Nothing _ _ = return ()
putHeaderM (Just x) h f = P.putByteString h >> P.putByteString ": " >> f x >> P.putByteString "\r\n"
putHeaderML :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderML a b c = putHeaderM a b (sequence_ . intersperse (P.putByteString ",") . map c)
putHeaderMLE :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> B.ByteString -> P.Put
putHeaderMLE a b c extra = putHeaderM a b (sequence_ . ((:) (P.putByteString extra)) . intersperse (P.putByteString ", ") . map c)
putHeaderL :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderL [] _ _ = return ()
putHeaderL xs h f = P.putByteString h >> P.putByteString ": " >> mapM_ f xs >> P.putByteString "\r\n"
putHeaderMulti :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderMulti vs name f = forM_ vs $ \v -> do
P.putByteString name
P.putByteString ": "
f v
P.putByteString "\r\n"
whenMaybe :: Maybe a -> (a -> P.Put) -> P.Put
whenMaybe Nothing _ = return ()
whenMaybe (Just x) f = f x
putCookie :: Cookie -> P.Put
putCookie cookie = do
P.putByteString $ cookieName cookie
P.putWord8 0x3d
P.putByteString $ cookieValue cookie
whenMaybe (cookiePath cookie) $ \s -> do
P.putByteString "; path="
P.putByteString $ fromString s
whenMaybe (cookieDomain cookie) $ \s -> do
P.putByteString "; domain="
P.putByteString $ fromString s
whenMaybe (cookieExpires cookie) $ \date -> do
P.putByteString "; expires="
putDate date
when (cookieSecure cookie) $ P.putByteString "; secure"
putContentRange (Just (a, b), Just c) = putShow a >> putChar '-' >> putShow b >> putChar '/' >> putShow c
putContentRange (Just (a, b), Nothing) = putShow a >> putChar '-' >> putShow b >> P.putByteString "/*"
putContentRange (Nothing, Just c) = P.putByteString "*/" >> putShow c
putContentRange (Nothing, Nothing) = P.putByteString "*/*"
putList :: Char -> (a -> P.Put) -> [a] -> P.Put
putList _ _ [] = return ()
putList sep f (x:xs) = f x >> mapM_ (\x -> putChar sep >> f x) xs
putMediaType ((ty, subty), opts) = do
putString ty
putChar '/'
putString subty
let f (a, b) = putChar ';' >> putString a >> putChar '=' >> putString b
mapM_ f opts
putQuoted :: B.ByteString -> P.Put
putQuoted s = putChar '"' >> f s >> putChar '"' where
f s
| B.null s = return ()
| otherwise = P.putByteString left >> f right where
(left, right) = B.span (/= (c2w) '"') s
timeLocale = TimeLocale {wDays = [("Sunday","Sun"),("Monday","Mon"),("Tuesday","Tue"),("Wednesday","Wed"),("Thursday","Thu"),("Friday","Fri"),("Saturday","Sat")], months = [("January","Jan"),("February","Feb"),("March","Mar"),("April","Apr"),("May","May"),("June","Jun"),("July","Jul"),("August","Aug"),("September","Sep"),("October","Oct"),("November","Nov"),("December","Dec")], intervals = [("year","years"),("month","months"),("day","days"),("hour","hours"),("min","mins"),("sec","secs"),("usec","usecs")], amPm = ("AM","PM"), dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y", dateFmt = "%m/%d/%y", timeFmt = "%H:%M:%S", time12Fmt = "%I:%M:%S %p"}
putDate = putString . formatTime timeLocale "%a, %d %b %Y %H:%M:%S GMT"
putETag (weakness, tag) = (if weakness then P.putByteString "W/" else return ()) >> putQuoted tag
putETagList = either (const $ putChar '*') $ putList ',' putQuoted
putWETagList = either (const $ putChar '*') $ putList ',' putETag
putPragma (key, mvalue) = putString key >> maybe (return ()) putString mvalue
putRange (RangeOf a b) = putShow a >> putChar '-' >> putShow b
putRange (RangeSuffix a) = putChar '-' >> putShow a
putRange (RangeFrom a) = putShow a >> putChar '-'
putHeaders :: Headers -> P.Put
putHeaders headers = do
putHeaderM (httpAccept headers) "Accept" $ putQualityList putMediaType
putHeaderM (httpAcceptCharset headers) "Accept-Charset" $ putQualityList putString
putHeaderM (httpAcceptEncoding headers) "Accept-Encoding" $ putQualityList putString
putHeaderM (httpAcceptLanguage headers) "Accept-Language" $ putQualityList putString
when (httpAcceptRanges headers) $ P.putByteString "Accept-Ranges: bytes\r\n"
putHeaderM (httpAge headers) "Age" putShow
putHeaderML (httpAllow headers) "Allow" putShow
putHeaderM (httpAuthorization headers) "Authorization" P.putByteString
putHeaderL (httpConnection headers ++ if httpConnectionClose headers then ["close"] else [])
"Connection" putString
putHeaderL (httpContentEncodings headers) "Content-Encoding" putString
putHeaderML (httpContentLanguage headers) "Content-Language" putString
putHeaderM (httpContentLength headers) "Content-Length" putShow
putHeaderM (httpContentLocation headers) "Content-Location" P.putByteString
putHeaderM (httpContentRange headers) "Content-Range" putContentRange
putHeaderM (httpContentType headers) "Content-Type" putMediaType
putHeaderM (httpDate headers) "Date" putDate
putHeaderM (httpETag headers) "ETag" putETag
putHeaderM (httpExpires headers) "Expires" putDate
putHeaderM (httpHost headers) "Host" P.putByteString
putHeaderM (httpIfMatch headers) "If-Match" putETagList
putHeaderM (httpIfModifiedSince headers) "If-Modified-Since" putDate
putHeaderM (httpIfNoneMatch headers) "If-None-Match" putWETagList
putHeaderM (httpIfRange headers) "If-Range" $ either putQuoted putDate
putHeaderM (httpIfUnmodifiedSince headers) "If-Unmodified-Since" putDate
putHeaderM (httpKeepAlive headers) "Keep-Alive" putShow
putHeaderM (httpLastModified headers) "Last-Modified" putDate
putHeaderM (httpLocation headers) "Location" P.putByteString
putHeaderML (httpPragma headers) "Pragma" putPragma
putHeaderM (httpProxyAuthenticate headers) "Proxy-Authenticate" P.putByteString
putHeaderM (httpProxyAuthorization headers) "Proxy-Authorization" P.putByteString
putHeaderMLE (httpRange headers) "Range" putRange "bytes="
putHeaderM (httpReferer headers) "Referer" P.putByteString
putHeaderM (httpRetryAfter headers) "Retry-After" putShow
putHeaderM (httpServer headers) "Server" P.putByteString
putHeaderL (httpTransferEncoding headers) "Transfer-Encoding" putString
putHeaderML (httpTrailer headers) "Trailer" putString
putHeaderM (httpUserAgent headers) "User-Agent" P.putByteString
putHeaderM (httpWWWAuthenticate headers) "WWW-Authenticate" P.putByteString
putHeaderMulti (httpSetCookie headers) "Set-Cookie" putCookie
putHeaderMulti (httpSetCookie headers) "Cookie" putCookie
mapM_ (\(k, v) -> P.putByteString k >> putString ": " >> P.putByteString v >> P.putByteString "\r\n") $
Map.toList $ httpOtherHeaders headers
putRequest :: Request -> P.Put
putRequest (Request method url major minor headers) = do
putShow method >> putChar ' ' >> P.putByteString (URL.serialiseRelative url) >> putChar ' '
P.putByteString "HTTP/"
putShow major >> putChar '.' >> putShow minor >> P.putByteString "\r\n"
putHeaders headers
P.putByteString "\r\n"
putReply :: Reply -> P.Put
putReply (Reply major minor status message headers) = do
P.putByteString "HTTP/" >> putShow major >> putChar '.' >> putShow minor
putChar ' ' >> putShow status >> putChar ' '
putString message >> P.putByteString "\r\n"
putHeaders headers
P.putByteString "\r\n"