fix(avs): avs background synchs and lms userlist result no longer block handler

src/Handler/Admin.hs

@@ -54,9 +54,8 @@ getAdminProblemsR = do
     -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
     (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
     (Right AvsLicenceDifferences{..}) -> do
-      let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
+      let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld      
-      -- mapM_  (queueJob' . flip JobSynchroniseAvsId cutOffAvsSynch) problemIds
+      forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)      
-      runDBJobs . forM_ problemIds $ queueDBJob . flip JobSynchroniseAvsId (Just nowaday)
       return $ Right
         ( Set.size avsLicenceDiffRevokeAll
         , Set.size avsLicenceDiffGrantVorfeld

src/Handler/LMS.hs

@@ -671,15 +671,15 @@ postLmsR sid qsh = do
 
         fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
 
-      runDBJobs $ forM_ selectedUsers $ \uid ->
+      forM_ selectedUsers $ \uid ->
-        queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
+        queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
       let numUsers = length selectedUsers
           mStatus  = bool Success Warning $ delUsers < numUsers
       addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers      
       reloadKeepGetParams $ LmsR sid qsh
 
     (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do      
-      numExaminees <- runDBJobs $ do
+      numExaminees <- runDB $ do
         okUsers <- selectList [ LmsUserQualification  ==. qid                       -- matching qualification
                               , LmsUserEnded          ==. Nothing                   -- not yet deleted
                               , LmsUserStatus         ==. Nothing                   -- not yet decided
@@ -690,7 +690,7 @@ postLmsR sid qsh = do
             newPin <- liftIO randomLMSpw
             update lid [LmsUserPin =. newPin, LmsUserDatePin =. now, LmsUserResetPin =. True]
           when (isNotifyAct action) $
-            queueDBJob $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
+            queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False }
         return $ length okUsers
       let numSelected  = length selectedUsers
           diffSelected = numSelected - numExaminees

src/Handler/LMS/Result.hs

@@ -212,7 +212,7 @@ postLmsResultR sid qsh = do
 
 -- Direct File Upload/Download
 
-saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int
+saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int
 saveResultCsv qid i LmsResultTableCsv{..} = do
     now <- liftIO getCurrentTime
     void $ upsert
@@ -238,12 +238,12 @@ postLmsResultUploadR sid qsh = do
     FormSuccess file -> do
       -- content <- fileSourceByteString file
       -- return $ Just (fileName file, content)
-      nr <- runDBJobs $ do
+      nr <- runDB $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
         nr <- runConduit $ fileSource file
                 .| decodeCsv
                 .| foldMC (saveResultCsv qid) 0
-        queueDBJob $ JobLmsResults qid
+        queueJob' $ JobLmsResults qid
         return nr
       addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
       redirect $ LmsResultR sid qsh
@@ -267,7 +267,7 @@ postLmsResultDirectR sid qsh = do
   (status, msg) <- case files of
     [(fhead,file)] -> do
       lmsDecoder <- getLmsCsvDecoder
-      runDBJobs $ do
+      runDB $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
         enr <- try $ runConduit $ fileSource file
                 .| lmsDecoder
@@ -279,7 +279,7 @@ postLmsResultDirectR sid qsh = do
           Right nr -> do
             let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
             $logInfoS "LMS" msg
-            when (nr > 0) $ queueDBJob $ JobLmsResults qid
+            when (nr > 0) $ queueJob' $ JobLmsResults qid
             return (ok200, msg)
     []     -> do
       let msg = "Result upload file missing."

src/Handler/LMS/Userlist.hs

@@ -212,7 +212,7 @@ postLmsUserlistR sid qsh = do
 -- Direct File Upload/Download
 --  saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) =>
 --                      Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b
-saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int
+saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int
 saveUserlistCsv qid i LmsUserlistTableCsv{..} = do
     now <- liftIO getCurrentTime
     void $ upsert
@@ -236,10 +236,10 @@ postLmsUserlistUploadR sid qsh = do
   ((result,widget), enctype) <- runFormPost makeUserlistUploadForm
   case result of
     FormSuccess file -> do
-      nr <- runDBJobs $ do
+      nr <- runDB $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
         nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0
-        queueDBJob $ JobLmsUserlist qid
+        queueJob' $ JobLmsUserlist qid
         return nr
       addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen")
       redirect $ LmsUserlistR sid qsh
@@ -263,7 +263,7 @@ postLmsUserlistDirectR sid qsh = do
   (status, msg) <- case files of
     [(fhead,file)] -> do
       lmsDecoder <- getLmsCsvDecoder
-      runDBJobs $ do
+      runDB $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
         enr <- try $ runConduit $ fileSource file
                 .| lmsDecoder
@@ -275,7 +275,7 @@ postLmsUserlistDirectR sid qsh = do
           Right nr -> do
             let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ".  "
             $logInfoS "LMS" msg 
-            when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
+            when (nr > 0) $ queueJob' $ JobLmsUserlist qid
             return (ok200, msg)
     []     -> do
       let msg = "Userlist upload file missing."

src/Handler/Users.hs

@@ -359,11 +359,11 @@ postUsersR = do
       | Set.null usersSet && isNotSetSupervisor act ->
           addMessageI Info MsgActionNoUsersSelected          
     (UserLdapSyncData, userSet) -> do
-      runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid
+      forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid
       addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet      
       redirectKeepGetParams UsersR
     (UserAvsSyncData, userSet) -> do
-      runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseAvsUser uid Nothing
+      forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing
       addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet      
       redirectKeepGetParams UsersR
     (UserHijack, Set.minView -> Just (uid, _)) ->

src/Jobs/Handler/SynchroniseAvs.hs

@@ -22,24 +22,24 @@ import Jobs.Queue
 import Handler.Utils.Avs
 
 dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
-dispatchJobSynchroniseAvs numIterations epoch iteration pause
+dispatchJobSynchroniseAvs numIterations epoch iteration pause  
-  -- TODO: refactor so that the AvsIdLookup becomes obsolete
+  = JobHandlerException . runDB $ do
-  = JobHandlerAtomic . runConduit $
+      now <- liftIO getCurrentTime
-      readUsers .| filterIteration .| sinkDBJobs
+      todos <- runConduit $ readUsers .| filterIteration now .| sinkList
+      putMany todos
   where
-    readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
+    readUsers :: ConduitT () UserId _ ()
     readUsers = selectKeys [] []
 
-    filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
+    filterIteration :: UTCTime -> ConduitT UserId AvsSync _ ()
-    filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
+    filterIteration now = C.mapMaybeM $ \userId -> runMaybeT $ do
       let
         userIteration, currentIteration :: Integer
         userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
         currentIteration = toInteger iteration `mod` toInteger numIterations
       --  $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
-      guard $ userIteration == currentIteration
+      guard $ userIteration == currentIteration      
-      
+      return $ AvsSync userId now pause      
-      return $ JobSynchroniseAvsUser userId pause
 
 -- dispatchJobSynchroniseAvs' :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
 -- dispatchJobSynchroniseAvs' numIterations epoch iteration pause = JobHandlerAtomic $ do 
@@ -97,7 +97,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
                 AvsInterfaceUnavailable -> return ()  -- ignore and retry later
                 AvsUserUnknownByAvs _   -> return ()  -- ignore for users no longer listed in AVS
                 otherExc                -> throwM otherExc
-            )
+            )            
 
 -- needed, since JobSynchroniseAvsQueue cannot requeue itself due to JobNoQueueSame (and having no parameters)
 dispatchJobSynchroniseAvsNext :: JobHandler UniWorX

src/Jobs/Queue.hs

@@ -152,7 +152,7 @@ sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) ()
 sinkDBJobs = C.mapM_ queueDBJob
 
 runDBJobs :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
--- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
+-- | Blocking! Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
 --
 -- Jobs get immediately executed if the transaction succeeds
 runDBJobs act = do
@@ -161,7 +161,7 @@ runDBJobs act = do
   forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform
   return ret
 
-
+-- | Blocking!
 runDBJobs' :: YesodJobDB UniWorX a -> DB a
 runDBJobs' act = do
   (ret, jIds) <- mapReaderT runWriterT act