{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Network.HTTP.Client.Headers
( parseStatusHeaders
) where
import Control.Applicative ((<$>), (<*>))
import Control.Exception (throwIO)
import Control.Monad
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.CaseInsensitive as CI
import Network.HTTP.Client.Connection
import Network.HTTP.Client.Types
import Network.HTTP.Types
import Data.Word (Word8)
charLF, charCR, charSpace, charColon, charPeriod :: Word8
charLF = 10
charCR = 13
charSpace = 32
charColon = 58
charPeriod = 46
parseStatusHeaders :: Connection -> IO StatusHeaders
parseStatusHeaders conn = do
(status, version) <- getStatusLine
headers <- parseHeaders 0 id
return $! StatusHeaders status version headers
where
getStatusLine = do
bs <- connectionRead conn
when (S.null bs) $ throwIO NoResponseDataReceived
status@(code, _) <- connectionReadLineWith conn bs >>= parseStatus 3
if code == status100
then connectionDropTillBlankLine conn >> getStatusLine
else return status
parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)
parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1)
parseStatus _ bs = do
let (ver, bs2) = S.breakByte charSpace bs
(code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2
msg = S.dropWhile (== charSpace) bs3
case (,) <$> parseVersion ver <*> readInt code of
Just (ver', code') -> return (Status code' msg, ver')
Nothing -> throwIO $ InvalidStatusLine bs
stripPrefixBS x y
| x `S.isPrefixOf` y = Just $ S.drop (S.length x) y
| otherwise = Nothing
parseVersion bs0 = do
bs1 <- stripPrefixBS "HTTP/" bs0
let (num1, S.drop 1 -> num2) = S.breakByte charPeriod bs1
HttpVersion <$> readInt num1 <*> readInt num2
readInt bs =
case S8.readInt bs of
Just (i, "") -> Just i
_ -> Nothing
parseHeaders 100 _ = throwIO OverlongHeaders
parseHeaders count front = do
line <- connectionReadLine conn
if S.null line
then return $ front []
else do
header <- parseHeader line
parseHeaders (count + 1) $ front . (header:)
parseHeader :: S.ByteString -> IO Header
parseHeader bs = do
let (key, bs2) = S.breakByte charColon bs
when (S.null bs2) $ throwIO $ InvalidHeader bs
return (CI.mk $! strip key, strip $! S.drop 1 bs2)
strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)