Re-raise exceptions in the main thread
This commit is contained in:
parent
917ddbbd50
commit
86febd09a7
1 changed files with 24 additions and 3 deletions
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP, OverloadedStrings #-}
|
||||
|
||||
-- | This module provides remote monitoring of a running process over
|
||||
-- HTTP. It can be used to run an HTTP server that provides both a
|
||||
|
@ -43,7 +43,7 @@ module System.Remote.Monitoring
|
|||
, getDistribution
|
||||
) where
|
||||
|
||||
import Control.Concurrent (ThreadId, forkIO)
|
||||
import Control.Concurrent (ThreadId, myThreadId, throwTo)
|
||||
import qualified Data.ByteString as S
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Text as T
|
||||
|
@ -58,6 +58,13 @@ import qualified System.Metrics.Label as Label
|
|||
import System.Remote.Snap
|
||||
import Network.Socket (withSocketsDo)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
import Control.Concurrent (forkFinally)
|
||||
#else
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Exception (SomeException, mask, try)
|
||||
#endif
|
||||
|
||||
-- $configuration
|
||||
--
|
||||
-- To make full use out of this this module you must first enable GC
|
||||
|
@ -224,7 +231,11 @@ forkServerWith :: Metrics.Store -- ^ Metric store
|
|||
-> IO Server
|
||||
forkServerWith store host port = do
|
||||
Metrics.registerCounter "ekg.server_timestamp_ms" getTimeMs store
|
||||
tid <- withSocketsDo $ forkIO $ startServer store host port
|
||||
me <- myThreadId
|
||||
tid <- withSocketsDo $ forkFinally (startServer store host port) $ \ r ->
|
||||
case r of
|
||||
Left e -> throwTo me e
|
||||
Right _ -> return ()
|
||||
return $! Server tid store
|
||||
where
|
||||
getTimeMs :: IO Int64
|
||||
|
@ -265,3 +276,13 @@ getDistribution :: T.Text -- ^ Distribution name
|
|||
-> IO Distribution.Distribution
|
||||
getDistribution name server =
|
||||
Metrics.createDistribution name (serverMetricStore server)
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- Backwards compatibility shims
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 706
|
||||
forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
|
||||
forkFinally action and_then =
|
||||
mask $ \restore ->
|
||||
forkIO $ try (restore action) >>= and_then
|
||||
#endif
|
||||
|
|
Loading…
Reference in a new issue