wai-app-file-cgi 3.0.9 → 3.1.0
raw patch · 11 files changed
+55/−287 lines, 11 filesdep ~waidep ~warp
Dependency ranges changed: wai, warp
Files
- Network/Wai/Application/Classic/CGI.hs +3/−4
- Network/Wai/Application/Classic/Def.hs +1/−7
- Network/Wai/Application/Classic/Field.hs +6/−19
- Network/Wai/Application/Classic/File.hs +38/−61
- Network/Wai/Application/Classic/FileInfo.hs +0/−41
- Network/Wai/Application/Classic/Header.hs +0/−45
- Network/Wai/Application/Classic/Range.hs +0/−67
- Network/Wai/Application/Classic/Redirect.hs +1/−2
- Network/Wai/Application/Classic/RevProxy.hs +1/−6
- Network/Wai/Application/Classic/Types.hs +0/−29
- wai-app-file-cgi.cabal +5/−6
Network/Wai/Application/Classic/CGI.hs view
@@ -59,7 +59,7 @@ cgi (rhdl,whdl,_) = do when body $ toCGI whdl req hClose whdl -- telling EOF- fromCGI rhdl cspec req+ fromCGI rhdl ---------------------------------------------------------------- @@ -68,13 +68,12 @@ toCGI :: Handle -> Request -> IO () toCGI whdl req = sourceRequestBody req $$ CB.sinkHandle whdl -fromCGI :: Handle -> ClassicAppSpec -> Request -> IO Response-fromCGI rhdl cspec req = do+fromCGI :: Handle -> IO Response+fromCGI rhdl = do (src', hs) <- cgiHeader `E.catch` recover let (st, hdr, hasBody) = case check hs of Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True)- logger cspec req st Nothing let src | hasBody = src' | otherwise = CL.sourceNull return $ responseSource st hdr src
Network/Wai/Application/Classic/Def.hs view
@@ -2,22 +2,16 @@ module Network.Wai.Application.Classic.Def where -import Network.HTTP.Types-import Network.Wai import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types -- |--- Default value for 'ClassicAppSpec'. 'softwareName' is \"Classic\". 'logger' does not log at all. 'dater' calls 'epochTime' for every request. 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\".+-- Default value for 'ClassicAppSpec'. 'softwareName' is \"Classic\". 'dater' calls 'epochTime' for every request. 'statusFileDir' is \"\/usr\/local\/share\/html\/status\/\". defaultClassicAppSpec :: ClassicAppSpec defaultClassicAppSpec = ClassicAppSpec { softwareName = "Classic"- , logger = defaultLogger , statusFileDir = "/usr/local/share/html/status/" }--defaultLogger :: Request -> Status -> Maybe Integer -> IO ()-defaultLogger _ _ _ = return () ----------------------------------------------------------------
Network/Wai/Application/Classic/Field.hs view
@@ -4,7 +4,6 @@ import Control.Arrow (first) import Control.Monad (mplus)-import Data.Array ((!)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8@@ -13,7 +12,6 @@ import Data.StaticHash (StaticHash) import qualified Data.StaticHash as SH import qualified Data.Text as T-import Network.HTTP.Date import Network.HTTP.Types import Network.Mime (defaultMimeMap, defaultMimeType, MimeType) import Network.SockAddr@@ -24,17 +22,8 @@ ---------------------------------------------------------------- -languages :: IndexedHeader -> [ByteString]-languages reqidx = maybe [] parseLang $ reqidx ! idxAcceptLanguage--ifModifiedSince :: IndexedHeader -> Maybe HTTPDate-ifModifiedSince reqidx = reqidx ! idxIfModifiedSince >>= parseHTTPDate--ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate-ifUnmodifiedSince reqidx = reqidx ! idxIfUnmodifiedSince >>= parseHTTPDate--ifRange :: IndexedHeader -> Maybe HTTPDate-ifRange reqidx = reqidx ! idxIfRange >>= parseHTTPDate+languages :: RequestHeaders -> [ByteString]+languages = maybe [] parseLang . lookup hAcceptLanguage ---------------------------------------------------------------- @@ -69,12 +58,10 @@ where addr = B8.pack . showSockAddr . remoteHost $ req -newHeader :: Bool -> ByteString -> ByteString -> ResponseHeaders-newHeader ishtml file date- | ishtml = lastMod : textHtmlHeader- | otherwise = lastMod : (hContentType, mimeType file) : []- where- lastMod = (hLastModified, date)+newHeader :: Bool -> ByteString -> ResponseHeaders+newHeader ishtml file+ | ishtml = textHtmlHeader+ | otherwise = [(hContentType, mimeType file)] mimeType :: ByteString -> MimeType mimeType file =fromMaybe defaultMimeType . foldr1 mplus . map lok $ targets
Network/Wai/Application/Classic/File.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-} module Network.Wai.Application.Classic.File ( fileApp , redirectHeader ) where +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative+#endif import Control.Exception.IOChoice.Lifted import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import Data.Maybe import qualified Data.ByteString.Char8 as BS (concat)-import qualified Data.ByteString.Lazy.Char8 as BL (length) import Network.HTTP.Types import Network.Wai import Network.Wai.Internal import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.FileInfo-import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Status import Network.Wai.Application.Classic.Types@@ -25,16 +25,19 @@ ---------------------------------------------------------------- -type Rsp = IO RspSpec+data RspSpec = NoBody Status+ | NoBodyHdr Status ResponseHeaders+ | BodyFile Status ResponseHeaders FilePath+ deriving (Eq,Show) ---------------------------------------------------------------- -data HandlerInfo = HandlerInfo FileAppSpec Request IndexedHeader Path [Lang]+data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang] -langSuffixes :: IndexedHeader -> [Lang]-langSuffixes reqidx = map (\x -> (<.> x)) langs ++ [id, (<.> "en")]+langSuffixes :: RequestHeaders -> [Lang]+langSuffixes hdr = map (\x -> (<.> x)) langs ++ [id, (<.> "en")] where- langs = map fromByteString $ languages reqidx+ langs = map fromByteString $ languages hdr ---------------------------------------------------------------- @@ -59,98 +62,72 @@ fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application fileApp cspec spec filei req respond = do- RspSpec st body <- case method of+ rspspec <- case method of Right GET -> processGET hinfo ishtml rfile Right HEAD -> processGET hinfo ishtml rfile _ -> return notAllowed- (response, mlen) <- case body of- NoBody -> noBody st- BodyStatus -> bodyStatus st- BodyFileNoBody hdr -> bodyFileNoBody st hdr- BodyFile hdr afile rng -> bodyFile st hdr afile rng- logger cspec req st mlen+ response <- case rspspec of+ NoBody st -> bodyStatus st+ NoBodyHdr st hdr -> return $ responseLBS st hdr ""+ BodyFile st hdr fl -> return $ ResponseFile st hdr fl Nothing respond response where- reqidx = indexRequestHeader (requestHeaders req)- hinfo = HandlerInfo spec req reqidx file langs+ hinfo = HandlerInfo spec req file langs method = parseMethod $ requestMethod req path = pathinfoToFilePath req filei file = addIndex spec path ishtml = isHTML spec file rfile = redirectPath spec path- langs = langSuffixes reqidx- noBody st = return (responseLBS st [] "", Nothing)+ langs = langSuffixes $ requestHeaders req+ noBody st = return $ responseLBS st [] "" bodyStatus st = liftIO (getStatusInfo cspec req langs st) >>= statusBody st statusBody st StatusNone = noBody st statusBody st (StatusByteString bd) =- return (responseLBS st hdr bd, Just (len bd))+ return $ responseLBS st hdr bd where- len = fromIntegral . BL.length hdr = textPlainHeader statusBody st (StatusFile afile len) =- return (ResponseFile st hdr fl mfp, Just len)+ return $ ResponseFile st hdr fl mfp where mfp = Just (FilePart 0 len len) fl = pathString afile hdr = textHtmlHeader- bodyFileNoBody st hdr =- return (responseLBS st hdr "", Nothing)- bodyFile st hdr afile rng =- return (ResponseFile st hdr fl mfp, Just len)- where- (len, mfp) = case rng of- -- sendfile of Linux does not support the entire file- Entire bytes -> (bytes, Just (FilePart 0 bytes bytes))- Part skip bytes total -> (bytes, Just (FilePart skip bytes total))- fl = pathString afile ---------------------------------------------------------------- -processGET :: HandlerInfo -> Bool -> Maybe Path -> Rsp+processGET :: HandlerInfo -> Bool -> Maybe Path -> IO RspSpec processGET hinfo ishtml rfile = tryGet hinfo ishtml ||> tryRedirect hinfo rfile ||> return notFound -tryGet :: HandlerInfo -> Bool -> Rsp-tryGet hinfo@(HandlerInfo _ _ _ _ langs) True =+tryGet :: HandlerInfo -> Bool -> IO RspSpec+tryGet hinfo@(HandlerInfo _ _ _ langs) True = runAnyOne $ map (tryGetFile hinfo True) langs tryGet hinfo False = tryGetFile hinfo False id -tryGetFile :: HandlerInfo -> Bool -> Lang -> Rsp-tryGetFile (HandlerInfo _ req reqidx file _) ishtml lang = do+tryGetFile :: HandlerInfo -> Bool -> Lang -> IO RspSpec+tryGetFile (HandlerInfo _ req file _) ishtml lang = do let file' = pathString $ lang file- finfo <- fromFileInfo <$> liftIO (getFileInfo req file')- let mtime = fileinfoTime finfo- size = fileinfoSize finfo- sfile = fileinfoName finfo- date = fileinfoDate finfo- mrange = requestHeaderRange req- hdr = newHeader ishtml (pathByteString file) date- Just pst = ifmodified reqidx size mtime mrange- <|> ifunmodified reqidx size mtime mrange- <|> ifrange reqidx size mtime mrange- <|> unconditional reqidx size mtime mrange- case pst of- Full st- | 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 size))+ hdr = newHeader ishtml $ pathByteString file+ finfo <- fromFileInfo <$> liftIO (getFileInfo req file') -- expecting an error+ let afile = pathString $ fileinfoName finfo+ return $ BodyFile ok200 hdr afile ---------------------------------------------------------------- -tryRedirect :: HandlerInfo -> Maybe Path -> Rsp+tryRedirect :: HandlerInfo -> Maybe Path -> IO RspSpec tryRedirect _ Nothing = goNext-tryRedirect (HandlerInfo spec req reqidx _ langs) (Just file) =+tryRedirect (HandlerInfo spec req _ langs) (Just file) = runAnyOne $ map (tryRedirectFile hinfo) langs where- hinfo = HandlerInfo spec req reqidx file langs+ hinfo = HandlerInfo spec req file langs -tryRedirectFile :: HandlerInfo -> Lang -> Rsp-tryRedirectFile (HandlerInfo _ req _ file _) lang = do+tryRedirectFile :: HandlerInfo -> Lang -> IO RspSpec+tryRedirectFile (HandlerInfo _ req file _) lang = do let file' = pathString $ lang file _ <- liftIO $ getFileInfo req file' -- expecting an error- return $ RspSpec movedPermanently301 (BodyFileNoBody hdr)+ return $ NoBodyHdr movedPermanently301 hdr where hdr = redirectHeader req @@ -173,7 +150,7 @@ ---------------------------------------------------------------- notFound :: RspSpec-notFound = RspSpec notFound404 BodyStatus+notFound = NoBody notFound404 notAllowed :: RspSpec-notAllowed = RspSpec methodNotAllowed405 BodyStatus+notAllowed = NoBody methodNotAllowed405
Network/Wai/Application/Classic/FileInfo.hs view
@@ -1,49 +1,8 @@ module Network.Wai.Application.Classic.FileInfo where -import Data.ByteString (ByteString)-import Network.HTTP.Date-import Network.HTTP.Types import Network.Wai-import Network.Wai.Application.Classic.Field-import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Path-import Network.Wai.Application.Classic.Range import Network.Wai.Application.Classic.Types--------------------------------------------------------------------data StatusAux = Full Status | Partial Integer Integer deriving Show--ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux-ifmodified reqidx size mtime mrange = do- date <- ifModifiedSince reqidx- if date /= mtime- then unconditional reqidx size mtime mrange- else Just (Full notModified304)--ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux-ifunmodified reqidx size mtime mrange = do- date <- ifUnmodifiedSince reqidx- if date == mtime- then unconditional reqidx size mtime mrange- else Just (Full preconditionFailed412)--ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux-ifrange reqidx size mtime mrange = do- date <- ifRange reqidx- rng <- mrange- if date == mtime- then parseRange size rng- else Just (Full ok200)--unconditional :: IndexedHeader -> Integer -> HTTPDate -> Maybe ByteString -> Maybe StatusAux-unconditional _ size _ mrange =- maybe (Just (Full ok200)) (parseRange size) mrange--parseRange :: Integer -> ByteString -> Maybe StatusAux-parseRange size rng = case skipAndSize rng size of- Nothing -> Just (Full requestedRangeNotSatisfiable416)- Just (skip,len) -> Just (Partial skip len) ----------------------------------------------------------------
Network/Wai/Application/Classic/Header.hs view
@@ -2,8 +2,6 @@ module Network.Wai.Application.Classic.Header where -import Data.Array-import Data.Array.ST import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS (tail,break) import Network.HTTP.Types.Header@@ -43,46 +41,3 @@ Just hostport -> case BS.break (== ':') hostport of (host,"") -> (host,"80") (host,port) -> (host, BS.tail port)---------------------------------------------------------------------- | Array for a set of HTTP headers.-type IndexedHeader = Array Int (Maybe ByteString)--------------------------------------------------------------------indexRequestHeader :: RequestHeaders -> IndexedHeader-indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex--idxAcceptLanguage,idxIfModifiedSince,idxIfUnmodifiedSince,idxIfRange :: Int-idxAcceptLanguage = 0-idxIfModifiedSince = 1-idxIfUnmodifiedSince = 2-idxIfRange = 3--requestMaxIndex :: Int-requestMaxIndex = 3--requestKeyIndex :: HeaderName -> Int-requestKeyIndex "accept-language" = idxAcceptLanguage-requestKeyIndex "if-modified-since" = idxIfModifiedSince-requestKeyIndex "if-unmodified-since" = idxIfUnmodifiedSince-requestKeyIndex "if-range" = idxIfRange-requestKeyIndex _ = -1--defaultIndexRequestHeader :: IndexedHeader-defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]--------------------------------------------------------------------traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader-traverseHeader hdr maxidx getIndex = runSTArray $ do- arr <- newArray (0,maxidx) Nothing- mapM_ (insert arr) hdr- return arr- where- insert arr (key,val)- | idx == -1 = return ()- | otherwise = writeArray arr idx (Just val)- where- idx = getIndex key
− Network/Wai/Application/Classic/Range.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Network.Wai.Application.Classic.Range (skipAndSize) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>), (<$), (<*), (*>))-#endif-import Control.Applicative ((<|>), many)-import Data.Attoparsec.ByteString hiding (satisfy)-import Data.Attoparsec.ByteString.Char8 hiding (take)-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B8-import Network.HTTP.Types---- |--- >>> 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 [rng] -> adjust rng size- _ -> Nothing--adjust :: ByteRange -> Integer -> Maybe (Integer,Integer)-adjust (ByteRangeFromTo beg end) siz- | beg <= end && end <= siz = Just (beg, end - beg + 1)- | otherwise = Nothing-adjust (ByteRangeFrom beg) siz- | beg <= siz = Just (beg, siz - beg)- | otherwise = Nothing-adjust (ByteRangeSuffix end) siz- | end <= siz = Just (siz - end, end)- | otherwise = Nothing--parseRange :: ByteString -> Maybe [ByteRange]-parseRange bs = case parseOnly byteRange bs of- Right x -> Just x- _ -> Nothing--byteRange :: Parser [ByteRange]-byteRange = string "bytes=" *> (ranges <* endOfInput)--ranges :: Parser [ByteRange]-ranges = sepBy1 (range <|> suffixRange) (spcs >> char ',' >> spcs)--range :: Parser ByteRange-range = do- beg <- num <* char '-'- (ByteRangeFromTo beg <$> num) <|> return (ByteRangeFrom beg)--suffixRange :: Parser ByteRange-suffixRange = ByteRangeSuffix <$> (char '-' *> num)--num :: Parser Integer-num = read <$> many1 digit--spcs :: Parser ()-spcs = () <$ many spc--spc :: Parser Char-spc = satisfy (`B8.elem` " \t")
Network/Wai/Application/Classic/Redirect.hs view
@@ -12,8 +12,7 @@ import Network.Wai.Application.Classic.Types redirectApp :: ClassicAppSpec -> RedirectRoute -> Application-redirectApp cspec route req respond = do- logger cspec req status Nothing+redirectApp _ route req respond = respond $ responseLBS status hdr "" where path = fromByteString $ rawPathInfo req
Network/Wai/Application/Classic/RevProxy.hs view
@@ -37,14 +37,10 @@ clientBody = H.responseBody hrsp ct = lookup hContentType hdr src = toSource ct clientBody- logger cspec req status (fromIntegral <$> mlen) respond $ responseSource status hdr src httpClientRequest = reqToHReq req route mgr = revProxyManager spec- mlen = case requestBodyLength req of- ChunkedBody -> Nothing- KnownLength len -> Just len fixHeader = addVia cspec req . filter headerToBeRelay headerToBeRelay :: Header -> Bool@@ -108,8 +104,7 @@ FIXME: badGateway :: ClassicAppSpec -> Request-> SomeException -> IO Response-badGateway cspec req _ = do- logger cspec req st Nothing -- FIXME body length+badGateway cspec req _ = return $ responseBuilder st hdr bdy where hdr = addServer cspec textPlainHeader
Network/Wai/Application/Classic/Types.hs view
@@ -6,8 +6,6 @@ import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Network.HTTP.Client as H import Network.HTTP.Date-import Network.HTTP.Types-import Network.Wai import Network.Wai.Handler.Warp (FileInfo(..)) import Network.Wai.Application.Classic.Path @@ -16,8 +14,6 @@ data ClassicAppSpec = ClassicAppSpec { -- | Name specified to Server: in HTTP response. softwareName :: ByteString- -- | A function for logging. The third argument is a body size.- , logger :: Request -> Status -> Maybe Integer -> IO () -- | A function to get HTTP's GMT Date. , statusFileDir :: Path }@@ -102,31 +98,6 @@ -- | Destination port number. , revProxyPort :: Int } deriving (Eq,Show)--------------------------------------------------------------------data RspSpec = RspSpec {- -- | Response status.- rspStatus :: Status- -- | Response body.- , rspBody :: RspBody- } deriving (Eq,Show)--data RspBody =- NoBody- | BodyStatus- | BodyFileNoBody ResponseHeaders- | BodyFile ResponseHeaders Path Range- deriving (Eq,Show)--data Range =- -- | Entire file showing its file size- Entire Integer- -- | A part of a file taking offset and length- | Part Integer -- offset- Integer -- length- Integer -- total- deriving (Eq,Show) ----------------------------------------------------------------
wai-app-file-cgi.cabal view
@@ -1,5 +1,5 @@ Name: wai-app-file-cgi-Version: 3.0.9+Version: 3.1.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -27,7 +27,6 @@ Network.Wai.Application.Classic.Header Network.Wai.Application.Classic.Lang Network.Wai.Application.Classic.Path- Network.Wai.Application.Classic.Range Network.Wai.Application.Classic.Redirect Network.Wai.Application.Classic.Status Network.Wai.Application.Classic.Types@@ -61,9 +60,9 @@ , text , transformers , unix- , wai >= 3.0 && < 3.1+ , wai >= 3.2 && < 3.3 , wai-conduit- , warp >= 3.1.12 && < 3.2+ , warp >= 3.2 && < 3.3 , word8 Test-Suite doctest@@ -91,9 +90,9 @@ , hspec >= 1.3 , http-types , unix- , wai >= 3.0 && < 3.1+ , wai >= 3.2 && < 3.3 , wai-app-file-cgi- , warp >= 3.1.12 && < 3.2+ , warp >= 3.2 && < 3.3 , HTTP Source-Repository head