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 @@ -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 + 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 @@ -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 -> diff --git a/Network/Wai/Application/Classic/EnumLine.hs b/Network/Wai/Application/Classic/EnumLine.hs --- a/Network/Wai/Application/Classic/EnumLine.hs +++ b/Network/Wai/Application/Classic/EnumLine.hs @@ -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 diff --git a/Network/Wai/Application/Classic/Field.hs b/Network/Wai/Application/Classic/Field.hs --- a/Network/Wai/Application/Classic/Field.hs +++ b/Network/Wai/Application/Classic/Field.hs @@ -13,6 +13,7 @@ import Data.ByteString (ByteString) import Data.ByteString.Char8 () import Data.Maybe +import Network.HTTP.Types import Network.Wai ---------------------------------------------------------------- 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,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 +++ "/" ---------------------------------------------------------------- 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 @@ -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 diff --git a/Network/Wai/Application/Classic/Header.hs b/Network/Wai/Application/Classic/Header.hs --- a/Network/Wai/Application/Classic/Header.hs +++ b/Network/Wai/Application/Classic/Header.hs @@ -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 diff --git a/Network/Wai/Application/Classic/MaybeIter.hs b/Network/Wai/Application/Classic/MaybeIter.hs --- a/Network/Wai/Application/Classic/MaybeIter.hs +++ b/Network/Wai/Application/Classic/MaybeIter.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/Wai/Application/Classic/Range.hs b/Network/Wai/Application/Classic/Range.hs --- a/Network/Wai/Application/Classic/Range.hs +++ b/Network/Wai/Application/Classic/Range.hs @@ -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") diff --git a/Network/Wai/Application/Classic/Status.hs b/Network/Wai/Application/Classic/Status.hs deleted file mode 100644 --- a/Network/Wai/Application/Classic/Status.hs +++ /dev/null @@ -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" 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.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 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.0.2 +Version: 0.1.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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