-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} -- Module for functions directly related to the AVS interface, -- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification module Handler.Utils.Avs ( guessAvsUser , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , AvsLicenceDifferences(..) , setLicence, setLicenceAvs, setLicencesAvs , retrieveDifferingLicences, retrieveDifferingLicencesStatus , computeDifferingLicences , synchAvsLicences , lookupAvsUser, lookupAvsUsers , AvsException(..) , updateReceivers , AvsPersonIdMapPersonCard ) where import Import -- import Handler.Utils -- import qualified Database.Esqueleto.Legacy as E import Utils.Avs import Utils.Users import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import Foundation.Yesod.Auth (userLookupAndUpsert) import Handler.Utils.Company import Handler.Utils.Qualification import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E -------------------- -- AVS Exceptions -- -------------------- data AvsException = AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond | AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet | AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS DB | AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found in our DB | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result | AvsSetLicencesFailed Text -- AvsSetLicence total failure deriving (Show, Eq, Ord, Generic) instance Exception AvsException {- Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException? -} ------------------ -- AVS Handlers -- ------------------ {- TODOs Connect AVS query to LDAP queries for automatic synchronisation: - add query to Auth.LDAP.campusUserMatr - add query to Auth.LDAP.campusLogin - jobs.Handler.dispatchJobSynchroniseUserdb -} {- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround -- Do we need this? -- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence) getLicence uid = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences return (avsLicenceRampLicence <$> ulicence) getLicenceDB :: UserId -> DB (Maybe AvsLicence) getLicenceDB uid = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences return (avsLicenceRampLicence <$> ulicence) -- | Should be avoided, since all licences must be requested at once. getLicenceByAvsId :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Set AvsPersonId -> m (Set AvsPersonLicence) getLicenceByAvsId aids = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery AvsResponseGetLicences licences <- throwLeftM avsQueryGetAllLicences return $ Set.filter (\x -> avsLicencePersonID x `Set.member` aids) licences -} -- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool setLicence :: (PersistUniqueRead backend, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BaseBackend backend ~ SqlBackend) => UserId -> AvsLicence -> ReaderT backend m Bool setLicence uid lic = do Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid setLicenceAvs userAvsPersonId lic setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => AvsPersonId -> AvsLicence -> m Bool setLicenceAvs apid lic = do let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } (1 ==) <$> setLicencesAvs req --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => Set AvsPersonLicence -> m Int setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Html . tshow) return $ do AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery aux aqsl 0 persLics where aux aqsl batch0_ok pls | Set.null pls = return batch0_ok | otherwise = do let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1 case response of AvsResponseSetLicencesError{..} -> do let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage $logErrorS "AVS" msg throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus AvsResponseSetLicences msgs -> do let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs ok_ids = Set.map avsResponsePersonID ok 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 aux aqsl (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) -- | Retrieve all currently valid driving licences and check against our database -- Only react to changes as compared to last seen status in avs.model -- TODO: run in a background job, once the interface is actually available synchAvsLicences :: Handler Bool synchAvsLicences = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery allLicences <- throwLeftM avsQueryGetAllLicences deltaLicences <- computeDifferingLicences allLicences setResponse <- setLicencesAvs deltaLicences let setOk = setResponse == Set.size deltaLicences if setOk then $logInfoS "AVS" "FRADrive Licences written to AVS successfully." else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete." return setOk data AvsLicenceDifferences = AvsLicenceDifferences { avsLicenceDiffRevokeAll :: Set AvsPersonId -- revoke all driving licences in AVS (set 0) , avsLicenceDiffGrantVorfeld :: Set AvsPersonId -- grant apron driving licence in AVS (set 1, upgrade from 0) , avsLicenceDiffRevokeRollfeld :: Set AvsPersonId -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2) , avsLicenceDiffGrantRollfeld :: Set AvsPersonId -- grant maneuvering area driving licence (set 2) } deriving (Show) #ifdef DEVELOPMENT -- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build #else avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions [ avsLicenceDiffRevokeAll , avsLicenceDiffGrantVorfeld , avsLicenceDiffRevokeRollfeld , avsLicenceDiffGrantRollfeld ] #endif avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = Set.map (AvsPersonLicence AvsNoLicence) avsLicenceDiffRevokeAll <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffGrantVorfeld <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffRevokeRollfeld <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard) avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status] retrieveDifferingLicences :: Handler AvsLicenceDifferences retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) retrieveDifferingLicencesStatus = retrieveDifferingLicences' True retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) retrieveDifferingLicences' getStatus = do #ifdef DEVELOPMENT avsUsrs <- runDB $ selectList [] [LimitTo 444] let allLicences = AvsResponseGetLicences $ Set.fromList $ [ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2 , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1 , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts) , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig) -- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1 ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] #else AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery allLicences <- throwLeftM avsQueryGetAllLicences #endif lDiff <- getDifferingLicences allLicences #ifdef DEVELOPMENT let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5" lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error fakes = Set.fromList $ [ AvsStatusPerson (AvsPersonId 77 ) $ Set.singleton $ mkAdpc True AvsCardColorGelb , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"] , AvsStatusPerson (AvsPersonId 5 ) $ Set.fromList [mkAdpc True AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"] , AvsStatusPerson (AvsPersonId 2 ) $ Set.singleton $ mkAdpc True AvsCardColorGrün ] <> [ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ] #else let statQry = avsLicenceDifferences2LicenceIds lDiff lStat <- if getStatus && notNull statQry then -- throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry -- don't throw up here, licence differences are too important! TODO: Warn in Problem-Handler avsQueryStatus (AvsQueryStatus statQry) >>= \case Left err -> do addMessage Error $ toHtml $ "avsQueryStatus failed for " <> tshow (length statQry) <> " requests with: \n" <> tshow err <> "\nREQUEST:\n" <> tshow statQry return $ AvsResponseStatus mempty Right res -> return res else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls #endif return (lDiff, avsResponseStatusMap lStat) getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences getDifferingLicences (AvsResponseGetLicences licences) = do now <- liftIO getCurrentTime --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' rollfeld = Set.map avsLicencePersonID rollfeld' antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId) antijoinAvsLicences lic avsLics = fmap unwrapIds $ E.select $ do ((_qauli :& _qualUser :& usrAvs) :& excl) <- E.from $ ( E.table @Qualification `E.innerJoin` E.table @QualificationUser `E.on` ( \(quali :& qualUser) -> (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence E.&&. (now `validQualification` qualUser) -- currently valid and not blocked ) `E.innerJoin` E.table @UserAvs `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) ) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join return (usrAvs E.?. UserAvsPersonId, excl) unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId) unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty where aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r) aux _ acc = acc -- should never occur ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,) <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld let setTo0 = vorfRevoke -- revoke driving licences setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence return AvsLicenceDifferences { avsLicenceDiffRevokeAll = setTo0 , avsLicenceDiffGrantVorfeld = setTo1up , avsLicenceDiffRevokeRollfeld = setTo1down , avsLicenceDiffGrantRollfeld = setTo2 } {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query C (0,1,0) -> ((x,_),(_,_)) : set F for id D (0,1,1) -> ((x,_),(x,_)) : set R for id E (1,0,0) -> ((_,x),(_,_)) : set 0 for id F (1,0,1) -> ((_,x),(x,_)) : set 0 for id G (1,1,0) -> ((_,_),(_,_)) : nop H (1,1,1) -> ((_,_),(x,_)) : set R for id I (2,0,0) -> ((_,x),(_,x)) : set 0 for id J (2,0,1) -> ((_,x),(_,_)) : set 0 for id K (2,1,0) -> ((_,_),(_,x)) : set F for id L (2,1,1) -> ((_,_),(_,_)) : nop PROBLEM: B & H in conflict! (Note that nop is automatic except for case B) Results: set to 0: determined by vorfeld-unset -- zuerst set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) -} -- | 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 guessAvsUser :: Text -> Handler (Maybe UserId) guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr -> let avsid = AvsPersonId avsidNr maybeAvsUpsert = maybeCatchAll $ upsertAvsUserById avsid extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid in maybeM maybeAvsUpsert extractUid $ runDB $ getBy $ UniqueUserAvsId avsid guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoTxt) Nothing $ \avsno -> runDB (selectList [UserAvsNoPerson ==. avsno] []) <&> \case [Entity _ UserAvs{userAvsUser=uid}] -> Just uid _ -> Nothing guessAvsUser someid = do let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard case discernAvsCardPersonalNo someid of Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid -- NOTE: card validity might be outdated, so we must always check with avs -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do -- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid -- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid -- cards <- selectList [UserAvsCardCardNo ==. cardNo] [] -- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of -- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard) -- _ -> return Nothing Just cid@(Right _wholeNumber) -> maybeUpsertAvsUserByCard cid >>= \case Nothing -> runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case [Entity uid _] -> return $ Just uid _ -> return Nothing uid -> return uid Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case Right (Just Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)) Right (Just Entity{entityKey=uid}) -> return $ Just uid other -> do -- attempt to recover by trying other ids whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external 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) -- | 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! upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case Right (Just Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) 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 apid <- runDB . runMaybeT $ do let someIdent = stripCI otherId uid <- MaybeT (getKeyBy $ UniqueEmail someIdent) <|> 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. upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! upsertAvsUserByCard persNo = do let qry = case persNo of Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry case Set.elems adps of [] -> throwM AvsPersonSearchEmpty (_:_:_) -> throwM AvsPersonSearchAmbiguous [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update -- do -- mbuid <- runDB $ getBy $ UniqueUserAvsId api -- case mbuid of -- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau -- Nothing -> upsertAvsUserById api -- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen). upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId) upsertAvsUserById api = do mbapd <- lookupAvsUser api now <- liftIO getCurrentTime mbuid <- runDB $ do mbuid <- getBy (UniqueUserAvsId api) case (mbuid, mbapd) of (Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] [] case candidates of [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing) (_:_) -> throwM $ AvsUserAmbiguous api [] -> do upsRes :: Either SomeException (Maybe (Entity User)) <- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes case upsRes of Right (Just Entity{entityKey=uid}) -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway Right Nothing -> do $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases" return mbuid -- == Nothing -- user could not be created somehow Left err -> do $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases: " <> tshow err return mbuid -- == Nothing -- user could not be created somehow (Just Entity{ entityKey = uaid }, _) -> do update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch return mbuid _other -> return mbuid $logInfoS "AVS" $ "upsert prestep result: " <> tshow mbuid <> " --- " <> tshow mbapd case (mbuid, mbapd) of ( _ , Nothing ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet (Nothing, Just AvsDataPerson{avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname, ..}) -> do -- No LDAP User, but found in AVS; create new user let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr pinCard = Set.lookupMax avsPersonPersonCards userPin = personCard2pin <$> pinCard fakeIdent = CI.mk $ "AVSID:" <> tshow api fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo newUsr = AddUserData { audTitle = Nothing , audFirstName = avsFirstName , audSurname = avsSurname , audDisplayName = avsFirstName <> Text.cons ' ' avsSurname , audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , audMatriculation = Just $ tshow avsPersonPersonNo , audSex = Nothing , audBirthday = Nothing , audMobile = Nothing , audTelephone = Nothing , audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo , audFDepartment = Nothing , audPostAddress = userFirmAddr , audPrefersPostal = True , audPinPassword = userPin , audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , audIdent = fakeIdent -- use AvsPersonId instead , audPassword = Nothing --, audAuth = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known } mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] -- forM_ cs $ -- only save used cards for the postal address update detection \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now upsertUserCompany uid mbCompany userFirmAddr return mbUid (Just (Entity _ UserAvs{userAvsUser=uid}) , Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonPersonNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards userFirmAddr = plaintextToStoredMarkup <$> mbCoFirmAddr pinCard = Set.lookupMax avsPersonPersonCards userPin = personCard2pin <$> pinCard runDB $ do update uid [ UserFirstName =. avsFirstName -- update in case of name changes via AVS; might be changed again through LDAP , UserSurname =. avsSurname , UserDisplayName =. avsFirstName <> Text.cons ' ' avsSurname , UserMatrikelnummer =. Just (tshow avsPersonPersonNo) -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo ] oldCards <- selectList [UserAvsCardPersonId ==. api] [] let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before encRecipient :: CryptoUUIDUser <- encrypt uid $logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr, UserPostLastUpdate =. Just now] whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now upsertUserCompany uid mbCompany userFirmAddr forM_ avsPersonPersonCards $ \aCard -> do let fcn = getFullCardNo aCard -- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused deleteWhere [UserAvsCardCardNo ==. fcn] insert_ $ UserAvsCard { userAvsCardPersonId = api , userAvsCardCardNo = fcn , userAvsCardCard = aCard , userAvsCardLastSynch = now } return $ Just uid lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m (Maybe AvsDataPerson) lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) -- | retrieves complete avs user records for given AvsPersonIds. -- Note that this requires several AVS-API queries, since -- - avsQueryPerson does not support querying an AvsPersonId directly -- - avsQueryStatus only provides limited information -- avsQuery is used to obtain all card numbers, which are then queried separately an merged -- May throw Servant.ClientError or AvsExceptions -- Does not write to our own DB! lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) lookupAvsUsers apis = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis let forFoldlM = $(permuteFun [3,2,1]) foldlM forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} return $ mergeByPersonId adps acc2 -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) updateReceivers uid = do -- First perform AVS update for receiver runDB (getBy (UniqueUserAvsUser uid)) >>= \case Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid Nothing -> return () -- Retrieve updated user and supervisors now (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) <$> getJustEntity uid <*> (E.select $ do (usrSuper :& usrAvs) <- E.from $ E.table @UserSupervisor `E.leftJoin` E.table @UserAvs `E.on` (\(usrSuper :& userAvs) -> usrSuper E.^. UserSupervisorSupervisor E.=?. userAvs E.?. UserAvsUser) E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid) E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications) pure (usrSuper E.^. UserSupervisorSupervisor, usrAvs E.?. UserAvsPersonId) ) let (superVs, avsIds) = unzip avsSupers receiverIDs :: [UserId] = E.unValue <$> superVs toUpdate = Set.fromList $ mapMaybe E.unValue avsIds directResult = return (underling, pure underling, True) -- already contains updated address forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById) -- attempt to update postaddress from AVS if null receiverIDs then directResult else do receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above if null receivers then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers))