diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg
index ff4428e24..45e3c9131 100644
--- a/messages/uniworx/categories/avs/de-de-formal.msg
+++ b/messages/uniworx/categories/avs/de-de-formal.msg
@@ -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}
\ No newline at end of file
+AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
+AvsLicence: Fahrberechtigung
\ 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 831a371df..7660963b6 100644
--- a/messages/uniworx/categories/avs/en-eu.msg
+++ b/messages/uniworx/categories/avs/en-eu.msg
@@ -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}
\ No newline at end of file
+AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
+AvsLicence: Driving Licence
\ No newline at end of file
diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs
index 436de5a9c..b438803cd 100644
--- a/src/Handler/Admin/Avs.hs
+++ b/src/Handler/Admin/Avs.hs
@@ -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|
Success:
User created or updated.|]
+ (Right Nothing) ->
+ return $ Just [whamlet|Warning:
No user found.|]
+ (Left e) -> do
+ let msg = tshow (e :: SomeException)
+ return $ Just [whamlet|Error:
#{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|Success:
Licence #{tshow lic}|]
+ (Right Nothing) ->
+ return $ Just [whamlet|Warning:
User not found.|]
+ (Left e) -> do
+ let msg = tshow (e :: SomeException)
+ return $ Just [whamlet|Error:
#{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|Success:
Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
+ (Right False) ->
+ return $ Just [whamlet|Error:
Licence could not be set for #{tshow aid}.|]
+ (Left e) -> do
+ let msg = tshow (e :: SomeException)
+ return $ Just [whamlet|Error:
#{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|Success:
Licences sychronized.|]
+ (Right False) ->
+ return $ Just [whamlet|Error:
Licences could not be synchronized, see error log.|]
+ (Left e) -> do
+ let msg = tshow (e :: SomeException)
+ return $ Just [whamlet|Error:
#{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")
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 158b0a033..d604e7ed9 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -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)
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 3f7d374bf..69f166549 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -302,7 +302,11 @@ data FormIdentifier
| FIDAllocationRegister
| FIDAllocationNotification
| FIDAvsQueryPerson
- | FIDAvsQueryStatus
+ | FIDAvsQueryStatus
+ | FIDAvsCreateUser
+ | FIDAvsQueryLicenceDiffs
+ | FIDAvsQueryLicence
+ | FIDAvsSetLicence
| FIDLmsLetter
deriving (Eq, Ord, Read, Show)
diff --git a/templates/avs.hamlet b/templates/avs.hamlet
index 4cdddbc72..cd6cfa8e5 100644
--- a/templates/avs.hamlet
+++ b/templates/avs.hamlet
@@ -6,7 +6,39 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
- Person Search:
+ Upsert User by CardNo or Fraport Personnel Number:
+ ^{crUsrForm}
+ $maybe answer <- mbCrUser
+
+ ^{answer}
+
+
+
+ Get Licence by AVS Person ID:
+ ^{getLicForm}
+ $maybe answer <- mbGetLic
+
+ ^{answer}
+
+
+
+ Set Licence by AVS Person ID:
+ ^{setLicForm}
+ $maybe answer <- mbSetLic
+
+ ^{answer}
+
+
+
+ Synchronize licences with AVS.
+ ^{qryLicForm}
+ $maybe answer <- mbQryLic
+
+ ^{answer}
+
+
+
+ Person search:
^{personForm}
$maybe answer <- mbPerson
@@ -15,7 +47,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
- Person Status:
+ Person status:
^{statusForm}
$maybe answer <- mbStatus