From b97c28413b2ce92c51ce3733e7588b36e3c25ec1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 22 Dec 2022 16:06:03 +0100 Subject: [PATCH] chore(avs): distinguish grant vorfeld between up and downgrade --- .../uniworx/categories/admin/de-de-formal.msg | 5 ++- messages/uniworx/categories/admin/en-eu.msg | 5 ++- src/Handler/Admin.hs | 6 ++- src/Handler/Admin/Avs.hs | 33 ++++++++------- src/Handler/Utils/Avs.hs | 42 +++++++++++++------ src/Model/Types/Lms.hs | 2 +- src/Utils/Form.hs | 21 +++++----- templates/admin-problems.hamlet | 9 ++-- .../avs-synchronisation/de-de-formal.hamlet | 34 +++++++-------- .../i18n/avs-synchronisation/en-eu.hamlet | 36 ++-------------- 10 files changed, 96 insertions(+), 97 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 3de34f94f..ba5140988 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -99,8 +99,9 @@ ProblemsHeading: Problemübersicht ProblemsHeadingDrivers: Fahrberechtigungen ProblemsAvsProblem: Synchronisation mit AVS/MoBaKo komplett fehlgeschlagen ProblemsDriverSynch n@Int: #{tshow n} Diskrepanzen zwischen AVS und FRADrive -ProblemsDriverSynch0: Alle Sperrungen von Fahrberechtigungen sind im AVS eingetragen -ProblemsDriverSynch1: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen +ProblemsDriverSynch0: Alle Sperrungen von Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen +ProblemsDriverSynch1down: Alle Sperrungen von Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen +ProblemsDriverSynch1up: Alle gültigen Vorfeld-Fahrberechtigungen 'F' sind im AVS eingetragen ProblemsDriverSynch2: Alle gültigen Rollfeld-Fahrberechtigungen 'R' sind im AVS eingetragen ProblemsRDriversHaveFs: Alle Inhaber einer Rollfeld-Fahrberechtigung besitzen auch eine gültige Vorfeld-Fahrberechtigung ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS Identifikationsnummer zugeordnet werden diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 37cca0d0f..1c7d95a49 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -99,8 +99,9 @@ ProblemsHeading: Overview Problems ProblemsHeadingDrivers: Driving Licences ProblemsAvsProblem: Synchronisation with AVS/MoBaKo failed entirely ProblemsDriverSynch n: #{tshow n} mismatches between AVS and FRADrive -ProblemsDriverSynch0: All revocations of driving licences were successfully registered with AVS -ProblemsDriverSynch1: All valid apron driving licences 'F' were successfully registered with AVS +ProblemsDriverSynch0: All revocations of apron driving licences 'F' were successfully registered with AVS +ProblemsDriverSynch1down: All revocations of maneuvering area driving licences 'R' were successfully registered with AVS +ProblemsDriverSynch1up: All valid apron driving licences 'F' were successfully registered with AVS ProblemsDriverSynch2: All valid maneuvering area driving licences 'R' were successfully registered with AVS ProblemsRDriversHaveFs: All driving licence 'R' holders also have a valid 'F' licence ProblemsDriversHaveAvsIds: All driving licence holder could be matched with their AVS id diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 94d6e2e29..1594693a7 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -49,7 +49,11 @@ getAdminProblemsR = do diffLics <- try retrieveDifferingLicences <&> \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> Left $ text2widget $ tshow (e :: SomeException) - (Right (to0, to1, to2)) -> Right (Set.size to0, Set.size to1, Set.size to2) + (Right AvsLicenceDifferences{..}) -> Right ( Set.size avsLicenceDiffRevokeAll + , Set.size avsLicenceDiffGrantVorfeld + , Set.size avsLicenceDiffRevokeRollfeld + , Set.size avsLicenceDiffGrantRollfeld + ) -- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself -- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2) -- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches` diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 169700aa0..0292c4732 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -311,16 +311,17 @@ getProblemAvsSynchR = do -- TODO: just for Testing -- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) - -- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678] - -- setTo1 = Set.fromList [AvsPersonId minutes] - -- setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678] - - (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case + -- avsLicenceDiffRevokeAll = Set.fromList [AvsPersonId hours, AvsPersonId minutes] + -- avsLicenceDiffGrantVorfeld = Set.fromList [AvsPersonId minutes] + -- avsLicenceDiffRevokeRollfeld = Set.fromList [AvsPersonId hours, AvsPersonId 12345678] + -- avsLicenceDiffGrantRollfeld = Set.fromList [AvsPersonId hours] + + AvsLicenceDifferences{..} <- try retrieveDifferingLicences >>= \case Right res -> return res Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) redirect AdminR - - unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros -> + -- unknowns + unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros -> runDB $ E.select $ do (toZero :& usrAvs) <- X.from $ E.toValues neZeros `E.leftJoin` E.table @UserAvs @@ -349,11 +350,12 @@ getProblemAvsSynchR = do | otherwise -> addMessageI Info MsgRevokeUnknownLicencesOk Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR - - ((tres0,tb0),(tres1,tb1),(tres2,tb2)) <- runDB $ (,,) - <$> mkLicenceTable "driveSynchNoLicence" AvsNoLicence setTo0 (Just LicenceTableChangeAvs) - <*> mkLicenceTable "driveSynchVorfeld" AvsLicenceVorfeld setTo1 (Just LicenceTableChangeAvs) - <*> mkLicenceTable "driveSynchRollfeld" AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs) + -- licence differences + ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) + <$> mkLicenceTable "avsLicDiffRevokeVorfeld" AvsNoLicence avsLicenceDiffRevokeAll (Just LicenceTableChangeAvs) + <*> mkLicenceTable "avsLicDiffGrantVorfeld" AvsLicenceVorfeld avsLicenceDiffGrantVorfeld (Just LicenceTableChangeAvs) + <*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsNoLicence avsLicenceDiffRevokeRollfeld (Just LicenceTableChangeAvs) + <*> mkLicenceTable "avsLicDiffGrantRollfeld" AvsLicenceRollfeld avsLicenceDiffGrantRollfeld (Just LicenceTableChangeAvs) let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () procRes aLic (LicenceTableChangeAvsData , apids) = do try (setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids) >>= \case @@ -388,9 +390,10 @@ getProblemAvsSynchR = do -- procRes alic (LicenceTableGrantFDriveData{..}, apids ) = do -- TODO: continue here !!! procRes _alic r@(_, _apids) = addMessage Error $ toHtml $ "NOT YET IMPLEMENTED !!! " <> tshow r - formResult tres2 $ procRes AvsLicenceRollfeld - formResult tres1 $ procRes AvsLicenceVorfeld - formResult tres0 $ procRes AvsNoLicence + formResult tres2 $ procRes AvsLicenceRollfeld + formResult tres1up $ procRes AvsLicenceVorfeld + formResult tres1down $ procRes AvsLicenceVorfeld + formResult tres0 $ procRes AvsNoLicence siteLayoutMsg MsgAvsTitleLicenceSynch $ do setTitleI MsgAvsTitleLicenceSynch diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 79c260d43..085b2a8a2 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -9,6 +9,7 @@ module Handler.Utils.Avs ( validQualification, validQualification' , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface + , AvsLicenceDifferences(..) , setLicence, setLicenceAvs, setLicencesAvs , retrieveDifferingLicences, computeDifferingLicences , synchAvsLicences @@ -179,20 +180,31 @@ synchAvsLicences = do else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete." return setOk -computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) -computeDifferingLicences argl = do - (setTo0, setTo1, setTo2) <- getDifferingLicences argl - return $ Set.map (AvsPersonLicence AvsNoLicence) setTo0 - <> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1 - <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2 +data AvsLicenceDifferences = AvsLicenceDifferences + { avsLicenceDiffRevokeAll :: Set AvsPersonId -- revoke all driving licences in AVS (set 0) + , avsLicenceDiffGrantVorfeld :: Set AvsPersonId -- grant apron driving licence in AVS (set 1, upgrade from 0) + , avsLicenceDiffRevokeRollfeld :: Set AvsPersonId -- revoke maneuvering area driving licence, but retain apron driving licence (set 1, downgrade from 2) + , avsLicenceDiffGrantRollfeld :: Set AvsPersonId -- grant maneuvering area driving licence (set 2) + } + deriving (Show) -retrieveDifferingLicences :: Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId) +avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence +avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = + Set.map (AvsPersonLicence AvsNoLicence) avsLicenceDiffRevokeAll + <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffGrantVorfeld + <> Set.map (AvsPersonLicence AvsLicenceVorfeld) avsLicenceDiffRevokeRollfeld + <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld + +computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) +computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences + +retrieveDifferingLicences :: Handler AvsLicenceDifferences retrieveDifferingLicences = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery allLicences <- throwLeftM avsQueryGetAllLicences getDifferingLicences allLicences -getDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId) +getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences getDifferingLicences (AvsResponseGetLicences licences) = do now <- liftIO getCurrentTime --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences @@ -233,10 +245,16 @@ getDifferingLicences (AvsResponseGetLicences licences) = do ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,) <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld - let setTo0 = vorfRevoke -- ready to use with SET 0 - setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke) - setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) - return (setTo0, setTo1, setTo2) + let setTo0 = vorfRevoke -- revoke driving licences + setTo1up = vorfGrant Set.\\ rollGrant -- grant apron driving licence + setTo1down = rollRevoke Set.\\ vorfRevoke -- revoke maneuvering area licence, but retain apron driving licence + setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld) -- grant maneuvering driving licence + return AvsLicenceDifferences + { avsLicenceDiffRevokeAll = setTo0 + , avsLicenceDiffGrantVorfeld = setTo1up + , avsLicenceDiffRevokeRollfeld = setTo1down + , avsLicenceDiffGrantRollfeld = setTo2 + } {- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 9f6ff5a98..36370ba72 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -67,7 +67,7 @@ instance Csv.ToField LmsStatus where data QualificationBlocked = QualificationBlockedLms { qualificationBlockedDay :: Day } - | QualificationBlockedAvs { qualificationBlockedDay :: Day } + | QualificationBlockedAvs { qualificationBlockedDay :: Day } -- not yet used deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) deriveJSON defaultOptions diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index d250dfff0..5c630b4ce 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -546,8 +546,8 @@ runButtonForm fid = do return (btnForm, res) -- | like `runButtonForm` but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass. -runButtonForm' ::(PathPiece ident, Eq ident, RenderMessage site FormMessage, - Button site ButtonSubmit, Button site a) +runButtonForm' :: ( PathPiece ident, Eq ident, RenderMessage site FormMessage + , Button site ButtonSubmit, Button site a) => [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) runButtonForm' btns fid = do currentRoute <- getCurrentRoute @@ -562,14 +562,13 @@ runButtonForm' btns fid = do -- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure -- that the button press still applies to the correct situation -runButtonFormHash ::( Hashable h, PathPiece ident, Eq ident, RenderAFormSite site - , RenderMessage site (ValueRequired site) - , Button site ButtonSubmit, Button site a, Finite a) +runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site + , Button site ButtonSubmit, Button site a, Finite a, Hashable h) => h -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) runButtonFormHash (hash -> hVal) fid = do currentRoute <- getCurrentRoute let bForm = disambiguateButtons $ combinedButtonFieldF "" - hForm = areq hiddenField "" $ Just hVal + hForm = aopt hiddenField "" $ Just $ Just hVal ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute @@ -577,11 +576,11 @@ runButtonFormHash (hash -> hVal) fid = do , formSubmit = FormNoSubmit } res <- formResultMaybe btnResult $ \case - (_, rVal) | rVal /= hVal -> do - addMessageI Error MsgBtnFormOutdated - whenIsJust currentRoute redirect -- redirect needed to reset hidden-field - return Nothing - (btn, _ ) -> return $ Just btn + (btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching + _ -> do + addMessageI Error MsgBtnFormOutdated + whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value + return Nothing return (btnForm, res) diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index 4f16c1042..60227f240 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -17,12 +17,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
^{flagError False}
^{modal (i18n MsgProblemsAvsProblem) (Right err)} - $of Right (ok0,ok1,ok2) + $of Right (ok0,ok1up,ok1down,ok2)
^{flagNonZero ok2}
^{simpleLinkI MsgProblemsDriverSynch2 ProblemAvsSynchR} -
^{flagNonZero ok1} -
^{simpleLinkI MsgProblemsDriverSynch1 ProblemAvsSynchR} +
^{flagNonZero ok1down} +
^{simpleLinkI MsgProblemsDriverSynch1down ProblemAvsSynchR} + +
^{flagNonZero ok1up} +
^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR}
^{flagNonZero ok0}
^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet index 707595162..37fb9de6f 100644 --- a/templates/i18n/avs-synchronisation/de-de-formal.hamlet +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -7,42 +7,42 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

