From 06f283be7ef1198e1010e7a3eec764fe6ef4bf27 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Jan 2023 17:36:11 +0100 Subject: [PATCH] chore(avs): add safety catch for revoke unknown avs licences --- .../uniworx/categories/avs/de-de-formal.msg | 5 +- messages/uniworx/categories/avs/en-eu.msg | 5 +- src/Handler/Admin/Avs.hs | 95 +++++++++++-------- src/Utils/Form.hs | 6 +- src/Utils/Frontend/Modal.hs | 6 +- templates/i18n/admin-test/de-de-formal.hamlet | 2 +- templates/i18n/admin-test/en-eu.hamlet | 7 +- .../avs-synchronisation/de-de-formal.hamlet | 2 +- .../i18n/avs-synchronisation/en-eu.hamlet | 3 +- 9 files changed, 80 insertions(+), 51 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 351ced6a1..e1c14dd4f 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -14,8 +14,9 @@ AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! AvsLicence: Fahrberechtigung AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive -BtnRevokeAvsLicences: Fahrberechtigungen im AVS sofort entziehen -BtnImportUnknownAvsIds: Daten unbekannter Personen importieren +BtnAvsRevokeUnknown: Fahrberechtigungen im AVS sofort entziehen +BtnAvsImportUnknown: AVS Daten unbekannter Personen importieren +AvsRevokeFor n@Int: Sind Sie absolut sicher, dass Sie #{n} #{pluralDE n "unbekanntem Fahrer" "unbekannten Fahrern"} jegliche Fahrlizenz im AVS sofort entziehen wollen? AvsImportIDs n@Int m@Int: AVS Persondendaten importiert: #{show n}/#{show m} AvsImportAmbiguous n@Int: Import für #{show n} uneindeutige AVS IDs fehlgeschlagen AvsImportUnknowns n@Int: Import für #{show n} unbekannte AVS IDs fehlgeschlagen diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 05b2f16a2..7499244f6 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -14,8 +14,9 @@ AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} AvsLicence: Driving Licence AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive -BtnRevokeAvsLicences: Revoke AVS driving licences immediately -BtnImportUnknownAvsIds: Import unknown person data +BtnAvsRevokeUnknown: Revoke AVS driving licences for unknown persons immediately +BtnAvsImportUnknown: Import AVS data for unknown persons +AvsRevokeFor n@Int: Are you sure to immediately revoke all apron driving licences for #{n} unknown #{pluralENs n "driver"}? AvsImportIDs n m: AVS person data imported: #{show n}/#{show m} AvsImportAmbiguous n@Int: Import failed for #{show n} ambiguous AVS Ids AvsImportUnknowns n@Int: Import failed for #{show n} unknown AVS Ids diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index d06081f09..5edaee4bb 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -39,7 +39,7 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton --- Button needed only here +-- Button only needed in AVS TEST; further buttons see below data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonAvsTest @@ -277,18 +277,24 @@ type SynchTableExpr = ( E.SqlExpr (E.Value AvsPersonId) type SynchDBRow = (E.Value AvsPersonId, E.Value AvsLicence, Entity Qualification, Entity QualificationUser, Entity User) -} - -data ButtonAvsSynch = BtnImportUnknownAvsIds | BtnRevokeAvsLicences +-- Buttons only needed for AVS Synching +data ButtonAvsImportUnknown = BtnAvsImportUnknown deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonAvsSynch -instance Finite ButtonAvsSynch +instance Universe ButtonAvsImportUnknown +instance Finite ButtonAvsImportUnknown +nullaryPathPiece ''ButtonAvsImportUnknown camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonAvsImportUnknown id +instance Button UniWorX ButtonAvsImportUnknown where + btnClasses BtnAvsImportUnknown = [BCIsButton, BCPrimary] -nullaryPathPiece ''ButtonAvsSynch camelToPathPiece -embedRenderMessage ''UniWorX ''ButtonAvsSynch id - -instance Button UniWorX ButtonAvsSynch where - btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary] - btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger] +data ButtonAvsRevokeUnknown = BtnAvsRevokeUnknown + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonAvsRevokeUnknown +instance Finite ButtonAvsRevokeUnknown +nullaryPathPiece ''ButtonAvsRevokeUnknown camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonAvsRevokeUnknown id +instance Button UniWorX ButtonAvsRevokeUnknown where + btnClasses BtnAvsRevokeUnknown = [BCIsButton, BCDanger] data LicenceTableAction = LicenceTableChangeAvs @@ -310,7 +316,7 @@ data LicenceTableActionData = LicenceTableChangeAvsData postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR = getProblemAvsSynchR -getProblemAvsSynchR = do +getProblemAvsSynchR = do let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r) catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences @@ -325,32 +331,47 @@ getProblemAvsSynchR = do pure toZero let unknownLicenceOwners = E.unValue <$> unknownLicenceOwners' numUnknownLicenceOwners = length unknownLicenceOwners - (btnUnknownWgt, btnUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDAbsUnknownLicences - case btnUnknownRes of - Nothing -> return () - (Just BtnImportUnknownAvsIds) -> catchAllAvs $ do - res <- forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job - let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty) - --TODO: continue here! - --procRes (Left (AvsUserAmbiguous api)) = (Sum 0, Set.singleton api, mempty, mempty) - --procRes (Left (AvsUserUnknownByAvs api)) = (Sum 0, mempty, Set.singleton api, mempty) - procRes (Left (err :: SomeException)) = (Sum 0, mempty, mempty, Set.singleton $ tshow err) - (Sum oks, ambis, unkns, errs) = foldMap procRes res - ms = if oks == numUnknownLicenceOwners then Success else Warning - unless (null ambis) $ addMessageModal Error (i18n $ MsgAvsImportAmbiguous $ length ambis) (Right (text2widget $ tshow ambis)) - unless (null unkns) $ addMessageModal Error (i18n $ MsgAvsImportUnknowns $ length unkns) (Right (text2widget $ tshow unkns)) - unless (null errs) $ addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow errs )) - addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners - redirect ProblemAvsSynchR - (Just BtnRevokeAvsLicences) -> catchAllAvs $ do - let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners - no_revokes = Set.size revokes - oks <- setLicencesAvs revokes - if oks < no_revokes - then addMessageI Error MsgRevokeUnknownLicencesFail - else addMessageI Info MsgRevokeUnknownLicencesOk - redirect ProblemAvsSynchR + (btnImportUnknownWgt, btnImportUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsImportUnknown + ifMaybeM btnImportUnknownRes () $ \BtnAvsImportUnknown -> catchAllAvs $ do + res <- forM (take 500 unknownLicenceOwners) $ try . upsertAvsUserById -- TODO: turn this into a background job + let procRes (Right _) = (Sum 1, mempty :: Set.Set AvsPersonId, mempty :: Set.Set AvsPersonId, mempty) + --TODO: continue here! + --procRes (Left (AvsUserAmbiguous api)) = (Sum 0, Set.singleton api, mempty, mempty) + --procRes (Left (AvsUserUnknownByAvs api)) = (Sum 0, mempty, Set.singleton api, mempty) + procRes (Left (err :: SomeException)) = (Sum 0, mempty, mempty, Set.singleton $ tshow err) + (Sum oks, ambis, unkns, errs) = foldMap procRes res + ms = if oks == numUnknownLicenceOwners then Success else Warning + unless (null ambis) $ addMessageModal Error (i18n $ MsgAvsImportAmbiguous $ length ambis) (Right (text2widget $ tshow ambis)) + unless (null unkns) $ addMessageModal Error (i18n $ MsgAvsImportUnknowns $ length unkns) (Right (text2widget $ tshow unkns)) + unless (null errs) $ addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow errs )) + addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners + redirect ProblemAvsSynchR + + (btnRevokeUnknownWgt, btnRevokeUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDBtnAvsRevokeUnknown + let revokeUnknownExecWgt = btnRevokeUnknownWgt + revokeUnknownSafetyWgt = [whamlet| +
+
+
+ ^{modalBtn} + |] + modalBtn = btnModal MsgBtnAvsRevokeUnknown (btnClasses BtnAvsRevokeUnknown) (Right youSureWgt) + youSureWgt = [whamlet| +

+ _{MsgAvsRevokeFor (length unknownLicenceOwners)} +

+ ^{revokeUnknownExecWgt} + |] + + ifMaybeM btnRevokeUnknownRes () $ \BtnAvsRevokeUnknown -> catchAllAvs $ do + let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners + no_revokes = Set.size revokes + oks <- setLicencesAvs revokes + if oks < no_revokes + then addMessageI Error MsgRevokeUnknownLicencesFail + else addMessageI Info MsgRevokeUnknownLicencesOk + redirect ProblemAvsSynchR -- licence differences ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 3878aa51e..6e7c5c8bb 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -297,15 +297,15 @@ data FormIdentifier | FIDLanguage | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDExamAutoOccurrenceIgnoreRoom UUID | FIDTestDownload + | FIDLmsLetter | FIDAvsQueryPerson | FIDAvsQueryStatus | FIDAvsCreateUser | FIDAvsQueryLicenceDiffs | FIDAvsQueryLicence | FIDAvsSetLicence - | FIDAvsRemoveLicences - | FIDLmsLetter - | FIDAbsUnknownLicences + | FIDBtnAvsImportUnknown + | FIDBtnAvsRevokeUnknown deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index 8709b7314..c7c3ad8d0 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -49,15 +49,15 @@ modal modalTrigger' modalContent = customModal Modal{..} modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger") -- | Variant of `modal` that looks like a button -btnModal :: (PathPiece (ButtonClass site)) - => Text -- ^ Button Text +btnModal :: (RenderMessage site a, PathPiece (ButtonClass site)) + => a -- ^ Button Text -> [ButtonClass site] -- ^ Button class -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget -> WidgetFor site () -- ^ result widget btnModal btl bcs = modal fakeBtn where fakeBtn = [whamlet|