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