Merge branch 'fradrive/jost' into 'master'
AVS automatic synchronisation See merge request fradrive/fradrive!37
This commit is contained in:
commit
776e6b6736
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,24 @@ 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 " ~* "
|
||||
|
||||
-- | 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)
|
||||
@ -415,6 +435,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 ()
|
||||
@ -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")
|
||||
@ -528,9 +529,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 +574,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -22,7 +22,7 @@ module Handler.Utils.Avs
|
||||
, computeDifferingLicences
|
||||
-- , synchAvsLicences
|
||||
, queryAvsFullStatus
|
||||
-- , lookupAvsUser, lookupAvsUsers
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
, AvsException(..)
|
||||
, updateReceivers
|
||||
, AvsPersonIdMapPersonCard
|
||||
@ -903,30 +903,32 @@ 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]
|
||||
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
|
||||
, 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
|
||||
@ -965,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) <-
|
||||
@ -991,19 +993,21 @@ 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
|
||||
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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -7,11 +7,14 @@ 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.Map as Map
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
@ -23,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
|
||||
@ -128,3 +132,59 @@ 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
|
||||
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 =
|
||||
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))
|
||||
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 ()
|
||||
|
||||
(AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences
|
||||
-- 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
|
||||
| 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
|
||||
|
||||
|
||||
@ -109,6 +109,7 @@ data Job
|
||||
-- , jSynchAfter :: Maybe Day
|
||||
-- }
|
||||
| JobSynchroniseAvsQueue
|
||||
| JobSynchroniseAvsLicences
|
||||
| JobChangeUserDisplayEmail { jUser :: UserId
|
||||
, jDisplayEmail :: UserEmail
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
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
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
@ -43,7 +43,41 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb1up}
|
||||
<h3>
|
||||
Keine gültige Fahrberechtigung in FRADrive, aber im AVS vorhanden
|
||||
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
|
||||
|
||||
@ -35,7 +35,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
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
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
@ -43,6 +43,40 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<p>
|
||||
^{tb1up}
|
||||
<h3>
|
||||
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)
|
||||
<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}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user