wai-app-file-cgi 0.0.2 → 0.1.0
raw patch · 12 files changed
+85/−95 lines, 12 filesdep +case-insensitivedep +http-types
Dependencies added: case-insensitive, http-types
Files
- Network/Wai/Application/Classic.hs +7/−12
- Network/Wai/Application/Classic/CGI.hs +8/−8
- Network/Wai/Application/Classic/EnumLine.hs +1/−1
- Network/Wai/Application/Classic/Field.hs +1/−0
- Network/Wai/Application/Classic/File.hs +31/−28
- Network/Wai/Application/Classic/FileInfo.hs +17/−16
- Network/Wai/Application/Classic/Header.hs +6/−4
- Network/Wai/Application/Classic/MaybeIter.hs +1/−2
- Network/Wai/Application/Classic/Range.hs +2/−2
- Network/Wai/Application/Classic/Status.hs +0/−17
- Network/Wai/Application/Classic/Types.hs +9/−2
- wai-app-file-cgi.cabal +2/−3
Network/Wai/Application/Classic.hs view
@@ -2,17 +2,12 @@ WAI (Web Application Interface) Application for static files and CGI. -} -module Network.Wai.Application.Classic (- module Network.Wai.Application.Classic.CGI- , module Network.Wai.Application.Classic.File- , module Network.Wai.Application.Classic.Types- , module Network.Wai.Application.Classic.Header- , module Network.Wai.Application.Classic.Utils- ) where+module Network.Wai.Application.Classic (module Classic) where -import Network.Wai.Application.Classic.CGI-import Network.Wai.Application.Classic.File-import Network.Wai.Application.Classic.Types-import Network.Wai.Application.Classic.Header-import Network.Wai.Application.Classic.Utils+import Network.Wai.Application.Classic.CGI as Classic+import Network.Wai.Application.Classic.File as Classic+import Network.Wai.Application.Classic.Types as Classic+import Network.Wai.Application.Classic.Header as Classic+import Network.Wai.Application.Classic.Utils as Classic+
Network/Wai/Application/Classic/CGI.hs view
@@ -10,10 +10,11 @@ import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS-import Data.Char+import Data.CaseInsensitive hiding (map) import Data.Enumerator hiding (map, filter, drop, break) import qualified Data.Enumerator.Binary as EB import qualified Data.Enumerator.List as EL+import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.EnumLine as ENL import Network.Wai.Application.Classic.Field@@ -64,7 +65,7 @@ Nothing -> (status500,[],True) Just (s,h) -> (s,h,False) hdr' = addHeader hdr- liftIO $ logger spec req st+ liftIO $ logger spec req st NoBody -- cannot know body length if emp then emptyBody =$ response build st hdr' else response build st hdr')@@ -80,7 +81,7 @@ } (prog, scriptName, pathinfo) = pathinfoToCGI (cgiSrc cgii) (cgiDst cgii)- (pathInfo req)+ (rawPathInfo req) toBuilder = EL.map fromByteString emptyBody = EB.isolate 0 response build status hs = toBuilder =$ build status hs@@ -88,7 +89,7 @@ Nothing -> Just (status200, hs) Just l -> toStatus l >>= \s -> Just (s,hs') where- hs' = filter (\(k,_) -> ciLowerCase k /= "status") hs+ hs' = filter (\(k,_) -> foldedCase k /= "status") hs toStatus s = BS.readInt s >>= \x -> Just (Status (fst x) s) addHeader hdr = ("Server", softwareName spec) : hdr @@ -104,7 +105,7 @@ , ("SERVER_NAME", BS.unpack . serverName $ req) , ("SERVER_PORT", show . serverPort $ req) , ("REMOTE_ADDR", naddr)- , ("SERVER_PROTOCOL", "HTTP/" ++ (BS.unpack . httpVersion $ req))+ , ("SERVER_PROTOCOL", show . httpVersion $ req) , ("SERVER_SOFTWARE", BS.unpack sname) , ("PATH_INFO", pathinfo) , ("QUERY_STRING", query req)@@ -113,7 +114,7 @@ addLength = addEnv "CONTENT_LENGTH" $ lookupField fkContentLength headers addType = addEnv "CONTENT_TYPE" $ lookupField fkContentType headers addCookie = addEnv "HTTP_COOKIE" $ lookupField fkCookie headers- query = BS.unpack . safeTail . queryString+ query = BS.unpack . safeTail . rawQueryString where safeTail "" = "" safeTail bs = BS.tail bs@@ -128,12 +129,11 @@ parseHeader = takeHeader >>= maybe (return Nothing) (return . Just . map parseField) where- parseField bs = (CIByteString key skey, val)+ parseField bs = (mk key, val) where (key,val) = case BS.break (==':') bs of kv@(_,"") -> kv (k,v) -> let v' = BS.dropWhile (==' ') $ BS.tail v in (k,v')- skey = BS.map toLower key takeHeader :: Iteratee ByteString IO (Maybe [ByteString]) takeHeader = ENL.head >>= maybe (return Nothing) $. \l ->
Network/Wai/Application/Classic/EnumLine.hs view
@@ -48,7 +48,7 @@ czs = BL.toChunks zs lf = 10 cr = 13- eol c = c == lf || c == cr+ eol = (`elem` [lf, cr]) type Builder = BL.ByteString -> BL.ByteString
Network/Wai/Application/Classic/Field.hs view
@@ -13,6 +13,7 @@ import Data.ByteString (ByteString) import Data.ByteString.Char8 () import Data.Maybe+import Network.HTTP.Types import Network.Wai ----------------------------------------------------------------
Network/Wai/Application/Classic/File.hs view
@@ -7,6 +7,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL ()+import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.FileInfo@@ -31,7 +32,7 @@ contents, an index file must be created beforehand. The following HTTP headers are handled: Acceptable-Language:,-If-Modified-Since:. (Range:, If-Range:, If-Unmodified-Since:)+If-Modified-Since:, Range:, If-Range:, If-Unmodified-Since:. -} fileApp :: AppSpec -> FileRoute -> Application@@ -39,13 +40,16 @@ RspSpec st hdr body <- case method of "GET" -> processGET req file ishtml rfile "HEAD" -> processHEAD req file ishtml rfile- _ -> return $ notAllowed- liftIO $ logger spec req st+ _ -> return notAllowed+ liftIO $ logger spec req st body let hdr' = addHeader hdr case body of- NoBody -> return $ responseLBS st hdr' ""- BodyLBS bd -> return $ responseLBS st hdr' bd- BodyFile afile _ -> return $ ResponseFile st hdr' afile -- FIXME size+ 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)) where method = requestMethod req path = pathinfoToFilePath req filei@@ -56,7 +60,7 @@ ---------------------------------------------------------------- -processGET :: Request -> FilePath -> Bool -> (Maybe FilePath) -> Rsp+processGET :: Request -> FilePath -> Bool -> Maybe FilePath -> Rsp processGET req file ishtml rfile = runAny [ tryGet req file ishtml langs , tryRedirect req rfile langs@@ -72,23 +76,22 @@ tryGetFile :: Request -> FilePath -> String -> MRsp tryGetFile req file lang = do let file' = if null lang then file else file ++ lang- (liftIO $ fileInfo file') |>| \(size, mtime) -> do+ liftIO (fileInfo file') |>| \(size, mtime) -> do let hdr = newHeader file mtime- mst = ifmodified req size mtime- ||| ifunmodified req size mtime- ||| ifrange req size mtime- ||| unconditional req size mtime- case mst of- Just st- | st == statusOK -> just $ RspSpec statusOK hdr (BodyFile file' size)- -- FIXME skip len- | st == statusPartialContent -> undefined- | otherwise -> just $ RspSpec st hdr NoBody- _ -> nothing -- never reached+ 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))+ | otherwise -> just $ RspSpec st hdr NoBody + Partial skip len -> just $ RspSpec statusPartialContent hdr (BodyFile file' (Part skip len))+ ---------------------------------------------------------------- -processHEAD :: Request -> FilePath -> Bool -> (Maybe FilePath) -> Rsp+processHEAD :: Request -> FilePath -> Bool -> Maybe FilePath -> Rsp processHEAD req file ishtml rfile = runAny [ tryHead req file ishtml langs , tryRedirect req rfile langs@@ -104,17 +107,17 @@ tryHeadFile :: Request -> FilePath -> String -> MRsp tryHeadFile req file lang = do let file' = if null lang then file else file ++ lang- (liftIO $ fileInfo file') |>| \(size, mtime) -> do+ liftIO (fileInfo file') |>| \(size, mtime) -> do let hdr = newHeader file mtime- mst = ifmodified req size mtime- ||| Just statusOK- case mst of- Just st -> just $ RspSpec st hdr NoBody- _ -> nothing -- never reached+ Just pst = ifmodified req size mtime -- never Nothing+ ||| Just (Full statusOK)+ case pst of+ Full st -> just $ RspSpec st hdr NoBody+ _ -> nothing -- never reached ---------------------------------------------------------------- -tryRedirect :: Request -> (Maybe FilePath) -> [String] -> MRsp+tryRedirect :: Request -> Maybe FilePath -> [String] -> MRsp tryRedirect _ Nothing _ = nothing tryRedirect req (Just file) langs = runAnyMaybe $ map (tryRedirectFile req file) langs@@ -133,7 +136,7 @@ +++ serverName req +++ ":" +++ (BS.pack . show . serverPort) req- +++ pathInfo req+ +++ rawPathInfo req +++ "/" ----------------------------------------------------------------
Network/Wai/Application/Classic/FileInfo.hs view
@@ -4,12 +4,12 @@ import qualified Data.ByteString.Char8 as BS import Data.Time import Data.Time.Clock.POSIX+import Network.HTTP.Types import Network.Wai-import Network.Wai.Application.Classic.Header 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 Network.Wai.Application.Classic.Status import System.Directory import System.FilePath import System.Posix.Files@@ -29,37 +29,38 @@ ---------------------------------------------------------------- -ifmodified :: Request -> Integer -> UTCTime -> Maybe Status+data StatusAux = Full Status | Partial Integer Integer deriving Show++ifmodified :: Request -> Integer -> UTCTime -> Maybe StatusAux ifmodified req size mtime = do date <- ifModifiedSince req if date /= mtime then unconditional req size mtime- else Just statusNotModified+ else Just (Full statusNotModified) -ifunmodified :: Request -> Integer -> UTCTime -> Maybe Status+ifunmodified :: Request -> Integer -> UTCTime -> Maybe StatusAux ifunmodified req size mtime = do date <- ifUnmodifiedSince req if date == mtime then unconditional req size mtime- else Just statusPreconditionFailed+ else Just (Full statusPreconditionFailed) -ifrange :: Request -> Integer -> UTCTime -> Maybe Status+ifrange :: Request -> Integer -> UTCTime -> Maybe StatusAux ifrange req size mtime = do date <- ifRange req rng <- lookupRequestField fkRange req if date == mtime- then Just statusOK+ then Just (Full statusOK) else range size rng -unconditional :: Request -> Integer -> UTCTime -> Maybe Status+unconditional :: Request -> Integer -> UTCTime -> Maybe StatusAux unconditional req size _ =- maybe (Just statusOK) (range size) $ lookupRequestField fkRange req+ maybe (Just (Full statusOK)) (range size) $ lookupRequestField fkRange req -range :: Integer -> ByteString -> Maybe Status+range :: Integer -> ByteString -> Maybe StatusAux range size rng = case skipAndSize rng size of- Nothing -> Just statusRequestedRangeNotSatisfiable- Just (_,_) -> Just statusNotImplemented--- Just (skip,len) -> Just statusPartialContent -- FIXME skip len+ Nothing -> Just (Full statusRequestedRangeNotSatisfiable)+ Just (skip,len) -> Just (Partial skip len) ----------------------------------------------------------------@@ -67,10 +68,10 @@ pathinfoToFilePath :: Request -> FileRoute -> FilePath pathinfoToFilePath req filei = path' where- path = pathInfo req+ path = rawPathInfo req src = fileSrc filei dst = fileDst filei- path' = dst </> (drop (BS.length src) $ BS.unpack path)+ path' = dst </> drop (BS.length src) (BS.unpack path) addIndex :: AppSpec -> FilePath -> FilePath addIndex spec path
Network/Wai/Application/Classic/Header.hs view
@@ -4,7 +4,9 @@ import Data.ByteString (ByteString) import Data.ByteString.Char8 ()+import Data.CaseInsensitive import Data.Maybe+import Network.HTTP.Types import Network.Wai ----------------------------------------------------------------@@ -78,7 +80,7 @@ Looking up a header in 'RequestHeaders'. -} lookupField :: FieldKey -> RequestHeaders -> Maybe ByteString-lookupField x (((CIByteString _ l), val):kvs)- | x == l = Just val- | otherwise = lookupField x kvs-lookupField _ [] = Nothing+lookupField x ((key, val):kvs)+ | x == foldedCase key = Just val+ | otherwise = lookupField x kvs+lookupField _ [] = Nothing
Network/Wai/Application/Classic/MaybeIter.hs view
@@ -3,7 +3,6 @@ import Control.Monad (mplus) import Data.ByteString (ByteString) import Data.Enumerator (Iteratee)-import Network.Wai import Network.Wai.Application.Classic.Types ----------------------------------------------------------------@@ -46,7 +45,7 @@ Nothing -> nothing Just x -> act x -(|||) :: Maybe Status -> Maybe Status -> Maybe Status+(|||) :: Maybe a -> Maybe a -> Maybe a (|||) = mplus ----------------------------------------------------------------
Network/Wai/Application/Classic/Range.hs view
@@ -4,7 +4,7 @@ import Control.Applicative hiding (many,optional) import Data.Attoparsec.Char8 hiding (take)-import Data.ByteString.Char8 hiding (map, count, take)+import Data.ByteString.Char8 hiding (map, count, take, elem) skipAndSize :: ByteString -> Integer -> Maybe (Integer,Integer) skipAndSize bs size = case parseRange bs of@@ -50,4 +50,4 @@ spcs = () <$ many spc spc :: Parser Char-spc = satisfy (\c -> c == ' ' || c == '\t')+spc = satisfy (`elem` " \t")
− Network/Wai/Application/Classic/Status.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.Wai.Application.Classic.Status where--import Network.Wai--statusNotModified :: Status-statusNotModified = Status 304 "Not Modified"--statusPreconditionFailed :: Status-statusPreconditionFailed = Status 412 "Precondition Failed"--statusRequestedRangeNotSatisfiable :: Status-statusRequestedRangeNotSatisfiable = Status 416 "Requested Range Not Satisfiable"--statusNotImplemented :: Status-statusNotImplemented = Status 501 "Not Implemented"
Network/Wai/Application/Classic/Types.hs view
@@ -2,6 +2,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)+import Network.HTTP.Types import Network.Wai data AppSpec = AppSpec {@@ -12,7 +13,7 @@ -- | Whether this is an HTML or not. , isHTML :: FilePath -> Bool -- | A function for logging.- , logger :: Request -> Status -> IO ()+ , logger :: Request -> Status -> RspBody -> IO () } data FileRoute = FileRoute {@@ -44,4 +45,10 @@ -- | Body as Lazy ByteString. | BodyLBS BL.ByteString -- | Body as a file.- | BodyFile FilePath Integer+ | BodyFile FilePath Range++data Range =+ -- | Entire file showing its file size+ Entire Integer+ -- | A part of a file taking offset and length+ | Part Integer Integer
wai-app-file-cgi.cabal view
@@ -1,5 +1,5 @@ Name: wai-app-file-cgi-Version: 0.0.2+Version: 0.1.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -29,14 +29,13 @@ Network.Wai.Application.Classic.MaybeIter Network.Wai.Application.Classic.Range Network.Wai.Application.Classic.Utils- Network.Wai.Application.Classic.Status Build-Depends: base >= 4 && < 5, process, haskell98, network >=2.2 && <2.3, transformers, time, filepath, directory, unix, containers, attoparsec, wai, enumerator >= 0.4.9, bytestring, blaze-builder,- wai-app-static+ wai-app-static, http-types, case-insensitive Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/wai-app-file-cgi.git