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