refactor(avs): complete rewrite AVS synch

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

View File

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

View File

@ -680,8 +680,12 @@ getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do
uid <- decrypt uuid
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
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson

View File

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

View File

@ -16,6 +16,7 @@ module Handler.Utils.Avs
, upsertAvsUserById
, updateAvsUserByIds
, linktoAvsUserByUIDs
, queueAvsUpdateByUID, queueAvsUpdateByAID
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..)
, setLicence, setLicenceAvs, setLicencesAvs
@ -47,6 +48,8 @@ import qualified Control.Monad.Catch as Catch
-- import Auth.LDAP (ldapUserPrincipalName)
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
import Jobs.Queue
import Utils.Avs
import Utils.Mail (pickValidEmail)
import Utils.Users
@ -314,13 +317,6 @@ updateRecord ent new (CheckAvsUpdate up l) =
let newval = new ^. l
lensRec = fieldLensVal up
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
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
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)) ???
-- | 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 api = do
createAvsUserById :: Maybe UserId -> AvsPersonId -> Handler UserId
createAvsUserById muid api = do
AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
case Set.toList contactRes of
[] -> throwM $ AvsUserUnknownByAvs api
@ -469,10 +494,12 @@ createAvsUserById api = do
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDB $ do
mbUid <- firstJustM $ catMaybes
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
, persMail <&> guessUserByEmail
]
mbUid <- if isJust muid
then return muid
else firstJustM $ catMaybes
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
, persMail <&> guessUserByEmail
]
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
return (mbUid, mbUAvs)
usrCardNo <- queryAvsFullCardNo api
@ -488,14 +515,20 @@ createAvsUserById api = do
, userAvsLastCardNo = usrCardNo
}
case oldUsr of
(_ , Just Entity{entityVal=UserAvs{userAvsPersonId=api'}})
| api /= api' -> throwM $ AvsIdMismatch api api'
| otherwise -> throwM $ AvsUserUnknownByAvs api
(Nothing , Just _) -> throwM $ AvsUserUnknownByAvs api -- this case should never occur
(Just uid, Just Entity{entityVal=UserAvs{userAvsPersonId=api',userAvsUser=uid'}})
| 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
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
maybe (throwM $ AvsUserUnknownByAvs api) return updRes
(Nothing, Nothing) -> do
case updRes of
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
let pinPass = avsFullCardNo2pin <$> usrCardNo
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;
@ -612,10 +662,11 @@ guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
other -> return other
guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible
catchAVS2message (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
Nothing -> Just uid
other -> other
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> do -- ensure internal user is linked to avs, if possible
let ldapUid = Just uid
avsUid <- catchAVS2message $ upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo
unless (ldapUid == avsUid) $ addMessageI Warning MsgAvsPersonSearchAmbiguous
return ldapUid
Right Entity{entityKey=uid} -> return $ Just uid
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
@ -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!
AvsResponsePerson adps <- avsQuery qry
case Set.elems adps of
[] -> return Nothing
[] -> return Nothing -- throwM AvsPersonSearchEmpty -- since return a Maybe, there is no need to throw here
(_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update
@ -647,7 +698,7 @@ upsertAvsUserById :: AvsPersonId -> Handler UserId
upsertAvsUserById api = do
upd <- runDB (updateAvsUserById api)
case upd of
Nothing -> createAvsUserById api
Nothing -> createAvsUserById Nothing api -- attempts to link to exisiting user vie UserCompanyPersonalNumber
(Just uid) -> return uid
-- 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
batch1_ok = Set.size ok
forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
$logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
-- TODO: Admin Error page
$logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
aux (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
{- NOT USED ANYWHERE:

View File

@ -4,9 +4,9 @@
module Jobs.Handler.SynchroniseAvs
( dispatchJobSynchroniseAvs
, dispatchJobSynchroniseAvsId
, dispatchJobSynchroniseAvsUser
, dispatchJobSynchroniseAvsQueue -- internal only
-- , dispatchJobSynchroniseAvsId
-- , dispatchJobSynchroniseAvsUser
, dispatchJobSynchroniseAvsQueue
) where
import Import
@ -46,37 +46,61 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
guard $ userIteration == currentIteration
return $ AvsSync userId now pause
dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do
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
-- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
-- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
-- 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 $ workJobSychronizeAvs uid pause
-- dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX
-- dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause
workJobSychronizeAvs :: UserId -> Maybe Day -> Handler ()
workJobSychronizeAvs uid pause = do
now <- liftIO getCurrentTime
-- void $ E.upsert
-- AvsSync { avsSyncUser = uid
-- , avsSyncCreationTime = now
-- , 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
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
-- workJobSychronizeAvs :: UserId -> Maybe Day -> Handler ()
-- workJobSychronizeAvs uid pause = do
-- now <- liftIO getCurrentTime
-- -- void $ E.upsert
-- -- AvsSync { avsSyncUser = uid
-- -- , avsSyncCreationTime = now
-- -- , 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
-- 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)
-- 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 = JobHandlerException $ do
(unlinked,linked) <- runDB $ do
dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
jobs <- runDB $ do
jobs <- E.select (do
(avsSync :& usrAvs) <- E.from $ E.table @AvsSync
`E.leftJoin` E.table @UserAvs
@ -86,16 +110,16 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
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)
return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
)
let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
E.deleteWhere [AvsSyncId <-. syncIds]
return (unlinked, linked)
now <- liftIO getCurrentTime
E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
return jobs
let (unlinked, linked) = foldl' discernJob mempty jobs
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)
discernJob (accUid, accApi) ( _ , E.Value (Just api)) = ( accUid, Set.insert api accApi)
discernJob (accUid, accApi) (E.Value uid, E.Value Nothing ) = (Set.insert uid accUid, accApi)

View File

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