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 @@ -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 diff --git a/Network/Wai/Application/Classic/Def.hs b/Network/Wai/Application/Classic/Def.hs --- a/Network/Wai/Application/Classic/Def.hs +++ b/Network/Wai/Application/Classic/Def.hs @@ -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 () ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Field.hs b/Network/Wai/Application/Classic/Field.hs --- a/Network/Wai/Application/Classic/Field.hs +++ b/Network/Wai/Application/Classic/Field.hs @@ -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 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 @@ -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 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 @@ -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) ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Header.hs b/Network/Wai/Application/Classic/Header.hs --- a/Network/Wai/Application/Classic/Header.hs +++ b/Network/Wai/Application/Classic/Header.hs @@ -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 diff --git a/Network/Wai/Application/Classic/Range.hs b/Network/Wai/Application/Classic/Range.hs deleted file mode 100644 --- a/Network/Wai/Application/Classic/Range.hs +++ /dev/null @@ -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") diff --git a/Network/Wai/Application/Classic/Redirect.hs b/Network/Wai/Application/Classic/Redirect.hs --- a/Network/Wai/Application/Classic/Redirect.hs +++ b/Network/Wai/Application/Classic/Redirect.hs @@ -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 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 @@ -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 diff --git a/Network/Wai/Application/Classic/Types.hs b/Network/Wai/Application/Classic/Types.hs --- a/Network/Wai/Application/Classic/Types.hs +++ b/Network/Wai/Application/Classic/Types.hs @@ -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) ---------------------------------------------------------------- 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: 3.0.9 +Version: 3.1.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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