diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 3cb709b6f..886ffa010 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -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|
Error:
#{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|Error:
#{msg}|]
+ Right (AvsResponseContact pns) -> return $ Just [whamlet|
+
+ $forall p <- pns
+ - #{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")
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index 96d39bdc4..59cabb982 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -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
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index 560aa49ad..71e90c910 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -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!
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 5b7096749..9ad82b29f 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -301,6 +301,7 @@ data FormIdentifier
| FIDLmsLetter
| FIDAvsQueryPerson
| FIDAvsQueryStatus
+ | FIDAvsQueryContact
| FIDAvsCreateUser
| FIDAvsQueryLicenceDiffs
| FIDAvsQueryLicence
diff --git a/templates/avs.hamlet b/templates/avs.hamlet
index 5d4bd6bf8..b9dadd9b8 100644
--- a/templates/avs.hamlet
+++ b/templates/avs.hamlet
@@ -38,7 +38,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
- Person search:
+ Person Search:
^{personForm}
$maybe answer <- mbPerson
@@ -47,12 +47,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
- Person status:
+ Person Status:
^{statusForm}
$maybe answer <- mbStatus
Unverarbeitete Antwort: #
^{answer}
+
+
+ Info Person Contact:
+ ^{contactForm}
+ $maybe answer <- mbContact
+
+ Unverarbeitete Antwort: #
+ ^{answer}
+
+
^{modal "AVS Konfiguration" (Right avsWgt)}
\ No newline at end of file