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}