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

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)

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

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

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
+  AvsLicenceSynchConf
-      -- TODO: turn level into a setting
+    { avsLicenceSynchLevel        = synchLevel   -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F
-      -- TODO: enable a cron job by setting
+    , 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
+          in if NTop (Just n) <= NTop maxChanges
-          when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|]
+              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
+  -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies
-  multiFirmBlocks <- if synchLevel >= 5
+  multiFirmBlocks <- ifNothingM reasonFilter mempty $ \reasons -> do
-    then return mempty
+    now <- liftIO getCurrentTime
-    else do
+    firmBlocks <- runDBRead $ E.select $ do
-      firmBlocks <- runDBRead $ E.select $ do
+      (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs
-        (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 @QualificationUser      `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser)
+        `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) ->
-          `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) ->
+            qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
-              qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser
+            E.&&. qblock `isLatestBlockBefore'` E.val now)
-              E.&&. qblock `isLatestBlockBefore'` E.val now)
+      E.where_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons)
-        E.where_ $ (E.val ("Firm"::Text) `E.isInfixOf` qblock E.^. QualificationUserBlockReason)
+          E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld)
-            E.&&.  uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld)
+          E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock)
-            E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock)
+      return $ uavs E.^. UserAvsPersonId
-        return $ uavs E.^. UserAvsPersonId
+    firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks                      -- may throw, but we need to abort then
-      firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks                      -- may throw, but we need to abort then
+    return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData
-      return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData
 
   let fltrIds
         | synchLevel >= 5 = id

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

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

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