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.4.6.4 +Version: 7.5.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 @@ -27,6 +27,7 @@ default: True Library + Default-language: Haskell2010 Exposed-modules: Happstack.Server Happstack.Server.Auth @@ -129,6 +130,7 @@ buildable: False Test-Suite happstack-server-tests + Default-language: Haskell2010 Type: exitcode-stdio-1.0 Main-Is: Test.hs GHC-Options: -threaded 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 @@ -8,6 +8,7 @@ import qualified Paths_happstack_server as Paths import qualified Data.Version as DV +import Control.Applicative (pure) import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar) import Control.Exception.Extensible as E import Control.Monad @@ -56,7 +57,7 @@ rloop timeoutIO mlog host handler inputStr | L.null inputStr = return () | otherwise - = join $ + = (join $ do let parseRequest = do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr @@ -76,7 +77,7 @@ case parseRequest of Left err -> error $ "failed to parse HTTP request: " ++ err Right (m, u, cookies, v, headers, body, nextRequest) - -> return $ + -> pure $ do bodyRef <- newMVar (Body body) bodyInputRef <- newEmptyMVar let req = Request (toSecure timeoutIO) m (pathEls (path u)) (path u) (query u) @@ -85,7 +86,9 @@ let ioseq act = act >>= \x -> x `seq` return x (res, handlerKilled) <- ((, False) `liftM` ioseq (handler req)) - `E.catch` \(e::E.SomeException) -> return (failResponse (show e), fromException e == Just ThreadKilled) + `E.catches` [ Handler $ \(e::EscapeHTTP) -> throwIO e -- need to handle this higher up + , Handler $ \(e::E.SomeException) -> pure (failResponse (show e), fromException e == Just ThreadKilled) + ] case mlog of Nothing -> return () @@ -106,7 +109,12 @@ cleanupTempFiles req -- do not continue if handler was killed when (not handlerKilled && continueHTTP req res) $ - rloop timeoutIO mlog host handler nextRequest + rloop timeoutIO mlog host handler nextRequest) `E.catch` (escapeHttpHandler timeoutIO) + +escapeHttpHandler :: TimeoutIO + -> EscapeHTTP + -> IO () +escapeHttpHandler tio (EscapeHTTP f) = f tio -- 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 @@ -6,6 +6,7 @@ import Control.Applicative (Applicative, pure, (<*>), Alternative(empty,(<|>))) import Control.Concurrent (newMVar) +import Control.Exception (throwIO) import Control.Monad ( MonadPlus(mzero, mplus), ap, liftM, msum ) @@ -50,7 +51,8 @@ import Happstack.Server.Internal.Cookie (Cookie) import Happstack.Server.Internal.RFC822Headers (parseContentType) -import Happstack.Server.Internal.Types (canHaveBody) +import Happstack.Server.Internal.Types (EscapeHTTP(..), canHaveBody) +import Happstack.Server.Internal.TimeoutIO (TimeoutIO) import Happstack.Server.Types import Prelude (Bool(..), Either(..), Eq(..), Functor(..), IO, Monad(..), Char, Maybe(..), String, Show(..), ($), (.), (>), (++), (&&), (||), (=<<), const, concatMap, flip, id, otherwise, zip) @@ -809,3 +811,8 @@ instance WebMonad a m => WebMonad a (ExceptT e m) where finishWith = lift . finishWith + +escapeHTTP :: (ServerMonad m, MonadIO m) => + (TimeoutIO -> IO ()) + -> m a +escapeHTTP h = liftIO (throwIO (EscapeHTTP h)) diff --git a/src/Happstack/Server/Internal/TimeoutIO.hs b/src/Happstack/Server/Internal/TimeoutIO.hs --- a/src/Happstack/Server/Internal/TimeoutIO.hs +++ b/src/Happstack/Server/Internal/TimeoutIO.hs @@ -15,6 +15,7 @@ { toHandle :: Handle , toPutLazy :: L.ByteString -> IO () , toPut :: B.ByteString -> IO () + , toGet :: IO (Maybe B.ByteString) , toGetContents :: IO L.ByteString , toSendFile :: FilePath -> Offset -> ByteCount -> IO () , toShutdown :: IO () diff --git a/src/Happstack/Server/Internal/TimeoutSocket.hs b/src/Happstack/Server/Internal/TimeoutSocket.hs --- a/src/Happstack/Server/Internal/TimeoutSocket.hs +++ b/src/Happstack/Server/Internal/TimeoutSocket.hs @@ -4,6 +4,7 @@ -} module Happstack.Server.Internal.TimeoutSocket where +import Control.Applicative (pure) import Control.Concurrent (threadWaitWrite) import Control.Exception as E (catch, throw) import Control.Monad (liftM, when) @@ -34,6 +35,16 @@ return () {-# INLINE sPutTickle #-} +sGet :: TM.Handle + -> Socket + -> IO (Maybe B.ByteString) +sGet handle socket = + do s <- N.recv socket 65536 + TM.tickle handle + if S.null s + then pure Nothing + else pure (Just s) + sGetContents :: TM.Handle -> Socket -- ^ Connected socket -> IO L.ByteString -- ^ Data received @@ -79,6 +90,7 @@ TimeoutIO { toHandle = handle , toShutdown = sClose socket , toPutLazy = sPutLazyTickle handle socket + , toGet = sGet handle socket , toPut = sPutTickle handle socket , toGetContents = sGetContents handle socket , toSendFile = sendFileTickle handle socket diff --git a/src/Happstack/Server/Internal/Types.hs b/src/Happstack/Server/Internal/Types.hs --- a/src/Happstack/Server/Internal/Types.hs +++ b/src/Happstack/Server/Internal/Types.hs @@ -16,9 +16,11 @@ HttpVersion(..), Length(..), Method(..), canHaveBody, Headers, continueHTTP, Host, ContentType(..), readDec', fromReadS, readM, FromReqURI(..), - showRsValidator + showRsValidator, EscapeHTTP(..) ) where + +import Control.Exception (Exception, SomeException) import Control.Monad.Error (Error(strMsg)) import Control.Monad.Trans (MonadIO(liftIO)) import qualified Control.Concurrent.Thread.Group as TG @@ -43,6 +45,7 @@ import Happstack.Server.Internal.RFC822Headers ( ContentType(..) ) import Happstack.Server.Internal.Cookie import Happstack.Server.Internal.LogFormat (formatRequestCombined) +import Happstack.Server.Internal.TimeoutIO (TimeoutIO) import Numeric (readDec, readSigned) import System.Log.Logger (Priority(..), logM) @@ -515,3 +518,17 @@ "1" -> Just True "true" -> Just True _ -> Nothing + +------------------------------------------------------------------------------ +-- EscapeHTTP - escape hatched use by websockets +------------------------------------------------------------------------------ + +-- | Escape from the HTTP world and get direct access to the underlying 'TimeoutIO' functions +data EscapeHTTP + = EscapeHTTP (TimeoutIO -> IO ()) + deriving (Typeable) + +instance Exception EscapeHTTP + +instance Show EscapeHTTP where + show (EscapeHTTP {}) = "" 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 @@ -35,6 +35,8 @@ -- * MonadPlus helpers , require , requireM + -- * escapeHTTP + , escapeHTTP ) where import Control.Applicative (Alternative, Applicative) @@ -109,3 +111,4 @@ case mbVal of Nothing -> mzero Just a -> handle a +