fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into course-visibility

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-08 15:43:00 +02:00
commit 1e016dab17
18 changed files with 147 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
CHANGELOG.md
View File

@ -2,6 +2,20 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [18.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.4.0...v18.5.0) (2020-08-03)
### Bug Fixes
* **jobs:** queue certain jobs at most once ([1be9716](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1be9716))
### Features
* admin-crontab-r ([460c133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/460c133))
## [18.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.3.0...v18.4.0) (2020-08-02)

2
config/settings.yml
View File

@ -35,7 +35,7 @@ bearer-expiration: 604800
bearer-encoding: HS256
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
session-files-expire: 3600
prune-unreferenced-files: 600
prune-unreferenced-files: 28800
keep-unreferenced-files: 86400
health-check-interval:
matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"

6
messages/uniworx/de-de-formal.msg
View File

@ -1350,6 +1350,7 @@ MenuAllocationPriorities: Zentrale Dringlichkeiten
MenuAllocationCompute: Platzvergabe berechnen
MenuAllocationAccept: Platzvergabe akzeptieren
MenuFaq: FAQ
MenuAdminCrontab: Crontab
BreadcrumbSubmissionFile: Datei
BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
@ -1421,6 +1422,7 @@ BreadcrumbAllocationCompute: Platzvergabe berechnen
BreadcrumbAllocationAccept: Platzvergabe akzeptieren
BreadcrumbMessageHide: Verstecken
BreadcrumbFaq: FAQ
BreadcrumbAdminCrontab: Crontab
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
@ -2677,3 +2679,7 @@ SubmissionDoneByFile: Je nach Bewertungsdatei
SubmissionDoneAlways: Immer
CorrUploadSubmissionDoneMode: Bewertung abgeschlossen
CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschlossen markiert werden? Bewertungen sind erst für Studierende sichtbar und zählen gegen Examboni, wenn sie abgeschlossen sind.
AdminCrontabNotGenerated: (Noch) keine Crontab generiert
CronMatchAsap: ASAP
CronMatchNone: Nie

6
messages/uniworx/en-eu.msg
View File

@ -1350,6 +1350,7 @@ MenuAllocationPriorities: Central priorities
MenuAllocationCompute: Compute allocation
MenuAllocationAccept: Accept allocation
MenuFaq: FAQ
MenuAdminCrontab: Crontab
BreadcrumbSubmissionFile: File
BreadcrumbSubmissionUserInvite: Invitation to participate in a submission
@ -1421,6 +1422,7 @@ BreadcrumbAllocationCompute: Compute allocation
BreadcrumbAllocationAccept: Accept allocation
BreadcrumbMessageHide: Hide
BreadcrumbFaq: FAQ
BreadcrumbAdminCrontab: Crontab
ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn}
ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn}
@ -2677,3 +2679,7 @@ SubmissionDoneByFile: According to correction file
SubmissionDoneAlways: Always
CorrUploadSubmissionDoneMode: Rating finished
CorrUploadSubmissionDoneModeTip: Should uploaded corrections be marked as finished? The rating is only visible to the submittors and considered for any exam bonuses if it is finished.
AdminCrontabNotGenerated: Crontab not (yet) generated
CronMatchAsap: ASAP
CronMatchNone: Never

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "18.4.0",
"version": "18.5.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "18.4.0",
"version": "18.5.0",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 18.4.0
version: 18.5.0
dependencies:
- base

1
routes
View File

@ -56,6 +56,7 @@
/admin/test AdminTestR GET POST
/admin/errMsg AdminErrMsgR GET POST
/admin/tokens AdminTokensR GET POST
/admin/crontab AdminCrontabR GET
/health HealthR GET !free
/instance InstanceR GET !free

4
src/Cron.hs
View File

@ -1,6 +1,6 @@
module Cron
( evalCronMatch
, CronNextMatch(..)
, CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone
, nextCronMatch
, module Cron.Types
) where
@ -84,6 +84,8 @@ consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
deriving (Eq, Ord, Show, Read, Functor)
makePrisms ''CronNextMatch
instance Applicative CronNextMatch where
pure = MatchAt
_ <*> MatchNone = MatchNone

2
src/Database/Esqueleto/Utils.hs
View File

