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