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

refactor(avs): complete rewrite AVS synch

Browse Source 
Three former background jobs could be removed
This commit is contained in:
Steffen Jost 2024-04-25 15:11:37 +02:00
parent fea749f367
commit 6fd45f6896
6 changed files with 152 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Handler/Admin.hs
View File

@ -8,7 +8,6 @@ module Handler.Admin
import Import import Import
import Jobs
-- import Data.Either -- import Data.Either
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
@ -95,7 +94,7 @@ handleAdminProblems mbProblemTable = do
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
(Right AvsLicenceDifferences{..}) -> do (Right AvsLicenceDifferences{..}) -> do
let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday) queueAvsUpdateByAID problemIds $ Just nowaday
return $ Right return $ Right
( Set.size avsLicenceDiffRevokeAll ( Set.size avsLicenceDiffRevokeAll
, Set.size avsLicenceDiffGrantVorfeld , Set.size avsLicenceDiffGrantVorfeld

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

@ -680,8 +680,12 @@ getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do getAdminAvsUserR uuid = do
uid <- decrypt uuid uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId let set_apid = Set.singleton $ AvsObjPersonId userAvsPersonId
mbContact <- try $ avsQuery $ AvsQueryContact set_apid
-- mbStatus <- try $ avsQuery $ AvsQueryStatus set_apid
-- CONTINUE HERE
mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson setTitle $ toHtml $ show userAvsNoPerson

4
src/Handler/Users.hs
View File

@ -370,8 +370,8 @@ postUsersR = do
addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
redirectKeepGetParams UsersR redirectKeepGetParams UsersR
(UserAvsSyncData, userSet) -> do (UserAvsSyncData, userSet) -> do
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing queueAvsUpdateByUID userSet Nothing
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
redirectKeepGetParams UsersR redirectKeepGetParams UsersR
(UserHijack, Set.minView -> Just (uid, _)) -> (UserHijack, Set.minView -> Just (uid, _)) ->
hijackUser uid >>= sendResponse hijackUser uid >>= sendResponse

102
src/Handler/Utils/Avs.hs
View File

@ -16,6 +16,7 @@ module Handler.Utils.Avs
, upsertAvsUserById , upsertAvsUserById
, updateAvsUserByIds , updateAvsUserByIds
, linktoAvsUserByUIDs , linktoAvsUserByUIDs
, queueAvsUpdateByUID, queueAvsUpdateByAID
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..) , AvsLicenceDifferences(..)
, setLicence, setLicenceAvs, setLicencesAvs , setLicence, setLicenceAvs, setLicencesAvs
@ -47,6 +48,8 @@ import qualified Control.Monad.Catch as Catch
-- import Auth.LDAP (ldapUserPrincipalName) -- import Auth.LDAP (ldapUserPrincipalName)
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
import Jobs.Queue
import Utils.Avs import Utils.Avs
import Utils.Mail (pickValidEmail) import Utils.Mail (pickValidEmail)
import Utils.Users import Utils.Users
@ -314,13 +317,6 @@ updateRecord ent new (CheckAvsUpdate up l) =
let newval = new ^. l let newval = new ^. l
lensRec = fieldLensVal up lensRec = fieldLensVal up
in ent & lensRec .~ newval in ent & lensRec .~ newval
-- | shall not throw, updates exisitng and attempts to link users with yet unknown AVSIDs
linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs = error "TODO: Not yet implemented."
-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
@ -454,10 +450,39 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
update uaId avs_ups -- update stored avsinfo for future updates update uaId avs_ups -- update stored avsinfo for future updates
return (apid, usrId) return (apid, usrId)
linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs uids = do
ips <- runDB $ E.select $ do
usr <- E.from $ E.table @User
let uid = usr E.^. UserId
ipn = usr E.^. UserCompanyPersonalNumber
E.where_ $ E.isJust ipn
E.&&. uid `E.in_` E.vals uids
E.&&. E.notExists (do
usrAvs <- E.from $ E.table @UserAvs
E.where_ $ uid E.==. usrAvs E.^. UserAvsUser
)
return (uid, ipn)
mapM_ procUsr ips
where
procUsr (E.Value uid, E.Value (Just ipn)) = void $ maybeCatchAll $ fmap Just $ linktoAvsUserByUID uid $ mkAvsInternalPersonalNo ipn
procUsr _ = return ()
-- | similar to 'upsertAvsUserByCard', but accounts for the known UserId
linktoAvsUserByUID :: UserId -> AvsInternalPersonalNo -> Handler ()
linktoAvsUserByUID uid aipn = do
AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryInternalPersonalNo = Just aipn}
case Set.elems adps of
[] -> throwM AvsPersonSearchEmpty
(_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataPerson{avsPersonPersonID=api}] ->
void $ createAvsUserById (Just uid) api
-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ??? -- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints -- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
createAvsUserById :: AvsPersonId -> Handler UserId createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId
createAvsUserById api = do createAvsUserById muid api = do
AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
case Set.toList contactRes of case Set.toList contactRes of
[] -> throwM $ AvsUserUnknownByAvs api [] -> throwM $ AvsUserUnknownByAvs api
@ -469,10 +494,12 @@ createAvsUserById api = do
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDB $ do oldUsr <- runDB $ do
mbUid <- firstJustM $ catMaybes mbUid <- if isJust muid
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing then return muid
, persMail <&> guessUserByEmail else firstJustM $ catMaybes
] [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
, persMail <&> guessUserByEmail
]
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
return (mbUid, mbUAvs) return (mbUid, mbUAvs)
usrCardNo <- queryAvsFullCardNo api usrCardNo <- queryAvsFullCardNo api
@ -488,14 +515,20 @@ createAvsUserById api = do
, userAvsLastCardNo = usrCardNo , userAvsLastCardNo = usrCardNo
} }
case oldUsr of case oldUsr of
(_ , Just Entity{entityVal=UserAvs{userAvsPersonId=api'}}) (Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur
| api /= api' -> throwM $ AvsIdMismatch api api' (Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}})
| otherwise -> throwM $ AvsUserUnknownByAvs api | api /= api' -> throwM $ AvsIdMismatch api api'
| uid /= uid' -> throwM $ AvsUserAmbiguous api
| otherwise -> return uid -- nothing to do
(Just uid, Nothing) -> runDB $ do -- link with matching exisitng user (Just uid, Nothing) -> runDB $ do -- link with matching exisitng user
insert_ $ usrAvs uid Nothing -- company info should cause the user to be associated with the company during the update insert_ $ usrAvs uid Nothing -- company info should cause the user to be associated with the company during the update
updRes <- updateAvsUserById api -- no loop, since updateAvsUserById does not call createAvsUserById updRes <- updateAvsUserById api -- no loop, since updateAvsUserById does not call createAvsUserById
maybe (throwM $ AvsUserUnknownByAvs api) return updRes case updRes of
(Nothing, Nothing) -> do Nothing -> throwM $ AvsUserUnknownByAvs api
Just uid'
| uid /= uid' -> throwM $ AvsUserAmbiguous api
| otherwise -> return uid
(Nothing, Nothing) -> do -- create fresh user
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
let pinPass = avsFullCardNo2pin <$> usrCardNo let pinPass = avsFullCardNo2pin <$> usrCardNo
newUserData = AddUserData newUserData = AddUserData
@ -591,6 +624,23 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
] ]
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler ()
queueAvsUpdateByUID uids pause = do
now <- liftIO getCurrentTime
runDB $ putMany [AvsSync uid now pause | uid <- toList uids]
queueJob' JobSynchroniseAvsQueue
queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> Handler ()
queueAvsUpdateByAID aids pause = do
now <- liftIO getCurrentTime
runDB $ do
uids <- E.select $ do
usrAvs <- E.from $ E.table @UserAvs
E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids
-- E.&&. (E.isNothing pause E.||. pause E.>. E.dayMaybe (usrAvs E.?. UserAvsLastSynch)) -- pause is checked later on in JobSynchroniseAvsQueue
return $ usrAvs E.^. UserAvsUser
putMany [AvsSync uid now pause | E.Value uid <- uids]
queueJob' JobSynchroniseAvsQueue
-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo;
@ -612,10 +662,11 @@ guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
other -> return other other -> return other
guessAvsUser someid = do guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case try (runDB $ ldapLookupAndUpsert someid) >>= \case
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible
catchAVS2message (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case let ldapUid = Just uid
Nothing -> Just uid avsUid <- catchAVS2message $ upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo
other -> other unless (ldapUid == avsUid) $ addMessageI Warning MsgAvsPersonSearchAmbiguous
return ldapUid
Right Entity{entityKey=uid} -> return $ Just uid Right Entity{entityKey=uid} -> return $ Just uid
other -> do -- attempt to recover by trying other ids other -> do -- attempt to recover by trying other ids
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
@ -636,7 +687,7 @@ upsertAvsUserByCard persNo = do
-- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB! -- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
AvsResponsePerson adps <- avsQuery qry AvsResponsePerson adps <- avsQuery qry
case Set.elems adps of case Set.elems adps of
[] -> return Nothing [] -> return Nothing -- throwM AvsPersonSearchEmpty -- since return a Maybe, there is no need to throw here
(_:_:_) -> throwM AvsPersonSearchAmbiguous (_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update [AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update
@ -647,7 +698,7 @@ upsertAvsUserById :: AvsPersonId -> Handler UserId
upsertAvsUserById api = do upsertAvsUserById api = do
upd <- runDB (updateAvsUserById api) upd <- runDB (updateAvsUserById api)
case upd of case upd of
Nothing -> createAvsUserById api Nothing -> createAvsUserById Nothing api -- attempts to link to exisiting user vie UserCompanyPersonalNumber
(Just uid) -> return uid (Just uid) -> return uid
-- Licences -- Licences
@ -691,8 +742,7 @@ setLicencesAvs = aux 0
bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
batch1_ok = Set.size ok batch1_ok = Set.size ok
forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
$logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
-- TODO: Admin Error page
aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
{- NOT USED ANYWHERE: {- NOT USED ANYWHERE:

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

@ -4,9 +4,9 @@
module Jobs.Handler.SynchroniseAvs module Jobs.Handler.SynchroniseAvs
( dispatchJobSynchroniseAvs ( dispatchJobSynchroniseAvs
, dispatchJobSynchroniseAvsId -- , dispatchJobSynchroniseAvsId
, dispatchJobSynchroniseAvsUser -- , dispatchJobSynchroniseAvsUser
, dispatchJobSynchroniseAvsQueue -- internal only , dispatchJobSynchroniseAvsQueue
) where ) where
import Import import Import
@ -46,37 +46,61 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
guard $ userIteration == currentIteration guard $ userIteration == currentIteration
return $ AvsSync userId now pause return $ AvsSync userId now pause
dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX -- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do -- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
usrAvs <- runDB $ getBy (UniqueUserAvsId apid) -- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
ifNothingM usrAvs insertUnknown processKnown -- where
where -- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause
processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause -- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX -- dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX
dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause -- dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause
workJobSychronizeAvs :: UserId -> Maybe Day -> Handler () -- workJobSychronizeAvs :: UserId -> Maybe Day -> Handler ()
workJobSychronizeAvs uid pause = do -- workJobSychronizeAvs uid pause = do
now <- liftIO getCurrentTime -- now <- liftIO getCurrentTime
-- void $ E.upsert -- -- void $ E.upsert
-- AvsSync { avsSyncUser = uid -- -- AvsSync { avsSyncUser = uid
-- , avsSyncCreationTime = now -- -- , avsSyncCreationTime = now
-- , avsSyncPause = pause -- -- , 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 -- -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308
runDB $ maybeM -- runDB $ maybeM
(insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause}) -- (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause})
(\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> -- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} ->
update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) -- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now])
(getBy $ UniqueAvsSyncUser uid) -- (getBy $ UniqueAvsSyncUser uid)
queueJob JobSynchroniseAvsQueue -- void $ queueJob JobSynchroniseAvsQueue
-- dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
-- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
-- (unlinked,linked) <- runDB $ do
-- jobs <- E.select (do
-- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
-- `E.leftJoin` E.table @UserAvs
-- `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
-- let pause = avsSync E.^. AvsSyncPause
-- lastSync = usrAvs E.?. UserAvsLastSynch
-- E.where_ $ E.isNothing pause
-- E.||. E.isNothing lastSync
-- E.||. pause E.>. E.dayMaybe lastSync
-- return (avsSync E.^. AvsSyncId, avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
-- )
-- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
-- E.deleteWhere [AvsSyncId <-. syncIds]
-- return (unlinked, linked)
-- void $ updateAvsUserByIds linked
-- void $ linktoAvsUserByUIDs unlinked
-- -- we do not reschedule failed synchs here in order to avoid a loop
-- where
-- discernJob (accSync, accUid, accApi) (E.Value k, _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi)
-- discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi)
dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
dispatchJobSynchroniseAvsQueue = JobHandlerException $ do dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
(unlinked,linked) <- runDB $ do jobs <- runDB $ do
jobs <- E.select (do jobs <- E.select (do
(avsSync :& usrAvs) <- E.from $ E.table @AvsSync (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
`E.leftJoin` E.table @UserAvs `E.leftJoin` E.table @UserAvs
@ -86,16 +110,16 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
E.where_ $ E.isNothing pause E.where_ $ E.isNothing pause
E.||. E.isNothing lastSync E.||. E.isNothing lastSync
E.||. pause E.>. E.dayMaybe lastSync E.||. pause E.>. E.dayMaybe lastSync
return (avsSync E.^. AvsSyncId, avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId) return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
) )
let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs now <- liftIO getCurrentTime
E.deleteWhere [AvsSyncId <-. syncIds] E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
return (unlinked, linked) return jobs
let (unlinked, linked) = foldl' discernJob mempty jobs
void $ updateAvsUserByIds linked void $ updateAvsUserByIds linked
void $ linktoAvsUserByUIDs unlinked void $ linktoAvsUserByUIDs unlinked
-- we do not reschedule failed synchs here in order to avoid a loop -- we do not reschedule failed synchs here in order to avoid a loop
where where
discernJob (accSync, accUid, accApi) (E.Value k, _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi) discernJob (accUid, accApi) ( _ , E.Value (Just api)) = ( accUid, Set.insert api accApi)
discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi) discernJob (accUid, accApi) (E.Value uid, E.Value Nothing ) = (Set.insert uid accUid, accApi)

16
src/Jobs/Types.hs
View File

@ -102,12 +102,12 @@ data Job
, jIteration :: Natural , jIteration :: Natural
, jSynchAfter :: Maybe Day , jSynchAfter :: Maybe Day
} }
| JobSynchroniseAvsUser { jUser :: UserId -- | JobSynchroniseAvsUser { jUser :: UserId
, jSynchAfter :: Maybe Day -- , jSynchAfter :: Maybe Day
} -- }
| JobSynchroniseAvsId { jAvsId :: AvsPersonId -- | JobSynchroniseAvsId { jAvsId :: AvsPersonId
, jSynchAfter :: Maybe Day -- , jSynchAfter :: Maybe Day
} -- }
| JobSynchroniseAvsQueue | JobSynchroniseAvsQueue
| JobChangeUserDisplayEmail { jUser :: UserId | JobChangeUserDisplayEmail { jUser :: UserId
, jDisplayEmail :: UserEmail , jDisplayEmail :: UserEmail
@ -350,8 +350,8 @@ jobNoQueueSame = \case
JobSynchroniseLdap{} -> Just JobNoQueueSame JobSynchroniseLdap{} -> Just JobNoQueueSame
JobSynchroniseLdapUser{} -> Just JobNoQueueSame JobSynchroniseLdapUser{} -> Just JobNoQueueSame
JobSynchroniseAvs{} -> Just JobNoQueueSame JobSynchroniseAvs{} -> Just JobNoQueueSame
JobSynchroniseAvsUser{} -> Just JobNoQueueSame -- JobSynchroniseAvsUser{} -> Just JobNoQueueSame
JobSynchroniseAvsId{} -> Just JobNoQueueSame -- JobSynchroniseAvsId{} -> Just JobNoQueueSame
JobSynchroniseAvsQueue{} -> Just JobNoQueueSame JobSynchroniseAvsQueue{} -> Just JobNoQueueSame
JobChangeUserDisplayEmail{} -> Just JobNoQueueSame JobChangeUserDisplayEmail{} -> Just JobNoQueueSame
JobPruneSessionFiles{} -> Just JobNoQueueSameTag JobPruneSessionFiles{} -> Just JobNoQueueSameTag