{-# LANGUAGE OverloadedStrings #-}
module ClassicSpec where
import Control.Applicative
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Conduit
import Network.HTTP.Conduit
import qualified Network.HTTP.Types as H
import Prelude hiding (catch)
import Test.Hspec
spec :: Spec
spec = do
describe "cgiApp" $ do
it "accepts POST" $ do
let url = "http://127.0.0.1:2345/cgi-bin/echo-env/pathinfo?query=foo"
bdy <- responseBody <$> sendPOST url "foo bar.\nbaz!\n"
ans <- BL.readFile "test/data/post"
bdy `shouldBe` ans
it "causes 500 if the CGI script does not exist" $ do
let url = "http://127.0.0.1:2345/cgi-bin/broken"
sc <- responseStatus <$> sendPOST url "foo bar.\nbaz!\n"
sc `shouldBe` H.internalServerError500
describe "fileApp" $ do
it "returns index.html for /" $ do
let url = "http://127.0.0.1:2345/"
rsp <- simpleHttp url
ans <- BL.readFile "test/html/index.html"
rsp `shouldBe` ans
it "returns 400 if not exist" $ do
let url = "http://127.0.0.1:2345/dummy"
req <- parseUrl url
sc <- responseStatus <$> safeHttpLbs req
sc `shouldBe` H.notFound404
it "returns Japanese HTML if language is specified" $ do
let url = "http://127.0.0.1:2345/ja/"
bdy <- responseBody <$> sendGET url [("Accept-Language", "ja, en;q=0.7")]
ans <- BL.readFile "test/html/ja/index.html.ja"
bdy `shouldBe` ans
it "returns 304 if not changed" $ do
let url = "http://127.0.0.1:2345/"
hdr <- responseHeaders <$> sendGET url []
let Just lm = lookup "Last-Modified" hdr
sc <- responseStatus <$> sendGET url [("If-Modified-Since", lm)]
sc `shouldBe` H.notModified304
it "can handle partial request" $ do
let url = "http://127.0.0.1:2345/"
ans = "html>\n<html"
bdy <- responseBody <$> sendGET url [("Range", "bytes=10-20")]
bdy `shouldBe` ans
it "can handle HEAD" $ do
let url = "http://127.0.0.1:2345/"
sc <- responseStatus <$> sendHEAD url []
sc `shouldBe` H.ok200
it "returns 404 for HEAD if not exist" $ do
let url = "http://127.0.0.1:2345/dummy"
sc <- responseStatus <$> sendHEAD url []
sc `shouldBe` H.notFound404
it "can handle HEAD even if language is specified" $ do
let url = "http://127.0.0.1:2345/ja/"
sc <- responseStatus <$> sendHEAD url [("Accept-Language", "ja, en;q=0.7")]
sc `shouldBe` H.ok200
it "returns 304 for HEAD if not modified" $ do
let url = "http://127.0.0.1:2345/"
hdr <- responseHeaders <$> sendHEAD url []
let Just lm = lookup "Last-Modified" hdr
sc <- responseStatus <$> sendHEAD url [("If-Modified-Since", lm)]
sc `shouldBe` H.notModified304
it "redirects to dir/ if trailing slash is missing" $ do
let url = "http://127.0.0.1:2345/redirect"
rsp <- simpleHttp url
ans <- BL.readFile "test/html/redirect/index.html"
rsp `shouldBe` ans
----------------------------------------------------------------
sendGET ::String -> H.RequestHeaders -> IO (Response BL.ByteString)
sendGET url hdr = do
req' <- parseUrl url
let req = req' { requestHeaders = hdr }
safeHttpLbs req
sendHEAD :: String -> H.RequestHeaders -> IO (Response BL.ByteString)
sendHEAD url hdr = do
req' <- parseUrl url
let req = req' {
requestHeaders = hdr
, method = "HEAD"
}
safeHttpLbs req
sendPOST :: String -> BL.ByteString -> IO (Response BL.ByteString)
sendPOST url body = do
req' <- parseUrl url
let req = req' {
method = "POST"
, requestBody = RequestBodyLBS body
}
safeHttpLbs req
----------------------------------------------------------------
safeHttpLbs :: Request (ResourceT IO) -> IO (Response BL.ByteString)
safeHttpLbs req = withManager $ httpLbs req {
checkStatus = \_ _ _ -> Nothing -- prevent throwing an error
}