1{-# LANGUAGE OverloadedStrings #-} 2 3module ResponseSpec (main, spec) where 4 5import Control.Concurrent (threadDelay) 6import qualified Data.ByteString as S 7import qualified Data.ByteString.Char8 as S8 8import Data.Maybe (mapMaybe) 9import Network.HTTP.Types 10import Network.Wai hiding (responseHeaders) 11import Network.Wai.Handler.Warp 12import Network.Wai.Handler.Warp.Response 13import RunSpec (withApp, msWrite, msRead, withMySocket) 14import Test.Hspec 15 16main :: IO () 17main = hspec spec 18 19testRange :: S.ByteString -- ^ range value 20 -> String -- ^ expected output 21 -> Maybe String -- ^ expected content-range value 22 -> Spec 23testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do 24 msWrite ms "GET / HTTP/1.0\r\n" 25 msWrite ms "Range: bytes=" 26 msWrite ms range 27 msWrite ms "\r\n\r\n" 28 threadDelay 10000 29 bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 30 last bss `shouldBe` out 31 let hs = mapMaybe toHeader bss 32 lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange 33 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) 34 where 35 app _ = ($ responseFile status200 [] "attic/hex" Nothing) 36 title = show (range, out, crange) 37 toHeader s = 38 case break (== ':') s of 39 (x, ':':y) -> Just (x, dropWhile (== ' ') y) 40 _ -> Nothing 41 42testPartial :: Integer -- ^ file size 43 -> Integer -- ^ offset 44 -> Integer -- ^ byte count 45 -> String -- ^ expected output 46 -> Spec 47testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do 48 msWrite ms "GET / HTTP/1.0\r\n\r\n" 49 threadDelay 10000 50 bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 51 out `shouldBe` last bss 52 let hs = mapMaybe toHeader bss 53 lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) 54 lookup "Content-Range" hs `shouldBe` Just range 55 where 56 app _ = ($ responseFile status200 [] "attic/hex" $ Just $ FilePart offset count size) 57 title = show (offset, count, out) 58 toHeader s = 59 case break (== ':') s of 60 (x, ':':y) -> Just (x, dropWhile (== ' ') y) 61 _ -> Nothing 62 range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size 63 64spec :: Spec 65spec = do 66{- http-client does not support this. 67 describe "preventing response splitting attack" $ do 68 it "sanitizes header values" $ do 69 let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello" 70 withApp defaultSettings app $ \port -> do 71 res <- sendGET $ "http://127.0.0.1:" ++ show port 72 getHeaderValue "foo" (responseHeaders res) `shouldBe` 73 Just "foo bar" -- HTTP inserts two spaces for \r\n. 74-} 75 76 describe "sanitizeHeaderValue" $ do 77 it "doesn't alter valid multiline header values" $ do 78 sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar" 79 80 it "adds missing spaces after \r\n" $ do 81 sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar" 82 83 it "discards empty lines" $ do 84 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar" 85 86 context "when sanitizing single occurrences of \n" $ do 87 it "replaces \n with \r\n" $ do 88 sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar" 89 90 it "adds missing spaces after \n" $ do 91 sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar" 92 93 it "discards single occurrences of \r" $ do 94 sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar" 95 96 describe "range requests" $ do 97 testRange "2-3" "23" $ Just "2-3/16" 98 testRange "5-" "56789abcdef" $ Just "5-15/16" 99 testRange "5-8" "5678" $ Just "5-8/16" 100 testRange "-3" "def" $ Just "13-15/16" 101 testRange "16-" "" $ Just "*/16" 102 testRange "-17" "0123456789abcdef" Nothing 103 104 describe "partial files" $ do 105 testPartial 16 2 2 "23" 106 testPartial 16 0 2 "01" 107 testPartial 16 3 8 "3456789a" 108