diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index e999ea1af..644f47af6 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -588,40 +588,46 @@ mkUpdate usr npi opi (CheckAvsUpdate up la) mkUpdate _ _ _ _ = Nothing -updateAvsUserByIds :: Set AvsPersonId -> Handler (Set UserId) +updateAvsUserByIds :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) updateAvsUserByIds apids = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids - foldMapM procResp adcs + res <- foldMapM procResp adcs + let missing = Set.toList $ Set.difference apids $ Set.map fst res + unless (null missing) $ runDB $ do + now <- liftIO getCurrentTime + updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] + return res where - procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo) + procResp (AvsDataContact apid avsPersonInfo avsFirmInfo) | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) | otherwise = fmap maybeMonoid . runDB . runMaybeT $ do - (Entity _ usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid - oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs + (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid + oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! + -- oldAvsFirmInfo <- hoistMaybe $ userAvsLastFirmInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! let usrId = userAvsUser usravs usr <- MaybeT $ get usrId - let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) - [ CheckAvsUpdate UserFirstName _avsInfoFirstName - , CheckAvsUpdate UserSurname _avsInfoLastName - , CheckAvsUpdate UserDisplayName _avsInfoDisplayName - , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth - , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo - , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo - , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo - ] - lift $ update usrId ups - return $ Set.singleton usrId + now <- liftIO getCurrentTime + let usr_ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) + [ CheckAvsUpdate UserFirstName _avsInfoFirstName + , CheckAvsUpdate UserSurname _avsInfoLastName + , CheckAvsUpdate UserDisplayName _avsInfoDisplayName + , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth + , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo + , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` + , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo + , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + ] + -- frm_ups = mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo) + -- [ CheckAvsUpdate - -updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => AvsPersonId -> m (Maybe UserId) -updateAvsUserById apid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid - case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of - [] -> throwM AvsPersonSearchEmpty - (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do - return Nothing -- TODO + -- ] + avs_ups = [ UserAvsNoPerson =. api | Just api <- [readMay $ avsInfoPersonNo avsPersonInfo]] + <> [ UserAvsLastSynch =. now + , UserAvsLastSynchError =. Nothing + , UserAvsLastPersonInfo =. Just avsPersonInfo + , UserAvsLastFirmInfo =. Just avsFirmInfo + ] + lift $ update usrId usr_ups + lift $ update uaId avs_ups + return $ Set.singleton (apid, usrId) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 0b393f0e2..6829386aa 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -93,9 +93,8 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do void $ queueJob JobSynchroniseAvsNext catch (void $ upsertAvsUserById apid) -- already updates UserAvsLastSynch (\exc -> do - now <- liftIO getCurrentTime - let excMsg = tshow exc <> " at " <> tshow now - runDB (update avsKey [UserAvsLastSynchError =. Just excMsg, UserAvsLastSynch =. now]) + now <- liftIO getCurrentTime + runDB (update avsKey [UserAvsLastSynchError =. Just (tshow exc), UserAvsLastSynch =. now]) case exc of AvsInterfaceUnavailable -> return () -- ignore and retry later AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS