diff --git a/messages/button/de.msg b/messages/button/de.msg index 3d6df1522..a0e59982a 100644 --- a/messages/button/de.msg +++ b/messages/button/de.msg @@ -4,4 +4,5 @@ AmbiguousButtons: Mehrere Submit-Buttons aktiv WrongButtonValue: Submit-Button hat falschen Wert -MultipleButtonValues: Submit-Button hat mehrere Werte \ No newline at end of file +MultipleButtonValues: Submit-Button hat mehrere Werte +BtnFormOutdated: Knopfdruck verworfen wegen zwischenzeitlicher Datenänderungen \ No newline at end of file diff --git a/messages/button/en.msg b/messages/button/en.msg index d2a12f40f..4f714d799 100644 --- a/messages/button/en.msg +++ b/messages/button/en.msg @@ -5,3 +5,4 @@ AmbiguousButtons: Multiple active submit buttons WrongButtonValue: Submit button has wrong value MultipleButtonValues: Submit button has multiple values +BtnFormOutdated: Button ignored due to interim data changes \ No newline at end of file diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 169fd2987..10e6d43cc 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -12,4 +12,7 @@ AvsVersionNo: Versionsnummer AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} AvsLicence: Fahrberechtigung -AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id \ No newline at end of file +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 \ 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 3ee9a293e..a7c3fa30f 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -12,4 +12,7 @@ AvsVersionNo: Version number AvsQueryEmpty: At least one query field must be filled! 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 \ No newline at end of file +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 \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 5215d16b5..4fe634943 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -47,6 +47,7 @@ getAdminR = do -- (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) + -- 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` -- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody}) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index d455788ae..0075a3652 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -2,9 +2,12 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + module Handler.Admin.Avs ( getAdminAvsR , postAdminAvsR + , getQualificationSynchR, postQualificationSynchR ) where import Import @@ -18,6 +21,14 @@ import Handler.Utils.Avs import Utils.Avs + +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Experimental as E hiding (from, on) +import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Utils as E + + -- Button needed only here data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) @@ -181,44 +192,44 @@ postAdminAvsR = do mbSetLic <- formResultMaybe setLicRes procFormSetLic - ((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest) - let procFormQryLic btn = case btn of - BtnCheckLicences -> do - res <- try $ do - allLicences <- throwLeftM avsQueryGetAllLicences - computeDifferingLicences allLicences - case res of - (Right diffs) -> do - let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs - r_grant = showLics AvsLicenceRollfeld - f_set = showLics AvsLicenceVorfeld - revoke = showLics AvsNoLicence - return $ Just [whamlet| -

Licence check differences: -

Grant R: -

- #{r_grant} -

Set to F: -

- #{f_set} -

Revoke licence: -

- #{revoke} - |] - (Left e) -> do - let msg = tshow (e :: SomeException) - return $ Just [whamlet|

Licence check error:

#{msg}|] - BtnSynchLicences -> do - res <- try synchAvsLicences - 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|

Licence synchronisation error:

#{msg}|] - mbQryLic <- formResultMaybe qryLicRes procFormQryLic + (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs + mbQryLic <- case qryLicRes of + Nothing -> return Nothing + (Just BtnCheckLicences) -> do + res <- try $ do + allLicences <- throwLeftM avsQueryGetAllLicences + computeDifferingLicences allLicences + case res of + (Right diffs) -> do + let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs + r_grant = showLics AvsLicenceRollfeld + f_set = showLics AvsLicenceVorfeld + revoke = showLics AvsNoLicence + return $ Just [whamlet| +

Licence check differences: +

Grant R: +

+ #{r_grant} +

Set to F: +

+ #{f_set} +

Revoke licence: +

+ #{revoke} + |] + (Left e) -> do + let msg = tshow (e :: SomeException) + return $ Just [whamlet|

Licence check error:

#{msg}|] + (Just BtnSynchLicences) -> do + res <- try synchAvsLicences + 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|

Licence synchronisation error:

#{msg}|] actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute siteLayoutMsg MsgMenuAvs $ do @@ -228,7 +239,77 @@ postAdminAvsR = do 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 } + setLicForm = wrapFormHere setLicWgt setLicEnctype -- TODO: use i18nWidgetFile instead if this is to become permanent $(widgetFile "avs") + +{- + +type SynchTableExpr = ( E.SqlExpr (E.Value AvsPersonId) + `E.LeftOuterJoin` E.SqlExpr (Entity UserAvs) + `E.LeftOuterJoin` ( E.SqlExpr (Entity Qualification) + `E.InnerJoin` E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + )) + +type SynchDBRow = (E.Value AvsPersonId, E.Value AvsLicence, Entity Qualification, Entity QualificationUser, Entity User) +-} + + +data ButtonAvsSynch = BtnRevokeAvsLicences | BtnImportUnknownAvsIds + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonAvsSynch +instance Finite ButtonAvsSynch + +nullaryPathPiece ''ButtonAvsSynch camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonAvsSynch id + +instance Button UniWorX ButtonAvsSynch where + btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary] + btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger] + + +postQualificationSynchR, getQualificationSynchR :: Handler Html +postQualificationSynchR = getQualificationSynchR +getQualificationSynchR = do + -- TODO: just for Testing + now <- liftIO getCurrentTime + let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) + setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes] + -- (setTo0, _setTo1, _setTo2) <- retrieveDifferingLicences + unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros -> + runDB $ E.select $ do + (toZero :& usrAvs) <- X.from $ + E.toValues neZeros `E.leftJoin` E.table @UserAvs + `X.on` (\(toZero :& usrAvs) -> usrAvs E.?. UserAvsPersonId E.==. E.just toZero) + E.where_ $ E.isNothing (usrAvs E.?. UserAvsPersonId) + pure toZero + let unknownLicenceOwners = E.unValue <$> unknownLicenceOwners' + numUnknownLicenceOwners = length unknownLicenceOwners + (btnUnknownWgt, btnUnknownRes) <- runButtonFormHash (hash unknownLicenceOwners) FIDAbsUnknownLicences + case btnUnknownRes of + (Just BtnImportUnknownAvsIds) -> addMessage Info "UnknownAvsIds pressed." + -- do + -- let procAid = (Sum . (maybe 0 (const 1))) <$> upsertAvsUserById + -- oks <- getSum <$> foldMapM procAid unknownLicenceOwners + -- let ms = if oks == numUnkownLicenceOwners then Info else Warning + -- addMessageI ms $ MsgAvsImportIDs oks + + + (Just BtnRevokeAvsLicences) -> addMessage Info "Revoke Avs Licences pressed." + Nothing -> return () + + -- move elsewhere? + -- let dbtIdent = "drivingLicenceSynch" :: Text + -- dbtStyle = def + {- dbtSQLQuery = \(usrAvs `E.LeftOuterJoin` (qaul `E.InnerJoin` qualUser `E.InnerJoin` user)) -> do + E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser + E.on $ qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification + E.on $ user E.^. UserId E.==. usrAvs E.^ UserAvsUser + E.where_ $ E.isJust (qual E.^. QualificationAvsLicence) + -} + siteLayoutMsg MsgAvsTitleLicenceSynch $ do + setTitleI MsgAvsTitleLicenceSynch + $(i18nWidgetFile "avs-synchronisation") + + \ No newline at end of file diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index aa91006f3..c5341bad7 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -177,8 +177,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either - let nowaday = utctDay now - noOne = AvsPersonId 0 + let nowaday = utctDay now vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' @@ -200,13 +199,13 @@ getDifferingLicences (AvsResponseGetLicences licences) = do ) `E.innerJoin` E.table @UserAvs `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) - ) `E.fullOuterJoin` E.toValues (set2NonEmpty noOne avsLics) -- left-hand side produces all currently valid matching qualifications + ) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications `E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl) E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join return (usrAvs E.?. UserAvsPersonId, excl) unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId) - unwrapIds = mapBoth (Set.delete noOne) . foldr aux mempty + unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty where aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 319b7e68e..ca1ad2599 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -183,7 +183,7 @@ discernAvsCardPersonalNo _ = Nothing -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int deriving (Eq, Ord, Generic, Typeable) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable) instance E.SqlString AvsPersonId -- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API; instance FromJSON AvsPersonId where @@ -196,6 +196,9 @@ instance Show AvsPersonId where instance Read AvsPersonId where readPrec = fmap AvsPersonId readPrec +-- | Non-existing default, also needed for query all ramp driving licences +avsPersonIdZero :: AvsPersonId +avsPersonIdZero = AvsPersonId 0 -- this mus be zero acording to VSM specification newtype AvsObjPersonId = AvsObjPersonId -- tagged object { avsObjPersonID :: AvsPersonId diff --git a/src/Utils.hs b/src/Utils.hs index 0213629d9..fc4f9b211 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -708,6 +708,10 @@ partitionWith f (x:xs) = case f x of nonEmpty' :: Alternative f => [a] -> f (NonEmpty a) nonEmpty' = maybe empty pure . nonEmpty +whenNonEmpty :: (Applicative f, Monoid a, MonoFoldable mono) => mono -> (NonEmpty (Element mono) -> f a) -> f a +whenNonEmpty (toList -> h:t) = ($ (h :| t)) +whenNonEmpty _ = const $ pure mempty + dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq dropWhileM p xs' | Just (x, xs) <- uncons xs' @@ -734,6 +738,7 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a pattern NonEmpty x xs = x :| xs {-# COMPLETE NonEmpty #-} + ---------- -- Sets -- ---------- diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 5dffe2666..1ce36fc89 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -55,7 +55,7 @@ makeLenses_ ''AvsQuery -- | To query all active licences, a special constant argument must be prepared avsQueryAllLicences :: AvsQueryGetLicences -avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId $ AvsPersonId 0 +avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 69f166549..4aef3c423 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -308,6 +308,7 @@ data FormIdentifier | FIDAvsQueryLicence | FIDAvsSetLicence | FIDLmsLetter + | FIDAbsUnknownLicences deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -373,6 +374,7 @@ class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessa data ButtonMessage = MsgAmbiguousButtons | MsgWrongButtonValue | MsgMultipleButtonValues + | MsgBtnFormOutdated deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -- | Default button for submitting. Required in Foundation for Login, other Buttons defined in Handler.Utils.Form @@ -561,6 +563,30 @@ runButtonForm' btns fid = do return (btnForm, res) +-- | 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 ::(PathPiece ident, Eq ident, RenderAFormSite site + , RenderMessage site (ValueRequired site) + , Button site ButtonSubmit, Button site a, Finite a) + => Int -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) +runButtonFormHash hVal fid = do + currentRoute <- getCurrentRoute + let bForm = disambiguateButtons $ combinedButtonFieldF "" + hForm = areq hiddenField "" $ Just hVal + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> + flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm + let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute + , formEncoding = btnEnctype + , formSubmit = FormNoSubmit + } + res <- formResultMaybe btnResult $ \case + (_, rVal) | rVal /= hVal -> addMessageI Error MsgBtnFormOutdated + >> return Nothing + (btn, _ ) -> return $ Just btn + return (btnForm, res) + + + ------------------- -- Custom Fields -- ------------------- diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet new file mode 100644 index 000000000..e511d2c83 --- /dev/null +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -0,0 +1,33 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + + +
+

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

+ Es wurden #{length unknownLicenceOwners} + Personen mit einer Fahrberechtigung im AVS gefunden, + welche FRADrive unbekannt sind. + + 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 +

+ Hier folgt eine dbTable mit Actions \ No newline at end of file diff --git a/templates/i18n/avs-synchronisation/en-eu.hamlet b/templates/i18n/avs-synchronisation/en-eu.hamlet new file mode 100644 index 000000000..6ded32437 --- /dev/null +++ b/templates/i18n/avs-synchronisation/en-eu.hamlet @@ -0,0 +1,40 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + + +

+

+ 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 +

+ Hier folgt eine dbTable mit Actions \ No newline at end of file