- #{r_grant} -
- #{f_set} -
- #{revoke} - |] - (Left e) -> do - let msg = tshow (e :: SomeException) - return $ Just [whamlet|
+ #{r_grant} +
+ #{f_set} +
+ #{revoke} + |] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|
- Vorläufige Admin Ansicht AVS Daten. - Ansicht zeigt aktuelle Daten. - Es erfolgte damit aber noch kein Update der FRADrive Daten. -
-
- Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. - In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. -
- ^{foldMap jsonWidget mbContact} -
- ^{foldMap jsonWidget mbDataPerson} - |] + mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId + mbDataPerson <- lookupAvsUser userAvsPersonId let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] siteLayout heading $ do setTitle $ toHtml $ show userAvsNoPerson - resWgt + [whamlet| +
+ Vorläufige Admin Ansicht AVS Daten. + Ansicht zeigt aktuelle Daten. + Es erfolgte damit aber noch kein Update der FRADrive Daten. +
+
+ Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. + In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. +
+ ^{foldMap jsonWidget mbContact} +
+ ^{foldMap jsonWidget mbDataPerson} + |] instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where hasEntity = _dbrOutput . _2 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index f1436cebe..aed4dda0a 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -12,7 +12,7 @@ module Handler.Utils.Avs ( guessAvsUser - , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard + , upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , AvsLicenceDifferences(..) , setLicence, setLicenceAvs, setLicencesAvs @@ -24,6 +24,7 @@ module Handler.Utils.Avs , updateReceivers , AvsPersonIdMapPersonCard -- CR3 + , SomeAvsQuery(..) , queryAvsCardNo, queryAvsCardNos ) where @@ -76,15 +77,22 @@ instance Exception AvsException {- Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException? --} + handleAvsExceptions = (`catches` handlers) + where + handlers = + [ Handler (\(e::AvsException -> handleAvsException e)) + , Handler (\(e::ClientError -> handleClientError e)) + ] +-} ------------------ -- AVS Handlers -- ------------------ +{- -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users --- If an existing User with internal number is found, an AVS query is executed +-- If an existing User with internal number is found, an AVS update query is executed guessAvsUser :: Text -> Handler (Maybe UserId) guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr -> let avsid = AvsPersonId avsidNr @@ -108,7 +116,7 @@ guessAvsUser someid = do -- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard) -- _ -> return Nothing Just cid@(Left _wholeNumber) -> - maybeUpsertAvsUserByCard cid >>= \case + maybeUpsertAvsUserByCard cid >>= \case Nothing -> runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case [Entity uid _] -> return $ Just uid @@ -124,7 +132,8 @@ guessAvsUser someid = do let someIdent = stripCI someid in MaybeT (getKeyBy $ UniqueEmail someIdent) <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) - +-} +{- -- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Address upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! @@ -139,7 +148,7 @@ upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid) ifMaybeM apid Nothing upsertAvsUserById - +-} -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. @@ -329,6 +338,14 @@ updateReceivers uid = do ------------------ -- CR3 Functions +-- +-- DONE Update UserCompany too +-- DONE #124 Add an old default supervisor to an Admin TODO-List +-- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen +-- TODO #36 "company postal preference", but for updates only yet +-- +-- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do + -- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API class SomeAvsQuery q where @@ -463,16 +480,16 @@ updateRecord dbv inp (CheckAvsUpdate up l) = in dbv & lensRec .~ newval --- | Update given AvsPersonId by querying AVS for each; update only, no insertion! +-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId)) updateAvsUserByIds apids = do - AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids + AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched! let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order) res <- foldMapM procResp requestedAnswers let missing = Set.toList $ Set.difference apids $ Set.map fst res unless (null missing) $ do now <- liftIO getCurrentTime - updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- TODO: last successfull synch + updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- all others were already marked as updated return res where procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do @@ -505,12 +522,6 @@ updateAvsUserByIds apids = do , UserAvsLastPersonInfo =. Just newAvsPersonInfo , UserAvsLastFirmInfo =. Just newAvsFirmInfo ] - -- - -- TODO: Update UserCompany too - -- DONE #124 Add an old default supervisor to an Admin TODO-List - -- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen - -- TODO #36 "company postal preference" - -- lift $ do -- maybeT no longer needed from here onwards -- update company association & supervision Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo @@ -519,10 +530,10 @@ updateAvsUserByIds apids = do let oldCompanyId = entityKey <$> oldCompanyEnt oldCompanyMb = entityVal <$> oldCompanyEnt pst_up = if - | isJust oldCompanyId && (oldCompanyId == primaryCompanyId) - -> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference | isNothing oldCompanyMb -> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line + -> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference | otherwise -> Nothing superReasonComDef = tshow SupervisorReasonCompanyDefault @@ -645,6 +656,44 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do ] + + +-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; +-- fail-safe, may or may not update existing users, may insert new users +-- If an existing User with internal number is found, an AVS update query is executed +guessAvsUser :: Text -> Handler (Maybe UserId) +guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr)) + | prefix=="AVSID:" = + let avsid = AvsPersonId nr in + runDB (getBy $ UniqueUserAvsId avsid) >>= \case + (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid + Nothing -> maybeCatchAll $ upsertAvsUserById avsid + | prefix=="AVSNO:" = + runDB (selectList [UserAvsNoPerson ==. nr] []) <&> \case + [ Entity{entityVal=UserAvs{userAvsUser=uid}}] -> Just uid + _ -> Nothing -- not existing or not unique +guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) = + maybeCatchAll $ upsertAvsUserByCard someavsid >>= \case + Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB + runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) <&> \case + [Entity{entityKey=uid}] -> Just uid + _ -> Nothing -- not existing or not unique + 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 + maybeCatchAll (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case + Nothing -> Just uid + other -> other + 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 + runDB . runMaybeT $ + let someIdent = stripCI someid + in MaybeT (getKeyBy $ UniqueEmail someIdent) + <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) + -- <|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey someIdent) + -- Licences setLicence :: (PersistUniqueRead backend, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 53dce7cb9..b8f3cfff6 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -819,15 +819,19 @@ fltrAVSCardNos queryUser = Map.singleton "avs-card" fch cs -> do let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout - maybeTimeoutHandler toutsecs (queryAvsCardNos crds) >>= \case + maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case Nothing -> addMessageI Error MsgAvsCommunicationTimeout >> return (const E.false) - (Just (null -> True)) -> return (const E.false) - (Just apids) -> return $ + (Just (Left err)) -> addMessage Error (someExc2Html err) + >> return (const E.false) + (Just (Right (null -> True))) -> return (const E.false) + (Just (Right apids)) -> return $ \(queryUser -> user) -> E.exists $ E.from $ \usrAvs -> E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids + someExc2Html :: SomeException -> Html + someExc2Html (SomeException e) = text2Html $ tshow e fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrAVSCardNosUI mPrev = diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 6829386aa..ff6ec6bbc 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -85,8 +85,9 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ 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 -> return $ Just uae + 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 @@ -96,7 +97,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do now <- liftIO getCurrentTime runDB (update avsKey [UserAvsLastSynchError =. Just (tshow exc), UserAvsLastSynch =. now]) case exc of - AvsInterfaceUnavailable -> return () -- ignore and retry later + 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 ) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index cb6e843ce..cfdda50fa 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -37,7 +37,7 @@ avsMaxSetLicenceAtOnce :: Int avsMaxSetLicenceAtOnce = 80 -- maximum input set size for avsQuerySetLicences as enforced by AVS avsMaxQueryAtOnce :: Int -avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus as enforced by AVS +avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS avsMaxQueryDelay :: Int avsMaxQueryDelay = 300000 -- microsecond to wait before sending another AVS query