From 4154b1f26bcdc21d36cd9fd54e8a7379b960ecb8 Mon Sep 17 00:00:00 2001
From: Steffen Jost <s.jost@fraport.de>
Date: Tue, 30 Jan 2024 14:44:43 +0100
Subject: [PATCH] chore(utils): add timeoutHandler to run a sub-handler to be
 killed by timeout

---
 src/Handler/Course/Edit.hs      |  6 +++---
 src/Handler/Utils.hs            |  2 ++
 src/Handler/Utils/Concurrent.hs | 32 ++++++++++++++++++++++++++++++++
 src/Jobs.hs                     |  8 ++++----
 4 files changed, 41 insertions(+), 7 deletions(-)
 create mode 100644 src/Handler/Utils/Concurrent.hs

diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index 127056489..ae88bb64c 100644
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@@ -279,8 +279,8 @@ getCourseNewR = do
                     , E.desc $ courseCreated course]                                     -- most recent created course
           E.limit 1
           return course
-      template <- case listToMaybe oldCourses of
-        (Just oldTemplate) ->
+      template <- case oldCourses of
+        (oldTemplate:_) ->
             let newTemplate = courseToForm oldTemplate mempty mempty in
             return $ Just $ newTemplate
                 { cfCourseId   = Nothing
@@ -289,7 +289,7 @@ getCourseNewR = do
                 , cfRegTo      = Nothing
                 , cfDeRegUntil = Nothing
                 }
-        Nothing -> do
+        [] -> do
             (tidOk,sshOk,cshOk) <- runDB $ (,,)
                 <$> ifMaybeM mbTid True existsKey
                 <*> ifMaybeM mbSsh True existsKey
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 715c910a5..4e2c18e92 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -35,6 +35,8 @@ import Handler.Utils.Qualification as Handler.Utils
 
 import Handler.Utils.Term as Handler.Utils
 
+import Handler.Utils.Concurrent as Handler.Utils
+
 import Control.Monad.Logger
 
 
diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs
new file mode 100644
index 000000000..60e476a19
--- /dev/null
+++ b/src/Handler/Utils/Concurrent.hs
@@ -0,0 +1,32 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.Utils.Concurrent
+  ( module Handler.Utils.Concurrent
+  ) where
+
+
+import Import
+import UnliftIO.Concurrent
+
+
+-- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay`
+timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a)
+timeoutHandler maxWait act = do
+    innerAct <- handlerToIO
+    (hresult, tid) <- liftIO $ do 
+      hresult <- newTVarIO Nothing
+      tid <- forkIO $ innerAct $ do 
+        res <- act
+        liftIO $ atomically $ writeTVar hresult $ Just res
+      return (hresult, tid)
+    res <- liftIO $ do
+      flag <- registerDelay maxWait
+      atomically $ do 
+        res <- readTVar hresult
+        out <- readTVar flag
+        checkSTM $ out || isJust res
+        return res
+    when (isNothing res) $ killThread tid
+    return res
diff --git a/src/Jobs.hs b/src/Jobs.hs
index f48922abb..b45b24b82 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -47,7 +47,7 @@ import qualified Control.Monad.Catch as Exc
 
 import Data.Time.Zones
 
-import Control.Concurrent.STM (stateTVar, retry)
+import Control.Concurrent.STM (stateTVar)
 import Control.Concurrent.STM.Delay
 
 import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay)
@@ -260,7 +260,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
                   (nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan
                   lift . lift $ writeTVar chan newQueue
                   jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState
-                  receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers'
+                  receiver <- maybe (lift $ lift retrySTM) return =<< uniformMay jobWorkers'
                   return (nextVal, receiver)
                 whenIsJust next $ \(nextVal, receiver) -> do
                   atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!)
@@ -373,8 +373,8 @@ execCrontab = do
     State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
     prevExec <- State.get
     case earliestJob settings prevExec crontab refT of
-      Nothing -> liftBase retry
-      Just (_, MatchNone) -> liftBase retry
+      Nothing -> liftBase retrySTM
+      Just (_, MatchNone) -> liftBase retrySTM
       Just x -> return (crontab, x, prevExec)
 
   do