module Network.MiniHTTP.Marshal
( Request(..)
, Reply(..)
, Range(..)
, Headers(..)
, emptyHeaders
, statusToMessage
, Method(..)
, MediaType
, putRequest
, putReply
, parseRequest
, parseReply
) where
import Prelude hiding (putChar)
import Control.Monad (when)
import GHC.Exts()
import Data.Time (UTCTime(..))
import Data.Time.Format (formatTime)
import Data.Time.Calendar (fromGregorian)
import Data.Time.LocalTime (TimeOfDay(..), timeOfDayToTime)
import Data.Int (Int64)
import Data.Maybe (isJust, maybe)
import Data.List (foldl')
import System.Locale (TimeLocale(..))
import qualified Data.Map as Map
import Control.Applicative ((<|>), liftA, liftA2, (*>))
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.Get as G
import qualified Data.Binary.Strict.Class as C
import qualified Data.Binary.Strict.ByteSet as BSet
import Debug.Trace (trace)
debug x = trace (show x) x
data Request =
Request { reqMethod :: Method
, reqUrl :: B.ByteString
, 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
, 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
, httpTrailer :: Maybe [String]
, httpTransferEncoding :: [String]
, httpUserAgent :: Maybe B.ByteString
, httpWWWAuthenticate :: Maybe B.ByteString
, httpOtherHeaders :: Map.Map B.ByteString B.ByteString
} deriving (Show)
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"
ctexts = texts `BSet.difference` (BSet.fromList $ map c2w "()\\")
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'
comment = do
char '('
comment <- C.many ((C.spanOf $ BSet.member ctexts) <|> quotedPair <|> comment) >>= return . B.concat
char ')'
return comment
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
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 $ debug 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 }
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)
]
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
method <- parseMethod strmethod
headers <- parseHeaders
return $ Request method url 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'
putString = P.putByteString . B.pack . map c2w
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 (mapM_ 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"
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
putHeaderML (httpRange headers) "Range" putRange
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
mapM_ (\(k, v) -> P.putByteString k >> putString ": " >> P.putByteString v) $
Map.toList $ httpOtherHeaders headers
putRequest :: Request -> P.Put
putRequest (Request method url major minor headers) = do
putShow method >> putChar ' ' >> P.putByteString 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"