chore(avs): add all new avs functions to admin test interface for testing
This commit is contained in:
Steffen Jost
parent
8015775ce6
commit
cb58eb3690
@ -10,4 +10,5 @@ AvsLastName: Nachname
|
||||
AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
|
||||
AvsVersionNo: Versionsnummer
|
||||
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
|
||||
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
|
||||
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
|
||||
AvsLicence: Fahrberechtigung
|
||||
@ -10,4 +10,5 @@ AvsLastName: Last name
|
||||
AvsInternalPersonalNo: Personnel number (Fraport AG only)
|
||||
AvsVersionNo: Version number
|
||||
AvsQueryEmpty: At least one query field must be filled!
|
||||
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
|
||||
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
|
||||
AvsLicence: Driving Licence
|
||||
@ -14,9 +14,24 @@ import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
|
||||
import Utils.Avs
|
||||
|
||||
-- Button needed only here
|
||||
data ButtonAvsTest = BtnCheckLicences
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonAvsTest
|
||||
instance Finite ButtonAvsTest
|
||||
|
||||
nullaryPathPiece ''ButtonAvsTest camelToPathPiece
|
||||
|
||||
instance Button UniWorX ButtonAvsTest where
|
||||
btnLabel BtnCheckLicences = "Check all licences" -- could be msg
|
||||
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
|
||||
-- END Button
|
||||
|
||||
|
||||
avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
|
||||
avsCardNoField = convertField AvsCardNo avsCardNo textField
|
||||
|
||||
@ -57,6 +72,17 @@ validateAvsQueryStatus = do
|
||||
AvsQueryStatus ids <- State.get
|
||||
guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
|
||||
|
||||
|
||||
avsLicenceOptions :: OptionList AvsLicence
|
||||
avsLicenceOptions = mkOptionList
|
||||
[ Option
|
||||
{ optionDisplay = Text.singleton $ licence2char l
|
||||
, optionInternalValue = l
|
||||
, optionExternalValue = toJsonText l
|
||||
}
|
||||
| l <- universeF
|
||||
]
|
||||
|
||||
getAdminAvsR, postAdminAvsR :: Handler Html
|
||||
getAdminAvsR = postAdminAvsR
|
||||
postAdminAvsR = do
|
||||
@ -81,16 +107,73 @@ postAdminAvsR = do
|
||||
Right jsn -> return . Just $ tshow jsn
|
||||
mbStatus <- formResultMaybe sresult procFormStatus
|
||||
|
||||
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
|
||||
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
|
||||
let procFormCrUsr fr = do
|
||||
res <- try $ upsertAvsUser fr
|
||||
case res of
|
||||
(Right (Just uid)) -> do
|
||||
uuid :: CryptoUUIDUser <- encrypt uid
|
||||
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
|
||||
(Right Nothing) ->
|
||||
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
|
||||
|
||||
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
|
||||
flip (renderAForm FormStandard) html $ areq intField (fslI MsgAvsPersonId) Nothing
|
||||
let procFormGetLic fr = do
|
||||
res <- try $ getLicenceByAvsId $ AvsPersonId fr
|
||||
case res of
|
||||
(Right (Just lic)) ->
|
||||
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow lic}|]
|
||||
(Right Nothing) ->
|
||||
return $ Just [whamlet|<h2>Warning:</h2> User not found.|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbGetLic <- formResultMaybe getLicRes procFormGetLic
|
||||
|
||||
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
|
||||
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
|
||||
let procFormSetLic (aid, lic) = do
|
||||
res <- try $ setLicenceAvs (AvsPersonId aid) lic
|
||||
case res of
|
||||
(Right True) ->
|
||||
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
|
||||
(Right False) ->
|
||||
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbSetLic <- formResultMaybe setLicRes procFormSetLic
|
||||
|
||||
|
||||
((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
|
||||
let procFormQryLic BtnCheckLicences = do
|
||||
res <- try checkLicences
|
||||
case res of
|
||||
(Right True) ->
|
||||
return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
|
||||
(Right False) ->
|
||||
return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
|
||||
(Left e) -> do
|
||||
let msg = tshow (e :: SomeException)
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
mbQryLic <- formResultMaybe qryLicRes procFormQryLic
|
||||
|
||||
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
||||
siteLayoutMsg MsgMenuAvs $ do
|
||||
setTitleI MsgMenuAvs
|
||||
let personForm = wrapForm pwidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = penctype
|
||||
}
|
||||
statusForm = wrapForm swidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = senctype
|
||||
}
|
||||
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
|
||||
qryLicForm = wrapForm qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(widgetFile "avs")
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
|
||||
module Handler.Utils.Avs
|
||||
( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
|
||||
, getLicence, getLicenceDB
|
||||
, getLicence, getLicenceDB, getLicenceByAvsId
|
||||
, setLicence, setLicenceAvs, setLicencesAvs
|
||||
, checkLicences
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
@ -85,6 +85,14 @@ getLicenceDB uid = do
|
||||
let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
|
||||
return (avsLicenceRampLicence <$> ulicence)
|
||||
|
||||
getLicenceByAvsId :: (MonadHandler m, MonadThrow m, MonadReader UniWorX ((->) (HandlerSite m)), HandlerSite m ~ UniWorX) =>
|
||||
AvsPersonId -> m (Maybe AvsLicence)
|
||||
getLicenceByAvsId aid = do
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
|
||||
AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId aid
|
||||
let ulicence = Set.lookupMax $ Set.filter ((aid ==) . avsLicencePersonID) licences
|
||||
return (avsLicenceRampLicence <$> ulicence)
|
||||
|
||||
|
||||
-- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool
|
||||
setLicence :: (PersistUniqueRead backend, MonadThrow m,
|
||||
@ -179,7 +187,7 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
|
||||
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
|
||||
let setTo0 = vorfRevoke -- ready to use with SET 0
|
||||
setTo1 = (vorfGrant \\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
|
||||
setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
|
||||
setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld)
|
||||
{-
|
||||
Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
|
||||
@ -336,9 +344,6 @@ upsertAvsUserById api = do
|
||||
return $ Just uid
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
AvsPersonId -> m (Maybe AvsDataPerson)
|
||||
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
|
||||
|
||||
@ -302,7 +302,11 @@ data FormIdentifier
|
||||
| FIDAllocationRegister
|
||||
| FIDAllocationNotification
|
||||
| FIDAvsQueryPerson
|
||||
| FIDAvsQueryStatus
|
||||
| FIDAvsQueryStatus
|
||||
| FIDAvsCreateUser
|
||||
| FIDAvsQueryLicenceDiffs
|
||||
| FIDAvsQueryLicence
|
||||
| FIDAvsSetLicence
|
||||
| FIDLmsLetter
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
|
||||
@ -6,7 +6,39 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Person Search:
|
||||
Upsert User by CardNo or Fraport Personnel Number:
|
||||
^{crUsrForm}
|
||||
$maybe answer <- mbCrUser
|
||||
<p>
|
||||
^{answer}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Get Licence by AVS Person ID:
|
||||
^{getLicForm}
|
||||
$maybe answer <- mbGetLic
|
||||
<p>
|
||||
^{answer}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Set Licence by AVS Person ID:
|
||||
^{setLicForm}
|
||||
$maybe answer <- mbSetLic
|
||||
<p>
|
||||
^{answer}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Synchronize licences with AVS.
|
||||
^{qryLicForm}
|
||||
$maybe answer <- mbQryLic
|
||||
<p>
|
||||
^{answer}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Person search:
|
||||
^{personForm}
|
||||
$maybe answer <- mbPerson
|
||||
<p>
|
||||
@ -15,7 +47,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<p>
|
||||
Person Status:
|
||||
Person status:
|
||||
^{statusForm}
|
||||
$maybe answer <- mbStatus
|
||||
<p>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user