- AVS Fahrberechtigte, welche FRADrive unbekannt sind + Personendaten aller AVS Fahrberechtigten $if numUnknownLicenceOwners > 0

Es wurden #{length unknownLicenceOwners} Personen mit - einer Fahrberechtigung im AVS gefunden, - welche FRADrive unbekannt sind. - - ^{btnUnknownWgt} + einer Fahrberechtigung im AVS gefunden, # + welche FRADrive unbekannt sind. # + Es gibt zwei Möglichkeiten zum Auflösen dieses Problems: #

- Option 1: - - Personendaten aus dem AVS importeren, Fahrberechtigungen in AVS und FRADrive bleiben dabei erst einmal unverändert, - d.h. der Konflikt muss danach noch im nächsten Abschnitt aufgelöst werden. - -

- Option 2: - - Fahrberechtigungen all dieser Personen im AVS entziehen. + ^{btnUnknownWgt} $else

- Die Personendaten aller Fahrberechtigten im AVS sind FRADrive derzeit bekannt. + Die Personendaten aller Fahrberechtigten im AVS sind auch in FRADrive bekannt.

- Abweichende Fahrberechtigungen auflösen + Abweichende Fahrberechtigungen +

+ Die folgenden Abschnitte zeigen alle Abweichungen + zwischen dem AVS und den in FRADrive vorliegenden Fahrberechtigungen. # + Es wird dringend empfohlen, die Fahrberechtigungen im AVS anzupassen + und nicht umgekehrt.

