From f38281b346bdd6974ad1d68c655046ca52453e40 Mon Sep 17 00:00:00 2001
From: Nikolaj Gade <nikolaj@ingemanngade.net>
Date: Mon, 21 Oct 2024 16:49:16 +0200
Subject: [PATCH] :collision: Crashing

---
 a6/src/SPC.hs       | 19 ++++++++++++++++---
 a6/src/SPC_Tests.hs | 16 ++++++++++++++++
 2 files changed, 32 insertions(+), 3 deletions(-)

diff --git a/a6/src/SPC.hs b/a6/src/SPC.hs
index 95a5b0e..0b663ad 100644
--- a/a6/src/SPC.hs
+++ b/a6/src/SPC.hs
@@ -32,6 +32,7 @@ import Control.Concurrent
     readChan,
     ThreadId
   )
+import Control.Exception (SomeException, catch)
 import Control.Monad (ap, forever, liftM, void, filterM, when)
 import GenServer
 import System.Clock.Seconds (Clock (Monotonic), Seconds, getTime)
@@ -121,7 +122,8 @@ data SPCMsg
     MsgAddWorker WorkerName Worker
   | -- | Worker finished job
     MsgJobDone JobId
-  -- | MsgDebug (ReplyChan SPCState)
+  | -- | Crashed
+    MsgJobCrashed JobId
 
 -- | A handle to the SPC instance.
 data SPC = SPC (Server SPCMsg)
@@ -287,6 +289,12 @@ handleMsg c = do
                 spcJobsDone = (jobid, DoneCancelled) : spcJobsDone state
               }
         _ -> pure ()
+    MsgJobCrashed jobid -> do
+      state <- get
+      case (lookup jobid $ spcJobsRunning state) of
+        Just (_, _, _) -> do
+          jobDone jobid DoneCrashed
+        Nothing -> pure ()
     _ -> pure ()
 
 startSPC :: IO SPC
@@ -375,8 +383,13 @@ workerLoop c m = forever $ do
     -- stuff happening here
     MsgStartJob action jobid rsvp -> do
       t <- forkIO $ do
-        action
-        sendTo c $ MsgJobDone jobid
+        let doJob = do
+              action
+              sendTo c $ MsgJobDone jobid
+            onException :: SomeException -> IO ()
+            onException _ =
+              sendTo c $ MsgJobCrashed jobid
+        doJob `catch` onException
       reply rsvp t
 
 -- | Shut down a running worker. No effect if the worker is already
diff --git a/a6/src/SPC_Tests.hs b/a6/src/SPC_Tests.hs
index a3d9e0c..696e3f8 100644
--- a/a6/src/SPC_Tests.hs
+++ b/a6/src/SPC_Tests.hs
@@ -129,6 +129,22 @@ tests =
           r2 <- jobWait spc j2
           r2 @?= Done
 
+          x <- readIORef ref
+          x @?= True,
+        testCase "Crash" $ do
+          ref <- newIORef False
+          spc <- startSPC
+          w <- workerAdd spc "C1-10P"
+          isRight w @?= True
+
+          j1 <- jobAdd spc $ Job (error "boom") 1
+          r1 <- jobWait spc j1
+          r1 @?= DoneCrashed
+
+          -- Ensure new jobs can still work.
+          j2 <- jobAdd spc $ Job (writeIORef ref True) 1
+          r2 <- jobWait spc j2
+          r2 @?= Done
           x <- readIORef ref
           x @?= True
       ]