fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(avs): expand avs interface

Browse Source
This commit is contained in:
Steffen Jost 2022-11-14 18:46:38 +01:00
parent 2a6fee30ea
commit 6f7282b512
4 changed files with 92 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
routes
View File

@ -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

2
src/Handler/Users/Add.hs
View File

@ -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

81
src/Handler/Utils/Avs.hs
View File

@ -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

38
src/Model/Types/Avs.hs
View File

@ -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)