chore(avs): implement InfoPersonContact query and test

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|<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
+            personForm  = wrapFormHere pwidget  penctype
-            statusForm = wrapFormHere swidget  senctype
+            statusForm  = wrapFormHere swidget  senctype
-            crUsrForm  = wrapFormHere crUsrWgt crUsrEnctype
+            contactForm = wrapFormHere cwidget  cenctype
-            getLicForm = wrapFormHere getLicWgt getLicEnctype
+            crUsrForm   = wrapFormHere crUsrWgt crUsrEnctype
-            setLicForm = wrapFormHere setLicWgt setLicEnctype
+            getLicForm  = wrapFormHere getLicWgt getLicEnctype
+            setLicForm  = wrapFormHere setLicWgt setLicEnctype
         -- TODO: use i18nWidgetFile instead if this is to become permanent
         $(widgetFile "avs")
 

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

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 AVS = BasicAuth "avs_fradrive" String :> "FraVSMService" :> "v1" :> (AVSPersonSearch :<|> AVSPersonStatus :<|> AVSPersonContact :<|> AVSGetRampLicences :<|> AVSSetRampLicences)
-type AVSPersonSearch    = "PersonSearch" :> ReqBody '[JSON] AvsQueryPerson :> Post '[JSON] AvsResponsePerson
+type AVSPersonSearch    = "PersonSearch"            :> ReqBody '[JSON] AvsQueryPerson       :> Post '[JSON] AvsResponsePerson
-type AVSPersonStatus    = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Post '[JSON] AvsResponseStatus
+type AVSPersonStatus    = "PersonStatus"            :> ReqBody '[JSON] AvsQueryStatus       :> Post '[JSON] AvsResponseStatus
-type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
+type AVSPersonContact   = "InfoPersonContact"       :> ReqBody '[JSON] AvsQueryContact      :> Post '[JSON] AvsResponseContact
-type AVSSetRampLicences = "RampDrivingLicence"     :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
+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!

src/Utils/Form.hs

@@ -301,6 +301,7 @@ data FormIdentifier
   | FIDLmsLetter
   | FIDAvsQueryPerson
   | FIDAvsQueryStatus
+  | FIDAvsQueryContact
   | FIDAvsCreateUser
   | FIDAvsQueryLicenceDiffs
   | FIDAvsQueryLicence

templates/avs.hamlet

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