fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(avs): rewrite AVS synch (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2024-04-25 09:55:40 +02:00
parent 64a123387f
commit fea749f367
8 changed files with 27 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Handler/Admin/Avs.hs
View File

@ -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

6
src/Handler/Course/Edit.hs
View File

@ -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

2
src/Jobs/Handler/Invitation.hs
View File

@ -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)

2
src/Jobs/Handler/LMS.hs
View File

@ -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

63
src/Jobs/Handler/SynchroniseAvs.hs
View File

@ -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

6
src/Jobs/Types.hs
View File

@ -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

8
src/Utils.hs
View File

@ -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

4
src/Utils/Print.hs
View File

@ -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