From b1143cb12bea48d75a2453f92122edcfb4fe51f1 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Fri, 13 Aug 2021 13:53:13 +0200
Subject: [PATCH] fix(jobs): more general no queue same

---
 src/Jobs/Queue.hs | 16 +++++++++++++++-
 src/Jobs/Types.hs | 34 +++++++++++++++++++---------------
 2 files changed, 34 insertions(+), 16 deletions(-)

diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs
index af7e46791..c2732dd35 100644
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
 module Jobs.Queue
   ( writeJobCtl, writeJobCtlBlock
   , writeJobCtl', writeJobCtlBlock'
@@ -18,6 +20,8 @@ import qualified Data.Set as Set
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.HashMap.Strict as HashMap
 
+import qualified Data.Aeson as Aeson
+
 import Control.Monad.Random (evalRand, mkStdGen, uniform)
 
 import qualified Data.Conduit.List as C
@@ -30,6 +34,9 @@ import Control.Monad.Trans.Resource (register)
 
 import System.Clock (getTime, Clock(Monotonic))
 
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+
 
 data JobQueueException = JobQueuePoolEmpty
                        | JobQueueWorkerNotFound
@@ -92,7 +99,14 @@ queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX (Maybe QueuedJobId)
 queueJobUnsafe queuedJobWriteLastExec job = do
   $logDebugS "queueJob" $ tshow job
 
-  doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ]
+  doQueue <- maybeT (return True) $ do
+    noQueueSame <- hoistMaybe $ jobNoQueueSame job
+    lift . fmap not . E.selectExists . E.from $ \queuedJob -> case noQueueSame of
+      JobNoQueueSame -> E.where_ $ queuedJob E.^. QueuedJobContent E.==. E.val (toJSON job)
+      JobNoQueueSameTag ->
+        let Aeson.Object obj = toJSON job
+            tag = obj HashMap.! "job"
+         in E.where_ $ (queuedJob E.^. QueuedJobContent) E.->. "job" E.==. E.val tag
 
   if
     | doQueue -> Just <$> do
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index 81c741d12..94afb6b53 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -18,7 +18,7 @@ module Jobs.Types
   , showWorkerId, newWorkerId
   , JobQueue, jqInsert, jqDequeue', jqDequeue, jqDepth, jqContents
   , JobPriority(..), prioritiseJob
-  , jobNoQueueSame, jobMovable
+  , JobNoQueueSame(..), jobNoQueueSame, jobMovable
   , module Cron
   ) where
 
@@ -302,21 +302,25 @@ prioritiseJob (JobCtlGenerateHealthReport _)  = JobPrioRealtime
 prioritiseJob  JobCtlDetermineCrontab         = JobPrioRealtime
 prioritiseJob  _                              = JobPrioBatch
 
-jobNoQueueSame :: Job -> Bool
+data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+  
+jobNoQueueSame :: Job -> Maybe JobNoQueueSame
 jobNoQueueSame = \case
-  JobSendPasswordReset{}       -> True
-  JobTruncateTransactionLog{}  -> True
-  JobPruneInvitations{}        -> True
-  JobDeleteTransactionLogIPs{} -> True
-  JobSynchroniseLdapUser{}     -> True
-  JobChangeUserDisplayEmail{}  -> True
-  JobPruneSessionFiles{}       -> True
-  JobPruneUnreferencedFiles{}  -> True
-  JobInjectFiles{}             -> True
-  JobPruneFallbackPersonalisedSheetFilesKeys{} -> True
-  JobRechunkFiles{}            -> True
-  JobDetectMissingFiles{}      -> True
-  _                            -> False
+  JobSendPasswordReset{}       -> Just JobNoQueueSame
+  JobTruncateTransactionLog{}  -> Just JobNoQueueSame
+  JobPruneInvitations{}        -> Just JobNoQueueSame
+  JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
+  JobSynchroniseLdapUser{}     -> Just JobNoQueueSame
+  JobChangeUserDisplayEmail{}  -> Just JobNoQueueSame
+  JobPruneSessionFiles{}       -> Just JobNoQueueSameTag
+  JobPruneUnreferencedFiles{}  -> Just JobNoQueueSameTag
+  JobInjectFiles{}             -> Just JobNoQueueSameTag
+  JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
+  JobRechunkFiles{}            -> Just JobNoQueueSameTag
+  JobDetectMissingFiles{}      -> Just JobNoQueueSameTag
+  _                            -> Nothing
 
 jobMovable :: JobCtl -> Bool
 jobMovable = isn't _JobCtlTest