@ -298,6 +298,8 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.E
sqlProject = (E.?.)
unSqlProject _ _ = Just
infixl 8 ->.
(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t

9
src/Foundation.hs
View File

@ -2415,6 +2415,7 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
@ -2902,6 +2903,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
, navQuick' = mempty
, navForceActive = False
}
, NavLink
{ navLabel = MsgMenuAdminCrontab
, navRoute = AdminCrontabR
, navAccess' = return True
, navType = NavTypeLink { navModal = False }
, navQuick' = mempty
, navForceActive = False
}
, NavLink
{ navLabel = MsgMenuAdminTest
, navRoute = AdminTestR

1
src/Handler/Admin.hs
View File

@ -10,6 +10,7 @@ import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
import Handler.Admin.StudyFeatures as Handler.Admin
import Handler.Admin.Tokens as Handler.Admin
import Handler.Admin.Crontab as Handler.Admin
getAdminR :: Handler Html

44
src/Handler/Admin/Crontab.hs Normal file
View File

@ -0,0 +1,44 @@
module Handler.Admin.Crontab
( getAdminCrontabR
) where
import Import
import Jobs
import Handler.Utils.DateTime
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
getAdminCrontabR :: Handler Html
getAdminCrontabR = do
jState <- getsYesod appJobState
mCrontab' <- atomically . runMaybeT $ do
JobState{jobCurrentCrontab} <- MaybeT $ tryReadTMVar jState
MaybeT $ readTVar jobCurrentCrontab
let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _1 . _MatchNone)
siteLayoutMsg MsgMenuAdminCrontab $ do
setTitleI MsgMenuAdminCrontab
[whamlet|
$newline never
$maybe (genTime, crontab) <- mCrontab
<p>
^{formatTimeW SelFormatDateTime genTime}
<table .table .table--striped .table--hover>
$forall (match, job) <- crontab
<tr .table__row>
<td .table__td>
$case match
$of MatchAsap
_{MsgCronMatchAsap}
$of MatchNone
_{MsgCronMatchNone}
$of MatchAt t
^{formatTimeW SelFormatDateTime t}
<td .table__td>
<pre>
#{encodePrettyToTextBuilder job}
$nothing
_{MsgAdminCrontabNotGenerated}
|]

8
src/Handler/Admin/Test.hs
View File

@ -86,11 +86,9 @@ postAdminTestR = do
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
formResultModal emailResult AdminTestR $ \(email, ls) -> do
jId <- mapWriterT runDB $ do
jId <- queueJob $ JobSendTestEmail email ls
tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
return jId
runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
mapWriterT runDBJobs $ do
lift . queueDBJob $ JobSendTestEmail email ls
tell . pure $ Message Success [shamlet|Email-test gestartet|] (Just IconEmail)
addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
let emailWidget' = wrapForm emailWidget def

4
src/Handler/Utils/Exam.hs
View File

@ -1,4 +1,4 @@
{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module Handler.Utils.Exam
( fetchExamAux
@ -519,7 +519,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
)
postprocess result = (resultAscList, resultUsers)
where
resultAscList = pad . Map.fromListWith Set.union . accRes (pure <$> Set.lookupMin rangeAlphabet) $ (\r -> traceShow (over (traverse . _2 . traverse . traverse) CI.original r) r) result
resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
where
accRes _ [] = []
accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)

20
src/Jobs.hs
View File

