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 @@ -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' 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 @@ -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://" diff --git a/Network/Wai/Application/Classic/MaybeIter.hs b/Network/Wai/Application/Classic/MaybeIter.hs deleted file mode 100644 --- a/Network/Wai/Application/Classic/MaybeIter.hs +++ /dev/null @@ -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 diff --git a/Network/Wai/Application/Classic/Status.hs b/Network/Wai/Application/Classic/Status.hs --- a/Network/Wai/Application/Classic/Status.hs +++ b/Network/Wai/Application/Classic/Status.hs @@ -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 ---------------------------------------------------------------- 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 @@ -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'. diff --git a/Network/Wai/Application/Classic/Utils.hs b/Network/Wai/Application/Classic/Utils.hs --- a/Network/Wai/Application/Classic/Utils.hs +++ b/Network/Wai/Application/Classic/Utils.hs @@ -21,7 +21,7 @@ data Path = Path { pathString :: FilePath , pathByteString :: ByteString - } + } deriving Show instance IsString Path where fromString path = Path { 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.4.3 +Version: 0.4.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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