From 734eb8927ed51769a80a386076ad9e142ad0d23b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 17 Nov 2022 12:55:58 +0100 Subject: [PATCH] chore(avs): adjust to newly refined VSM specifications (DONE) --- src/Handler/Utils/Avs.hs | 85 +++++++++++++++++++++------------------- src/Model/Types/Avs.hs | 16 ++++---- 2 files changed, 53 insertions(+), 48 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 36375783b..3f89cc8c8 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -7,7 +7,7 @@ module Handler.Utils.Avs , getLicence, getLicenceDB , setLicence, setLicenceAvs, setLicencesAvs , checkLicences - , lookupAvsUser, lookupAvsUsers + , lookupAvsUser, lookupAvsUsers ) where import Import @@ -32,13 +32,13 @@ import Handler.Users.Add -------------------- 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 -- AvsPersionId not (or no longer) found in AVS DB - | AvsUserAmbiguous -- Multiple matching existing users found in our DB - | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result - | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result - + = 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 -- AvsPersionId not (or no longer) found in AVS DB + | AvsUserAmbiguous -- 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, Generic, Typeable) instance Exception AvsException @@ -92,11 +92,16 @@ setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => Set AvsPersonLicence -> m () setLicencesAvs pls = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponseSetLicences responses <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls - forM_ responses $ \AvsLicenceResponse{..} -> - unless (sloppyBool avsResponseSuccess) $ - -- TODO: create an Admin Problems overview page - $logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage + response <- throwLeftM . avsQuerySetLicences $ AvsQuerySetLicences pls + case response of + AvsResponseSetLicencesError{..} -> do + $logErrorS "AVS" $ "Set licence failed completely: " <> avsResponseSetLicencesStatus <> ". Details: " <> avsResponseSetLicencesMessage + throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus + AvsResponseSetLicences responses -> + forM_ responses $ \AvsLicenceResponse{..} -> + unless (sloppyBool avsResponseSuccess) $ do + -- TODO: create an Admin Problems overview page + $logErrorS "AVS" $ "Set licence failed for " <> tshow avsResponsePersonID <> " due to " <> cropText avsResponseMessage -- | Retrieve all currently valid driving licences and check against our database @@ -123,21 +128,21 @@ upsertAvsUser _someid = error "TODO" -- TODO STUB -- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. -- 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 +upsertAvsUserById api = do mbapd <- lookupAvsUser api - mbuid <- runDB $ do + 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 persNo <- avsPersonInternalPersonalNo -> do + | Just persNo <- avsPersonInternalPersonalNo -> do candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] [] case candidates of [uid] -> insertUniqueEntity $ UserAvs api uid (_:_) -> throwM AvsUserAmbiguous [] -> do - upsRes :: Either CampusUserConversionException (Entity User) + upsRes :: Either CampusUserConversionException (Entity User) <- try $ upsertCampusUserByCn persNo - case upsRes of + case upsRes of Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid _other -> return mbuid -- ==Nothing -- user could not be created somehow _other -> return mbuid @@ -148,14 +153,14 @@ upsertAvsUserById api = do mbCompany = firmAddress ^? _Just . _1 . _Just bestCard = Set.lookupMax avsPersonPersonCards fakeIdent = CI.mk $ tshow api - newUsr = AdminUserForm + newUsr = AdminUserForm { aufTitle = Nothing , aufFirstName = avsPersonFirstName , aufSurname = avsPersonLastName , aufDisplayName = avsPersonFirstName <> " " <> avsPersonLastName , aufDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , aufMatriculation = Nothing - , aufSex = Nothing + , aufSex = Nothing , aufMobile = Nothing , aufTelephone = Nothing , aufFPersonalNumber = avsPersonInternalPersonalNo @@ -168,62 +173,62 @@ upsertAvsUserById api = do , aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known } mbUid <- addNewUser newUsr -- trigger JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe - case (mbCompany, mbUid) of - (Just cpy, Just uid) -> runDB $ do + case (mbCompany, mbUid) of + (Just cpy, Just uid) -> runDB $ do cid <- upsertCompany cpy insert_ $ UserCompany cid uid False _ -> return () - + -- _newAvs = UserAvs avsPersonPersonID uid - -- _newAvsCards = UserAvsCard - error "TODO" -- CONTINUE HERE - (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates + -- _newAvsCards = UserAvsCard + error "TODO" -- CONTINUE HERE + (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates error "TODO" -- CONTINUE HERE --- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. +-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. ---upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => +--upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => -- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) -upsertAvsUserByCard :: +upsertAvsUserByCard :: Either (AvsCardNo,AvsVersionNo) AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! upsertAvsUserByCard persNo = do - let qry = case persNo of + let qry = case persNo of Left (acn,avn) -> def{ avsPersonQueryCardNo = Just acn, avsPersonQueryVersionNo = Just avn } Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry - case Set.elems adps of + case Set.elems adps of [] -> throwM AvsPersonSearchEmpty - (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataPerson{avsPersonPersonID=appi}] -> do + (_:_:_) -> throwM AvsPersonSearchAmbiguous + [AvsDataPerson{avsPersonPersonID=appi}] -> do mbuid <- runDB $ getBy $ UniqueUserAvsId appi - case mbuid of + case mbuid of (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau Nothing -> upsertAvsUserById appi -lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => +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 +-- 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 ) => +lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) -lookupAvsUsers apis = do +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 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 - + diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index dd576c823..16e0e78f1 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -331,17 +331,12 @@ data AvsLicenceResponse = AvsLicenceResponse , avsResponseSuccess :: SloppyBool , avsResponseMessage :: Text } - | AvsErrorResponse - { avsResponseStatus :: Text - , avsResponseMessage :: Text - } deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 , omitNothingFields = True , tagSingleConstructors = False - , rejectUnknownFields = False - , sumEncoding = UntaggedValue + , rejectUnknownFields = False } ''AvsLicenceResponse @@ -376,13 +371,18 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsResponseGetLicences -newtype AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse) +data AvsResponseSetLicences = AvsResponseSetLicences (Set AvsLicenceResponse) + | AvsResponseSetLicencesError + { avsResponseSetLicencesStatus :: Text + , avsResponseSetLicencesMessage :: Text + } deriving (Eq, Ord, Show, Generic, Typeable) deriveJSON defaultOptions - { fieldLabelModifier = dropCamel 2 + { fieldLabelModifier = dropCamel 4 , omitNothingFields = True , tagSingleConstructors = False , rejectUnknownFields = False + , sumEncoding = UntaggedValue } ''AvsResponseSetLicences