chore(avs): implement InfoPersonContact query and test
This commit is contained in:
parent
8d58b9321b
commit
6ca02875c2
@ -87,7 +87,7 @@ validateAvsQueryPerson = do
|
||||
makeAvsStatusForm :: Maybe AvsQueryStatus -> Form AvsQueryStatus
|
||||
makeAvsStatusForm tmpl = identifyForm FIDAvsQueryStatus . validateForm validateAvsQueryStatus $ \html ->
|
||||
flip (renderAForm FormStandard) html $
|
||||
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
|
||||
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl)
|
||||
where
|
||||
parseAvsIds :: Text -> AvsQueryStatus
|
||||
parseAvsIds txt = AvsQueryStatus $ Set.fromList ids
|
||||
@ -102,6 +102,25 @@ validateAvsQueryStatus = do
|
||||
AvsQueryStatus ids <- State.get
|
||||
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
|
||||
|
||||
makeAvsContactForm :: Maybe AvsQueryContact -> Form AvsQueryContact
|
||||
makeAvsContactForm tmpl = identifyForm FIDAvsQueryContact . validateForm validateAvsQueryContact $ \html ->
|
||||
flip (renderAForm FormStandard) html $
|
||||
parseAvsIds <$> areq textField (fslI MsgAvsPersonId) (unparseAvsIds <$> tmpl) -- consider using cfAnySeparatedSet here
|
||||
where
|
||||
parseAvsIds :: Text -> AvsQueryContact
|
||||
parseAvsIds txt = AvsQueryContact $ Set.fromList ids
|
||||
where
|
||||
nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt
|
||||
ids = catMaybes $ fmap AvsObjPersonId . readMay <$> nonemptys
|
||||
unparseAvsIds :: AvsQueryContact -> Text
|
||||
unparseAvsIds (AvsQueryContact ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids
|
||||
|
||||
validateAvsQueryContact :: FormValidator AvsQueryContact Handler ()
|
||||
validateAvsQueryContact = do
|
||||
AvsQueryContact ids <- State.get
|
||||
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
|
||||
|
||||
|
||||
avsLicenceOptions :: OptionList AvsLicence
|
||||
avsLicenceOptions = mkOptionList
|
||||
[ Option
|
||||
@ -142,7 +161,7 @@ postAdminAvsR = do
|
||||
|
||||
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
|
||||
let procFormStatus fr = do
|
||||
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryStatus fr
|
||||
case res of
|
||||
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
@ -153,6 +172,20 @@ postAdminAvsR = do
|
||||
|]
|
||||
mbStatus <- formResultMaybe sresult procFormStatus
|
||||
|
||||
((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
|
||||
let procFormContact fr = do
|
||||
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryContact fr
|
||||
case res of
|
||||
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
Right (AvsResponseContact pns) -> return $ Just [whamlet|
|
||||
<ul>
|
||||
$forall p <- pns
|
||||
<li>#{tshow p}
|
||||
|]
|
||||
mbContact <- formResultMaybe cresult procFormContact
|
||||
|
||||
|
||||
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
|
||||
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
|
||||
let procFormCrUsr fr = do
|
||||
@ -259,11 +292,12 @@ postAdminAvsR = do
|
||||
siteLayoutMsg MsgMenuAvs $ do
|
||||
setTitleI MsgMenuAvs
|
||||
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
|
||||
personForm = wrapFormHere pwidget penctype
|
||||
statusForm = wrapFormHere swidget senctype
|
||||
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
||||
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
personForm = wrapFormHere pwidget penctype
|
||||
statusForm = wrapFormHere swidget senctype
|
||||
contactForm = wrapFormHere cwidget cenctype
|
||||
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
||||
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(widgetFile "avs")
|
||||
|
||||
|
||||
@ -249,7 +249,8 @@ instance ToJSON AvsLicence where
|
||||
instance FromJSON AvsLicence where
|
||||
parseJSON (Number n) | n == 1 = pure AvsLicenceVorfeld -- ordered by occurrence, n==1 is most common case
|
||||
| n == 2 = pure AvsLicenceRollfeld
|
||||
| n == 0 = pure AvsNoLicence -- n==0 never received from AVS, only sent to AVS
|
||||
| n == 0 = pure AvsNoLicence
|
||||
-- | n ==(-1) = pure AvsNoLicenceGuest -- InfoContact may send -1 for Guest unable to obtain a licence
|
||||
#ifdef DEVELOPMENT
|
||||
parseJSON invalid = prependFailure "parsing AvsLicence failed, " $ fail $ "expected Int value being 0, 1 or 2. Found " ++ show invalid
|
||||
#else
|
||||
@ -345,7 +346,7 @@ instance Canonical AvsDataPersonCard where
|
||||
|
||||
-- TODO: use canonical in FromJSON/ToJSON instances for consistency
|
||||
instance FromJSON AvsDataPersonCard where
|
||||
parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard
|
||||
parseJSON = withObject "AvsDataPersonCard" $ \v -> AvsDataPersonCard -- NOTE: String "AvsDataPersonCard" is only used in error messages when parsing fails
|
||||
<$> ((v .: "Valid") <&> sloppyBool)
|
||||
<*> v .:? "ValidTo"
|
||||
<*> v .:? "IssueDate"
|
||||
@ -401,7 +402,7 @@ data AvsDataPerson = AvsDataPerson
|
||||
{ avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
|
||||
, avsPersonLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
|
||||
, avsPersonInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer
|
||||
, avsPersonPersonNo :: Int -- AVS Personennummer, Bedeutung ist unklar
|
||||
, avsPersonPersonNo :: Int -- AVS Personennummer, in menschlicher Kommunikation verwendet
|
||||
, avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle!
|
||||
, avsPersonPersonCards :: Set AvsDataPersonCard
|
||||
}
|
||||
@ -475,6 +476,108 @@ deriveJSON defaultOptions
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsLicenceResponse
|
||||
|
||||
data AvsPersonInfo = AvsPersonInfo
|
||||
{ avsInfoPersonNo :: Text -- Int -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation
|
||||
, avsInfoFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
|
||||
, avsInfoLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
|
||||
, avsInfoRampLicence :: AvsLicence -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence
|
||||
, avsInfoDateOfBirth :: Maybe Day
|
||||
, avsInfoPersonEMail :: Maybe Text
|
||||
, avsInfoPersonMobilePhoneNo :: Maybe Text
|
||||
, avsInfoInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer
|
||||
} deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
makeLenses_ ''AvsPersonInfo
|
||||
|
||||
instance FromJSON AvsPersonInfo where
|
||||
parseJSON = withObject "AvsPersonInfo" $ \o -> AvsPersonInfo
|
||||
<$> o .: "PersonsNo" -- NOTE: PersonsNo, not PersonNo as elsewhere
|
||||
<*> o .: "FirstName"
|
||||
<*> o .: "LastName"
|
||||
<*> o .: "RampLicence"
|
||||
<*> o .:? "DateOfBirth"
|
||||
<*> o .:?! "PersonEMail"
|
||||
<*> o .:?! "PersonMobilePhoneNo"
|
||||
<*> o .:?! "InternalPersonalNo"
|
||||
|
||||
|
||||
instance ToJSON AvsPersonInfo where
|
||||
toJSON AvsPersonInfo{..} = object $ catMaybes
|
||||
[ ("DateOfBirth" .=) <$> avsInfoDateOfBirth
|
||||
, ("PersonEMail" .=) <$> avsInfoPersonEMail & canonical
|
||||
, ("PersonMobilePhoneNo" .=) <$> avsInfoPersonMobilePhoneNo & canonical
|
||||
, ("InternalPersonalNo" .=) <$> avsInfoInternalPersonalNo & canonical
|
||||
] <>
|
||||
[ "PersonsNo" .= avsInfoPersonNo
|
||||
, "FirstName" .= avsInfoFirstName
|
||||
, "LastName" .= avsInfoLastName
|
||||
, "RampLicence" .= avsInfoRampLicence
|
||||
]
|
||||
-- derivePersistFieldJSON ''AvsPersonInfo
|
||||
|
||||
|
||||
data AvsFirmInfo = AvsFirmInfo
|
||||
{ avsFirmFirm :: Text
|
||||
, avsFirmFirmNo :: Int
|
||||
, avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen!
|
||||
, avsFirmZIPCode :: Maybe Text
|
||||
, avsFirmCity :: Maybe Text
|
||||
, avsFirmCountry :: Maybe Text
|
||||
, avsFirmStreetANDHouseNo :: Maybe Text
|
||||
, avsFirmEMail :: Maybe Text
|
||||
, avsFirmEMailSuperior :: Maybe Text
|
||||
} deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
makeLenses_ ''AvsFirmInfo
|
||||
|
||||
instance FromJSON AvsFirmInfo where
|
||||
parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo
|
||||
<$> o .: "Firm"
|
||||
<*> o .: "FirmNo"
|
||||
<*> o .: "Abbreviation"
|
||||
<*> o .:?! "ZIPCode"
|
||||
<*> o .:?! "City"
|
||||
<*> o .:?! "Country"
|
||||
<*> o .:?! "StreetANDHouseNo"
|
||||
<*> o .:?! "EMail"
|
||||
<*> o .:?! "EMailSuperior"
|
||||
|
||||
instance ToJSON AvsFirmInfo where
|
||||
toJSON AvsFirmInfo{..} = object $ catMaybes
|
||||
[ ("ZIPCode" .=) <$> avsFirmZIPCode & canonical
|
||||
, ("City" .=) <$> avsFirmCity & canonical
|
||||
, ("Country" .=) <$> avsFirmCountry & canonical
|
||||
, ("StreetANDHouseNo" .=) <$> avsFirmStreetANDHouseNo & canonical
|
||||
, ("EMail" .=) <$> avsFirmEMail & canonical
|
||||
, ("EMailSuperior" .=) <$> avsFirmEMailSuperior & canonical
|
||||
] <>
|
||||
[ "Firm" .= avsFirmFirm
|
||||
, "FirmNo" .= avsFirmFirmNo
|
||||
, "Abbreviation" .= avsFirmAbbreviation
|
||||
]
|
||||
-- derivePersistFieldJSON ''AvsFirmInfo
|
||||
|
||||
|
||||
data AvsDataContact = AvsDataContact
|
||||
{ avsContactPersonID :: AvsPersonId
|
||||
, avsContactPersonInfo :: AvsPersonInfo
|
||||
, avsContactFirmInfo :: AvsFirmInfo
|
||||
} deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
makeLenses_ ''AvsDataContact
|
||||
|
||||
-- instance Canonical AvsDataContact where
|
||||
-- canonical = over _avsContactPersonInfo canonical
|
||||
-- . over _avsContactFirmInfo canonical
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsDataContact
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
-- Responses --
|
||||
@ -498,6 +601,15 @@ deriveJSON defaultOptions
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsResponsePerson
|
||||
|
||||
newtype AvsResponseContact = AvsResponseContact (Set AvsDataContact)
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = dropCamel 2
|
||||
, omitNothingFields = True
|
||||
, tagSingleConstructors = False
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsResponseContact
|
||||
|
||||
newtype AvsResponseGetLicences = AvsResponseGetLicences (Set AvsPersonLicence)
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriveJSON defaultOptions
|
||||
@ -548,6 +660,10 @@ newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriveJSON defaultOptions ''AvsQueryStatus
|
||||
|
||||
newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriveJSON defaultOptions ''AvsQueryContact
|
||||
|
||||
newtype AvsQueryGetLicences = AvsQueryGetLicences AvsObjPersonId -- this should have been a set, but the specification was implemented differently
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
deriveJSON defaultOptions ''AvsQueryGetLicences
|
||||
|
||||
@ -24,11 +24,12 @@ import Model.Types.Avs
|
||||
-------------
|
||||
-- AVS API --
|
||||
-------------
|
||||
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
|
||||
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
|
||||
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
|
||||
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
|
||||
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
|
||||
type AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
|
||||
type AVSPersonSearch = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
|
||||
type AVSPersonStatus = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
|
||||
type AVSPersonContact = "InfoPersonContact" :> ReqBody '[JSON] AvsQueryContact :> Post '[JSON] AvsResponseContact
|
||||
type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
|
||||
type AVSSetRampLicences = "RampDrivingLicence" :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
|
||||
|
||||
avsMaxSetLicenceAtOnce :: Int
|
||||
avsMaxSetLicenceAtOnce = 99 -- maximum input set size for avsQuerySetLicences as enforced by AVS
|
||||
@ -49,6 +50,7 @@ data AvsQuery where
|
||||
data AvsQuery = AvsQuery
|
||||
{ avsQueryPerson :: forall m. MonadIO m => AvsQueryPerson -> m (Either ClientError AvsResponsePerson)
|
||||
, avsQueryStatus :: forall m. MonadIO m => AvsQueryStatus -> m (Either ClientError AvsResponseStatus)
|
||||
, avsQueryContact :: forall m. MonadIO m => AvsQueryContact -> m (Either ClientError AvsResponseContact)
|
||||
, avsQuerySetLicences :: forall m. MonadIO m => AvsQuerySetLicences -> m (Either ClientError AvsResponseSetLicences)
|
||||
-- , avsQueryGetLicences :: forall m. MonadIO m => AvsQueryGetLicences -> m (Either ClientError AvsResponseGetLicences) -- not supported by VSM
|
||||
, avsQueryGetAllLicences :: forall m. MonadIO m => m (Either ClientError AvsResponseGetLicences)
|
||||
@ -66,6 +68,7 @@ mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
|
||||
mkAvsQuery _ _ _ = AvsQuery
|
||||
{ avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty
|
||||
, avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty
|
||||
, avsQueryContact = \_ -> return . Right $ AvsResponseContact mempty
|
||||
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
|
||||
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
|
||||
}
|
||||
@ -73,12 +76,17 @@ mkAvsQuery _ _ _ = AvsQuery
|
||||
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
|
||||
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
|
||||
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
|
||||
, avsQueryContact = \q -> liftIO $ runClientM (rawQueryContact q) cliEnv
|
||||
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv
|
||||
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
|
||||
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
|
||||
}
|
||||
where
|
||||
(rawQueryPerson :<|> rawQueryStatus :<|> rawQueryGetLicences :<|> rawQuerySetLicences) = client avsApi basicAuth
|
||||
( rawQueryPerson
|
||||
:<|> rawQueryStatus
|
||||
:<|> rawQueryContact
|
||||
:<|> rawQueryGetLicences
|
||||
:<|> rawQuerySetLicences ) = client avsApi basicAuth
|
||||
catch404toEmpty :: Either ClientError AvsResponsePerson -> Either ClientError AvsResponsePerson
|
||||
catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
|
||||
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
|
||||
|
||||
@ -301,6 +301,7 @@ data FormIdentifier
|
||||
| FIDLmsLetter
|
||||
| FIDAvsQueryPerson
|
||||
| FIDAvsQueryStatus
|
||||
| FIDAvsQueryContact
|
||||
| FIDAvsCreateUser
|
||||
| FIDAvsQueryLicenceDiffs
|
||||
| FIDAvsQueryLicence
|
||||
|
||||
@ -38,7 +38,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Person search:
|
||||
Person Search:
|
||||
^{personForm}
|
||||
$maybe answer <- mbPerson
|
||||
<p>
|
||||
@ -47,12 +47,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Person status:
|
||||
Person Status:
|
||||
^{statusForm}
|
||||
$maybe answer <- mbStatus
|
||||
<p>
|
||||
Unverarbeitete Antwort: #
|
||||
^{answer}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Info Person Contact:
|
||||
^{contactForm}
|
||||
$maybe answer <- mbContact
|
||||
<p>
|
||||
Unverarbeitete Antwort: #
|
||||
^{answer}
|
||||
|
||||
|
||||
<section>
|
||||
^{modal "AVS Konfiguration" (Right avsWgt)}
|
||||
Loading…
Reference in New Issue
Block a user