wai-app-file-cgi 0.5.3 → 0.5.4
raw patch · 10 files changed
+229/−280 lines, 10 filesdep +io-choicedep −alternative-iodep ~http-typesPVP ok
version bump matches the API change (PVP)
Dependencies added: io-choice
Dependencies removed: alternative-io
Dependency ranges changed: http-types
API changes (from Hackage documentation)
Files
- Network/Wai/Application/Classic/CGI.hs +3/−3
- Network/Wai/Application/Classic/File.hs +13/−13
- Network/Wai/Application/Classic/FileInfo.hs +5/−5
- Network/Wai/Application/Classic/Lang.hs +4/−0
- Network/Wai/Application/Classic/Range.hs +9/−0
- Network/Wai/Application/Classic/RevProxy.hs +2/−2
- Network/Wai/Application/Classic/Status.hs +8/−8
- Test.hs +0/−227
- test/Test.hs +180/−0
- wai-app-file-cgi.cabal +5/−22
Network/Wai/Application/Classic/CGI.hs view
@@ -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
Network/Wai/Application/Classic/File.hs view
@@ -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
Network/Wai/Application/Classic/FileInfo.hs view
@@ -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) ----------------------------------------------------------------
Network/Wai/Application/Classic/Lang.hs view
@@ -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
Network/Wai/Application/Classic/Range.hs view
@@ -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
Network/Wai/Application/Classic/RevProxy.hs view
@@ -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
Network/Wai/Application/Classic/Status.hs view
@@ -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 ----------------------------------------------------------------
− Test.hs
@@ -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<html"--------------------------------------------------------------------case_head :: Assertion-case_head = do- Response sc _ _ <- sendHEAD url []- sc @?= H.statusOK- where- url = "http://localhost:8080/"--------------------------------------------------------------------case_head2 :: Assertion-case_head2 = do- Response sc _ _ <- sendHEAD url []- sc @?= H.statusNotFound- where- url = "http://localhost:8080/dummy"--------------------------------------------------------------------case_head_ja :: Assertion-case_head_ja = do- Response sc _ _ <- sendHEAD url [("Accept-Language", "ja, en;q=0.7")]- sc @?= H.statusOK- where- url = "http://localhost:8080/ja/"--------------------------------------------------------------------case_head_modified :: Assertion-case_head_modified = do- Response _ hdr _ <- sendHEAD url []- let Just lm = lookup fkLastModified hdr- Response sc _ _ <- sendHEAD url [("If-Modified-Since", lm)]- sc @?= H.statusNotModified- where- url = "http://localhost:8080/"--------------------------------------------------------------------case_redirect :: Assertion-case_redirect = do- rsp <- simpleHttp url- ans <- BL.readFile "test/html/redirect/index.html"- rsp @?= ans- where- url = "http://localhost:8080/redirect"-------------------------------------------------------------------------------------------------------------------------------------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 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"
+ test/Test.hs view
@@ -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<html"++----------------------------------------------------------------++case_head :: Assertion+case_head = do+ Response sc _ _ <- sendHEAD url []+ sc @?= H.ok200+ where+ url = "http://localhost:8080/"++----------------------------------------------------------------++case_head2 :: Assertion+case_head2 = do+ Response sc _ _ <- sendHEAD url []+ sc @?= H.notFound404+ where+ url = "http://localhost:8080/dummy"++----------------------------------------------------------------++case_head_ja :: Assertion+case_head_ja = do+ Response sc _ _ <- sendHEAD url [("Accept-Language", "ja, en;q=0.7")]+ sc @?= H.ok200+ where+ url = "http://localhost:8080/ja/"++----------------------------------------------------------------++case_head_modified :: Assertion+case_head_modified = do+ Response _ hdr _ <- sendHEAD url []+ let Just lm = lookup "Last-Modified" hdr+ Response sc _ _ <- sendHEAD url [("If-Modified-Since", lm)]+ sc @?= H.notModified304+ where+ url = "http://localhost:8080/"++----------------------------------------------------------------++case_redirect :: Assertion+case_redirect = do+ rsp <- simpleHttp url+ ans <- BL.readFile "test/html/redirect/index.html"+ rsp @?= ans+ where+ url = "http://localhost:8080/redirect"++----------------------------------------------------------------+----------------------------------------------------------------++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 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"
wai-app-file-cgi.cabal view
@@ -1,5 +1,5 @@ Name: wai-app-file-cgi-Version: 0.5.3+Version: 0.5.4 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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