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 @@ -120,7 +120,7 @@ (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) (cgiDst cgii) - (fromByteString (rawPathInfo req)) + (rawPathInfo req) (indexCgi spec) makeEnv :: Request -> String -> String -> String -> ByteString -> 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 @@ -8,8 +8,7 @@ #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif -import Control.Exception.IOChoice.Lifted -import Control.Monad.IO.Class (liftIO) +import Control.Exception.IOChoice import Data.ByteString (ByteString) import Data.Maybe import qualified Data.ByteString.Char8 as BS (concat) @@ -37,7 +36,7 @@ langSuffixes :: RequestHeaders -> [Lang] langSuffixes hdr = map (\x -> (<.> x)) langs ++ [id, (<.> "en")] where - langs = map fromByteString $ languages hdr + langs = languages hdr ---------------------------------------------------------------- @@ -80,7 +79,7 @@ rfile = redirectPath spec path langs = langSuffixes $ requestHeaders req noBody st = return $ responseLBS st [] "" - bodyStatus st = liftIO (getStatusInfo cspec req langs st) + bodyStatus st = getStatusInfo cspec req langs st >>= statusBody st statusBody st StatusNone = noBody st statusBody st (StatusByteString bd) = @@ -109,10 +108,9 @@ tryGetFile :: HandlerInfo -> Bool -> Lang -> IO RspSpec tryGetFile (HandlerInfo _ req file _) ishtml lang = do let file' = pathString $ lang file - hdr = newHeader ishtml $ pathByteString file - finfo <- fromFileInfo <$> liftIO (getFileInfo req file') -- expecting an error - let afile = pathString $ fileinfoName finfo - return $ BodyFile ok200 hdr afile + hdr = newHeader ishtml file + _ <- getFileInfo req file' -- expecting an error + return $ BodyFile ok200 hdr file' ---------------------------------------------------------------- @@ -126,7 +124,7 @@ tryRedirectFile :: HandlerInfo -> Lang -> IO RspSpec tryRedirectFile (HandlerInfo _ req file _) lang = do let file' = pathString $ lang file - _ <- liftIO $ getFileInfo req file' -- expecting an error + _ <- getFileInfo req file' -- expecting an error return $ NoBodyHdr movedPermanently301 hdr where hdr = redirectHeader req 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 @@ -9,10 +9,10 @@ pathinfoToFilePath :: Request -> FileRoute -> Path pathinfoToFilePath req filei = path' where - path = fromByteString $ rawPathInfo req + path = rawPathInfo req src = fileSrc filei dst = fileDst filei - path' = dst (path <\> src) + path' = dst (path <\> src) -- fixme addIndex :: FileAppSpec -> Path -> Path addIndex spec path diff --git a/Network/Wai/Application/Classic/Path.hs b/Network/Wai/Application/Classic/Path.hs --- a/Network/Wai/Application/Classic/Path.hs +++ b/Network/Wai/Application/Classic/Path.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Network.Wai.Application.Classic.Path ( - Path(..) - , fromString, fromByteString - , (+++), (), (<\>), (<.>) + Path + , pathString + , fromString + , (), (<\>), (<.>) , breakAtSeparator, hasLeadingPathSeparator, hasTrailingPathSeparator , isSuffixOf ) where @@ -11,38 +12,20 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 -import Data.Function import Data.String import Data.Word ---------------------------------------------------------------- --- | Smart file path. -data Path = Path { - pathString :: FilePath - , pathByteString :: ByteString - } - -instance IsString Path where - fromString path = Path { - pathString = path - , pathByteString = B8.pack path - } - -instance Show Path where - show = show . pathByteString +-- | File path. +type Path = ByteString -instance Eq Path where - (==) = (==) `on` pathByteString +pathString :: Path -> String +pathString = B8.unpack +{-# INLINE pathString #-} ---------------------------------------------------------------- -fromByteString :: ByteString -> Path -fromByteString path = Path { - pathString = B8.unpack path - , pathByteString = path - } - -- pathDot :: Word8 -- pathDot = 46 @@ -64,12 +47,11 @@ False -} hasLeadingPathSeparator :: Path -> Bool -hasLeadingPathSeparator path +hasLeadingPathSeparator bs | BS.null bs = False | BS.head bs == pathSep = True | otherwise = False - where - bs = pathByteString path +{-# INLINE hasLeadingPathSeparator #-} {-| Checking if the path ends with the path separator. @@ -80,23 +62,11 @@ False -} hasTrailingPathSeparator :: Path -> Bool -hasTrailingPathSeparator path +hasTrailingPathSeparator bs | BS.null bs = False | BS.last bs == pathSep = True | otherwise = False - where - bs = pathByteString path - -infixr +++ - -{-| - Appending. --} - -(+++) :: Path -> Path -> Path -p1 +++ p2 = fromByteString p - where - p = pathByteString p1 `BS.append` pathByteString p2 +{-# INLINE hasTrailingPathSeparator #-} {-| Appending with the file separator. @@ -112,17 +82,15 @@ -} () :: Path -> Path -> Path -p1 p2 - | has1 && not has2 || not has1 && has2 = p1 +++ p2 - | has1 = fromByteString pp1 - | otherwise = fromByteString pp2 +p1 p2 = p where - has1 = hasTrailingPathSeparator p1 - has2 = hasLeadingPathSeparator p2 - p1' = pathByteString p1 - p2' = pathByteString p2 - pp1 = p1' `BS.append` BS.tail p2' - pp2 = BS.concat [p1',pathSepBS,p2'] + !has1 = hasTrailingPathSeparator p1 + !has2 = hasLeadingPathSeparator p2 + !p | has1 && not has2 = p1 `BS.append` p2 + | not has1 && has2 = p1 `BS.append` p2 + | has1 = p1 `BS.append` BS.tail p2 + | otherwise = BS.concat [p1,pathSepBS,p2] +{-# INLINE () #-} {-| Removing prefix. The prefix of the second argument is removed @@ -136,21 +104,19 @@ "bar" -} (<\>) :: Path -> Path -> Path -p1 <\> p2 = fromByteString p +p1 <\> p2 = p where - p1' = pathByteString p1 - p2' = pathByteString p2 - p = BS.drop (BS.length p2') p1' + !p = BS.drop (BS.length p2) p1 +{-# INLINE (<\>) #-} {-| Adding suffix. -} (<.>) :: Path -> Path -> Path -p1 <.> p2 = fromByteString p +p1 <.> p2 = p where - p1' = pathByteString p1 - p2' = pathByteString p2 - p = BS.concat [p1',pathDotBS,p2'] + !p = BS.concat [p1,pathDotBS,p2] +{-# INLINE (<.>) #-} {-| Breaking at the first path separator. @@ -163,13 +129,9 @@ ("foo","") -} breakAtSeparator :: Path -> (Path,Path) -breakAtSeparator p = (fromByteString r1, fromByteString r2) - where - p' = pathByteString p - (r1,r2) = BS.break (== pathSep) p' +breakAtSeparator p = BS.break (== pathSep) p +{-# INLINE breakAtSeparator #-} isSuffixOf :: Path -> Path -> Bool -isSuffixOf p1 p2 = p1' `BS.isSuffixOf` p2' - where - p1' = pathByteString p1 - p2' = pathByteString p2 +isSuffixOf = BS.isSuffixOf +{-# INLINE isSuffixOf #-} 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 @@ -15,11 +15,11 @@ redirectApp _ route req respond = respond $ responseLBS status hdr "" where - path = fromByteString $ rawPathInfo req + path = rawPathInfo req src = redirectSrc route dst = redirectDst route -- Scheme must not be included because of no way to tell -- http or https. - rurl = "//" `append` pathByteString (dst (path <\> src)) + rurl = "//" `append` (dst (path <\> src)) hdr = locationHeader rurl status = movedPermanently301 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 @@ -59,7 +59,7 @@ , H.port = revProxyPort route , H.secure = False -- FIXME: upstream is HTTP only , H.requestHeaders = addForwardedFor req $ filter headerToBeRelay hdr - , H.path = pathByteString path' + , H.path = path' , H.queryString = dropQuestion query , H.requestBody = bodyToHBody len body , H.method = requestMethod req @@ -70,7 +70,7 @@ , H.redirectCount = 0 } where - path = fromByteString $ rawPathInfo req + path = rawPathInfo req src = revProxySrc route dst = revProxyDst route hdr = requestHeaders req 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 @@ -5,8 +5,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Network.HTTP.Client as H -import Network.HTTP.Date -import Network.Wai.Handler.Warp (FileInfo(..)) import Network.Wai.Application.Classic.Path ---------------------------------------------------------------- @@ -34,21 +32,6 @@ indexFile :: Path -- | Whether this is an HTML or not. , isHTML :: Path -> Bool - } - -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 { 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.1.0 +Version: 3.1.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -62,7 +62,7 @@ , unix , wai >= 3.2 && < 3.3 , wai-conduit - , warp >= 3.2 && < 3.3 + , warp >= 3.2.6 && < 3.3 , word8 Test-Suite doctest @@ -92,7 +92,7 @@ , unix , wai >= 3.2 && < 3.3 , wai-app-file-cgi - , warp >= 3.2 && < 3.3 + , warp >= 3.2.6 && < 3.3 , HTTP Source-Repository head