diff --git a/models/avs.model b/models/avs.model index 4871d7615..47d3f48b3 100644 --- a/models/avs.model +++ b/models/avs.model @@ -26,17 +26,6 @@ UserAvs UniqueUserAvsId personId deriving Generic Show --- Multiple UserAvsCards per UserAvs is possible and not too uncommon. --- Purpose of saving cards is to detect external changes in qualifications and postal addresses --- TODO: This table will be deleted if AVS CR3 SCF-165 is implemented -UserAvsCard - personId AvsPersonId - cardNo AvsFullCardNo - card AvsDataPersonCard - lastSynch UTCTime - -- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons - deriving Generic - AvsSync user UserId -- Note: we need to lookup UserAvs Entity anyway, so no benefit from storing AvsPersonId here creationTime UTCTime diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index b0020140a..642e1a15b 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -37,7 +37,7 @@ import Import 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 qualified Data.CaseInsensitive as CI import qualified Control.Monad.Catch as Catch @@ -105,194 +105,6 @@ catchAVS2message act = act `catches` handlers -- 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 update 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@(Right _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@(Left _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 (Left $ 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 (Left $ 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 AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! -upsertAvsUserByCard persNo = do - let qry = case persNo of - Right AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } - Left 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 Nothing Nothing Nothing) -- TODO info - (_:_) -> 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 now Nothing Nothing Nothing Nothing -- pin/addr are updated in next step anyway -- TODO info - 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 - (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 - , 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 - insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing Nothing Nothing Nothing -- TODO info - 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 - oldUpsertUserCompany 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 -- TODO: get rid of getCompanyAddress - 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 - oldUpsertUserCompany 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 - -- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored! lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => @@ -322,7 +134,7 @@ 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 + Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ Just <$> upsertAvsUserById apid Nothing -> return () -- Retrieve updated user and supervisors now (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,) @@ -339,8 +151,8 @@ updateReceivers uid = do 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 + directResult = return (underling, pure underling, True) -- already contains updated address + forM_ toUpdate (void . maybeCatchAll . fmap Just . upsertAvsUserById) -- attempt to update postaddress from AVS if null receiverIDs then directResult else do @@ -357,10 +169,10 @@ updateReceivers uid = do -- 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 +-- DONE #36 "company postal preference", but for updates only yet -- -- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do --- TODO: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables +-- DONE: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables -- | `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 @@ -763,7 +575,7 @@ guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr)) let avsid = AvsPersonId nr in runDB (getBy $ UniqueUserAvsId avsid) >>= \case (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid - Nothing -> catchAVS2message $ upsertAvsUserById avsid + Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid | prefix=="AVSNO:" = runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr]) guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) = @@ -797,15 +609,15 @@ 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 - [] -> throwM AvsPersonSearchEmpty + [] -> return Nothing (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always triggers an update + [AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update -- | 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 new user would violate uniqueness constraints -upsertAvsUserById0 :: AvsPersonId -> Handler UserId -upsertAvsUserById0 api = do +upsertAvsUserById :: AvsPersonId -> Handler UserId +upsertAvsUserById api = do upd <- runDB (updateAvsUserByIds $ Set.singleton api) case Set.toList upd of [] -> createAvsUserById api diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 20056248a..1c13fd5fd 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -8,11 +8,10 @@ import Import -- import Utils.PathPiece -- import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import qualified Data.Char as Char -import qualified Data.Text as Text - -import Database.Persist.Postgresql +-- import qualified Data.CaseInsensitive as CI +-- import qualified Data.Char as Char +-- import qualified Data.Text as Text +-- import Database.Persist.Postgresql -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma @@ -45,52 +44,3 @@ addCompanySupervisors cid uid = ] ) - - - -------------------- --- DEPRECATED - - --- | Ensure that the given user is linked to the given company -oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking -oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do - cid <- oldUpsertCompany cName cAddr - void $ insertUnique $ UserCompany uid cid False False 1 False - superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] - upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing - | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs - ] [] [] [] -oldUpsertUserCompany uid _ _ = - deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors? - --- | Does not update company address for now --- TODO: update company address, maybe?! -oldUpsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId -oldUpsertCompany cName cAddr = - let cName' = CI.mk cName in - getBy (UniqueCompanyName cName') >>= \case - Just ent -> return $ entityKey ent - Nothing -> getBy (UniqueCompanySynonym cName') >>= \case - Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent - Nothing -> do - let cShort = oldCompanyShorthandFromName cName - cShort' <- findShort cName' $ CI.mk cShort - let compy = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented - either entityKey id <$> insertBy compy - where - findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand - findShort fna fsh = aux 0 - where - aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in - checkUnique (Company fna fsh' 0 False Nothing Nothing) >>= \case - Nothing -> return fsh' - _other -> aux (n+1) - --- | Just a cheap heuristic, needs manual intervention anyway -oldCompanyShorthandFromName :: Text -> Text -oldCompanyShorthandFromName cName = - let cpats = splitCamel cName - strip = Text.filter Char.isAlphaNum . Text.take 3 - spats = strip <$> cpats - in Text.concat spats diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index ff6ec6bbc..2a2f2a31d 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -55,7 +55,7 @@ dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do return True _ -> -- unknown avsPersonId, attempt to create user return False - unless ok $ void $ maybeCatchAll $ upsertAvsUserById apid + unless ok $ void $ maybeCatchAll $ Just <$> upsertAvsUserById apid -- TOOD: needs thorough refactoring dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX