diff --git a/Network/Wai/Application/Classic/CGI.hs b/Network/Wai/Application/Classic/CGI.hs --- a/Network/Wai/Application/Classic/CGI.hs +++ b/Network/Wai/Application/Classic/CGI.hs @@ -48,7 +48,7 @@ cgiApp cspec spec cgii req = case method of "GET" -> cgiApp' False cspec spec cgii req "POST" -> cgiApp' True cspec spec cgii req - _ -> return $ responseLBS statusNotAllowed textPlainHeader "Method Not Allowed\r\n" -- xxx + _ -> return $ responseLBS methodNotAllowed405 textPlainHeader "Method Not Allowed\r\n" -- xxx where method = requestMethod req @@ -75,7 +75,7 @@ bsrc <- bufferSource $ CB.sourceHandle rhdl m <- (check <$> (bsrc $$ parseHeader)) `catch` recover let (st, hdr, hasBody) = case m of - Nothing -> (statusServerError,[],False) + Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True) hdr' = addServer cspec hdr liftIO $ logger cspec req st Nothing @@ -83,7 +83,7 @@ return $ ResponseSource st hdr' (Chunk <$> src) where check hs = lookup fkContentType hs >> case lookup "status" hs of - Nothing -> Just (status200, hs) + Nothing -> Just (ok200, hs) Just l -> toStatus l >>= \s -> Just (s,hs') where hs' = filter (\(k,_) -> k /= "status") hs diff --git a/Network/Wai/Application/Classic/File.hs b/Network/Wai/Application/Classic/File.hs --- a/Network/Wai/Application/Classic/File.hs +++ b/Network/Wai/Application/Classic/File.hs @@ -6,8 +6,8 @@ ) where import Control.Applicative +import Control.Exception.IOChoice.Lifted import Control.Monad.IO.Class (liftIO) -import Data.Alternative.IO.Lifted import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS (pack, concat) import qualified Data.ByteString.Lazy.Char8 as BL (length) @@ -105,8 +105,8 @@ processGET :: HandlerInfo -> Bool -> Maybe Path -> Rsp processGET hinfo ishtml rfile = tryGet hinfo ishtml - <||> tryRedirect hinfo rfile - <||> return notFound + ||> tryRedirect hinfo rfile + ||> return notFound tryGet :: HandlerInfo -> Bool -> Rsp tryGet hinfo@(HandlerInfo _ _ _ langs) True = @@ -126,16 +126,16 @@ <|> unconditional req size mtime case pst of Full st - | st == statusOK -> return $ RspSpec statusOK (BodyFile hdr sfile (Entire size)) - | otherwise -> return $ RspSpec st (BodyFileNoBody hdr) - Partial skip len -> return $ RspSpec statusPartialContent (BodyFile hdr sfile (Part skip len)) + | st == ok200 -> return $ RspSpec ok200 (BodyFile hdr sfile (Entire size)) + | otherwise -> return $ RspSpec st (BodyFileNoBody hdr) + Partial skip len -> return $ RspSpec partialContent206 (BodyFile hdr sfile (Part skip len)) ---------------------------------------------------------------- processHEAD :: HandlerInfo -> Bool -> Maybe Path -> Rsp processHEAD hinfo ishtml rfile = tryHead hinfo ishtml - <||> tryRedirect hinfo rfile - <||> return notFoundNoBody + ||> tryRedirect hinfo rfile + ||> return notFoundNoBody tryHead :: HandlerInfo -> Bool -> Rsp tryHead hinfo@(HandlerInfo _ _ _ langs) True = @@ -149,7 +149,7 @@ size = fileInfoSize finfo hdr = newHeader ishtml (pathByteString file) mtime Just pst = ifmodified req size mtime -- never Nothing - <|> Just (Full statusOK) + <|> Just (Full ok200) case pst of Full st -> return $ RspSpec st (BodyFileNoBody hdr) _ -> goNext -- never reached @@ -166,7 +166,7 @@ tryRedirectFile :: HandlerInfo -> Lang -> Rsp tryRedirectFile (HandlerInfo spec req file _) lang = do _ <- liftIO $ (getFileInfo spec) (lang file) - return $ RspSpec statusMovedPermanently (BodyFileNoBody hdr) + return $ RspSpec movedPermanently301 (BodyFileNoBody hdr) where hdr = redirectHeader req @@ -186,10 +186,10 @@ ---------------------------------------------------------------- notFound :: RspSpec -notFound = RspSpec statusNotFound BodyStatus +notFound = RspSpec notFound404 BodyStatus notFoundNoBody :: RspSpec -notFoundNoBody = RspSpec statusNotFound NoBody +notFoundNoBody = RspSpec notFound404 NoBody notAllowed :: RspSpec -notAllowed = RspSpec statusNotAllowed BodyStatus +notAllowed = RspSpec methodNotAllowed405 BodyStatus diff --git a/Network/Wai/Application/Classic/FileInfo.hs b/Network/Wai/Application/Classic/FileInfo.hs --- a/Network/Wai/Application/Classic/FileInfo.hs +++ b/Network/Wai/Application/Classic/FileInfo.hs @@ -19,30 +19,30 @@ date <- ifModifiedSince req if date /= mtime then unconditional req size mtime - else Just (Full statusNotModified) + else Just (Full notModified304) ifunmodified :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifunmodified req size mtime = do date <- ifUnmodifiedSince req if date == mtime then unconditional req size mtime - else Just (Full statusPreconditionFailed) + else Just (Full preconditionFailed412) ifrange :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifrange req size mtime = do date <- ifRange req rng <- lookupRequestField fkRange req if date == mtime - then Just (Full statusOK) + then Just (Full ok200) else range size rng unconditional :: Request -> Integer -> HTTPDate -> Maybe StatusAux unconditional req size _ = - maybe (Just (Full statusOK)) (range size) $ lookupRequestField fkRange req + maybe (Just (Full ok200)) (range size) $ lookupRequestField fkRange req range :: Integer -> ByteString -> Maybe StatusAux range size rng = case skipAndSize rng size of - Nothing -> Just (Full statusRequestedRangeNotSatisfiable) + Nothing -> Just (Full requestedRangeNotSatisfiable416) Just (skip,len) -> Just (Partial skip len) ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Lang.hs b/Network/Wai/Application/Classic/Lang.hs --- a/Network/Wai/Application/Classic/Lang.hs +++ b/Network/Wai/Application/Classic/Lang.hs @@ -10,6 +10,10 @@ import Data.Ord import Prelude hiding (takeWhile) +-- | +-- >>> parseLang "en-gb;q=0.8, en;q=0.7, da" +-- ["da","en-gb","en"] + parseLang :: ByteString -> [ByteString] parseLang bs = case parseOnly acceptLanguage bs of Right ls -> map fst $ sortBy detrimental ls diff --git a/Network/Wai/Application/Classic/Range.hs b/Network/Wai/Application/Classic/Range.hs --- a/Network/Wai/Application/Classic/Range.hs +++ b/Network/Wai/Application/Classic/Range.hs @@ -7,6 +7,15 @@ import Data.Attoparsec.ByteString.Char8 hiding (take) import Data.ByteString.Char8 hiding (map, count, take, elem) +-- | +-- >>> skipAndSize "bytes=0-399" 10000 +-- Just (0,400) +-- >>> skipAndSize "bytes=500-799" 10000 +-- Just (500,300) +-- >>> skipAndSize "bytes=-500" 10000 +-- Just (9500,500) +-- >>> skipAndSize "bytes=9500-" 10000 +-- Just (9500,500) skipAndSize :: ByteString -> Integer -> Maybe (Integer,Integer) skipAndSize bs size = case parseRange bs of Just [(mbeg,mend)] -> adjust mbeg mend size diff --git a/Network/Wai/Application/Classic/RevProxy.hs b/Network/Wai/Application/Classic/RevProxy.hs --- a/Network/Wai/Application/Classic/RevProxy.hs +++ b/Network/Wai/Application/Classic/RevProxy.hs @@ -43,7 +43,7 @@ getBody :: Request -> Int64 -> H.RequestBody IO getBody req len = H.RequestBodySource len (toBodySource req) where - toBodySource = (byteStringToBuilder <$>) . requestBody + toBodySource = (byteStringToBuilder <$>) . requestBody getLen :: Request -> Maybe Int64 getLen req = do @@ -93,4 +93,4 @@ where hdr = addServer cspec textPlainHeader bdy = byteStringToBuilder "Bad Gateway\r\n" - st = statusBadGateway + st = badGateway502 diff --git a/Network/Wai/Application/Classic/Status.hs b/Network/Wai/Application/Classic/Status.hs --- a/Network/Wai/Application/Classic/Status.hs +++ b/Network/Wai/Application/Classic/Status.hs @@ -5,7 +5,7 @@ import Control.Applicative import Control.Arrow import Control.Exception -import Data.Alternative.IO +import Control.Exception.IOChoice import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Char8 () import Data.Maybe @@ -19,8 +19,8 @@ getStatusInfo :: ClassicAppSpec -> FileAppSpec -> [Lang] -> Status -> IO StatusInfo getStatusInfo cspec spec langs st = getStatusFile getF dir code langs - <|> getStatusBS code - <|> return StatusNone + ||> getStatusBS code + ||> return StatusNone where dir = statusFileDir cspec getF = getFileInfo spec @@ -30,10 +30,10 @@ statusList :: [Status] statusList = [ - statusNotAllowed -- 405 File - , statusNotFound -- 404 File - , statusServerError -- 500 CGI - , statusBadGateway -- 502 RevProxy + methodNotAllowed405 -- File + , notFound404 -- File + , internalServerError500 -- CGI + , badGateway502 -- RevProxy ] ---------------------------------------------------------------- @@ -62,6 +62,6 @@ Nothing -> [] Just file -> map ($ (dir file)) langs tryFile = foldr func goNext - func f io = StatusFile f . fileInfoSize <$> getF f <|> io + func f io = StatusFile f . fileInfoSize <$> getF f ||> io ---------------------------------------------------------------- diff --git a/Test.hs b/Test.hs deleted file mode 100644 --- a/Test.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} - -module Main where - -import Control.Exception.Lifted -import qualified Data.ByteString.Lazy.Char8 as BL -import Network.HTTP.Conduit -import Network.HTTP.Date -import qualified Network.HTTP.Types as H -import Network.Wai.Application.Classic.Header -import Network.Wai.Application.Classic.Lang -import Network.Wai.Application.Classic.Range -import Prelude hiding (catch) -import Test.Framework.Providers.DocTest -import Test.Framework.Providers.HUnit -import Test.Framework.TH.Prime -import Test.HUnit - ----------------------------------------------------------------- - -main :: IO () -main = $(defaultMainGenerator) - ----------------------------------------------------------------- - -doc_test :: DocTests -doc_test = docTest ["Network/Wai/Application/Classic.hs"] ["-XOverloadedStrings"] - ----------------------------------------------------------------- - -case_lang :: Assertion -case_lang = do - let res = parseLang "en-gb;q=0.8, en;q=0.7, da" - res @?= ans - where - ans = ["da","en-gb","en"] - ----------------------------------------------------------------- - -case_date :: Assertion -case_date = do - let Just x = parseHTTPDate date - res = formatHTTPDate x - res @?= date - where - date = "Tue, 15 Nov 1994 08:12:31 GMT" - ----------------------------------------------------------------- - -case_range :: Assertion -case_range = do - let res1 = skipAndSize range1 size - res2 = skipAndSize range2 size - res3 = skipAndSize range3 size - res4 = skipAndSize range4 size - res1 @?= ans1 - res2 @?= ans2 - res3 @?= ans3 - res4 @?= ans4 - where - size = 10000 - range1 = "bytes=0-399" - range2 = "bytes=500-799" - range3 = "bytes=-500" - range4 = "bytes=9500-" - ans1 = Just (0,400) - ans2 = Just (500,300) - ans3 = Just (9500,500) - ans4 = Just (9500,500) - ----------------------------------------------------------------- - -case_post :: Assertion -case_post = do - Response _ _ bdy <- sendPOST url "foo bar.\nbaz!\n" - ans <- BL.readFile "test/data/post" - bdy @?= ans - where - url = "http://localhost:8080/cgi-bin/echo-env/pathinfo?query=foo" - -case_post2 :: Assertion -case_post2 = do - Response sc _ _ <- sendPOST url "foo bar.\nbaz!\n" - sc @?= H.statusServerError - where - url = "http://localhost:8080/cgi-bin/broken" - ----------------------------------------------------------------- - -case_get :: Assertion -case_get = do - rsp <- simpleHttp url - ans <- BL.readFile "test/html/index.html" - rsp @?= ans - where - url = "http://localhost:8080/" - ----------------------------------------------------------------- - -case_get2 :: Assertion -case_get2 = do - req <- parseUrl url - Response sc _ _ <- safeHttpLbs req - sc @?= H.statusNotFound - where - url = "http://localhost:8080/dummy" - ----------------------------------------------------------------- - -case_get_ja :: Assertion -case_get_ja = do - Response _ _ bdy <- sendGET url [("Accept-Language", "ja, en;q=0.7")] - ans <- BL.readFile "test/html/ja/index.html.ja" - bdy @?= ans - where - url = "http://localhost:8080/ja/" - ----------------------------------------------------------------- - -case_get_modified :: Assertion -case_get_modified = do - Response _ hdr _ <- sendGET url [] - let Just lm = lookup fkLastModified hdr - Response sc _ _ <- sendGET url [("If-Modified-Since", lm)] - sc @?= H.statusNotModified - where - url = "http://localhost:8080/" - ----------------------------------------------------------------- - -case_get_partial :: Assertion -case_get_partial = do - Response _ _ bdy <- sendGET url [("Range", "bytes=10-20")] - bdy @?= ans - where - url = "http://localhost:8080/" - ans = "html>\n 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 IO -> IO (Response BL.ByteString) -safeHttpLbs req = withManager (httpLbs req) `catch` httpHandler - ----------------------------------------------------------------- - -httpHandler :: HttpException -> IO (Response BL.ByteString) -httpHandler (StatusCodeException sc hd) = return (Response sc hd BL.empty) -httpHandler _ = error "handler" diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} + +module Main where + +import Control.Exception.Lifted +import qualified Data.ByteString.Lazy.Char8 as BL +import Network.HTTP.Conduit +import qualified Network.HTTP.Types as H +import Prelude hiding (catch) +import Test.Framework.Providers.DocTest +import Test.Framework.Providers.HUnit +import Test.Framework.TH.Prime +import Test.HUnit + +---------------------------------------------------------------- + +main :: IO () +main = $(defaultMainGenerator) + +---------------------------------------------------------------- + +doc_test :: DocTests +doc_test = docTest ["Network/Wai/Application/Classic.hs"] ["-XOverloadedStrings"] +---------------------------------------------------------------- + +case_post :: Assertion +case_post = do + Response _ _ bdy <- sendPOST url "foo bar.\nbaz!\n" + ans <- BL.readFile "test/data/post" + bdy @?= ans + where + url = "http://localhost:8080/cgi-bin/echo-env/pathinfo?query=foo" + +case_post2 :: Assertion +case_post2 = do + Response sc _ _ <- sendPOST url "foo bar.\nbaz!\n" + sc @?= H.internalServerError500 + where + url = "http://localhost:8080/cgi-bin/broken" + +---------------------------------------------------------------- + +case_get :: Assertion +case_get = do + rsp <- simpleHttp url + ans <- BL.readFile "test/html/index.html" + rsp @?= ans + where + url = "http://localhost:8080/" + +---------------------------------------------------------------- + +case_get2 :: Assertion +case_get2 = do + req <- parseUrl url + Response sc _ _ <- safeHttpLbs req + sc @?= H.notFound404 + where + url = "http://localhost:8080/dummy" + +---------------------------------------------------------------- + +case_get_ja :: Assertion +case_get_ja = do + Response _ _ bdy <- sendGET url [("Accept-Language", "ja, en;q=0.7")] + ans <- BL.readFile "test/html/ja/index.html.ja" + bdy @?= ans + where + url = "http://localhost:8080/ja/" + +---------------------------------------------------------------- + +case_get_modified :: Assertion +case_get_modified = do + Response _ hdr _ <- sendGET url [] + let Just lm = lookup "Last-Modified" hdr + Response sc _ _ <- sendGET url [("If-Modified-Since", lm)] + sc @?= H.notModified304 + where + url = "http://localhost:8080/" + +---------------------------------------------------------------- + +case_get_partial :: Assertion +case_get_partial = do + Response _ _ bdy <- sendGET url [("Range", "bytes=10-20")] + bdy @?= ans + where + url = "http://localhost:8080/" + ans = "html>\n 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 IO -> IO (Response BL.ByteString) +safeHttpLbs req = withManager (httpLbs req) `catch` httpHandler + +---------------------------------------------------------------- + +httpHandler :: HttpException -> IO (Response BL.ByteString) +httpHandler (StatusCodeException sc hd) = return (Response sc hd BL.empty) +httpHandler _ = error "handler" diff --git a/wai-app-file-cgi.cabal b/wai-app-file-cgi.cabal --- a/wai-app-file-cgi.cabal +++ b/wai-app-file-cgi.cabal @@ -1,5 +1,5 @@ Name: wai-app-file-cgi -Version: 0.5.3 +Version: 0.5.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -31,7 +31,6 @@ Network.Wai.Application.Classic.Status Network.Wai.Application.Classic.Types Build-Depends: base >= 4 && < 5 - , alternative-io , attoparsec >= 0.10.0.0 , attoparsec-conduit , blaze-builder @@ -43,7 +42,8 @@ , filepath , http-conduit , http-date - , http-types + , http-types >= 0.6.9 + , io-choice , lifted-base , network , process @@ -57,33 +57,16 @@ Test-Suite test Main-Is: Test.hs Type: exitcode-stdio-1.0 + HS-Source-Dirs: test Build-Depends: base >= 4 && < 5 - , HUnit - , alternative-io - , attoparsec >= 0.10.0.0 - , attoparsec-conduit - , blaze-builder , bytestring - , case-insensitive - , conduit >= 0.2 - , containers - , directory - , filepath , http-conduit - , http-date , http-types , lifted-base - , network - , process - , static-hash + , HUnit , test-framework-doctest , test-framework-hunit , test-framework-th-prime - , transformers - , unix - , wai >= 1.1 - , wai-app-static >= 0.3 - , wai-logger Source-Repository head Type: git