wai-app-file-cgi 0.4.3 → 0.4.4
raw patch · 7 files changed
+104/−144 lines, 7 files
Files
- Network/Wai/Application/Classic/CGI.hs +5/−6
- Network/Wai/Application/Classic/File.hs +69/−56
- Network/Wai/Application/Classic/MaybeIter.hs +0/−59
- Network/Wai/Application/Classic/Status.hs +24/−17
- Network/Wai/Application/Classic/Types.hs +4/−3
- Network/Wai/Application/Classic/Utils.hs +1/−1
- wai-app-file-cgi.cabal +1/−2
Network/Wai/Application/Classic/CGI.hs view
@@ -8,7 +8,6 @@ import Control.Applicative import Control.Exception import Control.Monad (when)-import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as BS hiding (unpack) import qualified Data.ByteString.Char8 as BS (readInt, unpack)@@ -53,14 +52,14 @@ cgiApp' :: Bool -> ClassicAppSpec -> CgiRoute -> Application cgiApp' body cspec cgii req = do- (rhdl,whdl,pid) <- liftIO $ execProcess cspec cgii req+ (rhdl,whdl,pid) <- tryIO $ execProcess cspec cgii req let cleanup = do hClose whdl hClose rhdl terminateProcess pid -- SIGTERM -- HTTP body can be obtained in this Iteratee level only- toCGI whdl body `catchError` const (liftIO cleanup)- liftIO $ hClose whdl+ toCGI whdl body `catchError` const (tryIO cleanup)+ tryIO $ hClose whdl respEnumerator $ \respIter -> -- this is IO fromCGI rhdl cspec req respIter `finally` cleanup@@ -76,7 +75,7 @@ m <- EL.head case m of Nothing -> return ()- Just b -> liftIO (BS.hPutStr whdl b) >> tocgi+ Just b -> tryIO (BS.hPutStr whdl b) >> tocgi fromCGI :: Handle -> ClassicAppSpec -> Request -> ResponseEnumerator a fromCGI rhdl cspec req respIter = run_ $ enumOutput $$ do@@ -87,7 +86,7 @@ Just (s,h) -> (s,h,True) hdr' = addServer cspec hdr -- logging- liftIO $ logger cspec req st Nothing -- cannot know body length+ tryIO $ logger cspec req st Nothing -- cannot know body length -- iteratee to build HTTP header and optionally HTTP body if hasBody then bodyAsBuilder =$ respIter st hdr'
Network/Wai/Application/Classic/File.hs view
@@ -1,24 +1,47 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.Wai.Application.Classic.File ( fileApp ) where import Control.Applicative-import Control.Monad.IO.Class (liftIO)+import Control.Exception+import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS (pack, concat) import qualified Data.ByteString.Lazy.Char8 as BL (length)+import Data.Enumerator (Iteratee(..), tryIO, catchError, throwError)+import Data.Typeable import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Classic.Field import Network.Wai.Application.Classic.FileInfo-import Network.Wai.Application.Classic.MaybeIter import Network.Wai.Application.Classic.Status import Network.Wai.Application.Classic.Types import Network.Wai.Application.Classic.Utils+import Prelude hiding (catch) ---------------------------------------------------------------- +type Iter = Iteratee ByteString IO+type Rsp = Iter RspSpec++instance Alternative Iter where+ empty = goNext+ x <|> y = x `catchError` const y++data AltIterErr = AltIterErr deriving (Show, Typeable)++instance Exception AltIterErr++goNext :: Iter a+goNext = throwError AltIterErr++runAlt :: [Iter a] -> Iter a+runAlt = foldr (<|>) goNext++----------------------------------------------------------------+ data HandlerInfo = HandlerInfo FileAppSpec Request Path [Lang] langSuffixes :: Request -> [Lang]@@ -55,10 +78,10 @@ _ -> return notAllowed (response, mlen) <- case body of NoBody -> return $ noBody st- BodyStatus -> statusBody st <$> liftIO (getStatusInfo cspec spec langs st)+ BodyStatus -> statusBody st <$> (tryIO $ getStatusInfo cspec spec langs st) BodyFileNoBody hdr -> return $ bodyFileNoBody st hdr BodyFile hdr afile rng -> return $ bodyFile st hdr afile rng- liftIO $ logger cspec req st mlen+ tryIO $ logger cspec req st mlen return response where hinfo = HandlerInfo spec req file langs@@ -96,79 +119,69 @@ ---------------------------------------------------------------- processGET :: HandlerInfo -> Bool -> Maybe Path -> Rsp-processGET hinfo ishtml rfile = runAny [- tryGet hinfo ishtml- , tryRedirect hinfo rfile- , just notFound- ]+processGET hinfo ishtml rfile = tryGet hinfo ishtml+ <|> tryRedirect hinfo rfile+ <|> return notFound -tryGet :: HandlerInfo -> Bool -> MRsp+tryGet :: HandlerInfo -> Bool -> Rsp tryGet hinfo@(HandlerInfo _ _ _ langs) True =- runAnyMaybe $ map (tryGetFile hinfo True) langs+ runAlt $ map (tryGetFile hinfo True) langs tryGet hinfo False = tryGetFile hinfo False id -tryGetFile :: HandlerInfo -> Bool -> Lang -> MRsp+tryGetFile :: HandlerInfo -> Bool -> Lang -> Rsp tryGetFile (HandlerInfo spec req file _) ishtml lang = do- let file' = lang file- liftIO (getFileInfo spec file') |>| \finfo -> do- let mtime = fileInfoTime finfo- size = fileInfoSize finfo- sfile = fileInfoName finfo- hdr = newHeader ishtml (pathByteString file) mtime- 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 (BodyFile hdr sfile (Entire size))- | otherwise -> just $ RspSpec st (BodyFileNoBody hdr)-- Partial skip len -> just $ RspSpec statusPartialContent (BodyFile hdr sfile (Part skip len))+ finfo <- tryIO (getFileInfo spec (lang file))+ let mtime = fileInfoTime finfo+ size = fileInfoSize finfo+ sfile = fileInfoName finfo+ hdr = newHeader ishtml (pathByteString file) mtime+ 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 -> return $ RspSpec statusOK (BodyFile hdr sfile (Entire size))+ | otherwise -> return $ RspSpec st (BodyFileNoBody hdr)+ Partial skip len -> return $ RspSpec statusPartialContent (BodyFile hdr sfile (Part skip len)) ---------------------------------------------------------------- processHEAD :: HandlerInfo -> Bool -> Maybe Path -> Rsp-processHEAD hinfo ishtml rfile = runAny [- tryHead hinfo ishtml- , tryRedirect hinfo rfile- , just notFoundNoBody- ]+processHEAD hinfo ishtml rfile = tryHead hinfo ishtml+ <|> tryRedirect hinfo rfile+ <|> return notFoundNoBody -tryHead :: HandlerInfo -> Bool -> MRsp+tryHead :: HandlerInfo -> Bool -> Rsp tryHead hinfo@(HandlerInfo _ _ _ langs) True =- runAnyMaybe $ map (tryHeadFile hinfo True) langs+ runAlt $ map (tryHeadFile hinfo True) langs tryHead hinfo False= tryHeadFile hinfo False id -tryHeadFile :: HandlerInfo -> Bool -> Lang -> MRsp+tryHeadFile :: HandlerInfo -> Bool -> Lang -> Rsp tryHeadFile (HandlerInfo spec req file _) ishtml lang = do- let file' = lang file- liftIO (getFileInfo spec file') |>| \finfo -> do- let mtime = fileInfoTime finfo- size = fileInfoSize finfo- hdr = newHeader ishtml (pathByteString file) mtime- Just pst = ifmodified req size mtime -- never Nothing- ||| Just (Full statusOK)- case pst of- Full st -> just $ RspSpec st (BodyFileNoBody hdr)- _ -> nothing -- never reached+ finfo <- tryIO (getFileInfo spec (lang file))+ let mtime = fileInfoTime finfo+ size = fileInfoSize finfo+ hdr = newHeader ishtml (pathByteString file) mtime+ Just pst = ifmodified req size mtime -- never Nothing+ <|> Just (Full statusOK)+ case pst of+ Full st -> return $ RspSpec st (BodyFileNoBody hdr)+ _ -> goNext -- never reached ---------------------------------------------------------------- -tryRedirect :: HandlerInfo -> Maybe Path -> MRsp-tryRedirect _ Nothing = nothing+tryRedirect :: HandlerInfo -> Maybe Path -> Rsp+tryRedirect _ Nothing = goNext tryRedirect (HandlerInfo spec req _ langs) (Just file) =- runAnyMaybe $ map (tryRedirectFile hinfo) langs+ runAlt $ map (tryRedirectFile hinfo) langs where hinfo = HandlerInfo spec req file langs -tryRedirectFile :: HandlerInfo -> Lang -> MRsp+tryRedirectFile :: HandlerInfo -> Lang -> Rsp tryRedirectFile (HandlerInfo spec req file _) lang = do- let file' = lang file- minfo <- liftIO $ getFileInfo spec file'- case minfo of- Nothing -> nothing- Just _ -> just $ RspSpec statusMovedPermanently (BodyFileNoBody hdr)+ _ <- tryIO $ getFileInfo spec (lang file)+ return $ RspSpec statusMovedPermanently (BodyFileNoBody hdr) where hdr = locationHeader redirectURL redirectURL = BS.concat [ "http://"
− Network/Wai/Application/Classic/MaybeIter.hs
@@ -1,59 +0,0 @@-module Network.Wai.Application.Classic.MaybeIter where--import Control.Monad (mplus)-import Data.ByteString (ByteString)-import Data.Enumerator (Iteratee)-import Network.Wai.Application.Classic.Types--------------------------------------------------------------------type MaybeIter a = Iteratee ByteString IO (Maybe a)-type MRsp = MaybeIter RspSpec--type Rsp = Iteratee ByteString IO RspSpec--------------------------------------------------------------------runAny :: Monad m => [m (Maybe a)] -> m a-runAny [] = error "runAny"-runAny (a:as) = do- mres <- a- case mres of- Nothing -> runAny as- Just res -> return res--runAnyMaybe :: Monad m => [m (Maybe a)] -> m (Maybe a)-runAnyMaybe [] = nothing-runAnyMaybe (a:as) = do- mx <- a- case mx of- Nothing -> runAnyMaybe as- Just _ -> return mx--------------------------------------------------------------------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- case v of- Nothing -> nothing- Just x -> act x--(|||) :: Maybe a -> Maybe a -> Maybe a-(|||) = mplus--------------------------------------------------------------------just :: Monad m => a -> m (Maybe a)-just = return . Just--nothing :: Monad m => m (Maybe a)-nothing = return Nothing
Network/Wai/Application/Classic/Status.hs view
@@ -1,24 +1,33 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.Wai.Application.Classic.Status (getStatusInfo) where +import Control.Applicative import Control.Arrow+import Control.Exception import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Char8 ()+import Data.Maybe import qualified Data.StaticHash as M import Network.HTTP.Types-import Network.Wai.Application.Classic.MaybeIter import Network.Wai.Application.Classic.Types import Network.Wai.Application.Classic.Utils+import Prelude hiding (catch) +instance Alternative IO where+ empty = goNext+ x <|> y = x `catch` (\(_ :: SomeException) -> y)++goNext :: IO a+goNext = throwIO $ userError "goNext for IO"+ ---------------------------------------------------------------- getStatusInfo :: ClassicAppSpec -> FileAppSpec -> [Lang] -> Status -> IO StatusInfo-getStatusInfo cspec spec langs st = runAny [- getStatusFile getF dir code langs- , return (getStatusBS code)- , return (Just StatusNone)- ]+getStatusInfo cspec spec langs st = getStatusFile getF dir code langs+ <|> getStatusBS code+ <|> return StatusNone where dir = statusFileDir cspec getF = getFileInfo spec@@ -41,8 +50,10 @@ where toRspBody s = StatusByteString $ BL.fromChunks [statusMessage s, "\r\n"] -getStatusBS :: Int -> Maybe StatusInfo-getStatusBS code = M.lookup code statusBSMap+getStatusBS :: Int -> IO StatusInfo+getStatusBS code = case M.lookup code statusBSMap of+ Nothing -> throwIO $ userError "getStatusBS"+ Just x -> return x ---------------------------------------------------------------- @@ -51,17 +62,13 @@ where toPath s = fromString $ show (statusCode s) ++ ".html" -getStatusFile :: (Path -> IO (Maybe FileInfo)) -> Path -> Int -> [Lang] -> IO (Maybe StatusInfo)-getStatusFile getF dir code langs = try mfiles+getStatusFile :: (Path -> 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- try [] = return Nothing- try (f:fs) = do- mfi <- getF f- case mfi of- Nothing -> try fs- Just fi -> return . Just $ StatusFile f (fileInfoSize fi)+ tryFile = foldr func goNext+ func f io = StatusFile f . fileInfoSize <$> getF f <|> io ----------------------------------------------------------------
Network/Wai/Application/Classic/Types.hs view
@@ -34,15 +34,16 @@ indexFile :: Path -- | Whether this is an HTML or not. , isHTML :: Path -> Bool- -- | A function to obtain information about a file- , getFileInfo :: Path -> IO (Maybe FileInfo)+ -- | 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- }+ } deriving Show data FileRoute = FileRoute { -- | Path prefix to be matched to 'rawPathInfo'.
Network/Wai/Application/Classic/Utils.hs view
@@ -21,7 +21,7 @@ data Path = Path { pathString :: FilePath , pathByteString :: ByteString- }+ } deriving Show instance IsString Path where fromString path = Path {
wai-app-file-cgi.cabal view
@@ -1,5 +1,5 @@ Name: wai-app-file-cgi-Version: 0.4.3+Version: 0.4.4 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -24,7 +24,6 @@ Network.Wai.Application.Classic.FileInfo Network.Wai.Application.Classic.Header Network.Wai.Application.Classic.Lang- Network.Wai.Application.Classic.MaybeIter Network.Wai.Application.Classic.Range Network.Wai.Application.Classic.RevProxy Network.Wai.Application.Classic.Status