From 9b4e480b9a395a0000c61e8a4fbff4ff96a06fba Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 9 Oct 2021 13:18:09 +0100
Subject: [PATCH 1/2] throw startServer exceptions synchronously

Error handling doesn't currently work with `forkServer`:
```
do
  s <- Just <$> forkServer "localhost" 8000 `catchAny` \e -> pure Nothing
```

The above code will not manage to deal with "port already in use" or similar, since the exceptions are being thrown asynchronously to the main thread.

To address that we use an Async to hold the server, so there's no longer a need to throw the exception back to the main thread.
---
 .vscode/settings.json       |  3 +++
 System/Remote/Monitoring.hs | 39 ++++++++++---------------------------
 ekg.cabal                   |  1 +
 3 files changed, 14 insertions(+), 29 deletions(-)
 create mode 100644 .vscode/settings.json

diff --git a/.vscode/settings.json b/.vscode/settings.json
new file mode 100644
index 0000000..0e4913b
--- /dev/null
+++ b/.vscode/settings.json
@@ -0,0 +1,3 @@
+{
+  "haskell.serverExecutablePath": "/Users/pepeiborra/scratch/ide/dist-newstyle/build/x86_64-osx/ghc-8.10.5/ghcide-1.4.2.3/x/ghcide/build/ghcide/ghcide"
+}
\ No newline at end of file
diff --git a/System/Remote/Monitoring.hs b/System/Remote/Monitoring.hs
index a45f0b0..c22b67a 100644
--- a/System/Remote/Monitoring.hs
+++ b/System/Remote/Monitoring.hs
@@ -30,6 +30,7 @@ module System.Remote.Monitoring
 
       -- * The monitoring server
       Server
+    , serverAsync
     , serverThreadId
     , serverMetricStore
     , forkServer
@@ -45,8 +46,8 @@ module System.Remote.Monitoring
     , getDistribution
     ) where
 
-import Control.Concurrent (ThreadId, myThreadId, throwTo)
-import Control.Exception (AsyncException(ThreadKilled), fromException)
+import Control.Concurrent.Async (async, Async (asyncThreadId))
+import Control.Concurrent (ThreadId)
 import qualified Data.ByteString as S
 import Data.Int (Int64)
 import qualified Data.Text as T
@@ -61,13 +62,6 @@ 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 module you must first enable GC
@@ -190,7 +184,7 @@ data Server = Server {
       -- | The thread ID of the server. You can kill the server by
       -- killing this thread (i.e. by throwing it an asynchronous
       -- exception.)
-      serverThreadId :: {-# UNPACK #-} !ThreadId
+      serverAsync :: {-# UNPACK #-} !(Async ())
 
       -- | The metric store associated with the server. If you want to
       -- add metric to the default store created by 'forkServer' you
@@ -198,6 +192,9 @@ data Server = Server {
     , serverMetricStore :: {-# UNPACK #-} !Metrics.Store
     }
 
+serverThreadId :: Server -> ThreadId
+serverThreadId = asyncThreadId . serverAsync
+
 -- | Like 'forkServerWith', but creates a default metric store with
 -- some predefined metrics. The predefined metrics are those given in
 -- 'System.Metrics.registerGcMetrics'.
@@ -262,14 +259,8 @@ forkServerMaybeHostnameWith :: Metrics.Store  -- ^ Metric store
                             -> IO Server
 forkServerMaybeHostnameWith store host port = do
     Metrics.registerCounter "ekg.server_timestamp_ms" getTimeMs store
-    me <- myThreadId
-    tid <- withSocketsDo $ forkFinally (startServer store host port) $ \ r ->
-        case r of
-            Right _ -> return ()
-            Left e  -> case fromException e of
-                Just ThreadKilled -> return ()
-                _                 -> throwTo me e
-    return $! Server tid store
+    a <- async $ withSocketsDo $ startServer store host port
+    return $! Server a store
   where
     getTimeMs :: IO Int64
     getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime
@@ -308,14 +299,4 @@ getDistribution :: T.Text  -- ^ Distribution name
                 -> Server  -- ^ Server that will serve the distribution
                 -> 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
+    Metrics.createDistribution name (serverMetricStore server)
\ No newline at end of file
diff --git a/ekg.cabal b/ekg.cabal
index e9c1977..784e0dc 100644
--- a/ekg.cabal
+++ b/ekg.cabal
@@ -41,6 +41,7 @@ library
 
   build-depends:
     aeson >= 0.4 && < 1.6,
+    async,
     base >= 4.5 && < 4.15,
     bytestring < 1.0,
     ekg-core >= 0.1 && < 0.2,

From 88dc2e19b8ba6aa83a5b7e0e9725edc8b2090ceb Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Sat, 9 Oct 2021 13:22:55 +0100
Subject: [PATCH 2/2] bump version

---
 ekg.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ekg.cabal b/ekg.cabal
index 784e0dc..6910531 100644
--- a/ekg.cabal
+++ b/ekg.cabal
@@ -1,5 +1,5 @@
 name:                ekg
-version:             0.4.0.16
+version:             0.5
 cabal-version:       >= 1.8
 synopsis:            Remote monitoring of processes
 description: