{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module ClassicSpec where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Data.List (isPrefixOf)
import Network.HTTP
import Network.Stream
import System.IO
import Test.Hspec
spec :: Spec
spec = do
describe "cgiApp" $ do
it "returns index.cgi with empty PATH_INFO for /cgi-bin/" $ do
let url = "http://127.0.0.1:2345/cgi-bin/"
bdy <- rspBody <$> sendGET url
bdy `shouldBe` "index.cgi\n"
it "accepts POST" $ do
let url = "http://127.0.0.1:2345/cgi-bin/echo-env/pathinfo?query=foo"
bdy <- rspBody <$> sendPOST url "foo bar.\nbaz!\n"
ans <- readFileAscii "test/data/post"
bdy `shouldBe` ans
it "accepts a large POST echoed back by the CGI" $ do
let url = "http://127.0.0.1:2345/cgi-bin/cat"
body = replicate 1000000 'x'
bdy <- rspBody <$> sendPOST url body
bdy `shouldBe` body
it "relays the status of the CGI" $ do
let url = "http://127.0.0.1:2345/cgi-bin/not-found"
rsp <- sendGET url
rspCode rsp `shouldBe` (4, 0, 4)
words (rspReason rsp) `shouldBe` ["Not", "Found"]
it "redirects if the CGI returns Location only" $ do
let url = "http://127.0.0.1:2345/cgi-bin/redirect"
rsp <- sendGET url
rspCode rsp `shouldBe` (3, 0, 2)
lookupHeader HdrLocation (rspHeaders rsp)
`shouldBe` Just "http://example.com/"
it "passes request headers as HTTP_* except Proxy" $ do
let url = "http://127.0.0.1:2345/cgi-bin/http-env"
hdr =
[ Header (HdrCustom "X-Foo") "foo"
, Header (HdrCustom "Proxy") "http://evil.example/"
]
bdy <- rspBody <$> sendGETwH url hdr
lines bdy `shouldBe` ["HTTP_X_FOO: foo", "HTTP_PROXY: ", "REMOTE_PORT: yes"]
it "accepts HEAD" $ do
let url = "http://127.0.0.1:2345/cgi-bin/"
rsp <- sendHEAD url
rspCode rsp `shouldBe` (2, 0, 0)
rspBody rsp `shouldBe` ""
it "causes 500 if the CGI script does not behave correctly" $ do
let url = "http://127.0.0.1:2345/cgi-bin/broken"
sc <- rspCode <$> sendPOST url "foo bar.\nbaz!\n"
sc `shouldBe` (5, 0, 0)
it "returns 400 if the path contains .." $ do
let url = "http://127.0.0.1:2345/cgi-bin/../cgi-bin/index.cgi"
sc <- rspCode <$> sendGET url
sc `shouldBe` (4, 0, 0)
describe "fileApp" $ do
it "returns index.html for /" $ do
let url = "http://127.0.0.1:2345/"
bdy <- rspBody <$> sendGET url
ans <- readFileAscii "test/html/index.html"
bdy `shouldBe` ans
it "works with files that lack a file extension" $ do
let url = "http://127.0.0.1:2345/no_extension"
bdy <- rspBody <$> sendGET url
ans <- readFileAscii "test/html/no_extension"
bdy `shouldBe` ans
it "returns 404 if not exist" $ do
let url = "http://127.0.0.1:2345/dummy"
sc <- rspCode <$> sendGET url
sc `shouldBe` (4, 0, 4)
it "returns 400 if the path contains .." $ do
let url = "http://127.0.0.1:2345/../../../../../../etc/hosts"
sc <- rspCode <$> sendGET url
sc `shouldBe` (4, 0, 0)
it "returns Japanese HTML if language is specified" $ do
let url = "http://127.0.0.1:2345/ja/"
bdy <- rspBody <$> sendGETwH url [Header HdrAcceptLanguage "ja, en;q=0.7"]
ans <- readFileAscii "test/html/ja/index.html.ja"
bdy `shouldBe` ans
it "returns English HTML even if language is specified" $ do
let url = "http://127.0.0.1:2345/"
bdy <- rspBody <$> sendGETwH url [Header HdrAcceptLanguage "ja, en;q=0.7"]
ans <- readFileAscii "test/html/index.html"
bdy `shouldBe` ans
it "returns 304 if not changed" $ do
let url = "http://127.0.0.1:2345/"
hdr <- rspHeaders <$> sendGET url
let Just lm = lookupHeader HdrLastModified hdr
sc <- rspCode <$> sendGETwH url [Header HdrIfModifiedSince lm]
sc `shouldBe` (3, 0, 4)
it "can handle partial request" $ do
let url = "http://127.0.0.1:2345/"
ans = "html>\n<html"
bdy <- rspBody <$> sendGETwH url [Header HdrRange "bytes=10-20"]
bdy `shouldBe` ans
it "can handle HEAD" $ do
let url = "http://127.0.0.1:2345/"
sc <- rspCode <$> sendHEAD url
sc `shouldBe` (2, 0, 0)
it "returns 404 for HEAD if not exist" $ do
let url = "http://127.0.0.1:2345/dummy"
sc <- rspCode <$> sendHEAD url
sc `shouldBe` (4, 0, 4)
it "can handle HEAD even if language is specified" $ do
let url = "http://127.0.0.1:2345/ja/"
sc <- rspCode <$> sendHEADwH url [Header HdrAcceptLanguage "ja, en;q=0.7"]
sc `shouldBe` (2, 0, 0)
it "returns 304 for HEAD if not modified" $ do
let url = "http://127.0.0.1:2345/"
hdr <- rspHeaders <$> sendHEAD url
let Just lm = lookupHeader HdrLastModified hdr
sc <- rspCode <$> sendHEADwH url [Header HdrIfModifiedSince lm]
sc `shouldBe` (3, 0, 4)
it "redirects to dir/ if trailing slash is missing" $ do
let url = "http://127.0.0.1:2345/redirect"
rsp <- sendGET url
let sc = rspCode rsp
hdr = rspHeaders rsp
Just lm = lookupHeader HdrLocation hdr
sc `shouldBe` (3, 0, 1)
lm `shouldBe` "//127.0.0.1:2345/redirect/"
it "keeps the query string when redirecting to dir/" $ do
let url = "http://127.0.0.1:2345/redirect?foo=bar"
rsp <- sendGET url
lookupHeader HdrLocation (rspHeaders rsp)
`shouldBe` Just "//127.0.0.1:2345/redirect/?foo=bar"
it "returns index.html for /exact-route.html matching exactRoute" $ do
let url = "http://127.0.0.1:2345/exact-route.html"
bdy <- rspBody <$> sendGET url
ans <- readFileAscii "test/html/index.html"
bdy `shouldBe` ans
describe "revProxyApp" $ do
it "returns 502 if the upstream is not available" $ do
let url = "http://127.0.0.1:2345/revproxy/"
sc <- rspCode <$> sendGET url
sc `shouldBe` (5, 0, 2)
it "removes hop-by-hop headers and appends X-Forwarded-For" $ do
let url = "http://127.0.0.1:2345/upstream/"
hdr =
[ Header HdrProxyAuthorization "secret"
, Header (HdrCustom "X-Forwarded-For") "192.0.2.1"
]
rsp <- sendGETwH url hdr
let ls = lines $ rspBody rsp
rhdr = rspHeaders rsp
ls `shouldContain` ["x-forwarded-for: 192.0.2.1, 127.0.0.1"]
filter (isPrefixOf "proxy-authorization") ls `shouldBe` []
lookupHeader (HdrCustom "X-Up") rhdr `shouldBe` Nothing
lookupHeader (HdrCustom "Keep-Alive") rhdr `shouldBe` Nothing
lookupHeader HdrVia rhdr `shouldSatisfy` (/= Nothing)
----------------------------------------------------------------
sendGET :: String -> IO (Response String)
sendGET url = sendGETwH url []
sendGETwH :: String -> [Header] -> IO (Response String)
sendGETwH url hdr = unResult $ simpleHTTP $ (getRequest url){rqHeaders = hdr}
sendHEAD :: String -> IO (Response String)
sendHEAD url = sendHEADwH url []
sendHEADwH :: String -> [Header] -> IO (Response String)
sendHEADwH url hdr = unResult $ simpleHTTP $ (headRequest url){rqHeaders = hdr}
sendPOST :: String -> String -> IO (Response String)
sendPOST url body = unResult $ simpleHTTP $ postRequestWithBody url "Text/Plain" body
unResult :: IO (Result (Response String)) -> IO (Response String)
unResult action = do
res <- action
case res of
Right rsp -> return rsp
Left _ -> error "Connection error"
readFileAscii :: FilePath -> IO String
readFileAscii name = do
h <- openFile name ReadMode
hSetEncoding h latin1
hGetContents h