-- SPDX-FileCopyrightText: 2022 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 Auth.LDAP (ldapUserPrincipalName) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) 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.dispatchJobSynchroniseLdap -} {- 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 nowaday = utctDay now 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.&&. (nowaday `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}] -> return $ Just uid _ -> return 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 $ ldapLookupAndUpsert someid) >>= \case Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)) 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) -- | 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 $ ldapLookupAndUpsert otherId) >>= \case Right 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 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) (_:_) -> throwM $ AvsUserAmbiguous api [] -> do upsRes :: Either SomeException (Entity User) <- try $ ldapLookupAndUpsert persNo $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes case upsRes of Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo -- pin/addr are updated in next step anyway Left err -> do $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err return mbuid -- == Nothing -- user could not be created somehow _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 , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known } mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do now <- liftIO getCurrentTime insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo 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 now <- liftIO getCurrentTime 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 <-. Nothing:oldPins] [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))