Signed-off-by: Anders Kaseorg <andersk@mit.edu>
{-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}
{-# OPTIONS_GHC -O2 -Wall #-}
{-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}
{-# OPTIONS_GHC -O2 -Wall #-}
+import Prelude hiding (catch)
import Control.Applicative
import Control.Applicative
-import Control.Exception
+import Control.Monad.CatchIO
import qualified Data.ByteString.Lazy as B
import Data.Char
import Data.Dynamic
import qualified Data.ByteString.Lazy as B
import Data.Char
import Data.Dynamic
import Numeric
import System.FilePath
import System.IO
import Numeric
import System.FilePath
import System.IO
+import System.IO.Error (isDoesNotExistError, isPermissionError)
import System.Locale
import System.Posix
import System.Posix.Handle
import System.Locale
import System.Posix
import System.Posix.Handle
(".zip", "application/zip")
]
(".zip", "application/zip")
]
-throwExceptionCGI :: Exception e => e -> CGI a
-throwExceptionCGI = throwCGI . toException
-
-catchExceptionCGI :: Exception e => CGI a -> (e -> CGI a) -> CGI a
-a `catchExceptionCGI` handler =
- a `catchCGI` \e -> case fromException e of
- Nothing -> throwCGI e
- Just e_ -> handler e_
-
data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
deriving (Show, Typeable)
data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
deriving (Show, Typeable)
return $ takeExtension base
case M.lookup (map toLower ext') types of
return $ takeExtension base
case M.lookup (map toLower ext') types of
- Nothing -> throwExceptionCGI Forbidden
+ Nothing -> throw Forbidden
Just t -> setHeader "Content-Type" t
checkMethod :: CGI CGIResult -> CGI CGIResult
Just t -> setHeader "Content-Type" t
checkMethod :: CGI CGIResult -> CGI CGIResult
"HEAD" -> rOutput >> outputNothing
"GET" -> rOutput
"POST" -> rOutput
"HEAD" -> rOutput >> outputNothing
"GET" -> rOutput
"POST" -> rOutput
- _ -> throwExceptionCGI BadMethod
httpDate :: String
httpDate = "%a, %d %b %Y %H:%M:%S %Z"
httpDate :: String
httpDate = "%a, %d %b %Y %H:%M:%S %Z"
checkModified mTime = do
setHeader "Last-Modified" $ formatHTTPDate mTime
(requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
checkModified mTime = do
setHeader "Last-Modified" $ formatHTTPDate mTime
(requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
- when (parseHTTPDate ims >= Just mTime) $ throwExceptionCGI NotModified
+ when (parseHTTPDate ims >= Just mTime) $ throw NotModified
checkIfRange :: EpochTime -> CGI (Maybe ())
checkIfRange mTime = do
checkIfRange :: EpochTime -> CGI (Maybe ())
checkIfRange mTime = do
(checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
case parseRange range size of
Just (a, b) | a <= b -> return $ Just (a, b)
(checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
case parseRange range size of
Just (a, b) | a <= b -> return $ Just (a, b)
- _ -> throwExceptionCGI BadRange
outputAll :: Handle -> FileOffset -> CGI CGIResult
outputAll h size = do
outputAll :: Handle -> FileOffset -> CGI CGIResult
outputAll h size = do
outputFPS =<< liftIO (B.hGet h (fromIntegral len))
serveFile :: FilePath -> CGI CGIResult
outputFPS =<< liftIO (B.hGet h (fromIntegral len))
serveFile :: FilePath -> CGI CGIResult
-serveFile file = (`catchExceptionCGI` outputMyError) $ do
+serveFile file = (`catch` outputMyError) $ do
checkExtension file
checkMethod $ do
let handleOpenError e =
checkExtension file
checkMethod $ do
let handleOpenError e =
- if isDoesNotExistError e then throwExceptionCGI NotFound
- else if isPermissionError e then throwExceptionCGI Forbidden
- else throwExceptionCGI e
- h <- liftIO (openBinaryFile file ReadMode) `catchExceptionCGI` handleOpenError
- let handlePostOpenError e = do
- liftIO $ hClose h
- throwCGI e
- (`catchCGI` handlePostOpenError) $ do
+ if isDoesNotExistError e then throw NotFound
+ else if isPermissionError e then throw Forbidden
+ else throw e
+ h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
+ (`onException` liftIO (hClose h)) $ do
status <- liftIO $ hGetStatus h
let mTime = modificationTime status
status <- liftIO $ hGetStatus h
let mTime = modificationTime status
Build-Depends:
base >= 4,
bytestring,
Build-Depends:
base >= 4,
bytestring,