diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index af85b8a8e..f07476330 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 81e5b5f15..16f3d25eb 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 8ff0bd673..4cebd0026 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index f501a830e..3bfa3fce0 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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: diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 5d3d73c99..57e8dbdd0 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -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) \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 3332aae69..1c865a328 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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