From a7cfb86419e9f4be42b2138949861d2998c3b7c4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 13 Oct 2018 15:53:38 +0200
Subject: [PATCH] Ignoring stale locks

---
 config/settings.yml |  1 +
 src/Jobs.hs         | 16 ++++++++++++++--
 src/Settings.hs     |  2 ++
 3 files changed, 17 insertions(+), 2 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index d34af3ad9..edd5dbaf0 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -19,6 +19,7 @@ mail-verp:
 job-workers:        "_env:JOB_WORKERS:10"
 job-flush-interval: "_env:JOB_FLUSH:30"
 job-cron-interval:  "_env:CRON_INTERVAL:60"
+job-stale-threshold: 300
 
 detailed-logging:  "_env:DETAILED_LOGGING:false"
 should-log-all:    "_env:LOG_ALL:false"
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 9155d59a6..831eef142 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -66,6 +66,7 @@ import qualified Control.Monad.State.Class as State
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
+import Control.Monad.Trans.Maybe (MaybeT(..))
 
 import Control.Monad.Random (MonadRandom(..), evalRand)
 
@@ -248,10 +249,21 @@ jLocked jId act = do
 
   let
     lock = runDB . setSerializable $ do
-      QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
-      maybe (return ()) throwM $ JLocked <$> pure jId <*> queuedJobLockInstance <*> queuedJobLockTime
+      qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
       instanceID <- getsYesod appInstanceID
+      threshold <- getsYesod $ appJobStaleThreshold . appSettings
       now <- liftIO getCurrentTime
+      hadStale <- maybeT (return False) $ do
+        lockTime <- MaybeT $ return queuedJobLockTime
+        lockInstance <- MaybeT $ return queuedJobLockInstance
+        if
+          | lockInstance == instanceID
+          , diffUTCTime now lockTime >= threshold
+            -> return True
+          | otherwise
+            -> throwM $ JLocked jId lockInstance lockTime
+      when hadStale .
+        $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
       val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
                            , QueuedJobLockTime =. Just now
                            ]
diff --git a/src/Settings.hs b/src/Settings.hs
index 2d48e2643..87ff88afe 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -85,6 +85,7 @@ data AppSettings = AppSettings
     , appJobWorkers             :: Int
     , appJobFlushInterval       :: Maybe NominalDiffTime
     , appJobCronInterval        :: NominalDiffTime
+    , appJobStaleThreshold      :: NominalDiffTime
 
     , appDetailedRequestLogging :: Bool
     -- ^ Use detailed request logging system
@@ -276,6 +277,7 @@ instance FromJSON AppSettings where
         appJobWorkers             <- o .:  "job-workers"
         appJobFlushInterval       <- o .:? "job-flush-interval"
         appJobCronInterval        <- o .:  "job-cron-interval"
+        appJobStaleThreshold      <- o .:  "job-stale-threshold"
 
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev