diff --git a/happstack-server.cabal b/happstack-server.cabal --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -1,5 +1,5 @@ Name: happstack-server -Version: 7.1.7.1 +Version: 7.3.0 Synopsis: Web related tools and services. Description: Happstack Server provides an HTTP server and a rich set of functions for routing requests, handling query parameters, generating responses, working with cookies, serving files, and more. For in-depth documentation see the Happstack Crash Course License: BSD3 diff --git a/src/Happstack/Server/Internal/Handler.hs b/src/Happstack/Server/Internal/Handler.hs --- a/src/Happstack/Server/Internal/Handler.hs +++ b/src/Happstack/Server/Internal/Handler.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables, TupleSections #-} module Happstack.Server.Internal.Handler ( request @@ -83,7 +83,8 @@ let ioseq act = act >>= \x -> x `seq` return x - res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e + (res, handlerKilled) <- ((, False) `liftM` ioseq (handler req)) + `E.catch` \(e::E.SomeException) -> return (result 500 $ "Server error: " ++ show e, fromException e == Just ThreadKilled) case mlog of Nothing -> return () @@ -102,7 +103,9 @@ putAugmentedResult timeoutIO req res -- clean up tmp files cleanupTempFiles req - when (continueHTTP req res) $ rloop timeoutIO mlog host handler nextRequest + -- do not continue if handler was killed + when (not handlerKilled && continueHTTP req res) $ + rloop timeoutIO mlog host handler nextRequest -- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup cleanupTempFiles :: Request -> IO () diff --git a/src/Happstack/Server/Internal/Monads.hs b/src/Happstack/Server/Internal/Monads.hs --- a/src/Happstack/Server/Internal/Monads.hs +++ b/src/Happstack/Server/Internal/Monads.hs @@ -200,10 +200,6 @@ askRq = ServerPartT $ ask localRq f m = ServerPartT $ local f (unServerPartT m) -instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where - askRq = lift askRq - localRq f = mapErrorT $ localRq f - ------------------------------- -- HERE BEGINS WebT definitions @@ -561,7 +557,7 @@ ------------------------------------------------------------------------------ -- ServerMonad, FilterMonad, and WebMonad instances for ReaderT, StateT, --- WriterT, and RWST +-- WriterT, RWST, and ErrorT ------------------------------------------------------------------------------ -- ReaderT @@ -626,3 +622,22 @@ instance (WebMonad a m, Monoid w) => WebMonad a (RWST r w s m) where finishWith = lift . finishWith + +-- ErrorT + +instance (Error e, ServerMonad m) => ServerMonad (ErrorT e m) where + askRq = lift askRq + localRq f = mapErrorT $ localRq f + +instance (Error e, FilterMonad a m) => FilterMonad a (ErrorT e m) where + setFilter f = lift $ setFilter f + composeFilter = lift . composeFilter + getFilter m = mapErrorT (\m' -> + do (eb, f) <- getFilter m' + case eb of + (Left e) -> return (Left e) + (Right b) -> return $ Right (b, f) + ) m + +instance (Error e, WebMonad a m) => WebMonad a (ErrorT e m) where + finishWith = lift . finishWith diff --git a/src/Happstack/Server/Monads.hs b/src/Happstack/Server/Monads.hs --- a/src/Happstack/Server/Monads.hs +++ b/src/Happstack/Server/Monads.hs @@ -31,14 +31,15 @@ -- * WebMonad , WebMonad(..) , escape - , escape' + , escape' -- * MonadPlus helpers , require , requireM ) where -import Control.Applicative (Alternative, Applicative) +import Control.Applicative (Alternative, Applicative) import Control.Monad (MonadPlus(mzero)) +import Control.Monad.Error (Error, ErrorT) import Control.Monad.Trans (MonadIO(..),MonadTrans(lift)) import Control.Monad.Reader (ReaderT) import Control.Monad.Writer (WriterT) @@ -61,6 +62,7 @@ instance (Happstack m) => Happstack (ReaderT r m) instance (Happstack m, Monoid w) => Happstack (WriterT w m) instance (Happstack m, Monoid w) => Happstack (RWST r w s m) +instance (Happstack m, Error e) => Happstack (ErrorT e m) -- | Get a header out of the request. getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString) diff --git a/src/Happstack/Server/RqData.hs b/src/Happstack/Server/RqData.hs --- a/src/Happstack/Server/RqData.hs +++ b/src/Happstack/Server/RqData.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} --- | Functions for extracting values from the query string, form data, cookies, etc. +-- | Functions for extracting values from the query string, form data, cookies, etc. -- -- For in-depth documentation see the following section of the Happstack Crash Course: -- -- -module Happstack.Server.RqData +module Happstack.Server.RqData ( -- * Looking up keys -- ** Form Values and Query Parameters look @@ -29,13 +29,13 @@ , lookInputs -- * Filters -- The look* functions normally search the QUERY_STRING and the Request - -- body for matches keys. + -- body for matches keys. , body , queryString , bytestring -- * Validation and Parsing , checkRq - , checkRqM + , checkRqM , readRq , unsafeReadRq -- * Handling POST\/PUT Requests @@ -46,7 +46,7 @@ -- * RqData Monad & Error Reporting , RqData , mapRqData - , Errors(..) + , Errors(..) -- ** Using RqData with ServerMonad , getDataFn , withDataFn @@ -65,7 +65,7 @@ import Control.Monad.State (StateT, mapStateT) import Control.Monad.Writer (WriterT, mapWriterT) import Control.Monad.RWS (RWST, mapRWST) -import Control.Monad.Error (Error(noMsg, strMsg)) +import Control.Monad.Error (Error(noMsg, strMsg), ErrorT, mapErrorT) import Control.Monad.Trans (MonadIO(..), lift) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.Char8 as L @@ -94,7 +94,7 @@ instance (Monoid e, Error e) => Applicative (ReaderError r e) where pure = return - (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a)) + (ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a)) = ReaderError $ ReaderT $ \env -> (f env) `apEither` (a env) instance (Monoid e, Error e) => Alternative (ReaderError r e) where @@ -120,7 +120,7 @@ noMsg = Errors [] strMsg str = Errors [str] -{- commented out to avoid 'Defined but not used' warning. +{- commented out to avoid 'Defined but not used' warning. readerError :: (Monoid e, Error e) => e -> ReaderError r e b readerError e = mapReaderErrorT ((Left e) `apEither`) (return ()) @@ -145,7 +145,7 @@ askRqEnv :: m RqEnv localRqEnv :: (RqEnv -> RqEnv) -> m a -> m a -- | lift some 'Errors' into 'RqData' - rqDataError :: Errors String -> m a + rqDataError :: Errors String -> m a instance HasRqData RqData where askRqEnv = RqData ask @@ -182,7 +182,7 @@ localRq (const rq') m ------------------------------------------------------------------------------ --- HasRqData instances for ReaderT, StateT, WriterT, and RWST +-- HasRqData instances for ReaderT, StateT, WriterT, RWST, and ErrorT ------------------------------------------------------------------------------ instance (Monad m, HasRqData m) => HasRqData (ReaderT s m) where @@ -205,6 +205,11 @@ localRqEnv f = mapRWST (localRqEnv f) rqDataError e = lift (rqDataError e) +instance (Monad m, Error e, HasRqData m) => HasRqData (ErrorT e m) where + askRqEnv = lift askRqEnv + localRqEnv f = mapErrorT (localRqEnv f) + rqDataError e = lift (rqDataError e) + -- | apply 'RqData a' to a 'RqEnv' -- -- see also: 'getData', 'getDataFn', 'withData', 'withDataFn', 'RqData', 'getDataFn' @@ -222,7 +227,7 @@ -- | use 'read' to convert a 'String' to a value of type 'a' -- -- > look "key" `checkRq` (unsafeReadRq "key") --- +-- -- use with 'checkRq' -- -- NOTE: This function is marked unsafe because some Read instances @@ -232,7 +237,7 @@ -- > read "1e10000000000000" :: Integer -- -- see also: 'readRq' -unsafeReadRq :: (Read a) => +unsafeReadRq :: (Read a) => String -- ^ name of key (only used for error reporting) -> String -- ^ 'String' to 'read' -> Either String a -- ^ 'Left' on error, 'Right' on success @@ -240,13 +245,13 @@ case reads val of [(a,[])] -> Right a _ -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val - + -- | use 'fromReqURI' to convert a 'String' to a value of type 'a' -- -- > look "key" `checkRq` (readRq "key") --- +-- -- use with 'checkRq' -readRq :: (FromReqURI a) => +readRq :: (FromReqURI a) => String -- ^ name of key (only used for error reporting) -> String -- ^ 'String' to 'read' -> Either String a -- ^ 'Left' on error, 'Right' on success @@ -263,7 +268,7 @@ -- by calling 'rqDataError'. -- -- This function is useful for a number of things including: --- +-- -- (1) Parsing a 'String' into another type -- -- (2) Checking that a value meets some requirements (for example, that is an Int between 1 and 10). @@ -322,7 +327,7 @@ (Just bdy) -> bdy -- | Gets the first matching named input parameter --- +-- -- Searches the QUERY_STRING followed by the Request body. -- -- see also: 'lookInputs' @@ -335,7 +340,7 @@ Nothing -> rqDataError (strMsg $ "Parameter not found: " ++ name) -- | Gets all matches for the named input parameter --- +-- -- Searches the QUERY_STRING followed by the Request body. -- -- see also: 'lookInput' @@ -351,7 +356,7 @@ -- -- see also: 'lookBSs' lookBS :: (Functor m, Monad m, HasRqData m) => String -> m L.ByteString -lookBS n = +lookBS n = do i <- fmap inputValue (lookInput n) case i of (Left _fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.") @@ -363,7 +368,7 @@ -- -- see also: 'lookBS' lookBSs :: (Functor m, Monad m, HasRqData m) => String -> m [L.ByteString] -lookBSs n = +lookBSs n = do is <- fmap (map inputValue) (lookInputs n) case partitionEithers is of ([], bs) -> return bs @@ -471,7 +476,7 @@ -- -- see also: 'lookReads' lookReads :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m [a] -lookReads name = +lookReads name = do vals <- looks name mapM (\v -> (return v) `checkRq` (readRq name)) vals @@ -481,7 +486,7 @@ -- must set enctype=\"multipart\/form-data\". -- -- This function returns a tuple consisting of: --- +-- -- (1) The temporary location of the uploaded file -- -- (2) The local filename supplied by the browser @@ -493,7 +498,7 @@ -- a 0-length file with an empty file name, so checking that (2) is -- not empty is usually sufficient to ensure the field has been -- filled. --- +-- -- NOTE: You must move the file from the temporary location before the -- 'Response' is sent. The temporary files are automatically removed -- after the 'Response' is sent. @@ -515,7 +520,7 @@ -- -- see also: 'lookPairsBS' lookPairs :: (Monad m, HasRqData m) => m [(String, Either FilePath String)] -lookPairs = +lookPairs = do (query, mBody, _cookies) <- askRqEnv let bdy = fromMaybeBody "lookPairs" "" mBody return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ bdy) @@ -527,20 +532,20 @@ -- -- see also: 'lookPairs' lookPairsBS :: (Monad m, HasRqData m) => m [(String, Either FilePath L.ByteString)] -lookPairsBS = +lookPairsBS = do (query, mBody, _cookies) <- askRqEnv let bdy = fromMaybeBody "lookPairsBS" "" mBody return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ bdy) -- | The POST\/PUT body of a Request is not received or decoded unless --- this function is invoked. +-- this function is invoked. -- -- It is an error to try to use the look functions for a POST\/PUT -- request with out first calling this function. -- -- It is ok to call 'decodeBody' at the beginning of every request: -- --- > main = simpleHTTP nullConf $ +-- > main = simpleHTTP nullConf $ -- > do decodeBody (defaultBodyPolicy "/tmp/" 4096 4096 4096) -- > handlers -- @@ -594,7 +599,7 @@ -- | similar to 'getDataFn', except it calls a sub-handler on success -- or 'mzero' on failure. --- +-- -- NOTE: you must call 'decodeBody' prior to calling this function if -- the request method is POST or PUT. withDataFn :: (HasRqData m, MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r @@ -602,7 +607,7 @@ -- | A variant of 'getDataFn' that uses 'FromData' to chose your -- 'RqData' for you. The example from 'getData' becomes: --- +-- -- > data AuthCredentials = AuthCredentials { username :: String, password :: String } -- > -- > isValid :: AuthCredentials -> Bool