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