@ -97,6 +97,7 @@ handleJobs foundation@UniWorX{..}
jobCrontab <- liftIO $ newTVarIO HashMap.empty
jobConfirm <- liftIO $ newTVarIO HashMap.empty
jobShutdown <- liftIO newEmptyTMVarIO
jobCurrentCrontab <- liftIO $ newTVarIO Nothing
atomically $ putTMVar appJobState JobState
{ jobContext = JobContext{..}
, ..
@ -109,12 +110,12 @@ manageCrontab :: forall m.
=> UniWorX -> (forall a. m a -> m a) -> m ()
manageCrontab foundation@UniWorX{..} unmask = do
ch <- allocateLinkedAsync $ do
context <- atomically . fmap jobContext $ readTMVar appJobState
jState <- atomically $ readTMVar appJobState
liftIO . unsafeHandler foundation . void $ do
atomically . assertM_ (not . Map.null . jobWorkers) $ readTMVar appJobState
runReaderT ?? foundation $
writeJobCtlBlock JobCtlDetermineCrontab
void $ evalRWST (forever execCrontab) context HashMap.empty
void $ evalRWST (forever execCrontab) jState HashMap.empty
let awaitTermination = guardM $
readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
@ -252,7 +253,7 @@ stopJobCtl UniWorX{appJobState} = do
, jobCron jSt'
] ++ workers
execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
execCrontab :: RWST JobState () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
-- seen, wait for the time of the next job and fire it
execCrontab = do
@ -276,7 +277,7 @@ execCrontab = do
refT <- liftIO getCurrentTime
settings <- getsYesod appSettings'
(currentCrontab, (jobCtl, nextMatch), currentState) <- mapRWST (liftIO . atomically) $ do
crontab <- liftBase . readTVar =<< asks jobCrontab
crontab <- liftBase . readTVar =<< asks (jobCrontab . jobContext)
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get
@ -288,13 +289,16 @@ execCrontab = do
do
lastTimes <- State.get
now <- liftIO getCurrentTime
$logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
let currentCrontab' = sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
crontabTVar <- asks jobCurrentCrontab
atomically . writeTVar crontabTVar $ Just (now, currentCrontab')
$logDebugS "Crontab" . intercalate "\n" $ "Current crontab:" : map tshow currentCrontab'
let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
newCrontab <- lift $ hoist lift determineCrontab'
when (newCrontab /= currentCrontab) $
mapRWST (liftIO . atomically) $
liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
liftBase . void . flip swapTVar newCrontab =<< asks (jobCrontab . jobContext)
mergeState
newState <- State.get
@ -315,11 +319,11 @@ execCrontab = do
MatchAsap -> doJob
MatchNone -> return ()
MatchAt nextTime -> do
JobContext{jobCrontab} <- ask
crontab <- asks $ jobCrontab . jobContext
nextTime' <- applyJitter jobCtl nextTime
$logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
logFunc <- askLoggerIO
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
whenM (liftIO . flip runLoggingT logFunc $ waitUntil crontab currentCrontab nextTime')
doJob
where

38
src/Jobs/Queue.hs
View File

@ -80,22 +80,28 @@ writeJobCtlBlock :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -
-- | Pass an instruction to the `Job`-Workers and block until it was acted upon
writeJobCtlBlock = writeJobCtlBlock' writeJobCtl
queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX QueuedJobId
queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX (Maybe QueuedJobId)
queueJobUnsafe queuedJobWriteLastExec job = do
$logInfoS "queueJob" $ tshow job
queuedJobCreationTime <- liftIO getCurrentTime
queuedJobCreationInstance <- getsYesod appInstanceID
insert QueuedJob
{ queuedJobContent = toJSON job
, queuedJobLockInstance = Nothing
, queuedJobLockTime = Nothing
, ..
}
-- We should not immediately notify a worker; instead wait for the transaction to finish first
-- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
-- return jId
doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ]
if
| doQueue -> Just <$> do
queuedJobCreationTime <- liftIO getCurrentTime
queuedJobCreationInstance <- getsYesod appInstanceID
insert QueuedJob
{ queuedJobContent = toJSON job
, queuedJobLockInstance = Nothing
, queuedJobLockTime = Nothing
, ..
}
-- We should not immediately notify a worker; instead wait for the transaction to finish first
-- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
-- return jId
| otherwise -> return Nothing
queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m (Maybe QueuedJobId)
-- ^ Queue a job for later execution
--
-- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
@ -105,15 +111,15 @@ queueJob' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m
-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
queueJob' job = do
app <- getYesod
queueJob job >>= flip runReaderT app . writeJobCtl . JobCtlPerform
queueJob job >>= maybe (return ()) (flip runReaderT app . writeJobCtl . JobCtlPerform)
-- | Slightly modified Version of `DB` for `runDBJobs`
type JobDB = YesodJobDB UniWorX
queueDBJob, queueDBJobCron :: Job -> YesodJobDB UniWorX ()
-- | Queue a job as part of a database transaction and execute it after the transaction succeeds
queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . Set.singleton
queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . Set.singleton
queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . maybe Set.empty Set.singleton
queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . maybe Set.empty Set.singleton
sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) ()
-- | Queue many jobs as part of a database transaction and execute them after the transaction passes

18
src/Jobs/Types.hs
View File

@ -17,6 +17,8 @@ module Jobs.Types
, showWorkerId, newWorkerId
, JobQueue, jqInsert, jqDequeue
, JobPriority(..), prioritiseJob
, jobNoQueueSame
, module Cron
) where
import Import.NoFoundation hiding (Unique, state)
@ -37,6 +39,8 @@ import Utils.Metrics (withJobWorkerStateLbls)
import qualified Prometheus (Label4)
import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
| JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
@ -232,6 +236,19 @@ prioritiseJob (JobCtlGenerateHealthReport _) = JobPrioRealtime
prioritiseJob JobCtlDetermineCrontab = JobPrioRealtime
prioritiseJob _ = JobPrioBatch
jobNoQueueSame :: Job -> Bool
jobNoQueueSame = \case
JobSendPasswordReset{} -> True
JobTruncateTransactionLog{} -> True
JobPruneInvitations{} -> True
JobDeleteTransactionLogIPs{} -> True
JobSynchroniseLdapUser{} -> True
JobChangeUserDisplayEmail{} -> True
JobPruneSessionFiles{} -> True
JobPruneUnreferencedFiles{} -> True
JobInjectFiles{} -> True
_ -> False
newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue JobPriority JobCtl }
deriving (Eq, Ord, Read, Show)
@ -253,6 +270,7 @@ data JobState = JobState
, jobPoolManager :: Async ()
, jobCron :: Async ()
, jobShutdown :: TMVar ()
, jobCurrentCrontab :: TVar (Maybe (UTCTime, [(CronNextMatch UTCTime, JobCtl)]))
}
jobWorkerNames :: JobState -> Set JobWorkerId