fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(avs): complete AVS synch resolutions options

Browse Source
This commit is contained in:
Steffen Jost 2022-12-23 16:22:55 +01:00
parent c27646978d
commit 913efb70ba
9 changed files with 105 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -20,6 +20,7 @@ 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
AvsSetLicences alic@AvsLicence n@Int m@Int: _{alic} im AVS gesetzt: #{show n}/#{show m}
SetFraDriveLicences q@String n@Int: #{q} in FRADrive gewährt für #{show n} Benutzer
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive zum Vortag beendet für #{show n} Fahrer
RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details

1
messages/uniworx/categories/avs/en-eu.msg
View File

@ -20,6 +20,7 @@ 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
AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m}
SetFraDriveLicences q@String n@Int: #{q} granted in FRADrive for #{show n} users
RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} now ended yesterday in FRADrive for #{show n} drivers
RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details

77
src/Handler/Admin/Avs.hs
View File

@ -306,21 +306,11 @@ data LicenceTableActionData = LicenceTableChangeAvsData
postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
postProblemAvsSynchR = getProblemAvsSynchR
getProblemAvsSynchR = do
now <- liftIO getCurrentTime
let nowaday = utctDay now
catchAllAvs = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR)
-- TODO: just for Testing
let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now)
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
-- unknowns
AvsLicenceDifferences{..} <- try retrieveDifferingLicences >>= \case
Right res -> return res
Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
redirect AdminR
--
unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
runDB $ E.select $ do
(toZero :& usrAvs) <- X.from $
@ -343,7 +333,7 @@ getProblemAvsSynchR = do
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))
unless (null errs) $ addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow errs ))
addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners
redirect ProblemAvsSynchR
@ -358,11 +348,21 @@ getProblemAvsSynchR = do
-- 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 ()
<$> mkLicenceTable "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll
<*> mkLicenceTable "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld
<*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld
<*> mkLicenceTable "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
#ifdef DEVELOPMENT
addMessage Info $ text2Html $ "0: " <> tshow tres0 -- DEBUG
addMessage Info $ text2Html $ "1u: " <> tshow tres1up -- DEBUG
addMessage Info $ text2Html $ "1d: " <> tshow tres1down -- DEBUG
addMessage Info $ text2Html $ "2: " <> tshow tres2 -- DEBUG
#endif
now <- liftIO getCurrentTime
let nowaday = utctDay now
catchAllAvs = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR)
procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
procRes aLic (LicenceTableChangeAvsData , apids) = catchAllAvs $ do
oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
let no_req = Set.size apids
@ -393,11 +393,19 @@ getProblemAvsSynchR = do
liftHandler $ addMessageI Success $ MsgRevokeFraDriveLicences alic oks
redirect ProblemAvsSynchR -- must be outside runDB
-- procRes alic (LicenceTableGrantFDriveData{..}, apids ) = do -- TODO: continue here !!!
procRes _alic r@(_, _apids) = addMessage Error $ toHtml $ "NOT YET IMPLEMENTED !!! " <> tshow r
procRes _alic (LicenceTableGrantFDriveData{..}, apids ) = do
(n, Qualification{qualificationShorthand}) <- runDB $ do
uas <- selectList [UserAvsPersonId <-. Set.toList apids] []
let uids = view _userAvsUser <$> uas
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd
(length uids,) <$> get404 licenceTableChangeFDriveQId
addMessageI Success $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
redirect ProblemAvsSynchR -- must be outside runDB
formResult tres2 $ procRes AvsLicenceRollfeld
formResult tres1up $ procRes AvsLicenceVorfeld
formResult tres1down $ procRes AvsLicenceVorfeld
formResult tres1up $ procRes AvsLicenceVorfeld
formResult tres0 $ procRes AvsNoLicence
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
@ -445,15 +453,16 @@ instance HasUser LicenceTableData where
hasUser = resultUser . _entityVal
mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAction -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable dbtIdent aLic apids defAct = do
mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
mkLicenceTable dbtIdent aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
now <- liftIO getCurrentTime
let nowaday = utctDay now
fltrLic qual = if
| aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS
| otherwise -> E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) -- if we suggest granting that licence, this join should deliver a value too
-- fltrLic qual = if
-- | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS
-- | otherwise -> E.isNothing (qual E.?. QualificationId) E.||. (E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)) -- if we suggest granting that licence, this join should deliver a value too
fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)
-- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution:
dbtSQLQuery = \((usrAvs `E.InnerJoin` user) `E.LeftOuterJoin` (qualUser `E.InnerJoin` qual)) -> do
E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification
@ -461,8 +470,7 @@ mkLicenceTable dbtIdent aLic apids defAct = do
E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
return (usrAvs, user, qualUser, qual)
dbtRowKey = (queryUserAvs >>> (E.^. UserAvsPersonId))
&&& (queryQualification >>> (E.?. QualificationId))
dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR?
--dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api, quali) -> return (user, qualUsr, api, quali) -- just remove Value wrapper in 3rd element
dbtProj = dbtProjFilteredPostId
dbtColonnade = mconcat
@ -503,13 +511,14 @@ mkLicenceTable dbtIdent aLic apids defAct = do
, optionInternalValue = qualId
, optionExternalValue = tshow cQualId
}
aLicQid = fmap entityKey . headMay $ filter ((== Just aLic) . qualificationAvsLicence . entityVal) avsQualifications
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
acts = mconcat
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
, if aLic /= AvsNoLicence
, if aLic == AvsNoLicence
then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) Nothing
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing
]
dbtParams = DBParamsForm
@ -520,7 +529,7 @@ mkLicenceTable dbtIdent aLic apids defAct = do
, dbParamsFormAdditional
= renderAForm FormStandard
$ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) defAct
<$> multiActionA acts (fslI MsgTableAction) (Just LicenceTableChangeAvs)
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def

