From d209a110e8d1989ca8d3e101e7203ba44b292a5f Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 8 Aug 2024 17:30:03 +0200 Subject: [PATCH 1/8] refactor(linter): implement minor hlit suggestion --- src/Handler/Utils/Communication.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 7e5a60004..4990c21f2 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -15,7 +15,7 @@ module Handler.Utils.Communication import Import import Handler.Utils -import Handler.Utils.Users +import Handler.Utils.Users import Jobs.Queue @@ -124,7 +124,7 @@ crJobsFirmCommunication jCompanies Communication{..} = do adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails netReceiverAddresses <- lift $ do netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email - maybeMapM getEmailAddressFor netReceiverIds + maybeMapM getEmailAddressFor netReceiverIds -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) forM_ jAllRecipientAddresses $ \raddr -> @@ -145,7 +145,7 @@ commR CommunicationRoute{..} = do decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) - getEntity uid + getEntity uid cUser <- maybeAuth (chosenRecipients, suggestedRecipients) <- runDB $ (,) <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) @@ -155,7 +155,7 @@ commR CommunicationRoute{..} = do MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute globalCC <- getsYesod $ view _appCommunicationGlobalCC - + let lookupUser :: UserId -> (UserDisplayName,UserSurname) lookupUser = @@ -163,7 +163,7 @@ commR CommunicationRoute{..} = do usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) in usrNames . flip Map.lookup usrMap - + chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) , (Right recp, recp `elem` map entityKey chosenRecipients) @@ -174,9 +174,9 @@ commR CommunicationRoute{..} = do [ ( (BoundedPosition RecipientCustom, pos) , (recp, True) ) - | (pos, recp) <- zip [0..] + | (pos, recp) <- zip [0..] ( mcons (Left <$> globalCC) - (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients))) + (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey . view _2) suggestedRecipients))) ) ] activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom @@ -243,7 +243,7 @@ commR CommunicationRoute{..} = do postProcess = Set.fromList . map fst . filter snd . Map.elems recipientsListMsg <- messageI Info MsgCommRecipientsList - + attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing @@ -261,9 +261,9 @@ commR CommunicationRoute{..} = do <*> ( CommunicationContent <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) - <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) + <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) + ) formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs @@ -272,13 +272,13 @@ commR CommunicationRoute{..} = do (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess - + let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit - } + } siteLayoutMsg crHeading $ do setTitleI crTitle let commTestTip = $(i18nWidgetFile "comm-test-tip") From 000d8100db357b2cbadcf6969221cc888adc0183 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 8 Aug 2024 18:19:09 +0200 Subject: [PATCH 2/8] chore(avs): towards #124 add jobworker for AVS licence synch (WIP) --- src/Jobs/Handler/SynchroniseAvs.hs | 29 +++++++++++++++++++++++++++++ src/Jobs/Types.hs | 1 + 2 files changed, 30 insertions(+) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 2de92b595..2b80faa60 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -7,10 +7,12 @@ module Jobs.Handler.SynchroniseAvs -- , dispatchJobSynchroniseAvsId -- , dispatchJobSynchroniseAvsUser , dispatchJobSynchroniseAvsQueue + , dispatchJobSynchroniseAvsLicences ) where import Import +import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.Conduit.List as C @@ -128,3 +130,30 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api) discernJob accs (E.Value uid, E.Value Nothing , E.Value True ) = accs & over _1 (Set.insert uid) discernJob accs ( _ , _ , E.Value False ) = accs + + +----------------- +-- AVS Licences + +dispatchJobSynchroniseAvsLicences :: JobHandler UniWorX +-- dispatchJobSynchroniseAvsLicences = error "TODO" +dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel > 0) $ do + let synchLevel = 0 -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F + -- TODO: turn level into a setting + -- TODO: enable a cron job by setting + procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler () + procLic aLic up apids + | n <- Set.size apids, n > 0 = do + let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic + logit errm = runDB $ logInterface' "AVS" subtype False (isJust errm) (Just n) (fromMaybe "Automatic synch" errm) + catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1)) + oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids + when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|] + | otherwise = return () + + AvsLicenceDifferences{..} <- retrieveDifferingLicences + when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True avsLicenceDiffGrantRollfeld --grant Rollfeld + when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld + when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True avsLicenceDiffGrantVorfeld --grant Vorfeld + when (synchLevel >= 1) $ procLic AvsNoLicence False avsLicenceDiffRevokeAll --revoke Vorfeld & Rollfeld + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 5c8f8fde4..24bb89c3a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -109,6 +109,7 @@ data Job -- , jSynchAfter :: Maybe Day -- } | JobSynchroniseAvsQueue + | JobSynchroniseAvsLicences | JobChangeUserDisplayEmail { jUser :: UserId , jDisplayEmail :: UserEmail } From 760b102d5260fbb8b2e1268fb6ba7322fe91990d Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 9 Aug 2024 17:01:10 +0200 Subject: [PATCH 3/8] chore(avs): flag AVS R-holders about to be revoked - flag on admin problem view - exempt from automatic avs licence synch for levels below 3 --- .../uniworx/categories/admin/de-de-formal.msg | 1 + messages/uniworx/categories/admin/en-eu.msg | 3 +- src/Handler/Admin.hs | 4 +-- src/Handler/Admin/Avs.hs | 33 +++++++++++++------ src/Handler/Utils/Avs.hs | 30 +++++++++-------- src/Jobs/Handler/SynchroniseAvs.hs | 13 +++++--- .../avs-synchronisation/de-de-formal.hamlet | 4 +-- .../i18n/avs-synchronisation/en-eu.hamlet | 4 +-- 8 files changed, 57 insertions(+), 35 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 48a4d8c15..e24dcad0b 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,6 +121,7 @@ ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche t ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +ProblemAvsUsrHadR: Momentan gültiges R im AVS AdminProblemSolved: Erledigt AdminProblemSolver: Bearbeitet von diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 6a969d8c0..d8f6ca0d7 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -120,7 +120,8 @@ ProblemsNoAvsIdHeading: Drivers without AVS id ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS: ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log -ProblemsInterfaceSince: Only considering successes and errors since +ProblemsInterfaceSince: Only considering successes and errors since +ProblemAvsUsrHadR: Currenlt R valid in AVS AdminProblemSolved: Done AdminProblemSolver: Solved by diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index e3c04c0de..4b86afc9f 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -93,7 +93,7 @@ handleAdminProblems mbProblemTable = do diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) - (Right AvsLicenceDifferences{..}) -> do + (Right (AvsLicenceDifferences{..},_)) -> do let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday return $ Right @@ -104,7 +104,7 @@ handleAdminProblems mbProblemTable = do ) -- 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` + -- diffLics <- (procDiffLics . fst <$> retrieveDifferingLicences) `catches` -- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody}) -- -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody -- ex -> return $ Left $ text2widget $ tshow ex) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index cf0d3ea3a..9763d11b0 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -378,8 +378,8 @@ postProblemAvsSynchR = getProblemAvsSynchR 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; do not call redirect within catchAllAvs actions! - (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus - + ((AvsLicenceDifferences{..}, rsChanged), apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus + let mkLicTbl = mkLicenceTable apidStatus rsChanged -- unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros -> runDB $ E.select $ do @@ -434,10 +434,10 @@ getProblemAvsSynchR = do -- licence differences ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) - <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll - <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld - <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld - <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld + <$> mkLicTbl "avsLicDiffRevokeVorfeld" AvsLicenceVorfeld avsLicenceDiffRevokeAll + <*> mkLicTbl "avsLicDiffGrantVorfeld" AvsNoLicence avsLicenceDiffGrantVorfeld + <*> mkLicTbl "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld avsLicenceDiffRevokeRollfeld -- downgrade to Vorfeld + <*> mkLicTbl "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld now <- liftIO getCurrentTime let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () @@ -528,9 +528,11 @@ instance HasUser LicenceTableData where -- instance HasQualificationUser LicenceTableData where -- Not possible, since not all rows have a QualificationUser -- hasQualificationUser = resultQualUser . _entityVal -mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) -mkLicenceTable apidStatus dbtIdent aLic apids = do - currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute +mkLicenceTable :: AvsPersonIdMapPersonCard -> Set AvsPersonId -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget) +mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do + (currentRoute, usrHasAvsRerr) <- liftHandler $ (,) + <$> (fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute) + <*> (messageTooltip <$> messageI Error MsgProblemAvsUsrHadR) avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] [Asc QualificationName] now <- liftIO getCurrentTime @@ -571,7 +573,18 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies - , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q + , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ + if aLic /= AvsLicenceVorfeld + then + \(preview resultQualification -> q) -> cellMaybe lmsShortCell q + else + \row -> + let q = row ^? resultQualification + apid = row ^. resultUserAvs . _userAvsPersonId + warnCell c = if Set.member apid rsChanged + then c <> spacerCell <> wgtCell usrHasAvsRerr -- expected to be effectively dead code in practice, but we never know + else c + in warnCell $ cellMaybe lmsShortCell q , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d -- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 3122b3151..a40cc72d3 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -903,20 +903,20 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} = <> Set.map (AvsPersonLicence AvsLicenceRollfeld) avsLicenceDiffGrantRollfeld computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) -computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences +computeDifferingLicences = fmap (avsLicenceDifferences2personLicences . fst) . getDifferingLicences type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard) avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status] -retrieveDifferingLicences :: Handler AvsLicenceDifferences +retrieveDifferingLicences :: Handler (AvsLicenceDifferences, Set AvsPersonId) retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False -retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) +retrieveDifferingLicencesStatus :: Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard) retrieveDifferingLicencesStatus = retrieveDifferingLicences' True -retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard) +retrieveDifferingLicences' :: Bool -> Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard) retrieveDifferingLicences' getStatus = do #ifdef DEVELOPMENT avsUsrs <- runDB $ selectList [] [LimitTo 444] @@ -926,7 +926,9 @@ retrieveDifferingLicences' getStatus = do , 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 - ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs] + ] ++ [AvsPersonLicence (bool AvsLicenceRollfeld AvsLicenceVorfeld $ even $ avsPersonId avsid) avsid + | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs + ] #else allLicences <- avsQueryNoCache AvsQueryGetAllLicences #endif @@ -942,7 +944,7 @@ retrieveDifferingLicences' getStatus = do ] <> [ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ] #else - let statQry = avsLicenceDifferences2LicenceIds lDiff + let statQry = avsLicenceDifferences2LicenceIds $ fst lDiff lStat <- if getStatus && notNull statQry then avsQueryNoCache (AvsQueryStatus statQry) -- `catch` handler @@ -954,7 +956,7 @@ retrieveDifferingLicences' getStatus = do return (lDiff, avsResponseStatusMap lStat) -getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences +getDifferingLicences :: AvsResponseGetLicences -> Handler (AvsLicenceDifferences, Set AvsPersonId) getDifferingLicences (AvsResponseGetLicences licences) = do now <- liftIO getCurrentTime --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences @@ -998,12 +1000,14 @@ getDifferingLicences (AvsResponseGetLicences licences) = do 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 - } + rsChanged = rollfeld `Set.intersection` Set.unions [vorfRevoke, rollRevoke, setTo1up] -- maneuvering driving licences to downgrade in AVS + alds = AvsLicenceDifferences + { avsLicenceDiffRevokeAll = setTo0 + , avsLicenceDiffGrantVorfeld = setTo1up + , avsLicenceDiffRevokeRollfeld = setTo1down + , avsLicenceDiffGrantRollfeld = setTo2 + } + return (alds, rsChanged) {- 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 diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 2b80faa60..6e346cd62 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -151,9 +151,12 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|] | otherwise = return () - AvsLicenceDifferences{..} <- retrieveDifferingLicences - when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True avsLicenceDiffGrantRollfeld --grant Rollfeld - when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld - when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True avsLicenceDiffGrantVorfeld --grant Vorfeld - when (synchLevel >= 1) $ procLic AvsNoLicence False avsLicenceDiffRevokeAll --revoke Vorfeld & Rollfeld + (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences + let mbRemoveRs + | synchLevel >= 3 = id + | otherwise = flip Set.difference rsChanged + when (synchLevel >= 1) $ procLic AvsNoLicence False $ mbRemoveRs avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld + when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ mbRemoveRs avsLicenceDiffGrantVorfeld --grant Vorfeld + when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld + when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True avsLicenceDiffGrantRollfeld --grant Rollfeld diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet index aecad66b5..a9a483b90 100644 --- a/templates/i18n/avs-synchronisation/de-de-formal.hamlet +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

