happstack-server 7.4.6.4 → 7.5.0

raw patch · 7 files changed

+57/−7 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• happstack-server.cabal +3/−1
• src/Happstack/Server/Internal/Handler.hs +12/−4
• src/Happstack/Server/Internal/Monads.hs +8/−1
• src/Happstack/Server/Internal/TimeoutIO.hs +1/−0
• src/Happstack/Server/Internal/TimeoutSocket.hs +12/−0
• src/Happstack/Server/Internal/Types.hs +18/−1
• src/Happstack/Server/Monads.hs +3/−0

@@ -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 <http://happstack.com/docs/crashcourse/index.html> 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

@@ -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 ()

@@ -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))

@@ -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 ()

@@ -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

@@ -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 {})         = "<EscapeHTTP _>"

@@ -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+