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