26
src/Handler/Tutorial/Users.hs
View File

@ -18,7 +18,7 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Time.Zones as TZ
-- import qualified Data.Time.Zones as TZ
import qualified Database.Esqueleto.Legacy as E
@ -98,27 +98,9 @@ postTUsersR tid ssh csh tutn = do
formResult participantRes $ \case
(TutorialUserGrantQualificationData{..}, selectedUsers) -> do
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
runDB . forM_ selectedUsers $ \qualificationUserUser -> void $ do
Entity quid _ <- upsert
QualificationUser
{ qualificationUserQualification = tuQualification
, qualificationUserValidUntil = tuValidUntil
, qualificationUserLastRefresh = today
, qualificationUserFirstHeld = today
, qualificationUserBlockedDue = Nothing
, ..
}
[ QualificationUserValidUntil =. tuValidUntil
, QualificationUserLastRefresh =. today
, QualificationUserBlockedDue =. Nothing
]
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid
, transactionQualification = tuQualification
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = tuValidUntil
}
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
today <- utctDay <$> liftIO getCurrentTime
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil
addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
redirect $ CTutorialR tid ssh csh tutn TUsersR
(TutorialUserSendMailData{}, selectedUsers) -> do

1
src/Handler/Utils.hs
View File

@ -31,6 +31,7 @@ import Handler.Utils.Files as Handler.Utils
import Handler.Utils.Download as Handler.Utils
import Handler.Utils.AuthorshipStatement as Handler.Utils
--import Handler.Utils.Company as Handler.Utils
import Handler.Utils.Qualification as Handler.Utils
import Handler.Utils.Term as Handler.Utils

13
src/Handler/Utils/Avs.hs
View File

@ -200,9 +200,20 @@ computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDiffer
retrieveDifferingLicences :: Handler AvsLicenceDifferences
retrieveDifferingLicences = do
#ifdef DEVELOPMENT
getDifferingLicences $ AvsResponseGetLicences $ Set.fromList -- DEBUG ONLY
[ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2
, AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 5 -- AVS:1 FD:0 (nichts)
, AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 2 -- AVS:1 FD:0 (ungültig)
-- , AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 4 -- AVS:1 FD:1
]
#else
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
allLicences <- throwLeftM avsQueryGetAllLicences
getDifferingLicences allLicences
#endif
getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
getDifferingLicences (AvsResponseGetLicences licences) = do
@ -447,4 +458,4 @@ updateReceivers uid = do
receivers <- runDB (catMaybes <$> mapM getEntity receiverIDs)
return $ if null receivers
then (underling, pure underling, True)
else (underling, receivers, underling `elem` receivers)
else (underling, receivers, underling `elem` receivers)

32
src/Handler/Utils/Qualification.hs Normal file
View File

@ -0,0 +1,32 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Handler.Utils.Qualification
( module Handler.Utils.Qualification
) where
import Import
upsertQualificationUser :: QualificationId -> Day -> Day -> UserId -> DB ()
upsertQualificationUser qualificationUserQualification today qualificationUserValidUntil qualificationUserUser = do
Entity quid _ <- upsert
QualificationUser
{ qualificationUserLastRefresh = today
, qualificationUserFirstHeld = today
, qualificationUserBlockedDue = Nothing
, ..
}
[ QualificationUserValidUntil =. qualificationUserValidUntil
, QualificationUserLastRefresh =. today
, QualificationUserBlockedDue =. Nothing
]
audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid
, transactionQualification = qualificationUserQualification
, transactionUser = qualificationUserUser
, transactionQualificationValidUntil = qualificationUserValidUntil
}

8
templates/i18n/avs-synchronisation/de-de-formal.hamlet
View File

@ -32,19 +32,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
Es wird dringend empfohlen, die Fahrberechtigungen im AVS anzupassen
und nicht umgekehrt.
<h3>
Fahrberechtigung Rollfeld im AVS erteilen
Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS
<p>
^{tb2}
<h3>
Rollfeld Berechtigung entziehen, Fahrberechtigung Vorfeld erteilen
Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden
<p>
^{tb1down}
<h3>
Fahrberechtigung Vorfeld im AVS erteilen
Fahrberechtigung Vorfeld gültig in FRADrive, fehlt aber im AVS
<p>
^{tb1up}
<h3>
Jegliche Fahrberechtigung im AVS entziehen
Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden
<p>
^{tb0}

8
test/Database/Fill.hs
View File

@ -505,6 +505,11 @@ fillDb = do
for_ [jost] $ \uid ->
void . insert' $ UserSchool uid avn False
void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321
void . insert' $ UserAvs (AvsPersonId 2) svaupel 2
void . insert' $ UserAvs (AvsPersonId 3) gkleen 3
void . insert' $ UserAvs (AvsPersonId 4) sbarth 4
void . insert' $ UserAvs (AvsPersonId 5) fhamann 5
void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
@ -520,9 +525,10 @@ fillDb = do
void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing
void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) Nothing
void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) Nothing
void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing
void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing
-- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing
void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing
void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now