git.iko.soy/typeable/wai
on warp-3.3.9-conn-closed-by-pear help sign in
typeable/wai/warp/test/ResponseSpec.hs
107 lines 4.2 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
3module ResponseSpec (main, spec) where
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
16main :: IO ()
17main = hspec spec
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
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
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-}
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"
80 it "adds missing spaces after \r\n" $ do
81 sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar"
83 it "discards empty lines" $ do
84 sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"
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"
90 it "adds missing spaces after \n" $ do
91 sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar"
93 it "discards single occurrences of \r" $ do
94 sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar"
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
104 describe "partial files" $ do
105 testPartial 16 2 2 "23"
106 testPartial 16 0 2 "01"
107 testPartial 16 3 8 "3456789a"