fix(avs): fix #124 implement automatic avs driving licence synchronisation

This commit is contained in:
Steffen Jost 2024-08-12 18:01:04 +02:00
parent e551fadd29
commit cc5da9a2a9
7 changed files with 166 additions and 42 deletions

View File

@ -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)

View File

@ -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")

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)
<p>
^{tb0}
$if notNull avsLicenceSynchTimes
<section>
<h2>
Automatische AVS Fahrlizen Sychronisation
<p>
<dl .deflist>
<dt .deflist__dt>
Uhrzeiten Synchronisation
<dd .deflist__dd>
Werktags, weniger Minuten nach folgenden vollen Stunden: #{tshow avsLicenceSynchTimes}
<dt .deflist__dt>
Synchronisationslevel
<dd .deflist__dd>
#{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
<dt .deflist__dt>
Ausnahmen
<dd .deflist__dd>
Keine automatische Synchronisation, wenn die Begründung des letzten Un-/Blocks zu diesen regulären Ausdruck passt: #{reasons}
$maybe maxChange <- avsLicenceSynchMaxChanges
<dt .deflist__dt>
Maximal Änderungen
<dd .deflist__dd>
Keine Synchronisation durchführen, wenn es mehr als #{maxChange} Änderungen pro Level wären

View File

@ -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)
<p>
^{tb0}
$if notNull avsLicenceSynchTimes
<section>
<h2>
Automatic AVS licence sychronisation
<p>
<dl .deflist>
<dt .deflist__dt>
Synchronisation times
<dd .deflist__dd>
Synchronize on weekdays, few minutes after each full hour: #{tshow avsLicenceSynchTimes}
<dt .deflist__dt>
Synchronisation level
<dd .deflist__dd>
#{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
<dt .deflist__dt>
Exemptions
<dd .deflist__dd>
Do not synchronize changes where the last un-/block reason matches #{reasons}
$maybe maxChange <- avsLicenceSynchMaxChanges
<dt .deflist__dt>
Max changes
<dd .deflist__dd>
Do not synchronize a licence if the number of changes exceeds #{maxChange}