wai-app-file-cgi 0.1.2 → 0.2.0

raw patch · 10 files changed

+168/−180 lines, 10 filesdep +arraydep +hashmapdep +http-datedep −timePVP ok

version bump matches the API change (PVP)

Dependencies added: array, hashmap, http-date

Dependencies removed: time

API changes (from Hackage documentation)

Files

• Network/Wai/Application/Classic/CGI.hs +10/−10
• Network/Wai/Application/Classic/Date.hs +0/−51
• Network/Wai/Application/Classic/Field.hs +31/−31
• Network/Wai/Application/Classic/File.hs +52/−38
• Network/Wai/Application/Classic/FileInfo.hs +26/−23
• Network/Wai/Application/Classic/Lang.hs +10/−14
• Network/Wai/Application/Classic/MaybeIter.hs +3/−1
• Network/Wai/Application/Classic/Types.hs +5/−5
• Network/Wai/Application/Classic/Utils.hs +26/−2
• wai-app-file-cgi.cabal +5/−5

@@ -9,7 +9,8 @@ import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString as BS hiding (unpack)+import qualified Data.ByteString.Char8 as BS (readInt, unpack) import Data.CaseInsensitive hiding (map) import Data.Enumerator hiding (map, filter, drop, break) import qualified Data.Enumerator.Binary as EB@@ -21,7 +22,6 @@ import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Types import Network.Wai.Application.Classic.Utils-import System.FilePath import System.IO import System.Process @@ -131,9 +131,9 @@   where     parseField bs = (mk key, val)       where-        (key,val) = case BS.break (==':') bs of+        (key,val) = case BS.breakByte 58 bs of -- ':'             kv@(_,"") -> kv-            (k,v) -> let v' = BS.dropWhile (==' ') $ BS.tail v in (k,v')+            (k,v) -> let v' = BS.dropWhile (==32) $ BS.tail v in (k,v') -- ' '  takeHeader :: Iteratee ByteString IO (Maybe [ByteString]) takeHeader = ENL.head >>= maybe (return Nothing) $. \l ->@@ -141,14 +141,14 @@        then return (Just [])        else takeHeader >>= maybe (return Nothing) (return . Just . (l:)) -pathinfoToCGI :: ByteString -> FilePath -> ByteString -> (FilePath, String, String)+pathinfoToCGI :: ByteString -> ByteString -> ByteString -> (FilePath, String, String) pathinfoToCGI src dst path = (prog, scriptName, pathinfo)   where-    src' = BS.unpack src-    path' = drop (BS.length src) $ BS.unpack path-    (prog',pathinfo) = break (== '/') path'-    prog = dst </> prog'-    scriptName = src' </> prog'+    path' = BS.drop (BS.length src) path+    (prog',pathinfo') = BS.breakByte pathSep path'+    prog = BS.unpack (dst </> prog')+    scriptName = BS.unpack (src </> prog')+    pathinfo = BS.unpack pathinfo'  ---------------------------------------------------------------- 

@@ -1,51 +0,0 @@-module Network.Wai.Application.Classic.Date (parseDate, utcToDate) where--import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import Data.Time-import Locale-import Control.Monad---- xxx: ClockTime -> UTCTime-------------------------------------------------------------------parseDate :: ByteString -> Maybe UTCTime-parseDate bs = rfc1123Date cs `mplus` rfc850Date cs `mplus` asctimeDate cs-  where-    cs = BS.unpack bs--------------------------------------------------------------------rfc1123Format :: String-rfc1123Format = "%a, %d %b %Y %H:%M:%S GMT"--rfc850Format :: String-rfc850Format  = "%A, %d-%b-%y %H:%M:%S GMT"---- xxx: allows "Nov 6" as well as "Nov  6", sigh.-asctimeFormat :: String-asctimeFormat = "%a %b %e %H:%M:%S %Y"--preferredFormat :: String-preferredFormat = rfc1123Format--------------------------------------------------------------------rfc1123Date :: String -> Maybe UTCTime-rfc1123Date = parseTime defaultTimeLocale preferredFormat--rfc850Date :: String -> Maybe UTCTime-rfc850Date str = parseTime defaultTimeLocale rfc850Format str >>= y2k-  where-    y2k utct = let (y,m,d) = toGregorian $ utctDay utct-               in if y < 1950-                  then Just utct { utctDay = fromGregorian (y+100) m d }-                  else Just utct--asctimeDate :: String -> Maybe UTCTime-asctimeDate = parseTime defaultTimeLocale asctimeFormat--------------------------------------------------------------------utcToDate :: UTCTime -> ByteString-utcToDate = BS.pack . formatTime defaultTimeLocale preferredFormat

@@ -2,63 +2,63 @@  module Network.Wai.Application.Classic.Field where +import Control.Arrow (first) import Control.Monad (mplus)-import Data.List-import qualified Data.Map as M (lookup)-import Data.Time-import Network.Wai.Application.Classic.Date-import Network.Wai.Application.Classic.Lang-import Network.Wai.Application.Classic.Header-import Network.Wai.Application.Static (defaultMimeTypes, defaultMimeType, MimeType) import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()+import qualified Data.ByteString as BS hiding (pack)+import Data.ByteString.Char8 as BS (pack)+import Data.HashMap (Map)+import qualified Data.HashMap as M+import Data.Map as Map (toList) import Data.Maybe+import Network.HTTP.Date import Network.HTTP.Types import Network.Wai+import Network.Wai.Application.Classic.Header+import Network.Wai.Application.Classic.Lang+import Network.Wai.Application.Static (defaultMimeTypes, defaultMimeType, MimeType)  ---------------------------------------------------------------- -languages :: Request -> [String]+languages :: Request -> [ByteString] languages req = maybe [] parseLang $ lookupRequestField fkAcceptLanguage req -ifModifiedSince :: Request -> Maybe UTCTime+ifModifiedSince :: Request -> Maybe HTTPDate ifModifiedSince = lookupAndParseDate fkIfModifiedSince -ifUnmodifiedSince :: Request -> Maybe UTCTime+ifUnmodifiedSince :: Request -> Maybe HTTPDate ifUnmodifiedSince = lookupAndParseDate fkIfUnmodifiedSince -ifRange :: Request -> Maybe UTCTime+ifRange :: Request -> Maybe HTTPDate ifRange = lookupAndParseDate fkIfRange -lookupAndParseDate :: ByteString -> Request -> Maybe UTCTime-lookupAndParseDate key req = lookupRequestField key req >>= parseDate+lookupAndParseDate :: ByteString -> Request -> Maybe HTTPDate+lookupAndParseDate key req = lookupRequestField key req >>= parseHTTPDate  ----------------------------------------------------------------  textPlain :: ResponseHeaders textPlain = [("Content-Type", "text/plain")] -newHeader :: FilePath -> UTCTime -> ResponseHeaders-newHeader file mtime = [-    ("Content-Type", mimeType file)-  , ("Last-Modified", utcToDate mtime)+newHeader :: Bool -> ByteString -> HTTPDate -> ResponseHeaders+newHeader ishtml file mtime = [+    ("Content-Type", if ishtml then "text/html" else mimeType file)+  , ("Last-Modified", formatHTTPDate mtime)   ] -mimeType :: FilePath -> MimeType-mimeType file =fromMaybe defaultMimeType . foldl1' mplus . map lok $ targets+mimeType :: ByteString -> MimeType+mimeType file =fromMaybe defaultMimeType . foldr1 mplus . map lok $ targets   where     targets = extensions file-    lok x = M.lookup x defaultMimeTypes+    lok x = M.lookup x defaultMimeTypes' -extensions :: FilePath -> [String]-extensions file = entire : exts+extensions :: ByteString -> [ByteString]+extensions file = exts   where-    exts' = split ('.'==) file-    exts = if exts' == [] then [] else tail exts'-    entire = foldr (\x y -> x ++ '.' : y) "" exts+    entire = case BS.breakByte 46 file of -- '.'+        (_,"") -> ""+        (_,x)  -> BS.tail x+    exts = if entire == "" then [] else entire : BS.split 46 file -split :: (Char -> Bool) -> String -> [String]-split _ "" = []-split p xs = case break p xs of-    (ys,"")   -> [ys]-    (ys,_:zs) -> ys : split p zs+defaultMimeTypes' :: Map ByteString MimeType+defaultMimeTypes' = M.fromList $ map (first BS.pack) $ Map.toList defaultMimeTypes

@@ -5,7 +5,9 @@   ) where  import Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString.Char8 as BS+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.Lazy.Char8 as BL () import Network.HTTP.Types import Network.Wai@@ -13,6 +15,7 @@ import Network.Wai.Application.Classic.FileInfo import Network.Wai.Application.Classic.MaybeIter import Network.Wai.Application.Classic.Types+import Network.Wai.Application.Classic.Utils  ---------------------------------------------------------------- @@ -42,42 +45,52 @@         "HEAD" -> processHEAD req file ishtml rfile         _      -> return notAllowed     liftIO $ logger spec req st body-    let hdr' = addHeader hdr+    let hdr' = addServer hdr     case body of         NoBody     -> return $ responseLBS st hdr' ""         BodyLBS bd -> return $ responseLBS st hdr' bd-        BodyFile afile (Entire _)-            -> return $ ResponseFile st hdr' afile Nothing-        BodyFile afile (Part skip len)-            -> return $ ResponseFile st hdr' afile (Just (FilePart skip len))+        BodyFile afile (Entire len) -> do+            let hdr'' = addLength hdr' len+            return $ ResponseFile st hdr'' (BS.unpack afile) Nothing+        BodyFile afile (Part skip len) -> do+            let hdr'' = addLength hdr' len+            return $ ResponseFile st hdr'' (BS.unpack afile) (Just (FilePart skip len))   where     method = requestMethod req     path = pathinfoToFilePath req filei     file = addIndex spec path     ishtml = isHTML spec file     rfile = redirectPath spec path-    addHeader hdr = ("Server", softwareName spec) : hdr+    addServer hdr = ("Server", softwareName spec) : hdr+    addLength hdr len = ("Content-Length", BS.pack . show $ len) : hdr  ---------------------------------------------------------------- -processGET :: Request -> FilePath -> Bool -> Maybe FilePath -> Rsp+type Lang = Maybe ByteString++langSuffixes :: Request -> [Lang]+langSuffixes req = map (Just . BS.cons 46) (languages req) ++ [Nothing, Just ".en"] -- '.'++----------------------------------------------------------------++processGET :: Request -> ByteString -> Bool -> Maybe ByteString -> Rsp processGET req file ishtml rfile = runAny [-    tryGet req file ishtml langs-  , tryRedirect req rfile langs+    tryGet req file ishtml+  , tryRedirect req rfile   , just notFound   ]-  where-    langs = map ('.':) (languages req) ++ ["",".en"] -tryGet :: Request -> FilePath -> Bool -> [String] -> MRsp-tryGet req file True langs = runAnyMaybe $ map (tryGetFile req file) langs-tryGet req file _    _     = tryGetFile req file ""+tryGet :: Request -> ByteString -> Bool -> MRsp+tryGet req file True  = runAnyMaybe $ map (tryGetFile req file True) langs+  where+    langs = langSuffixes req+tryGet req file False = tryGetFile req file False Nothing -tryGetFile :: Request -> FilePath -> String -> MRsp-tryGetFile req file lang = do-    let file' = if null lang then file else file ++ lang+tryGetFile :: Request -> ByteString -> Bool -> Lang -> MRsp+tryGetFile req file ishtml mlang = do+    let file' = maybe file (file +++) mlang     liftIO (fileInfo file') |>| \(size, mtime) -> do-      let hdr = newHeader file mtime+      let hdr = newHeader ishtml file mtime           Just pst = ifmodified req size mtime -- never Nothing                  ||| ifunmodified req size mtime                  ||| ifrange req size mtime@@ -91,24 +104,24 @@  ---------------------------------------------------------------- -processHEAD :: Request -> FilePath -> Bool -> Maybe FilePath -> Rsp+processHEAD :: Request -> ByteString -> Bool -> Maybe ByteString -> Rsp processHEAD req file ishtml rfile = runAny [-    tryHead req file ishtml langs-  , tryRedirect req rfile langs+    tryHead req file ishtml+  , tryRedirect req rfile   , just notFound   ]-  where-    langs = map ('.':) (languages req) ++ ["",".en"] -tryHead :: Request -> FilePath -> Bool -> [String] -> MRsp-tryHead req file True langs = runAnyMaybe $ map (tryHeadFile req file) langs-tryHead req file _    _     = tryHeadFile req file ""+tryHead :: Request -> ByteString -> Bool -> MRsp+tryHead req file True  = runAnyMaybe $ map (tryHeadFile req file True) langs+  where+    langs = langSuffixes req+tryHead req file False= tryHeadFile req file False Nothing -tryHeadFile :: Request -> FilePath -> String -> MRsp-tryHeadFile req file lang = do-    let file' = if null lang then file else file ++ lang+tryHeadFile :: Request -> ByteString -> Bool -> Lang -> MRsp+tryHeadFile req file ishtml mlang = do+    let file' = maybe file (file +++) mlang     liftIO (fileInfo file') |>| \(size, mtime) -> do-      let hdr = newHeader file mtime+      let hdr = newHeader ishtml file mtime           Just pst = ifmodified req size mtime -- never Nothing                  ||| Just (Full statusOK)       case pst of@@ -117,21 +130,22 @@  ---------------------------------------------------------------- -tryRedirect  :: Request -> Maybe FilePath -> [String] -> MRsp-tryRedirect _   Nothing     _     = nothing-tryRedirect req (Just file) langs =+tryRedirect  :: Request -> Maybe ByteString -> MRsp+tryRedirect _   Nothing     = nothing+tryRedirect req (Just file) =     runAnyMaybe $ map (tryRedirectFile req file) langs+  where+    langs = langSuffixes req -tryRedirectFile :: Request -> FilePath -> String -> MRsp-tryRedirectFile req file lang = do-    let file' = file ++ lang+tryRedirectFile :: Request -> ByteString -> Lang -> MRsp+tryRedirectFile req file mlang = do+    let file' = maybe file (file +++) mlang     minfo <- liftIO $ fileInfo file'     case minfo of       Nothing -> nothing       Just _  -> just $ RspSpec statusMovedPermanently hdr NoBody   where     hdr = [("Location", redirectURL)]-    (+++) = BS.append     redirectURL = "http://"               +++ serverName req               +++ ":"

@@ -1,51 +1,55 @@ module Network.Wai.Application.Classic.FileInfo where +import Control.Exception import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS-import Data.Time-import Data.Time.Clock.POSIX+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 import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.Header import Network.Wai.Application.Classic.Range import Network.Wai.Application.Classic.Types-import System.Directory-import System.FilePath+import Network.Wai.Application.Classic.Utils import System.Posix.Files  ---------------------------------------------------------------- -fileInfo :: FilePath -> IO (Maybe (Integer, UTCTime))-fileInfo file = do-    exist <- doesFileExist file-    if exist-       then do-         fs <- getFileStatus file-         let size = fromIntegral . fileSize $ fs-             mtime = posixSecondsToUTCTime . realToFrac . modificationTime $ fs-         return $ Just (size, mtime)+-- 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  ----------------------------------------------------------------  data StatusAux = Full Status | Partial Integer Integer deriving Show -ifmodified :: Request -> Integer -> UTCTime -> Maybe StatusAux+ifmodified :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifmodified req size mtime = do     date <- ifModifiedSince req     if date /= mtime        then unconditional req size mtime        else Just (Full statusNotModified) -ifunmodified :: Request -> Integer -> UTCTime -> Maybe StatusAux+ifunmodified :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifunmodified req size mtime = do     date <- ifUnmodifiedSince req     if date == mtime        then unconditional req size mtime        else Just (Full statusPreconditionFailed) -ifrange :: Request -> Integer -> UTCTime -> Maybe StatusAux+ifrange :: Request -> Integer -> HTTPDate -> Maybe StatusAux ifrange req size mtime = do     date <- ifRange req     rng  <- lookupRequestField fkRange req@@ -53,7 +57,7 @@        then Just (Full statusOK)        else range size rng -unconditional :: Request -> Integer -> UTCTime -> Maybe StatusAux+unconditional :: Request -> Integer -> HTTPDate -> Maybe StatusAux unconditional req size _ =     maybe (Just (Full statusOK)) (range size) $ lookupRequestField fkRange req @@ -62,23 +66,22 @@   Nothing         -> Just (Full statusRequestedRangeNotSatisfiable)   Just (skip,len) -> Just (Partial skip len) - ---------------------------------------------------------------- -pathinfoToFilePath :: Request -> FileRoute -> FilePath+pathinfoToFilePath :: Request -> FileRoute -> ByteString pathinfoToFilePath req filei = path'   where     path = rawPathInfo req     src = fileSrc filei     dst = fileDst filei-    path' = dst </> drop (BS.length src) (BS.unpack path)+    path' = dst </> BS.drop (BS.length src) path -addIndex :: AppSpec -> FilePath -> FilePath+addIndex :: AppSpec -> ByteString -> ByteString addIndex spec path   | hasTrailingPathSeparator path = path </> indexFile spec   | otherwise                     = path -redirectPath :: AppSpec -> FilePath -> Maybe FilePath+redirectPath :: AppSpec -> ByteString -> Maybe ByteString redirectPath spec path   | hasTrailingPathSeparator path = Nothing   | otherwise                     = Just (path </> indexFile spec)

@@ -3,12 +3,14 @@ module Network.Wai.Application.Classic.Lang (parseLang) where  import Control.Applicative hiding (many, optional)-import Data.Attoparsec.Char8 hiding (take)-import Data.ByteString.Char8 hiding (map, count, take)-import Data.List+import Data.Attoparsec (Parser, takeWhile, parse, feed, Result(..))+import Data.Attoparsec.Char8 (char, string, count, many, space, digit, option, sepBy1)+import Data.ByteString.Char8 hiding (map, count, take, takeWhile)+import Data.List (sortBy) import Data.Ord+import Prelude hiding (takeWhile) -parseLang :: ByteString -> [String]+parseLang :: ByteString -> [ByteString] parseLang bs = case feed (parse acceptLanguage bs) "" of     Done _ ls -> map fst $ sortBy detrimental ls     _         -> []@@ -17,20 +19,14 @@  ---------------------------------------------------------------- -acceptLanguage :: Parser [(String,Int)]+acceptLanguage :: Parser [(ByteString,Int)] acceptLanguage = rangeQvalue `sepBy1` (spaces *> char ',' *> spaces) -rangeQvalue :: Parser (String,Int)+rangeQvalue :: Parser (ByteString,Int) rangeQvalue = (,) <$> languageRange <*> quality -languageRange :: Parser String-languageRange = (++) <$> language <*> sublang--language :: Parser String-language = many1 letter_ascii--sublang :: Parser String-sublang = option "" ((:) <$> char '-' <*> many1 letter_ascii)+languageRange :: Parser ByteString+languageRange = takeWhile (\w -> w /= 32 && w /= 44 && w /= 59)  quality :: Parser Int quality = option 1000 (string ";q=" *> qvalue)

@@ -32,12 +32,14 @@  ---------------------------------------------------------------- +infixr 5 >>|, |>|, |||+ (>>|) :: Maybe a -> (a -> MaybeIter b) -> MaybeIter b v >>| act =     case v of       Nothing -> nothing       Just x  -> act x-+       (|>|) :: MaybeIter a -> (a -> MaybeIter b) -> MaybeIter b a |>| act = do     v <- a

@@ -9,9 +9,9 @@     -- | Name specified to Server: in HTTP response.     softwareName :: ByteString     -- | A file name of an index file.-  , indexFile :: FilePath+  , indexFile :: ByteString     -- | Whether this is an HTML or not.-  , isHTML :: FilePath -> Bool+  , isHTML :: ByteString -> Bool     -- | A function for logging.   , logger :: Request -> Status -> RspBody -> IO ()   }@@ -20,14 +20,14 @@     -- | Path prefix to be matched to 'pathInfo'.     fileSrc :: ByteString     -- | Path prefix to an actual file system.-  , fileDst :: FilePath+  , fileDst :: ByteString   }  data CgiRoute = CgiRoute {     -- | Path prefix to be matched to 'pathInfo'.     cgiSrc :: ByteString     -- | Path prefix to an actual file system.-  , cgiDst :: FilePath+  , cgiDst :: ByteString   }  data RspSpec = RspSpec {@@ -45,7 +45,7 @@     -- | Body as Lazy ByteString.   | BodyLBS BL.ByteString     -- | Body as a file.-  | BodyFile FilePath Range+  | BodyFile ByteString Range  data Range =     -- | Entire file showing its file size

@@ -1,9 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+ module Network.Wai.Application.Classic.Utils where  import Control.Applicative-import Network.Socket (getNameInfo, SockAddr, NameInfoFlag(..))-import Data.Maybe+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Char8 () import Data.List (isPrefixOf)+import Data.Maybe+import Data.Word+import Network.Socket (getNameInfo, SockAddr, NameInfoFlag(..))  {-|   A type for IP address in numeric string representation.@@ -22,3 +28,21 @@       | "::ffff:" `isPrefixOf` x = drop 7 x       | otherwise                = x +pathSep :: Word8+pathSep = 47++hasTrailingPathSeparator :: ByteString -> Bool+hasTrailingPathSeparator "" = False+hasTrailingPathSeparator path+  | BS.last path == pathSep = True+  | otherwise               = False++infixr +++++(+++) :: ByteString -> ByteString -> ByteString+(+++) = BS.append++(</>) :: ByteString -> ByteString -> ByteString+s1 </> s2+  | hasTrailingPathSeparator s1 = s1 +++ s2+  | otherwise                   = s1 +++ (pathSep `BS.cons` s2)

@@ -1,5 +1,5 @@ Name:                   wai-app-file-cgi-Version:                0.1.2+Version:                0.2.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -21,8 +21,7 @@                         Network.Wai.Application.Classic.File                         Network.Wai.Application.Classic.Types                         Network.Wai.Application.Classic.Header-  Other-Modules:        Network.Wai.Application.Classic.Date-                        Network.Wai.Application.Classic.EnumLine+  Other-Modules:        Network.Wai.Application.Classic.EnumLine                         Network.Wai.Application.Classic.Field                         Network.Wai.Application.Classic.FileInfo                         Network.Wai.Application.Classic.Lang@@ -30,12 +29,13 @@                         Network.Wai.Application.Classic.Range                         Network.Wai.Application.Classic.Utils   Build-Depends:        base >= 4 && < 5, process, haskell98,-                        network, transformers, time,+                        network, transformers,                         filepath, directory, unix,                         containers, attoparsec,                         wai, enumerator >= 0.4.9,                         bytestring, blaze-builder,-                        wai-app-static, http-types, case-insensitive+                        wai-app-static, http-types, http-date,+                        case-insensitive, hashmap, array Source-Repository head   Type:                 git   Location:             git://github.com/kazu-yamamoto/wai-app-file-cgi.git