From 6f7282b512c335fee1dc58860857ed7652fe3080 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 14 Nov 2022 18:46:38 +0100 Subject: [PATCH] chore(avs): expand avs interface --- routes | 8 ++-- src/Handler/Users/Add.hs | 2 +- src/Handler/Utils/Avs.hs | 81 ++++++++++++++++++++++++++++++++-------- src/Model/Types/Avs.hs | 38 +++++++++++-------- 4 files changed, 92 insertions(+), 37 deletions(-) diff --git a/routes b/routes index b08f5ccbc..8c3fb21f3 100644 --- a/routes +++ b/routes @@ -55,10 +55,10 @@ /users/#CryptoUUIDUser AdminUserR GET POST /users/#CryptoUUIDUser/delete AdminUserDeleteR POST /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation -/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self -/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash -!/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST -!/users/functionary-invite AdminFunctionaryInviteR GET POST +/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self +/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash +!/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST +!/users/functionary-invite AdminFunctionaryInviteR GET POST !/users/add AdminUserAddR GET POST /admin AdminR GET /admin/test AdminTestR GET POST diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 2664e4c2e..df15fb815 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -4,7 +4,7 @@ module Handler.Users.Add ( getAdminUserAddR, postAdminUserAddR - -- , AdminUserForm(..), adminUserForm -- no longer needed elsewhere + , AdminUserForm(..), adminUserForm -- no longer needed elsewhere -- , AuthenticationKind(..), classifyAuth, mkAuthMode -- no longer needed elsewhere ) where diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2734ca649..7963e8697 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -9,6 +9,7 @@ module Handler.Utils.Avs , setLicence, setLicenceAvs, setLicencesAvs , checkLicences , lookupAvsUser, lookupAvsUsers + , upsertAvsUser, upsertAvsUserByCard ) where import Import @@ -22,6 +23,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map -- import qualified Data.Text as Text +import Handler.Users.Add -------------------- @@ -29,8 +31,11 @@ import qualified Data.Map as Map -------------------- data AvsException - = AvsInterfaceUnavailable - | AvsUserUnknown UserId + = 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 + | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result + | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result deriving (Show, Generic, Typeable) instance Exception AvsException @@ -56,7 +61,7 @@ instance Exception AvsException 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 (AvsUserUnknown uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid + 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) @@ -64,15 +69,14 @@ getLicence uid = do getLicenceDB :: UserId -> DB (Maybe AvsLicence) getLicenceDB uid = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ getBy $ UniqueUserAvsUser uid + 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) - setLicence :: UserId -> AvsLicence -> DB () setLicence uid lic = do - Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ getBy $ UniqueUserAvsUser uid + Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid setLicenceAvs userAvsPersonId lic setLicenceAvs :: AvsPersonId -> AvsLicence -> DB () @@ -111,19 +115,63 @@ or -} -{- -upsertAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => - AvsPersonId -> m () +-- | 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). +upsertAvsUser :: AvsPersonId -> Handler (Maybe UserId) upsertAvsUser api = do - mbuid <- getBy $ UniqueUserAvsId api + mbuid <- runDB $ getBy $ UniqueUserAvsId api mbapd <- lookupAvsUser api case (mbuid, mbapd) of - ( _ , Nothing) -> error "TODO" -- CONTINUE HERE -- this should no happen - (Nothing, Just apd) -> do -- unknown user + ( _ , Nothing) -> throwM $ AvsUserUnknownByAvs api -- this should never happen + (Nothing, Just AvsDataPerson{..}) -> do -- unknown user, must be created + -- if | Just ipn <- avsPersonInternalPersonalNo -> TODO? + let _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 + , aufMobile = Nothing + , aufTelephone = Nothing + , aufFPersonalNumber = avsPersonInternalPersonalNo + , aufFDepartment = Nothing + , aufPostAddress = error "TODO" -- CONTINUE HERE + , aufPrefersPostal = error "TODO" -- CONTINUE HERE + , aufPinPassword = error "TODO" -- CONTINUE HERE + , aufEmail = "" + , aufIdent = error "TODO" -- CONTINUE HERE + , aufAuth = error "TODO" -- CONTINUE HERE AuthKindNoLogin or AuthKindLDAP if ldap search worked + } + -- _newAvs = UserAvs avsPersonPersonID uid + -- _newAvsCards = UserAvsCard error "TODO" -- CONTINUE HERE - (Just uid, Just apd) -> do -- known user + (Just _uid, Just _apd) -> do -- known user error "TODO" -- CONTINUE HERE --} + + +-- | 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, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) +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 + 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 + [] -> throwM AvsPersonSearchEmpty + (_:_:_) -> throwM AvsPersonSearchAmbiguous + [AvsDataPerson{avsPersonPersonID=appi}] -> do + mbuid <- runDB $ getBy $ UniqueUserAvsId appi + case mbuid of + (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau + Nothing -> upsertAvsUser appi + lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => @@ -136,6 +184,7 @@ lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) -- - 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 @@ -143,7 +192,7 @@ lookupAvsUsers apis = do 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} -> do - AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo} + 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 d28866782..8daaef962 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -80,13 +80,19 @@ instance FromJSON SloppyBool where -- AVS Datatypes -- ------------------- +type AvsInternalPersonalNo = Text -- type synonym for claritty/documentation within types + +-- CompleteCardNo = xxxxxxxx.y +-- where x is an 8 digit AvsCardNo prefixed by zeros +-- and y is the 1 digit AvsVersionNo +type AvsVersionNo = Text -- always 1 digit newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits deriving (Eq, Ord, Show, Generic, Typeable) deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) instance E.SqlString AvsCardNo -- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API instance FromJSON AvsCardNo where - parseJSON x = AvsCardNo <$> parseJSON x + parseJSON x = AvsCardNo . Text.justifyRight 8 '0' <$> parseJSON x instance ToJSON AvsCardNo where toJSON (AvsCardNo cno) = toJSON cno @@ -163,17 +169,17 @@ instance FromJSON AvsDataCardColor where data AvsDataPersonCard = AvsDataPersonCard - { avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans - , avsDataValidTo :: Maybe Day -- Nothing if returned with AvsResponseStatus - , avsDataIssueDate :: Maybe Day -- Nothing if returned with AvsResponseStatus + { avsDataValid :: Bool -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans + , avsDataValidTo :: Maybe Day -- Nothing if returned with AvsResponseStatus + , avsDataIssueDate :: Maybe Day -- Nothing if returned with AvsResponseStatus , avsDataCardColor :: AvsDataCardColor - , avsDataCardAreas :: Set Char -- logically a set of upper-case letters - , avsDataStreet :: Maybe Text -- Nothing if returned with AvsResponseStatus - , avsDataPostalCode:: Maybe Text -- Nothing if returned with AvsResponseStatus - , avsDataCity :: Maybe Text -- Nothing if returned with AvsResponseStatus - , avsDataFirm :: Maybe Text -- Nothing if returned with AvsResponseStatus - , avsDataCardNo :: AvsCardNo -- always 8 digits - , avsDataVersionNo :: Text + , avsDataCardAreas :: Set Char -- logically a set of upper-case letters + , avsDataStreet :: Maybe Text -- Nothing if returned with AvsResponseStatus + , avsDataPostalCode:: Maybe Text -- Nothing if returned with AvsResponseStatus + , avsDataCity :: Maybe Text -- Nothing if returned with AvsResponseStatus + , avsDataFirm :: Maybe Text -- Nothing if returned with AvsResponseStatus + , avsDataCardNo :: AvsCardNo -- always 8 digits number, prefixed with 0 + , avsDataVersionNo :: AvsVersionNo -- always 1 digit number } deriving (Eq, Ord, Show, Generic, Typeable) deriving anyclass (NFData) @@ -257,9 +263,9 @@ deriveJSON defaultOptions data AvsDataPerson = AvsDataPerson { avsPersonFirstName :: Text , avsPersonLastName :: Text - , avsPersonInternalPersonalNo :: Maybe Text -- Fraport Personalnummer - , avsPersonPersonNo :: Int -- AVS Personennummer, Bedeutung ist unklar - , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! + , avsPersonInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer + , avsPersonPersonNo :: Int -- AVS Personennummer, Bedeutung ist unklar + , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! , avsPersonPersonCards :: Set AvsDataPersonCard } deriving (Eq, Ord, Show, Generic, Typeable) @@ -373,10 +379,10 @@ deriveJSON defaultOptions ------------- data AvsQueryPerson = AvsQueryPerson { avsPersonQueryCardNo :: Maybe AvsCardNo + , avsPersonQueryVersionNo :: Maybe AvsVersionNo , avsPersonQueryFirstName :: Maybe Text , avsPersonQueryLastName :: Maybe Text - , avsPersonQueryInternalPersonalNo :: Maybe Text - , avsPersonQueryVersionNo :: Maybe Text + , avsPersonQueryInternalPersonalNo :: Maybe AvsInternalPersonalNo } deriving (Eq, Ord, Show, Generic, Typeable)