^{tb2}

- Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden + Fahrbrechtigung Rollfeld ungültig in FRADrive, aber im AVS vorhanden und Fahrberechtigung Vorfeld gültig in FRADrive

^{tb1down}

@@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

^{tb1up}

- Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden + Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden (Roll- oder Vorfeld)

^{tb0} \ No newline at end of file diff --git a/templates/i18n/avs-synchronisation/en-eu.hamlet b/templates/i18n/avs-synchronisation/en-eu.hamlet index a325d1fec..837e8622d 100644 --- a/templates/i18n/avs-synchronisation/en-eu.hamlet +++ b/templates/i18n/avs-synchronisation/en-eu.hamlet @@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

^{tb2}

- Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS + Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS and having a valid 'F' in FRADrive

^{tb1down}

@@ -43,6 +43,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

^{tb1up}

- No valid driving licence in FRADrive, but having a driving licence in AVS + No valid driving licence in FRADrive, but having any driving licence in AVS (maneuvering or apron)

^{tb0} From f4823aaf285c59f0adadf5c06bc83b91bfbc3e36 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 9 Aug 2024 17:59:14 +0200 Subject: [PATCH 4/8] refactor(avs): switch some runDB to runDBRead --- src/Foundation/Type.hs | 5 +++-- src/Handler/Utils/Avs.hs | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 162eb0887..1084d181d 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -15,7 +15,7 @@ module Foundation.Type , _memcachedLocalARC , SMTPPool , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey, _appVolatileClusterSettingsCache, _appAvsQuery - , DB, Form, MsgRenderer, MailM, DBFile + , DB, DBRead, Form, MsgRenderer, MailM, DBFile ) where import Import.NoFoundation @@ -123,8 +123,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings) - + type DB = YesodDB UniWorX +type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX) type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ()) type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerFor UniWorX) a diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index a40cc72d3..ae750c4ba 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -919,7 +919,7 @@ retrieveDifferingLicencesStatus = retrieveDifferingLicences' True retrieveDifferingLicences' :: Bool -> Handler ((AvsLicenceDifferences, Set AvsPersonId), AvsPersonIdMapPersonCard) retrieveDifferingLicences' getStatus = do #ifdef DEVELOPMENT - avsUsrs <- runDB $ selectList [] [LimitTo 444] + avsUsrs <- runDBRead $ selectList [] [LimitTo 444] let allLicences = AvsResponseGetLicences $ Set.fromList $ [ AvsPersonLicence AvsLicenceVorfeld $ AvsPersonId 77 -- AVS:1 FD:2 , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678 -- AVS:2 FD:1 @@ -967,7 +967,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' rollfeld = Set.map avsLicencePersonID rollfeld' - antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId) + antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DBRead (Set AvsPersonId,Set AvsPersonId) antijoinAvsLicences lic avsLics = fmap unwrapIds $ E.select $ do ((_qauli :& _qualUser :& usrAvs) :& excl) <- @@ -993,7 +993,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r) aux _ acc = acc -- should never occur - ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,) + ((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDBRead $ (,) <$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld let setTo0 = vorfRevoke -- revoke driving licences From 2ed626ea4aad67c031cd7862237957ec3ad8f451 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 9 Aug 2024 18:33:23 +0200 Subject: [PATCH 5/8] chore(avs): towards #124 add filter for multiple firm users with block reason '%firm%' - also add warning to admin avs licence difference for AVS R licence holders about to be changed --- src/Handler/Utils/Avs.hs | 2 +- src/Handler/Utils/Qualification.hs | 16 ++++++++++++- src/Jobs/Handler/SynchroniseAvs.hs | 36 ++++++++++++++++++++++++------ src/Model/Types/Avs.hs | 4 ++++ 4 files changed, 49 insertions(+), 9 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ae750c4ba..98fc33439 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -22,7 +22,7 @@ module Handler.Utils.Avs , computeDifferingLicences -- , synchAvsLicences , queryAvsFullStatus - -- , lookupAvsUser, lookupAvsUsers + , lookupAvsUser, lookupAvsUsers , AvsException(..) , updateReceivers , AvsPersonIdMapPersonCard diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 19888e2e6..cec61ac9e 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -58,7 +58,7 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified) )) --- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended +-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do newerBlock <- E.from $ E.table @QualificationUserBlock @@ -71,6 +71,20 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio )) ) +-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended +-- variant for inner joins +isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) +isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do + newerBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser + E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. newerBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId + E.&&. (( newerBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom) + E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins + E.&&. (newerBlock E.^. QualificationUserBlockFrom E.==. qualBlock E.^. QualificationUserBlockFrom) + )) + ) + -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 6e346cd62..b9835ba99 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -14,6 +14,7 @@ import Import import qualified Data.Text as Text import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Conduit.List as C import Database.Esqueleto.Experimental ((:&)(..)) @@ -25,6 +26,7 @@ import qualified Database.Esqueleto.Utils as E import Jobs.Queue import Handler.Utils.Avs +import Handler.Utils.Qualification -- pause is a date in the past; don't synch again if the last synch was after pause dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX @@ -150,13 +152,33 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|] | otherwise = return () + now <- liftIO getCurrentTime (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences - let mbRemoveRs - | synchLevel >= 3 = id - | otherwise = flip Set.difference rsChanged - when (synchLevel >= 1) $ procLic AvsNoLicence False $ mbRemoveRs avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld - when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ mbRemoveRs avsLicenceDiffGrantVorfeld --grant Vorfeld - when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld - when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True avsLicenceDiffGrantRollfeld --grant Rollfeld + -- for synchLevel < 5 prevent automatic changes to users blocked with a reason mentioning "Firm" and currently being associatd with multiple companies + multiFirmBlocks <- if synchLevel >= 5 + then return mempty + else do + firmBlocks <- runDBRead $ E.select $ do + (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs + `E.innerJoin` E.table @QualificationUser `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser) + `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) -> + qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser + E.&&. qblock `isLatestBlockBefore'` E.val now) + E.where_ $ (E.val ("Firm"::Text) `E.isInfixOf` qblock E.^. QualificationUserBlockReason) + E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld) + E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock) + return $ uavs E.^. UserAvsPersonId + firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks -- may throw, but we need to abort then + return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData + + let fltrIds + | synchLevel >= 5 = id + | synchLevel >= 3 = flip Set.difference multiFirmBlocks + | otherwise = flip Set.difference $ multiFirmBlocks `Set.union` rsChanged + + when (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld + when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld + when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld + when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 636b28291..0c50360be 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -501,6 +501,10 @@ deriveJSON defaultOptions } ''AvsDataPerson -} +hasMultipleFirms :: AvsDataPerson -> Bool +hasMultipleFirms AvsDataPerson{avsPersonPersonCards=crds} = + 1 < Set.size (Set.filter isJust $ Set.map avsDataFirm crds) + data AvsPersonLicence = AvsPersonLicence { avsLicenceRampLicence :: AvsLicence , avsLicencePersonID :: AvsPersonId From e551fadd29975d8d01746ff125849f226d107718 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 12 Aug 2024 12:36:27 +0200 Subject: [PATCH 6/8] chore(sql): add regex match for sql --- src/Database/Esqueleto/Utils.hs | 24 ++++++++++++++++++++++++ src/Handler/MailCenter.hs | 4 +++- 2 files changed, 27 insertions(+), 1 deletion(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6a59f0241..f8b488272 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -15,6 +15,7 @@ module Database.Esqueleto.Utils , (=?.), (?=.) , (=~.), (~=.) , (>~.), (<~.) + , (~.), (~*.) , or, and , any, all , not__, parens @@ -26,6 +27,7 @@ module Database.Esqueleto.Utils , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkDayFilter, mkDayFilterFrom, mkDayFilterTo , mkExistsFilter, mkExistsFilterWithComma + -- , mkRegExFilterWith , anyFilter, allFilter , ascNullsFirst, descNullsLast , orderByList @@ -163,6 +165,16 @@ infixl 4 <~. (<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) (<~.) a b = E.isNothing b E.||. (E.just a E.<. b) +infixr 2 ~., ~*. + +-- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters +(~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(~.) = E.unsafeSqlBinOp " ~ " + +-- | PostgreSQL regular expression match, case insensitive. Works, but may throw SQL errors +(~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(~*.) = E.unsafeSqlBinOp " ~* " + -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) @@ -415,6 +427,18 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives +-- like `mkContainsFilterWith` but allows regular expression criterias +-- This works, but throws SQL errors for unbalanced parenthesis and similar invalid regex expressions +-- mkRegExFilterWith :: (E.SqlString b, Ord a) +-- => (a -> b) +-- -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element +-- -> t -- ^ query row +-- -> Set.Set a -- ^ needle collection +-- -> E.SqlExpr (E.Value Bool) +-- mkRegExFilterWith cast lenslike row criterias +-- | Set.null criterias = true +-- | otherwise = any ((~.) (lenslike row) . E.val . cast) criterias + mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row -> Last Day -- ^ a day to filter for diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 2fe335e32..c6abfa015 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -107,12 +107,14 @@ mkMCTable = do dbtFilter = mconcat [ single ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) - , single ("subject" , FilterColumn . E.mkContainsFilter $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) + , single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) + -- , single ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort) + -- , prismAForm (singletonFilter "regex" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject ) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtIdent :: Text From cc5da9a2a9bfc8a29f6fe19260bd6dc5412ad4a1 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 12 Aug 2024 18:01:04 +0200 Subject: [PATCH 7/8] fix(avs): fix #124 implement automatic avs driving licence synchronisation --- src/Database/Esqueleto/Utils.hs | 12 ++++- src/Handler/Admin/Avs.hs | 1 + src/Jobs/Crontab.hs | 31 +++++++---- src/Jobs/Handler/SynchroniseAvs.hs | 52 +++++++++++-------- src/Settings.hs | 42 ++++++++++++--- .../avs-synchronisation/de-de-formal.hamlet | 36 ++++++++++++- .../i18n/avs-synchronisation/en-eu.hamlet | 34 ++++++++++++ 7 files changed, 166 insertions(+), 42 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f8b488272..dc927ec1d 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -15,7 +15,7 @@ module Database.Esqueleto.Utils , (=?.), (?=.) , (=~.), (~=.) , (>~.), (<~.) - , (~.), (~*.) + , (~.), (~*.), (!~.), (!~*.) , or, and , any, all , not__, parens @@ -165,7 +165,7 @@ infixl 4 <~. (<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) (<~.) a b = E.isNothing b E.||. (E.just a E.<. b) -infixr 2 ~., ~*. +infixr 2 ~., ~*., !~., !~*. -- | PostgreSQL regular expression match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters (~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) @@ -175,6 +175,14 @@ infixr 2 ~., ~*. (~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) (~*.) = E.unsafeSqlBinOp " ~* " +-- | PostgreSQL regular expression does not match, case sensitive. Works, but may throw SQL error for unblanced parenthesis, etc. Not suitable for dbTable filters +(!~.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(!~.) = E.unsafeSqlBinOp " !~ " + +-- | PostgreSQL regular expression does not match, case insensitive. Works, but may throw SQL errors +(!~*.) :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +(!~*.) = E.unsafeSqlBinOp " !~* " + -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9763d11b0..c3bf0c3f7 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -476,6 +476,7 @@ getProblemAvsSynchR = do formResult tres1up $ procRes AvsLicenceVorfeld formResult tres0 $ procRes AvsNoLicence + AvsLicenceSynchConf{..} <- getsYesod $ view _appAvsLicenceSynchConf siteLayoutMsg MsgAvsTitleLicenceSynch $ do setTitleI MsgAvsTitleLicenceSynch $(i18nWidgetFile "avs-synchronisation") diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 72ae6a7c4..9b76a0b00 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -110,7 +110,7 @@ determineCrontab = execWriterT $ do sheetJobs (Entity nSheet Sheet{..}) = do for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> do tellPrewarmJobs (JobCtlPrewarmSheetFile nSheet SheetExercise) aFrom - + when (isn't _JobsOffload appJobMode) $ do tell $ HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..}) @@ -181,7 +181,7 @@ determineCrontab = execWriterT $ do runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs - + when (isn't _JobsOffload appJobMode) $ do case appJobFlushInterval of Just interval | maybe True (> 0) appJobMaxFlush -> tell $ HashMap.singleton @@ -396,28 +396,41 @@ determineCrontab = execWriterT $ do whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsEnqueue) Cron - { cronInitial = CronAsap -- time after scheduling + { cronInitial = CronAsap -- time after scheduling , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] - , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) , cronMinute = cronMatchOne 2 , cronSecond = cronMatchOne 27 } , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely - } + } whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsDequeue) Cron - { cronInitial = CronAsap -- time after scheduling + { cronInitial = CronAsap -- time after scheduling , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] - , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) , cronMinute = cronMatchOne 7 , cronSecond = cronMatchOne 27 } , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely - } + } + + when (notNull (avsLicenceSynchTimes appAvsLicenceSynchConf)) $ tell $ HashMap.singleton + (JobCtlQueue JobSynchroniseAvsLicences) + Cron + { cronInitial = CronAsap + , cronRateLimit = 10 -- minimal time between two executions, before the second job is skipped + , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely + , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] --weekdays only + , cronHour = CronMatchSome . impureNonNull . Set.fromList $ avsLicenceSynchTimes appAvsLicenceSynchConf + , cronMinute = cronMatchOne 1 + , cronSecond = cronMatchOne 3 + } + } let correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) () @@ -455,7 +468,7 @@ determineCrontab = execWriterT $ do ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam return examFinished - notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime + notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime tell $ HashMap.singleton (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId) Cron diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index b9835ba99..db4d9482a 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -140,37 +140,43 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do dispatchJobSynchroniseAvsLicences :: JobHandler UniWorX -- dispatchJobSynchroniseAvsLicences = error "TODO" dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel > 0) $ do - let synchLevel = 0 -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F - -- TODO: turn level into a setting - -- TODO: enable a cron job by setting + AvsLicenceSynchConf + { avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F + , avsLicenceSynchReasonFilter = reasonFilter + , avsLicenceSynchMaxChanges = maxChanges + } <- getsYesod $ view _appAvsLicenceSynchConf + + let -- TODO: enable a cron job by setting procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler () procLic aLic up apids - | n <- Set.size apids, n > 0 = do + | n <- Set.size apids, n > 0 = let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic logit errm = runDB $ logInterface' "AVS" subtype False (isJust errm) (Just n) (fromMaybe "Automatic synch" errm) catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1)) - oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids - when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|] + in if NTop (Just n) <= NTop maxChanges + then do + oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids + when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|] + else + logit $ Just $ [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|] | otherwise = return () - now <- liftIO getCurrentTime (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences - -- for synchLevel < 5 prevent automatic changes to users blocked with a reason mentioning "Firm" and currently being associatd with multiple companies - multiFirmBlocks <- if synchLevel >= 5 - then return mempty - else do - firmBlocks <- runDBRead $ E.select $ do - (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs - `E.innerJoin` E.table @QualificationUser `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser) - `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) -> - qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser - E.&&. qblock `isLatestBlockBefore'` E.val now) - E.where_ $ (E.val ("Firm"::Text) `E.isInfixOf` qblock E.^. QualificationUserBlockReason) - E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld) - E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock) - return $ uavs E.^. UserAvsPersonId - firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks -- may throw, but we need to abort then - return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData + -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies + multiFirmBlocks <- ifNothingM reasonFilter mempty $ \reasons -> do + now <- liftIO getCurrentTime + firmBlocks <- runDBRead $ E.select $ do + (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs + `E.innerJoin` E.table @QualificationUser `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser) + `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) -> + qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser + E.&&. qblock `isLatestBlockBefore'` E.val now) + E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons) + E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld) + E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock) + return $ uavs E.^. UserAvsPersonId + firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks -- may throw, but we need to abort then + return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData let fltrIds | synchLevel >= 5 = id diff --git a/src/Settings.hs b/src/Settings.hs index 10e929b65..fef183886 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -102,6 +102,8 @@ data AppSettings = AppSettings -- ^ Configuration settings for accessing the LDAP-directory , appAvsConf :: Maybe AvsConf -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) + , appAvsLicenceSynchConf :: AvsLicenceSynchConf + -- ^ Configuration settings for automatically synching driving licences with AVS , appLprConf :: LprConf -- ^ Configuration settings for accessing a printer queue via lpr for letter mailing , appSmtpConf :: Maybe SmtpConf @@ -248,11 +250,11 @@ data AppSettings = AppSettings , appCommunicationAttachmentsMaxSize :: Maybe Natural , appCommunicationGlobalCC :: Maybe UserEmail - + , appFileChunkingParams :: FastCDCParameters , appLegalExternal :: Set LegalExternal - + } deriving Show @@ -335,6 +337,21 @@ data AvsConf = AvsConf , avsCacheExpiry :: DiffTime -- Seconds, only for non-licence related queries } deriving (Show) +data AvsLicenceSynchConf = AvsLicenceSynchConf + { avsLicenceSynchTimes :: [Natural] -- hours, when a synch should occur + , avsLicenceSynchLevel :: Int -- 0: No synch, 1: revoke Vorfeld, 2: Grant Vorfeld, 3: Downgrade to Vorfeld, 4: Grant Rollfeld + , avsLicenceSynchReasonFilter :: Maybe Text -- regular expression matched case-insensitive against latest block/grant reason, preventing automatic synch to users with this reason AND being associated with multiple companies + , avsLicenceSynchMaxChanges :: Maybe Int -- abort synch for group, if there are too many changes overall + } deriving (Show) + +instance Default AvsLicenceSynchConf where + def = AvsLicenceSynchConf + { avsLicenceSynchTimes = [] + , avsLicenceSynchLevel = 0 + , avsLicenceSynchReasonFilter = Nothing + , avsLicenceSynchMaxChanges = Nothing + } + data LprConf = LprConf { lprHost :: String , lprPort :: Int @@ -423,11 +440,11 @@ data SettingBotMitigation deriving anyclass (Universe, Finite) data LegalExternal = LegalExternal - { externalLanguage :: Lang + { externalLanguage :: Lang , externalImprint :: Text , externalDataProtection :: Text , externalTermsOfUse :: Text - , externalPayments :: Text + , externalPayments :: Text } deriving (Eq, Ord, Read, Show, Generic) makeLenses_ ''LegalExternal @@ -523,7 +540,7 @@ instance FromJSON LmsConf where lmsUploadHeader <- o .: "upload-header" lmsUploadDelimiter <- o .:? "upload-delimiter" lmsDownloadHeader <- o .: "download-header" - lmsDownloadDelimiter <- o .: "download-delimiter" + lmsDownloadDelimiter <- o .: "download-delimiter" lmsDownloadCrLf <- o .: "download-cr-lf" lmsDeletionDays <- o .: "deletion-days" return LmsConf{..} @@ -540,7 +557,17 @@ instance FromJSON AvsConf where avsCacheExpiry <- o .: "cache-expiry" return AvsConf{..} -makeLenses_ ''AvsConf +makeLenses_ ''AvsConf + +instance FromJSON AvsLicenceSynchConf where + parseJSON = withObject "AvsLicenceSynch" $ \o -> do + avsLicenceSynchTimes <- o .: "times" + avsLicenceSynchLevel <- o .: "level" + avsLicenceSynchReasonFilter <- o .:? "reason-filter" + avsLicenceSynchMaxChanges <- o .:? "max-changes" + return AvsLicenceSynchConf{..} + +makeLenses_ ''AvsLicenceSynchConf instance FromJSON LprConf where parseJSON = withObject "LprConf" $ \o -> do @@ -611,7 +638,7 @@ instance FromJSON ServerSessionSettings where , ServerSession.setPersistentCookies <$> persistentCookies ]) -instance FromJSON LegalExternal where +instance FromJSON LegalExternal where parseJSON = withObject "LegalExternal" $ \o -> do externalLanguage <- o .: "language" externalImprint <- o .: "imprint" @@ -640,6 +667,7 @@ instance FromJSON AppSettings where appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" + appAvsLicenceSynchConf <- o .:? "avs-licence-synch" .!= def appLprConf <- o .: "lpr" appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet index a9a483b90..0c5117f01 100644 --- a/templates/i18n/avs-synchronisation/de-de-formal.hamlet +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -46,4 +46,38 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden (Roll- oder Vorfeld)

^{tb0} - \ No newline at end of file + +$if notNull avsLicenceSynchTimes +

+

+ Automatische AVS Fahrlizen Sychronisation +

+

+
+ Uhrzeiten Synchronisation +
+ Werktags, weniger Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes} +
+ Synchronisationslevel +
+ #{avsLicenceSynchLevel} # + $case avsLicenceSynchLevel + $of 1 + Nur Vorfeld-Fahrberechtigungen entziehen + $of 2 + Vorfeld-Fahrberechtigungen entziehen und gewähren + $of 3 + Vorfeld-Fahrberechtigungen entziehen und gewähren, # + so wie Rollfeld-Fahrberechtigungen zu Vorfeld-Fahrberechtigungen herabstufen + $of _ + Vorfeld- und Rollfeld-Fahrberechtigungen entziehen und gewähren + $maybe reasons <- avsLicenceSynchReasonFilter +
+ Ausnahmen +
+ Keine automatische Synchronisation, wenn die Begründung des letzten Un-/Blocks zu diesen regulären Ausdruck passt: #{reasons} + $maybe maxChange <- avsLicenceSynchMaxChanges +
+ Maximal Änderungen +
+ Keine Synchronisation durchführen, wenn es mehr als #{maxChange} Änderungen pro Level wären diff --git a/templates/i18n/avs-synchronisation/en-eu.hamlet b/templates/i18n/avs-synchronisation/en-eu.hamlet index 837e8622d..0eba07f77 100644 --- a/templates/i18n/avs-synchronisation/en-eu.hamlet +++ b/templates/i18n/avs-synchronisation/en-eu.hamlet @@ -46,3 +46,37 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later No valid driving licence in FRADrive, but having any driving licence in AVS (maneuvering or apron)

