wai-app-file-cgi 0.6.0 → 0.7.0
raw patch · 9 files changed
+119/−130 lines, 9 filesdep +mime-typesdep +textdep −wai-app-staticdep ~blaze-htmldep ~conduitdep ~http-typesPVP ok
version bump matches the API change (PVP)
Dependencies added: mime-types, text
Dependencies removed: wai-app-static
Dependency ranges changed: blaze-html, conduit, http-types
API changes (from Hackage documentation)
Files
- Network/Wai/Application/Classic/CGI.hs +15/−11
- Network/Wai/Application/Classic/Conduit.hs +5/−3
- Network/Wai/Application/Classic/Field.hs +26/−17
- Network/Wai/Application/Classic/File.hs +25/−20
- Network/Wai/Application/Classic/FileInfo.hs +2/−2
- Network/Wai/Application/Classic/Header.hs +15/−46
- Network/Wai/Application/Classic/Range.hs +16/−17
- Network/Wai/Application/Classic/RevProxy.hs +8/−7
- wai-app-file-cgi.cabal +7/−7
Network/Wai/Application/Classic/CGI.hs view
@@ -45,11 +45,11 @@ -} cgiApp :: ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application cgiApp cspec spec cgii req = case method of- "GET" -> cgiApp' False cspec spec cgii req- "POST" -> cgiApp' True cspec spec cgii req- _ -> return $ responseLBS methodNotAllowed405 textPlainHeader "Method Not Allowed\r\n" -- xxx+ Right GET -> cgiApp' False cspec spec cgii req+ Right POST -> cgiApp' True cspec spec cgii req+ _ -> return $ responseLBS methodNotAllowed405 textPlainHeader "Method Not Allowed\r\n" -- xxx where- method = requestMethod req+ method = parseMethod $ requestMethod req cgiApp' :: Bool -> ClassicAppSpec -> CgiAppSpec -> CgiRoute -> Application cgiApp' body cspec spec cgii req = do@@ -71,23 +71,27 @@ fromCGI :: Handle -> ClassicAppSpec -> Application fromCGI rhdl cspec req = do- (src', hs) <- (CB.sourceHandle rhdl $$+ parseHeader) `catch` recover+ (src', hs) <- cgiHeader `catch` recover let (st, hdr, hasBody) = case check hs of Nothing -> (internalServerError500,[],False) Just (s,h) -> (s,h,True) hdr' = addServer cspec hdr liftIO $ logger cspec req st Nothing let src = if hasBody then src' else CL.sourceNull- return $ ResponseSource st hdr' (toResponseSource src)+ return $ ResponseSource st hdr' src where- check hs = lookup fkContentType hs >> case lookup "status" hs of+ check hs = lookup hContentType hs >> case lookup hStatus hs of Nothing -> Just (ok200, hs) Just l -> toStatus l >>= \s -> Just (s,hs') where- hs' = filter (\(k,_) -> k /= "status") hs+ hs' = filter (\(k,_) -> k /= hStatus) hs toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) emptyHeader = [] recover (_ :: SomeException) = return (CL.sourceNull, emptyHeader)+ cgiHeader = do+ (rsrc,hs) <- CB.sourceHandle rhdl $$+ parseHeader+ src <- toResponseSource rsrc+ return (src,hs) ---------------------------------------------------------------- @@ -133,9 +137,9 @@ , ("QUERY_STRING", query req) ] headers = requestHeaders req- addLen = addEnv "CONTENT_LENGTH" $ lookup fkContentLength headers- addType = addEnv "CONTENT_TYPE" $ lookup fkContentType headers- addCookie = addEnv "HTTP_COOKIE" $ lookup fkCookie headers+ addLen = addEnv "CONTENT_LENGTH" $ lookup hContentLength headers+ addType = addEnv "CONTENT_TYPE" $ lookup hContentType headers+ addCookie = addEnv "HTTP_COOKIE" $ lookup hCookie headers query = BS.unpack . safeTail . rawQueryString where safeTail "" = ""
Network/Wai/Application/Classic/Conduit.hs view
@@ -25,9 +25,11 @@ ---------------------------------------------------------------- -toResponseSource :: Source (ResourceT IO) ByteString - -> Source (ResourceT IO) (Flush Builder)-toResponseSource = ($= CL.map (Chunk . byteStringToBuilder))+toResponseSource :: ResumableSource (ResourceT IO) ByteString+ -> (ResourceT IO) (Source (ResourceT IO) (Flush Builder))+toResponseSource rsrc = do+ (src,_) <- unwrapResumable rsrc+ return $ src $= CL.map (Chunk . byteStringToBuilder) ----------------------------------------------------------------
Network/Wai/Application/Classic/Field.hs view
@@ -2,6 +2,7 @@ module Network.Wai.Application.Classic.Field where +import Control.Applicative import Control.Arrow (first) import Control.Monad (mplus) import Data.ByteString (ByteString)@@ -11,49 +12,52 @@ import Data.Maybe 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.HTTP.Types.Header+import Network.Mime (defaultMimeMap, defaultMimeType, MimeType) import Network.Wai import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Lang import Network.Wai.Application.Classic.Types-import Network.Wai.Application.Static (defaultMimeTypes, defaultMimeType, MimeType, fromFilePath) import Network.Wai.Logger.Utils+import System.Posix.Time ---------------------------------------------------------------- -languages :: Request -> [Ascii]-languages req = maybe [] parseLang $ lookupRequestField fkAcceptLanguage req+languages :: Request -> [ByteString]+languages req = maybe [] parseLang $ lookupRequestField hAcceptLanguage req ifModifiedSince :: Request -> Maybe HTTPDate-ifModifiedSince = lookupAndParseDate fkIfModifiedSince+ifModifiedSince = lookupAndParseDate hIfModifiedSince ifUnmodifiedSince :: Request -> Maybe HTTPDate-ifUnmodifiedSince = lookupAndParseDate fkIfUnmodifiedSince+ifUnmodifiedSince = lookupAndParseDate hIfUnmodifiedSince ifRange :: Request -> Maybe HTTPDate-ifRange = lookupAndParseDate fkIfRange+ifRange = lookupAndParseDate hIfRange -lookupAndParseDate :: FieldKey -> Request -> Maybe HTTPDate+lookupAndParseDate :: HeaderName -> Request -> Maybe HTTPDate lookupAndParseDate key req = lookupRequestField key req >>= parseHTTPDate ---------------------------------------------------------------- textPlainHeader :: ResponseHeaders-textPlainHeader = [("Content-Type", "text/plain")]+textPlainHeader = [(hContentType,"text/plain")] textHtmlHeader :: ResponseHeaders-textHtmlHeader = [("Content-Type", "text/html")]+textHtmlHeader = [(hContentType,"text/html")] locationHeader :: ByteString -> ResponseHeaders-locationHeader url = [("Location", url)]+locationHeader url = [(hLocation, url)] addServer :: ClassicAppSpec -> ResponseHeaders -> ResponseHeaders-addServer cspec hdr = ("Server", softwareName cspec) : hdr+addServer cspec hdr = (hServer, softwareName cspec) : hdr -- FIXME: the case where "Via:" already exists addVia :: ClassicAppSpec -> Request -> ResponseHeaders -> ResponseHeaders-addVia cspec req hdr = ("Via", val) : hdr+addVia cspec req hdr = (hVia, val) : hdr where ver = httpVersion req showBS = BS.pack . show@@ -69,19 +73,19 @@ ] addForwardedFor :: Request -> ResponseHeaders -> ResponseHeaders-addForwardedFor req hdr = ("X-Forwarded-For", addr) : hdr+addForwardedFor req hdr = (hXForwardedFor, addr) : hdr where addr = BS.pack . showSockAddr . remoteHost $ req addLength :: Integer -> ResponseHeaders -> ResponseHeaders-addLength len hdr = ("Content-Length", BS.pack . show $ len) : hdr+addLength len hdr = (hContentLength, BS.pack (show len)) : hdr newHeader :: Bool -> ByteString -> HTTPDate -> ResponseHeaders newHeader ishtml file mtime | ishtml = lastMod : textHtmlHeader- | otherwise = lastMod : [("Content-Type", mimeType file)]+ | otherwise = lastMod : (hContentType, mimeType file) : [] where- lastMod = ("Last-Modified", formatHTTPDate mtime)+ lastMod = (hLastModified, formatHTTPDate mtime) mimeType :: ByteString -> MimeType mimeType file =fromMaybe defaultMimeType . foldr1 mplus . map lok $ targets@@ -98,4 +102,9 @@ exts = if entire == "" then [] else entire : BS.split 46 file defaultMimeTypes' :: StaticHash ByteString MimeType-defaultMimeTypes' = SH.fromList $ map (first (BS.pack.fromFilePath)) $ Map.toList defaultMimeTypes+defaultMimeTypes' = SH.fromList $ map (first (BS.pack . T.unpack)) $ Map.toList defaultMimeMap++addDate :: ResponseHeaders -> IO ResponseHeaders+addDate hdr = do+ date <- formatHTTPDate . epochTimeToHTTPDate <$> epochTime+ return $ (hDate,date) : hdr
Network/Wai/Application/Classic/File.hs view
@@ -58,47 +58,52 @@ fileApp :: ClassicAppSpec -> FileAppSpec -> FileRoute -> Application fileApp cspec spec filei req = do RspSpec st body <- case method of- "GET" -> processGET hinfo ishtml rfile- "HEAD" -> processHEAD hinfo ishtml rfile- _ -> return notAllowed+ Right GET -> processGET hinfo ishtml rfile+ Right HEAD -> processHEAD hinfo ishtml rfile+ _ -> return notAllowed (response, mlen) <- case body of- NoBody -> return $ noBody st- BodyStatus -> statusBody st <$> liftIO (getStatusInfo cspec spec langs st)- BodyFileNoBody hdr -> return $ bodyFileNoBody st hdr- BodyFile hdr afile rng -> return $ bodyFile st hdr afile rng+ NoBody -> noBody st+ BodyStatus -> bodyStatus st+ BodyFileNoBody hdr -> bodyFileNoBody st hdr+ BodyFile hdr afile rng -> bodyFile st hdr afile rng liftIO $ logger cspec req st mlen return response where hinfo = HandlerInfo spec req file langs- method = requestMethod req+ method = parseMethod $ requestMethod req path = pathinfoToFilePath req filei file = addIndex spec path ishtml = isHTML spec file rfile = redirectPath spec path langs = langSuffixes req- noBody st = (responseLBS st hdr "", Nothing)- where- hdr = addServer cspec []+ noBody st = do+ hdr <- liftIO . addDate $ addServer cspec []+ return (responseLBS st hdr "", Nothing)+ bodyStatus st = liftIO (getStatusInfo cspec spec langs st)+ >>= statusBody st statusBody st StatusNone = noBody st- statusBody st (StatusByteString bd) = (responseLBS st hdr bd, Just (len bd))+ statusBody st (StatusByteString bd) = do+ hdr <- liftIO . addDate $ addServer cspec textPlainHeader+ return (responseLBS st hdr bd, Just (len bd)) where len = fromIntegral . BL.length- hdr = addServer cspec textPlainHeader- statusBody st (StatusFile afile len) = (ResponseFile st hdr fl mfp, Just len)+ statusBody st (StatusFile afile len) = do+ hdr <- liftIO . addDate $ addServer cspec textHtmlHeader+ return (ResponseFile st hdr fl mfp, Just len) where- hdr = addServer cspec textHtmlHeader mfp = Just (FilePart 0 len) fl = pathString afile- bodyFileNoBody st hdr = (responseLBS st hdr' "", Nothing)- where- hdr' = addServer cspec hdr- bodyFile st hdr afile rng = (ResponseFile st hdr' fl mfp, Just len)+ bodyFileNoBody st hdr = do+ hdr' <- liftIO . addDate $ addServer cspec hdr+ return (responseLBS st hdr' "", Nothing)+ bodyFile st hdr afile rng = do+ hdr' <- liftIO . addDate $ addLength len $ addServer cspec hdr+ 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)) Part skip bytes -> (bytes, Just (FilePart skip bytes))- hdr' = addLength len $ addServer cspec hdr fl = pathString afile ----------------------------------------------------------------
Network/Wai/Application/Classic/FileInfo.hs view
@@ -31,14 +31,14 @@ ifrange :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifrange req size mtime = do date <- ifRange req- rng <- lookupRequestField fkRange req+ rng <- lookupRequestField hRange req if date == mtime then Just (Full ok200) else range size rng unconditional :: Request -> Integer -> HTTPDate -> Maybe StatusAux unconditional req size _ =- maybe (Just (Full ok200)) (range size) $ lookupRequestField fkRange req+ maybe (Just (Full ok200)) (range size) $ lookupRequestField hRange req range :: Integer -> ByteString -> Maybe StatusAux range size rng = case skipAndSize rng size of
Network/Wai/Application/Classic/Header.hs view
@@ -2,66 +2,35 @@ module Network.Wai.Application.Classic.Header where -import Data.CaseInsensitive+import Data.ByteString (ByteString) import Data.Maybe-import Network.HTTP.Types+import Network.HTTP.Types.Header import Network.Wai ---------------------------------------------------------------- --- | Header field key. This must be lower case.-type FieldKey = CI Ascii---- | A type for look-up key.-fkAcceptLanguage :: FieldKey-fkAcceptLanguage = "accept-language"---- | Look-up key for Range:.-fkRange :: FieldKey-fkRange = "range"---- | Look-up key for If-Range:.-fkIfRange :: FieldKey-fkIfRange = "if-range"---- | Look-up key for Last-Modified:.-fkLastModified :: FieldKey-fkLastModified = "last-modified"---- | Look-up key for If-Modified-Since:.-fkIfModifiedSince :: FieldKey-fkIfModifiedSince = "if-modified-since"- -- | Look-up key for If-Unmodified-Since:.-fkIfUnmodifiedSince :: FieldKey-fkIfUnmodifiedSince = "if-unmodified-since"---- | Look-up key for Content-Length:.-fkContentLength :: FieldKey-fkContentLength = "content-length"---- | Look-up key for Content-Type:.-fkContentType :: FieldKey-fkContentType = "content-type"+hIfUnmodifiedSince :: HeaderName+hIfUnmodifiedSince = "if-unmodified-since" --- | Look-up key for Cookie:.-fkCookie :: FieldKey-fkCookie = "cookie"+-- | Look-up key for Status.+hStatus :: HeaderName+hStatus = "status" --- | Look-up key for User-Agent:.-fkUserAgent :: FieldKey-fkUserAgent = "user-agent"+-- | Look-up key for X-Forwarded-For.+hXForwardedFor :: HeaderName+hXForwardedFor = "x-forwarded-for" --- | Look-up key for Referer:.-fkReferer :: FieldKey-fkReferer = "referer"+-- | Look-up key for Via.+hVia :: HeaderName+hVia = "via" ---------------------------------------------------------------- {-| Looking up a header in 'Request'. -}-lookupRequestField :: FieldKey -> Request -> Maybe Ascii+lookupRequestField :: HeaderName -> Request -> Maybe ByteString lookupRequestField x req = lookup x hdrs where hdrs = requestHeaders req@@ -70,7 +39,7 @@ Looking up a header in 'Request'. If the header does not exist, empty 'Ascii' is returned. -}-lookupRequestField' :: FieldKey -> Request -> Ascii+lookupRequestField' :: HeaderName -> Request -> ByteString lookupRequestField' x req = fromMaybe "" $ lookup x hdrs where hdrs = requestHeaders req
Network/Wai/Application/Classic/Range.hs view
@@ -6,6 +6,7 @@ import Data.Attoparsec.ByteString hiding (satisfy) import Data.Attoparsec.ByteString.Char8 hiding (take) import Data.ByteString.Char8 hiding (map, count, take, elem)+import Network.HTTP.Types -- | -- >>> skipAndSize "bytes=0-399" 10000@@ -18,40 +19,38 @@ -- Just (9500,500) skipAndSize :: ByteString -> Integer -> Maybe (Integer,Integer) skipAndSize bs size = case parseRange bs of- Just [(mbeg,mend)] -> adjust mbeg mend size- _ -> Nothing+ Just [rng] -> adjust rng size+ _ -> Nothing -adjust :: Maybe Integer -> Maybe Integer -> Integer -> Maybe (Integer,Integer)-adjust (Just beg) (Just end) siz+adjust :: ByteRange -> Integer -> Maybe (Integer,Integer)+adjust (ByteRangeFromTo beg end) siz | beg <= end && end <= siz = Just (beg, end - beg + 1) | otherwise = Nothing-adjust (Just beg) Nothing siz+adjust (ByteRangeFrom beg) siz | beg <= siz = Just (beg, siz - beg) | otherwise = Nothing-adjust Nothing (Just end) siz+adjust (ByteRangeSuffix end) siz | end <= siz = Just (siz - end, end) | otherwise = Nothing-adjust Nothing Nothing _ = Nothing -type Range = (Maybe Integer, Maybe Integer)--parseRange :: ByteString -> Maybe [Range]+parseRange :: ByteString -> Maybe [ByteRange] parseRange bs = case parseOnly byteRange bs of Right x -> Just x _ -> Nothing -byteRange :: Parser [Range]+byteRange :: Parser [ByteRange] byteRange = string "bytes=" *> (ranges <* endOfInput) -ranges :: Parser [Range]+ranges :: Parser [ByteRange] ranges = sepBy1 (range <|> suffixRange) (spcs >> char ',' >> spcs) -range :: Parser Range-range = (,) <$> ((Just <$> num) <* char '-')- <*> option Nothing (Just <$> num)+range :: Parser ByteRange+range = do+ beg <- num <* char '-'+ (ByteRangeFromTo beg <$> num) <|> return (ByteRangeFrom beg) -suffixRange :: Parser Range-suffixRange = (,) Nothing <$> (char '-' *> (Just <$> num))+suffixRange :: Parser ByteRange+suffixRange = ByteRangeSuffix <$> (char '-' *> num) num :: Parser Integer num = read <$> many1 digit
Network/Wai/Application/Classic/RevProxy.hs view
@@ -53,7 +53,7 @@ getLen :: Request -> Maybe Int64 getLen req = do- len' <- lookup "content-length" $ requestHeaders req+ len' <- lookup hContentLength $ requestHeaders req case reads $ BS.unpack len' of [] -> Nothing (i, _):_ -> Just i@@ -72,18 +72,19 @@ let mlen = getLen req len = fromMaybe 0 mlen httpReq = toHTTPRequest req route len- H.Response status _ hdr downbody <- http httpReq mgr+ H.Response status _ hdr rdownbody <- http httpReq mgr let hdr' = fixHeader hdr liftIO $ logger cspec req status (fromIntegral <$> mlen)- return $ ResponseSource status hdr' (toResponseSource downbody)+ ResponseSource status hdr' <$> toResponseSource rdownbody where mgr = revProxyManager spec fixHeader = addVia cspec req . filter p- p ("Content-Encoding", _) = False- p ("Content-Length", _) = False- p _ = True+ p (k,_)+ | k == hContentEncoding = False+ | k == hContentLength = False+ | otherwise = True -type Resp = ResourceT IO (H.Response (Source (ResourceT IO) BS.ByteString))+type Resp = ResourceT IO (H.Response (ResumableSource (ResourceT IO) BS.ByteString)) http :: H.Request (ResourceT IO) -> H.Manager -> Resp http req mgr = H.http req mgr
wai-app-file-cgi.cabal view
@@ -1,5 +1,5 @@ Name: wai-app-file-cgi-Version: 0.6.0+Version: 0.7.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -32,27 +32,27 @@ , attoparsec >= 0.10.0.0 , attoparsec-conduit , blaze-builder+ , blaze-html , bytestring , case-insensitive- , conduit >= 0.4 && < 0.5+ , conduit >= 0.5 && < 0.6 , containers , directory , filepath , http-conduit , http-date- , http-types >= 0.6.9+ , http-types >= 0.7+ , mime-types , io-choice , lifted-base , network , process , resourcet , static-hash+ , text , transformers , unix , wai >= 1.2- -- should be removed someday- , blaze-html >= 0.5- , wai-app-static >= 1.2 , wai-logger Test-Suite test@@ -61,7 +61,7 @@ HS-Source-Dirs: test Build-Depends: base >= 4 && < 5 , bytestring- , conduit >= 0.4 && < 0.5+ , conduit >= 0.5 && < 0.6 , http-conduit , http-types , lifted-base