Fahrberechtigung Rollfeld im AVS erteilen

^{tb2} +

+ Rollfeld Berechtigung entziehen, Fahrberechtigung Vorfeld erteilen +

+ ^{tb1down}

Fahrberechtigung Vorfeld im AVS erteilen

- ^{tb1} + ^{tb1up}

Jegliche Fahrberechtigung im AVS entziehen

diff --git a/templates/i18n/avs-synchronisation/en-eu.hamlet b/templates/i18n/avs-synchronisation/en-eu.hamlet index 1daaba579..79ed4575e 100644 --- a/templates/i18n/avs-synchronisation/en-eu.hamlet +++ b/templates/i18n/avs-synchronisation/en-eu.hamlet @@ -6,37 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

- Please use GERMAN translation of this page for now. Below is outdated. TODO. - -
-

- AVS Fahrberechtigte, welche FRADrive unbekannt sind - - $if numUnknownLicenceOwners > 0 -

- Es wurden #{length unknownLicenceOwners} - Personen mit einer Fahrberechtigung im AVS gefunden, - welche FRADrive unbekannt sind. - - ^{btnUnknownWgt} - -

- Option 1: - - Personendaten aus dem AVS importeren, Fahrberechtigungen in AVS und FRADrive bleiben dabei erst einmal unverändert, - d.h. der Konflikt muss danach noch im nächsten Abschnitt aufgelöst werden. - -

- Option 2: - - Fahrberechtigungen all dieser Personen im AVS entziehen. - - $else -

- Die Personendaten aller Fahrberechtigten im AVS sind FRADrive derzeit bekannt. - -

-

- Abweichende Fahrberechtigungen auflösen + Use German translation

- Hier folgt eine dbTable mit Actions \ No newline at end of file + This page has not yet been translated to English yet. +