^{tb0} + +$if notNull avsLicenceSynchTimes +

+

+ Automatic AVS licence sychronisation +

+

+
+ Synchronisation times +
+ Synchronize on weekdays, few minutes after each full hour: #{tshow avsLicenceSynchTimes} +
+ Synchronisation level +
+ #{avsLicenceSynchLevel} # + $case avsLicenceSynchLevel + $of 1 + Revoke apron driving licences only + $of 2 + Grant and revoke apron driving licences only + $of 3 + Grant and revoke apron driving licences and downgrade maneuvering area licences to apron driving licences + $of _ + Grant and revoke all driving licences automatically + $maybe reasons <- avsLicenceSynchReasonFilter +
+ Exemptions +
+ Do not synchronize changes where the last un-/block reason matches #{reasons} + $maybe maxChange <- avsLicenceSynchMaxChanges +
+ Max changes +
+ Do not synchronize a licence if the number of changes exceeds #{maxChange} From be5e609b1fe879428784d78fa62a559d0764a85a Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 12 Aug 2024 18:01:59 +0200 Subject: [PATCH 8/8] fix(build): minor linter fix --- src/Jobs/Handler/SynchroniseAvs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index db4d9482a..1a3ed10ab 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -158,7 +158,7 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|] else - logit $ Just $ [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|] + logit $ Just [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|] | otherwise = return () (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences