diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 32675e9da..81e5b5f15 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -382,7 +382,7 @@ getProblemAvsSynchR = do numUnknownLicenceOwners = length unknownLicenceOwners (btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown - ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do + ifNothingM btnImportUnknownRes () $ \BtnAvsImportUnknown -> do res <- catchAllAvs $ forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty) --TODO: continue here! @@ -413,7 +413,7 @@ getProblemAvsSynchR = do ^{revokeUnknownExecWgt} |] - ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do + ifNothingM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> do let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners no_revokes = Set.size revokes oks <- catchAllAvs $ setLicencesAvs revokes diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index ae88bb64c..c1d5a580b 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -291,9 +291,9 @@ getCourseNewR = do } [] -> do (tidOk,sshOk,cshOk) <- runDB $ (,,) - <$> ifMaybeM mbTid True existsKey - <*> ifMaybeM mbSsh True existsKey - <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) + <$> ifNothingM mbTid True existsKey + <*> ifNothingM mbSsh True existsKey + <*> ifNothingM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh diff --git a/src/Jobs/Handler/Invitation.hs b/src/Jobs/Handler/Invitation.hs index 4e6afeb67..ad6cb7dc9 100644 --- a/src/Jobs/Handler/Invitation.hs +++ b/src/Jobs/Handler/Invitation.hs @@ -21,7 +21,7 @@ dispatchJobInvitation :: Maybe UserId -> Html -> JobHandler UniWorX dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = JobHandlerException $ do - (mInviter, mInviterAddress) <- ifMaybeM jInviter (Nothing,Nothing) $ \uid -> runDB $ do + (mInviter, mInviterAddress) <- ifNothingM jInviter (Nothing,Nothing) $ \uid -> runDB $ do usrEnt <- getEntity uid usrAdr <- join <$> traverse getEmailAddress usrEnt return (usrEnt ^? _Just . _entityVal, usrAdr) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index df8c2a193..b2440e73e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -92,7 +92,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act } _ -> return () -- send second reminders first, before enqueing even more - ifMaybeM (qualificationRefreshReminder quali) () sendReminders + ifNothingM (qualificationRefreshReminder quali) () sendReminders renewalUsers <- E.select $ do quser <- E.from $ E.table @QualificationUser diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 1a937221f..5d3d73c99 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -5,10 +5,8 @@ module Jobs.Handler.SynchroniseAvs ( dispatchJobSynchroniseAvs , dispatchJobSynchroniseAvsId - , dispatchJobSynchroniseAvsUser - , dispatchJobSynchroniseAvsNext -- internal only - , dispatchJobSynchroniseAvsQueue -- internal only - , dispatchJobSynchroniseAvsQueue' -- internal only TODO replace unprimed + , dispatchJobSynchroniseAvsUser + , dispatchJobSynchroniseAvsQueue -- internal only ) where import Import @@ -48,26 +46,18 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause guard $ userIteration == currentIteration return $ AvsSync userId now pause --- dispatchJobSynchroniseAvs' :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX --- dispatchJobSynchroniseAvs' numIterations epoch iteration pause = JobHandlerAtomic $ do - - dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do - ok <- runDB $ getBy (UniqueUserAvsId apid) >>= - \case - (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> do -- known user - workJobSychronizeAvs uid pause - return True - _ -> -- unknown avsPersonId, attempt to create user - return False - unless ok $ void $ maybeCatchAll $ Just <$> upsertAvsUserById apid -- TOOD: needs thorough refactoring - + usrAvs <- runDB $ getBy (UniqueUserAvsId apid) + ifNothingM usrAvs insertUnknown processKnown + where + processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause + insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX -dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDB $ workJobSychronizeAvs uid pause +dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause -workJobSychronizeAvs :: UserId -> Maybe Day -> DB () +workJobSychronizeAvs :: UserId -> Maybe Day -> Handler () workJobSychronizeAvs uid pause = do now <- liftIO getCurrentTime -- void $ E.upsert @@ -76,45 +66,16 @@ workJobSychronizeAvs uid pause = do -- , avsSyncPause = pause -- } -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308 - maybeM + runDB $ maybeM (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause}) (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) (getBy $ UniqueAvsSyncUser uid) - queueJob' JobSynchroniseAvsQueue + queueJob JobSynchroniseAvsQueue + dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX dispatchJobSynchroniseAvsQueue = JobHandlerException $ do - syncJob <- runDB $ - selectFirst [] [Asc AvsSyncCreationTime] >>= \case - Nothing -> return Nothing -- nothing more to do - Just Entity{entityKey=asid, entityVal=AvsSync{..}} -> do - delete asid - getBy (UniqueUserAvsUser avsSyncUser) >>= \case - Just uae@Entity{entityVal=UserAvs{userAvsLastSynch=_} } - -- | maybe True (utctDay userAvsLastSynch <) avsSyncPause -- TODO: we ignore pauses for now - -> return $ Just uae - _other -> return Nothing -- we just updated this one within the given limit or the entity does not exist - - ifMaybeM syncJob () $ \Entity{entityKey=avsKey, entityVal=UserAvs{userAvsPersonId=apid}} -> do - void $ queueJob JobSynchroniseAvsNext - catch (void $ upsertAvsUserById apid) -- already updates UserAvsLastSynch - (\exc -> do - now <- liftIO getCurrentTime - runDB (update avsKey [UserAvsLastSynchError =. Just (tshow exc), UserAvsLastSynch =. now]) - case exc of - AvsInterfaceUnavailable -> return () -- ignore and retry later -- TODO won't be retried, since individual job had been deleted - 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 -dispatchJobSynchroniseAvsNext = JobHandlerException $ void $ queueJob JobSynchroniseAvsQueue - - -dispatchJobSynchroniseAvsQueue' :: JobHandler UniWorX -dispatchJobSynchroniseAvsQueue' = JobHandlerException $ do (unlinked,linked) <- runDB $ do jobs <- E.select (do (avsSync :& usrAvs) <- E.from $ E.table @AvsSync diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 69ad6b4d6..3332aae69 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -108,8 +108,7 @@ data Job | JobSynchroniseAvsId { jAvsId :: AvsPersonId , jSynchAfter :: Maybe Day } - | JobSynchroniseAvsQueue - | JobSynchroniseAvsNext + | JobSynchroniseAvsQueue | JobChangeUserDisplayEmail { jUser :: UserId , jDisplayEmail :: UserEmail } @@ -353,8 +352,7 @@ jobNoQueueSame = \case JobSynchroniseAvs{} -> Just JobNoQueueSame JobSynchroniseAvsUser{} -> Just JobNoQueueSame JobSynchroniseAvsId{} -> Just JobNoQueueSame - JobSynchroniseAvsQueue{} -> Just JobNoQueueSame - JobSynchroniseAvsNext{} -> Just JobNoQueueSame + JobSynchroniseAvsQueue{} -> Just JobNoQueueSame JobChangeUserDisplayEmail{} -> Just JobNoQueueSame JobPruneSessionFiles{} -> Just JobNoQueueSameTag JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag diff --git a/src/Utils.hs b/src/Utils.hs index 8d42aa073..1344a6455 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -935,10 +935,10 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () --- ifMaybeM m d a = maybe (return d) a m -ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM -ifMaybeM Nothing dft _ = return dft -ifMaybeM (Just x) _ act = act x +-- ifNothingM m d a = maybe (return d) a m +ifNothingM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM +ifNothingM Nothing dft _ = return dft +ifNothingM (Just x) _ act = act x maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if maybePositive a | a > 0 = Just a diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index e52eb7670..6f3f19f0a 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -261,7 +261,7 @@ printLetter' pji pdf = do -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing - qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + qshort <- ifNothingM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get let logInter = flip (logInterface "Printer" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do @@ -279,7 +279,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." where reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do - qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get + qshort <- ifNothingM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get let logInter = flip (logInterface "Printer" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile case result of