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 @@ -12,7 +12,6 @@ -- * Files , FileAppSpec(..) , defaultFileAppSpec - , FileInfo(..) , FileRoute(..) , fileApp -- * Redirect 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,13 +2,10 @@ module Network.Wai.Application.Classic.Def where -import Control.Exception -import Network.HTTP.Date import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types -import System.Posix -- | -- 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\/\". @@ -25,33 +22,15 @@ ---------------------------------------------------------------- -- | --- Default value for 'defaultFileAppSpec'. 'indexFile' is \"index.html\". 'isHTML' matches \"*.html\" and \"*.html\". 'getFileInfo' calls `getFileStatus` for every request. +-- Default value for 'defaultFileAppSpec'. 'indexFile' is \"index.html\". 'isHTML' matches \"*.html\" and \"*.html\". defaultFileAppSpec :: FileAppSpec defaultFileAppSpec = FileAppSpec { indexFile = "index.html" , isHTML = defaultIsHTml - , getFileInfo = defaultGetFileInfo } defaultIsHTml :: Path -> Bool defaultIsHTml file = ".html" `isSuffixOf` file || ".htm" `isSuffixOf` file - -defaultGetFileInfo :: Path -> IO FileInfo -defaultGetFileInfo path = do - fs <- getFileStatus sfile - if not (isDirectory fs) then - return FileInfo { - fileInfoName = path - , fileInfoSize = size fs - , fileInfoTime = time fs - , fileInfoDate = formatHTTPDate (time fs) - } - else - throwIO $ userError "does not exist" - where - sfile = pathString path - size = fromIntegral . fileSize - time = epochTimeToHTTPDate . modificationTime ---------------------------------------------------------------- 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 @@ -21,6 +21,7 @@ import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Status import Network.Wai.Application.Classic.Types +import Network.Wai.Handler.Warp (getFileInfo) ---------------------------------------------------------------- @@ -79,7 +80,7 @@ rfile = redirectPath spec path langs = langSuffixes reqidx noBody st = return (responseLBS st [] "", Nothing) - bodyStatus st = liftIO (getStatusInfo cspec spec langs st) + bodyStatus st = liftIO (getStatusInfo cspec req langs st) >>= statusBody st statusBody st StatusNone = noBody st statusBody st (StatusByteString bd) = @@ -117,12 +118,13 @@ tryGet hinfo False = tryGetFile hinfo False id tryGetFile :: HandlerInfo -> Bool -> Lang -> Rsp -tryGetFile (HandlerInfo spec req reqidx file _) ishtml lang = do - finfo <- liftIO $ getFileInfo spec (lang file) - let mtime = fileInfoTime finfo - size = fileInfoSize finfo - sfile = fileInfoName finfo - date = fileInfoDate finfo +tryGetFile (HandlerInfo _ req reqidx 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 @@ -145,8 +147,9 @@ hinfo = HandlerInfo spec req reqidx file langs tryRedirectFile :: HandlerInfo -> Lang -> Rsp -tryRedirectFile (HandlerInfo spec req _ file _) lang = do - _ <- liftIO $ getFileInfo spec (lang file) +tryRedirectFile (HandlerInfo _ req _ file _) lang = do + let file' = pathString $ lang file + _ <- liftIO $ getFileInfo req file' -- expecting an error return $ RspSpec movedPermanently301 (BodyFileNoBody hdr) where hdr = redirectHeader req diff --git a/Network/Wai/Application/Classic/Status.hs b/Network/Wai/Application/Classic/Status.hs --- a/Network/Wai/Application/Classic/Status.hs +++ b/Network/Wai/Application/Classic/Status.hs @@ -13,18 +13,20 @@ import Data.ByteString.Lazy.Char8 () import qualified Data.StaticHash as M import Network.HTTP.Types +import Network.Wai (Request) import Network.Wai.Application.Classic.Path import Network.Wai.Application.Classic.Types +import Network.Wai.Handler.Warp ---------------------------------------------------------------- -getStatusInfo :: ClassicAppSpec -> FileAppSpec -> [Lang] -> Status -> IO StatusInfo -getStatusInfo cspec spec langs st = getStatusFile getF dir code langs - ||> getStatusBS code - ||> return StatusNone +getStatusInfo :: ClassicAppSpec -> Request -> [Lang] -> Status -> IO StatusInfo +getStatusInfo cspec req langs st = getStatusFile getF dir code langs + ||> getStatusBS code + ||> return StatusNone where dir = statusFileDir cspec - getF = getFileInfo spec + getF = getFileInfo req code = statusCode st ---------------------------------------------------------------- @@ -56,13 +58,15 @@ where toPath s = fromString $ show (statusCode s) ++ ".html" -getStatusFile :: (Path -> IO FileInfo) -> Path -> Int -> [Lang] -> IO StatusInfo +getStatusFile :: (FilePath -> IO FileInfo) -> Path -> Int -> [Lang] -> IO StatusInfo getStatusFile getF dir code langs = tryFile mfiles where mfiles = case M.lookup code statusFileMap of 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 + where + f' = pathString f ---------------------------------------------------------------- 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 @@ -8,6 +8,7 @@ import Network.HTTP.Date import Network.HTTP.Types import Network.Wai +import Network.Wai.Handler.Warp (FileInfo(..)) import Network.Wai.Application.Classic.Path ---------------------------------------------------------------- @@ -37,17 +38,22 @@ indexFile :: Path -- | Whether this is an HTML or not. , isHTML :: Path -> Bool - -- | A function to obtain information about a file. - -- If information is not obtained, an IO exception should be raised. - , getFileInfo :: Path -> IO FileInfo } -data FileInfo = FileInfo { - fileInfoName :: !Path - , fileInfoSize :: !Integer - , fileInfoTime :: !HTTPDate - , fileInfoDate :: !ByteString +data Fileinfo = Fileinfo { + fileinfoName :: !Path + , fileinfoSize :: !Integer + , fileinfoTime :: !HTTPDate + , fileinfoDate :: !ByteString } deriving (Eq, Show) + +fromFileInfo :: FileInfo -> Fileinfo +fromFileInfo x = Fileinfo { + fileinfoName = fromString $ fileInfoName x + , fileinfoSize = fileInfoSize x + , fileinfoTime = fileInfoTime x + , fileinfoDate = fileInfoDate x + } data FileRoute = FileRoute { -- | Path prefix to be matched to 'rawPathInfo'. 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.8 +Version: 3.0.9 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -63,6 +63,7 @@ , unix , wai >= 3.0 && < 3.1 , wai-conduit + , warp >= 3.1.12 && < 3.2 , word8 Test-Suite doctest @@ -90,9 +91,9 @@ , hspec >= 1.3 , http-types , unix - , wai >= 3 + , wai >= 3.0 && < 3.1 , wai-app-file-cgi - , warp >= 3.0.11 + , warp >= 3.1.12 && < 3.2 , HTTP Source-Repository head