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

chore(avs): add person status query demo interface

Browse Source
This commit is contained in:
Steffen Jost 2022-06-28 12:41:44 +02:00
parent 5b56017683
commit a0cfe7807b
5 changed files with 73 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -3,4 +3,5 @@ AvsFirstName: Vorname
AvsLastName: Nachname
AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
AvsVersionNo: Versionsnummer
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
AvsStatusQueryInvalid t@Text: Nur numerische IDs eingeben, durch Komma! #{show t}

3
messages/uniworx/categories/avs/en-eu.msg
View File

@ -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!
AvsQueryEmpty: At least one query field must be filled!
AvsStatusQueryInvalid t: Numeric IDs only, comma seperated! #{show t}

61
src/Handler/Admin/Avs.hs
View File

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

23
src/Handler/Utils/Servant/Avs.hs
View File

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

15
templates/avs.hamlet
View File

@ -1,8 +1,17 @@
<section>
<p>
Abfrage:
^{formWidget}
$maybe answer <- mbAnswer
Person Search:
^{personForm}
$maybe answer <- mbPerson
<p>
Unverarbeitete Antwort: #
#{answer}
<section>
<p>
Person Status:
^{statusForm}
$maybe answer <- mbStatus
<p>
Unverarbeitete Antwort: #
#{answer}