chore(avs): distinguish grant vorfeld between up and downgrade
This commit is contained in:
Steffen Jost
parent
6fcc48dea4
commit
b97c28413b
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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`
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
@ -17,12 +17,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<dt .deflist__dt>^{flagError False}
|
||||
<dd .deflist__dd>^{modal (i18n MsgProblemsAvsProblem) (Right err)}
|
||||
|
||||
$of Right (ok0,ok1,ok2)
|
||||
$of Right (ok0,ok1up,ok1down,ok2)
|
||||
<dt .deflist__dt>^{flagNonZero ok2}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch2 ProblemAvsSynchR}
|
||||
|
||||
<dt .deflist__dt>^{flagNonZero ok1}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1 ProblemAvsSynchR}
|
||||
<dt .deflist__dt>^{flagNonZero ok1down}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1down ProblemAvsSynchR}
|
||||
|
||||
<dt .deflist__dt>^{flagNonZero ok1up}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR}
|
||||
|
||||
<dt .deflist__dt>^{flagNonZero ok0}
|
||||
<dd .deflist__dd>^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR}
|
||||
|
||||
@ -7,42 +7,42 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
AVS Fahrberechtigte, welche FRADrive unbekannt sind
|
||||
Personendaten aller AVS Fahrberechtigten
|
||||
|
||||
$if numUnknownLicenceOwners > 0
|
||||
<p>
|
||||
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: #
|
||||
<p>
|
||||
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.
|
||||
|
||||
<p>
|
||||
Option 2:
|
||||
|
||||
Fahrberechtigungen all dieser Personen im AVS entziehen.
|
||||
^{btnUnknownWgt}
|
||||
|
||||
$else
|
||||
<p>
|
||||
Die Personendaten aller Fahrberechtigten im AVS sind FRADrive derzeit bekannt.
|
||||
Die Personendaten aller Fahrberechtigten im AVS sind auch in FRADrive bekannt.
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
Abweichende Fahrberechtigungen auflösen
|
||||
Abweichende Fahrberechtigungen
|
||||
<p>
|
||||
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.
|
||||
<h3>
|
||||
Fahrberechtigung Rollfeld im AVS erteilen
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
Rollfeld Berechtigung entziehen, Fahrberechtigung Vorfeld erteilen
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
Fahrberechtigung Vorfeld im AVS erteilen
|
||||
<p>
|
||||
^{tb1}
|
||||
^{tb1up}
|
||||
<h3>
|
||||
Jegliche Fahrberechtigung im AVS entziehen
|
||||
<p>
|
||||
|
||||
@ -6,37 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<h1>
|
||||
Please use GERMAN translation of this page for now. Below is outdated. TODO.
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
AVS Fahrberechtigte, welche FRADrive unbekannt sind
|
||||
|
||||
$if numUnknownLicenceOwners > 0
|
||||
<p>
|
||||
Es wurden #{length unknownLicenceOwners}
|
||||
Personen mit einer Fahrberechtigung im AVS gefunden,
|
||||
welche FRADrive unbekannt sind.
|
||||
|
||||
^{btnUnknownWgt}
|
||||
|
||||
<p>
|
||||
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.
|
||||
|
||||
<p>
|
||||
Option 2:
|
||||
|
||||
Fahrberechtigungen all dieser Personen im AVS entziehen.
|
||||
|
||||
$else
|
||||
<p>
|
||||
Die Personendaten aller Fahrberechtigten im AVS sind FRADrive derzeit bekannt.
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
Abweichende Fahrberechtigungen auflösen
|
||||
Use German translation
|
||||
<p>
|
||||
Hier folgt eine dbTable mit Actions
|
||||
This page has not yet been translated to English yet.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user