diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index b24c80818..351ced6a1 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index daa54cca9..05b2f16a2 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 2c7721836..371449e03 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index bb476a868..90af4f4f7 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index b5b1547f2..1ff03ffde 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index d4da76c77..ab199bfde 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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) \ No newline at end of file + else (underling, receivers, underling `elem` receivers) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs new file mode 100644 index 000000000..8a852079a --- /dev/null +++ b/src/Handler/Utils/Qualification.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2022 Steffen Jost +-- +-- 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 + } \ No newline at end of file diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet index 37fb9de6f..6c21b055c 100644 --- a/templates/i18n/avs-synchronisation/de-de-formal.hamlet +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -32,19 +32,19 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Es wird dringend empfohlen, die Fahrberechtigungen im AVS anzupassen und nicht umgekehrt.

- Fahrberechtigung Rollfeld im AVS erteilen + Fahrberechtigung Rollfeld gültig in FRADrive, fehlt aber im AVS

^{tb2}

- Rollfeld Berechtigung entziehen, Fahrberechtigung Vorfeld erteilen + Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden

^{tb1down}

- Fahrberechtigung Vorfeld im AVS erteilen + Fahrberechtigung Vorfeld gültig in FRADrive, fehlt aber im AVS

^{tb1up}

- Jegliche Fahrberechtigung im AVS entziehen + Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden

^{tb0} \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index ee05ac755..5c43956b5 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

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