diff --git a/Network/Wai/Application/Classic.hs b/Network/Wai/Application/Classic.hs --- a/Network/Wai/Application/Classic.hs +++ b/Network/Wai/Application/Classic.hs @@ -5,6 +5,7 @@ module Network.Wai.Application.Classic ( -- * Types AppSpec(..) + , FileInfo(..) -- * Files , FileRoute(..), fileApp -- * CGI 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 @@ -7,7 +7,7 @@ import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as BS hiding (unpack, pack) -import qualified Data.ByteString.Char8 as BS (unpack, pack) +import qualified Data.ByteString.Char8 as BS (pack) import qualified Data.ByteString.Lazy.Char8 as BL (length) import Network.HTTP.Types import Network.Wai @@ -41,8 +41,8 @@ fileApp :: AppSpec -> FileRoute -> Application fileApp spec filei req = do RspSpec st hdr body <- case method of - "GET" -> processGET req file ishtml rfile - "HEAD" -> processHEAD req file ishtml rfile + "GET" -> processGET spec req file ishtml rfile + "HEAD" -> processHEAD spec req file ishtml rfile _ -> return notAllowed let hdr'= addServer hdr (response, mlen) = case body of @@ -52,11 +52,11 @@ in (responseLBS st hdr' bd, Just len) BodyFile afile rng -> let (len, mfp) = case rng of - Entire bytes -> (bytes, Nothing) + -- 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 hdr' len - afile' = BS.unpack afile - in (ResponseFile st hdr'' afile' mfp, Just len) + in (ResponseFile st hdr'' afile mfp, Just len) liftIO $ logger spec req st mlen return response where @@ -77,55 +77,60 @@ ---------------------------------------------------------------- -processGET :: Request -> ByteString -> Bool -> Maybe ByteString -> Rsp -processGET req file ishtml rfile = runAny [ - tryGet req file ishtml - , tryRedirect req rfile +processGET :: AppSpec -> Request -> ByteString -> Bool -> Maybe ByteString -> Rsp +processGET spec req file ishtml rfile = runAny [ + tryGet spec req file ishtml + , tryRedirect spec req rfile , just notFound ] -tryGet :: Request -> ByteString -> Bool -> MRsp -tryGet req file True = runAnyMaybe $ map (tryGetFile req file True) langs +tryGet :: AppSpec -> Request -> ByteString -> Bool -> MRsp +tryGet spec req file True = runAnyMaybe $ map (tryGetFile spec req file True) langs where langs = langSuffixes req -tryGet req file False = tryGetFile req file False Nothing +tryGet spec req file False = tryGetFile spec req file False Nothing -tryGetFile :: Request -> ByteString -> Bool -> Lang -> MRsp -tryGetFile req file ishtml mlang = do +tryGetFile :: AppSpec -> Request -> ByteString -> Bool -> Lang -> MRsp +tryGetFile spec req file ishtml mlang = do let file' = maybe file (file +++) mlang - liftIO (fileInfo file') |>| \(size, mtime) -> do - let hdr = newHeader ishtml file mtime + liftIO (getFileInfo spec file') |>| \finfo -> do + let mtime = fileInfoTime finfo + size = fileInfoSize finfo + sfile = fileInfoName finfo + hdr = newHeader ishtml file mtime Just pst = ifmodified req size mtime -- never Nothing ||| ifunmodified req size mtime ||| ifrange req size mtime ||| unconditional req size mtime case pst of Full st - | st == statusOK -> just $ RspSpec statusOK hdr (BodyFile file' (Entire size)) + | st == statusOK -> just $ RspSpec statusOK hdr (BodyFile sfile (Entire size)) | otherwise -> just $ RspSpec st hdr NoBody - Partial skip len -> just $ RspSpec statusPartialContent hdr (BodyFile file' (Part skip len)) + Partial skip len -> just $ RspSpec statusPartialContent hdr (BodyFile sfile (Part skip len)) ---------------------------------------------------------------- -processHEAD :: Request -> ByteString -> Bool -> Maybe ByteString -> Rsp -processHEAD req file ishtml rfile = runAny [ - tryHead req file ishtml - , tryRedirect req rfile +processHEAD :: AppSpec -> Request -> ByteString -> Bool -> Maybe ByteString -> Rsp +processHEAD spec req file ishtml rfile = runAny [ + tryHead spec req file ishtml + , tryRedirect spec req rfile , just notFound ] -tryHead :: Request -> ByteString -> Bool -> MRsp -tryHead req file True = runAnyMaybe $ map (tryHeadFile req file True) langs +tryHead :: AppSpec -> Request -> ByteString -> Bool -> MRsp +tryHead spec req file True = runAnyMaybe $ map (tryHeadFile spec req file True) langs where langs = langSuffixes req -tryHead req file False= tryHeadFile req file False Nothing +tryHead spec req file False= tryHeadFile spec req file False Nothing -tryHeadFile :: Request -> ByteString -> Bool -> Lang -> MRsp -tryHeadFile req file ishtml mlang = do +tryHeadFile :: AppSpec -> Request -> ByteString -> Bool -> Lang -> MRsp +tryHeadFile spec req file ishtml mlang = do let file' = maybe file (file +++) mlang - liftIO (fileInfo file') |>| \(size, mtime) -> do - let hdr = newHeader ishtml file mtime + liftIO (getFileInfo spec file') |>| \finfo -> do + let mtime = fileInfoTime finfo + size = fileInfoSize finfo + hdr = newHeader ishtml file mtime Just pst = ifmodified req size mtime -- never Nothing ||| Just (Full statusOK) case pst of @@ -134,17 +139,17 @@ ---------------------------------------------------------------- -tryRedirect :: Request -> Maybe ByteString -> MRsp -tryRedirect _ Nothing = nothing -tryRedirect req (Just file) = - runAnyMaybe $ map (tryRedirectFile req file) langs +tryRedirect :: AppSpec -> Request -> Maybe ByteString -> MRsp +tryRedirect _ _ Nothing = nothing +tryRedirect spec req (Just file) = + runAnyMaybe $ map (tryRedirectFile spec req file) langs where langs = langSuffixes req -tryRedirectFile :: Request -> ByteString -> Lang -> MRsp -tryRedirectFile req file mlang = do +tryRedirectFile :: AppSpec -> Request -> ByteString -> Lang -> MRsp +tryRedirectFile spec req file mlang = do let file' = maybe file (file +++) mlang - minfo <- liftIO $ fileInfo file' + minfo <- liftIO $ getFileInfo spec file' case minfo of Nothing -> nothing Just _ -> just $ RspSpec statusMovedPermanently hdr NoBody 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,9 +1,7 @@ module Network.Wai.Application.Classic.FileInfo where -import Control.Exception import Data.ByteString (ByteString) import qualified Data.ByteString as BS hiding (unpack) -import qualified Data.ByteString.Char8 as BS (unpack) import Network.HTTP.Date import Network.HTTP.Types import Network.Wai @@ -12,24 +10,6 @@ import Network.Wai.Application.Classic.Range import Network.Wai.Application.Classic.Types import Network.Wai.Application.Classic.Utils -import System.Posix.Files - ----------------------------------------------------------------- - --- This function is slow. --- So, let's avoid using doesFileExist which uses getFilesStatus. -fileInfo :: ByteString -> IO (Maybe (Integer, HTTPDate)) -fileInfo file = handle nothing $ do - fs <- getFileStatus (BS.unpack file) - if doesExist fs - then return $ Just (size fs, mtime fs) - else return Nothing - where - nothing :: IOException -> IO (Maybe (Integer, HTTPDate)) - nothing _ = return Nothing - size = fromIntegral . fileSize - mtime = epochTimeToHTTPDate . modificationTime - doesExist = not . isDirectory ---------------------------------------------------------------- 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 @@ -2,6 +2,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) +import Network.HTTP.Date import Network.HTTP.Types import Network.Wai @@ -14,8 +15,15 @@ , isHTML :: ByteString -> Bool -- | A function for logging. The third argument is a body size. , logger :: Request -> Status -> Maybe Integer -> IO () + , getFileInfo :: ByteString -> IO (Maybe FileInfo) } +data FileInfo = FileInfo { + fileInfoName :: FilePath + , fileInfoSize :: Integer + , fileInfoTime :: HTTPDate + } + data FileRoute = FileRoute { -- | Path prefix to be matched to 'pathInfo'. fileSrc :: ByteString @@ -45,7 +53,7 @@ -- | Body as Lazy ByteString. | BodyLBS BL.ByteString -- | Body as a file. - | BodyFile ByteString Range + | BodyFile String Range data Range = -- | Entire file showing its file size 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.2.2 +Version: 0.2.3 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3