git.iko.soy/typeable/wai
on master help sign in
Sanitize header values to prevent response splitting
commitc478cbc77feb7fa4fc174bce8c88cc918bcea7fc authorSönke Hahn <soenke.hahn@zalora.com> dateThu 17 Sep 2015, 15:20 (11 years ago) parentc477e9a
3 files changed+58−25
compare with master
unifiedsplit
warp/Network/Wai/Handler/Warp/Response.hs+29−22 warp/test/HTTP.hs+5 warp/test/ResponseSpec.hs+24−3
warp/Network/Wai/Handler/Warp/Response.hs+29−22
@@ -3,9 +3,11 @@
33{-# LANGUAGE TupleSections #-}
44{-# LANGUAGE RankNTypes #-}
55{-# LANGUAGE CPP #-}
6+{-# LANGUAGE ViewPatterns #-}
67
78module Network.Wai.Handler.Warp.Response (
89 sendResponse
10+ , sanitizeHeaderValue -- for testing
911 , fileRange -- for testing
1012 , warpVersion
1113 , defaultServerValue
@@ -27,13 +29,15 @@ import Control.Monad (unless, when)
2729import Data.Array ((!))
2830import Data.ByteString (ByteString)
2931import qualified Data.ByteString as S
32+import qualified Data.ByteString.Char8 as S8
3033import Data.ByteString.Builder (byteString, Builder)
3134import Data.ByteString.Builder.Extra (flush)
3235import qualified Data.ByteString.Char8 as B (pack)
3336import qualified Data.CaseInsensitive as CI
37+import Data.Char
3438import Data.Function (on)
3539import Data.List (deleteBy)
36−import Data.Maybe (isJust, fromMaybe)
40+import Data.Maybe
3741#if MIN_VERSION_base(4,5,0)
3842# if __GLASGOW_HASKELL__ < 709
3943import Data.Monoid (mempty)
@@ -44,6 +48,7 @@ import Data.Monoid (mappend, mempty)
4448#endif
4549import Data.Streaming.Blaze (newBlazeRecv, reuseBufferStrategy)
4650import Data.Version (showVersion)
51+import Data.Word
4752import qualified Network.HTTP.Types as H
4853import Network.Wai
4954import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
@@ -143,26 +148,7 @@ sendResponse :: ByteString -- ^ default server value
143148 -> IO ByteString -- ^ source from client, for raw response
144149 -> Response -- ^ HTTP response including status code and response header.
145150 -> IO Bool -- ^ Returing True if the connection is persistent.
146−sendResponse defServer conn ii req reqidxhdr src response =
147− sendResponse' defServer conn ii req reqidxhdr src response'
148− where
149− doesContainCRLF :: [ByteString] -> Bool
150− doesContainCRLF = or . map (S.any (\w -> w == 10 || w == 13))
151− hsv = map snd $ responseHeaders response
152− response'
153− | doesContainCRLF hsv = response400
154− | otherwise = response
155− response400 = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request"
156−
157−sendResponse' :: ByteString -- ^ default server value
158− -> Connection
159− -> InternalInfo
160− -> Request -- ^ HTTP request.
161− -> IndexedHeader -- ^ Indexed header of HTTP request.
162− -> IO ByteString -- ^ source from client, for raw response
163− -> Response -- ^ HTTP response including status code and response header.
164− -> IO Bool -- ^ Returing True if the connection is persistent.
165−sendResponse' defServer conn ii req reqidxhdr src response = do
151+sendResponse defServer conn ii req reqidxhdr src (sanitizeHeaders -> response) = do
166152 hs <- addServerAndDate hs0
167153 if hasBody s then do
168154 -- HEAD comes here even if it does not have body.
@@ -198,7 +184,28 @@ sendResponse' defServer conn ii req reqidxhdr src response = do
198184 ResponseStream {} -> isKeepAlive
199185 ResponseRaw {} -> False
200186
201−----------------------------------------------------------------
187+sanitizeHeaders :: Response -> Response
188+sanitizeHeaders = mapResponseHeaders (map (fmap sanitizeHeaderValue))
189+
190+sanitizeHeaderValue :: ByteString -> ByteString
191+sanitizeHeaderValue v
192+ | containsNewlines v = case S8.lines $ S.filter (/= cr) v of
193+ x : xs -> S.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)
194+ [] -> ""
195+ | otherwise = v
196+ where
197+ containsNewlines = S.any (\w -> w == cr || w == lf)
198+ addSpaceIfMissing line = case S8.uncons line of
199+ Nothing -> Nothing
200+ Just (first, _) -> Just $ if first == ' ' || first == '\t'
201+ then line
202+ else " " <> line
203+
204+cr :: Word8
205+cr = fromIntegral (ord '\r')
206+
207+lf :: Word8
208+lf = fromIntegral (ord '\n')
202209
203210data Rsp = RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) Bool (IO ())
204211 | RspBuilder Builder Bool
warp/test/HTTP.hs+5
@@ -1,8 +1,11 @@
1+{-# LANGUAGE StandaloneDeriving #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
13module HTTP (
24 sendGET
35 , sendGETwH
46 , rspBody
57 , rspCode
8+ , rspHeaders
69 , getHeaderValue
710 , HeaderName(..)
811 ) where
@@ -27,3 +30,5 @@ getHeaderValue :: HasHeaders a => HeaderName -> a -> Maybe String
2730getHeaderValue key r = case retrieveHeaders key r of
2831 [] -> Nothing
2932 x:_ -> Just $ hdrValue x
33+
34+deriving instance Eq Header
warp/test/ResponseSpec.hs+24−3
@@ -85,11 +85,32 @@ testFileRange desc s rsphdr file mPart mRange ans = it desc $ do
8585spec :: Spec
8686spec = do
8787 describe "preventing response splitting attack" $ do
88− it "returns 400 if response headers contain illegal characters" $ do
89− let app _ f = f $ responseLBS status200 [("content-length", "20"),("foo", "foo\r\n\r\nbar\r\n")] "Hello"
88+ it "sanitizes header values" $ do
89+ let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"
9090 withApp defaultSettings app $ \port -> do
9191 res <- sendGET $ "http://127.0.0.1:" ++ show port
92− rspCode res `shouldBe` (4,0,0)
92+ getHeaderValue (HdrCustom "foo") res `shouldBe`
93+ Just "foo bar" -- HTTP inserts two spaces for \r\n.
94+
95+ describe "sanitizeHeaderValue" $ do
96+ it "doesn't alter valid multiline header values" $ do
97+ sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar"
98+
99+ it "adds missing spaces after \r\n" $ do
100+ sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar"
101+
102+ it "discards empty lines" $ do
103+ sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"
104+
105+ context "when sanitizing single occurences of \n" $ do
106+ it "replaces \n with \r\n" $ do
107+ sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"
108+
109+ it "adds missing spaces after \n" $ do
110+ sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar"
111+
112+ it "discards single occurrences of \r" $ do
113+ sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar"
93114
94115 describe "range requests" $ do
95116 testRange "2-3" "23" $ Just "2-3/16"