From a0cfe7807b86700dc0520fe0cbf06d8e6b39bafd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Jun 2022 12:41:44 +0200 Subject: [PATCH] chore(avs): add person status query demo interface --- .../uniworx/categories/avs/de-de-formal.msg | 3 +- messages/uniworx/categories/avs/en-eu.msg | 3 +- src/Handler/Admin/Avs.hs | 61 +++++++++++-------- src/Handler/Utils/Servant/Avs.hs | 23 ++++++- templates/avs.hamlet | 15 ++++- 5 files changed, 73 insertions(+), 32 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index f6c64fd08..2f01736a0 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -3,4 +3,5 @@ AvsFirstName: Vorname AvsLastName: Nachname AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsVersionNo: Versionsnummer -AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! \ No newline at end of file +AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! +AvsStatusQueryInvalid t@Text: Nur numerische IDs eingeben, durch Komma! #{show t} \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 1c9860fd1..f5e5f158d 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -3,4 +3,5 @@ AvsFirstName: First name AvsLastName: Last name AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsVersionNo: Version number -AvsQueryEmpty: At least one query field must be filled! \ No newline at end of file +AvsQueryEmpty: At least one query field must be filled! +AvsStatusQueryInvalid t: Numeric IDs only, comma seperated! #{show t} \ No newline at end of file diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 5099d1d4d..5b5179921 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -6,6 +6,8 @@ module Handler.Admin.Avs import Import import qualified Control.Monad.State.Class as State -- import Data.Aeson (encode) +import qualified Data.Text as Text +import qualified Data.Set as Set import Handler.Utils import Handler.Utils.Servant.Avs @@ -31,46 +33,53 @@ validateAvsPersonQuery = do is _Just avsPersonQueryInternalPersonalNo || is _Just avsPersonQueryVersionNo -{- - -makeAvsForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery -makeAvsForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> - flip (renderAForm FormStandard) html $ AvsStatusQuery - <$> aopt textField (fslI MsgAvsCardNo) (avsPersonQueryCardNo <$> tmpl) - <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) - <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) - <*> aopt textField (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) - <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) - -validateAvsPersonQuery :: FormValidator AvsPersonQuery Handler () -validateAvsPersonQuery = do - AvsPersonQuery{..} <- State.get - guardValidation MsgAvsQueryEmpty $ - is _Just avsPersonQueryCardNo || - is _Just avsPersonQueryFirstName || - is _Just avsPersonQueryLastName || - is _Just avsPersonQueryInternalPersonalNo || - is _Just avsPersonQueryVersionNo --} +makeAvsStatusForm :: Maybe AvsStatusQuery -> Form AvsStatusQuery +makeAvsStatusForm tmpl = identifyForm FIDAvsStatusQuery . validateForm validateAvsStatusQuery $ \html -> + flip (renderAForm FormStandard) html $ + parseAvsIds <$> areq textField (fslI MsgAvsCardNo) (unparseAvsIds <$> tmpl) + where + parseAvsIds :: Text -> AvsStatusQuery + parseAvsIds txt = AvsStatusQuery $ Set.fromList ids + where + nonemptys = filter (not . Text.null) $ Text.strip <$> Text.split (==',') txt + ids = catMaybes $ readMay <$> nonemptys + unparseAvsIds :: AvsStatusQuery -> Text + unparseAvsIds (AvsStatusQuery ids) = Text.intercalate ", " $ tshow <$> Set.toAscList ids +validateAvsStatusQuery :: FormValidator AvsStatusQuery Handler () +validateAvsStatusQuery = do + AvsStatusQuery ids <- State.get + guardValidation (MsgAvsStatusQueryInvalid $ tshow ids) $ not (null ids) getAdminAvsR, postAdminAvsR :: Handler Html getAdminAvsR = postAdminAvsR postAdminAvsR = do - ((result,widget), enctype) <- runFormPost $ makeAvsPersonForm Nothing - let procForm fr = do + ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing + let procFormPerson fr = do res <- runAvsPersonSearch fr case res of Left err -> return $ Just err Right jsn -> return $ Just $ tshow jsn - mbAnswer <- formResultMaybe result procForm + mbPerson <- formResultMaybe presult procFormPerson + + ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing + let procFormStatus fr = do + res <- runAvsStatusSearch fr + case res of + Left err -> return $ Just err + Right jsn -> return $ Just $ tshow jsn + mbStatus <- formResultMaybe sresult procFormStatus actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgMenuAvs $ do setTitleI MsgMenuAvs - let formWidget = wrapForm widget def + let personForm = wrapForm pwidget def { formAction = Just $ SomeRoute actionUrl - , formEncoding = enctype + , formEncoding = penctype + } + statusForm = wrapForm swidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = senctype } -- TODO: use i18nWidgetFile instead if this is to become permanent $(widgetFile "avs") diff --git a/src/Handler/Utils/Servant/Avs.hs b/src/Handler/Utils/Servant/Avs.hs index 78d59ca34..02479027a 100644 --- a/src/Handler/Utils/Servant/Avs.hs +++ b/src/Handler/Utils/Servant/Avs.hs @@ -38,7 +38,7 @@ deriveJSON defaultOptions -} -- data StatusQuery = StatusQuery -newtype AvsStatusQuery = AvsStatusQuery (Set UserMatriculation) +newtype AvsStatusQuery = AvsStatusQuery (Set Int) deriveJSON defaultOptions ''AvsStatusQuery type AvsPersonResponse = Value @@ -102,6 +102,27 @@ runAvsPersonSearch qry = do fullQuery = avsPersonSearch avsAuth qry liftIO $ over _Left tshow <$> runClientM fullQuery avsClient +runAvsStatusSearch :: AvsStatusQuery -> Import.Handler (Either Text AvsStatusResponse) +runAvsStatusSearch qry = do + manager <- getsYesod $ view _appHttpManager + mbAvsConf <- getsYesod $ view _appAvsConf + case mbAvsConf of + Nothing -> return $ Left "appAvsConfig is empty, i.e. invalid AVS configuration settings." + Just avsConf -> do + -- TODO: consider using Servant.Client.Core.parseBaseUrl within Settings already at Startup! + let avsServer = BaseUrl + { baseUrlScheme = Https + , baseUrlHost = avsHost avsConf + , baseUrlPort = avsPort avsConf + , baseUrlPath = "" + } + avsAuth = BasicAuthData + { basicAuthUsername = avsUser avsConf + , basicAuthPassword = avsPass avsConf + } + avsClient = mkClientEnv manager avsServer + fullQuery = avsPersonStatus avsAuth qry + liftIO $ over _Left tshow <$> runClientM fullQuery avsClient -- DEMO to check that it types run :: IO () diff --git a/templates/avs.hamlet b/templates/avs.hamlet index dd87cc7a3..82474ebfa 100644 --- a/templates/avs.hamlet +++ b/templates/avs.hamlet @@ -1,8 +1,17 @@

- Abfrage: - ^{formWidget} - $maybe answer <- mbAnswer + Person Search: + ^{personForm} + $maybe answer <- mbPerson

Unverarbeitete Antwort: # #{answer} + +

+

+ Person Status: + ^{statusForm} + $maybe answer <- mbStatus +

+ Unverarbeitete Antwort: # + #{answer} \ No newline at end of file