1{-# LANGUAGE DisambiguateRecordFields #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ViewPatterns #-}
4module Network.HTTP.Client.Headers
5    ( parseStatusHeaders
6    , validateHeaders
7    , HeadersValidationResult (..)
8    ) where
9
10import           Control.Applicative            as A ((<$>), (<*>))
11import           Control.Monad
12import qualified Data.ByteString                as S
13import qualified Data.ByteString.Char8          as S8
14import qualified Data.CaseInsensitive           as CI
15import           Data.Maybe (mapMaybe)
16import           Data.Monoid
17import           Network.HTTP.Client.Connection
18import           Network.HTTP.Client.Types
19import           System.Timeout                 (timeout)
20import           Network.HTTP.Types
21import Data.Word (Word8)
22
23charSpace, charColon, charPeriod :: Word8
24charSpace = 32
25charColon = 58
26charPeriod = 46
27
28
29parseStatusHeaders :: Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders
30parseStatusHeaders conn timeout' cont
31    | Just k <- cont = getStatusExpectContinue k
32    | otherwise      = getStatus
33  where
34    withTimeout = case timeout' of
35        Nothing -> id
36        Just  t -> timeout t >=> maybe (throwHttp ResponseTimeout) return
37
38    getStatus = withTimeout next
39      where
40        next = nextStatusHeaders >>= maybe next return
41
42    getStatusExpectContinue sendBody = do
43        status <- withTimeout nextStatusHeaders
44        case status of
45            Just  s -> return s
46            Nothing -> sendBody >> getStatus
47
48    nextStatusHeaders = do
49        (s, v) <- nextStatusLine
50        if statusCode s == 100
51            then connectionDropTillBlankLine conn >> return Nothing
52            else Just . StatusHeaders s v A.<$> parseHeaders (0 :: Int) id
53
54    nextStatusLine :: IO (Status, HttpVersion)
55    nextStatusLine = do
56        -- Ensure that there is some data coming in. If not, we want to signal
57        -- this as a connection problem and not a protocol problem.
58        bs <- connectionRead conn
59        when (S.null bs) $ throwHttp NoResponseDataReceived
60        connectionReadLineWith conn bs >>= parseStatus 3
61
62    parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)
63    parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1)
64    parseStatus _ bs = do
65        let (ver, bs2) = S.break (== charSpace) bs
66            (code, bs3) = S.break (== charSpace) $ S.dropWhile (== charSpace) bs2
67            msg = S.dropWhile (== charSpace) bs3
68        case (,) <$> parseVersion ver A.<*> readInt code of
69            Just (ver', code') -> return (Status code' msg, ver')
70            Nothing -> throwHttp $ InvalidStatusLine bs
71
72    stripPrefixBS x y
73        | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y
74        | otherwise = Nothing
75    parseVersion bs0 = do
76        bs1 <- stripPrefixBS "HTTP/" bs0
77        let (num1, S.drop 1 -> num2) = S.break (== charPeriod) bs1
78        HttpVersion <$> readInt num1 <*> readInt num2
79
80    readInt bs =
81        case S8.readInt bs of
82            Just (i, "") -> Just i
83            _ -> Nothing
84
85    parseHeaders 100 _ = throwHttp OverlongHeaders
86    parseHeaders count front = do
87        line <- connectionReadLine conn
88        if S.null line
89            then return $ front []
90            else do
91                mheader <- parseHeader line
92                case mheader of
93                    Just header ->
94                        parseHeaders (count + 1) $ front . (header:)
95                    Nothing ->
96                        -- Unparseable header line; rather than throwing
97                        -- an exception, ignore it for robustness.
98                        parseHeaders count front
99
100    parseHeader :: S.ByteString -> IO (Maybe Header)
101    parseHeader bs = do
102        let (key, bs2) = S.break (== charColon) bs
103        if S.null bs2
104            then return Nothing
105            else return (Just (CI.mk $! strip key, strip $! S.drop 1 bs2))
106
107    strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)
108
109data HeadersValidationResult
110    = GoodHeaders
111    | BadHeaders S.ByteString -- contains a message with the reason
112
113validateHeaders :: RequestHeaders -> HeadersValidationResult
114validateHeaders headers =
115    case mapMaybe validateHeader headers of
116        [] -> GoodHeaders
117        reasons -> BadHeaders (S8.unlines reasons)
118    where
119    validateHeader (k, v)
120        | S8.elem '\n' v = Just ("Header " <> CI.original k <> " has newlines")
121        | True = Nothing
122