+ ^{formatTimeW SelFormatDateTime genTime} +
| + $case match + $of MatchAsap + _{MsgCronMatchAsap} + $of MatchNone + _{MsgCronMatchNone} + $of MatchAt t + ^{formatTimeW SelFormatDateTime t} + |
+
+ #{encodePrettyToTextBuilder job}
+ $nothing
+ _{MsgAdminCrontabNotGenerated}
+ |]
diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs
index c31fd691b..645152b0e 100644
--- a/src/Handler/Admin/Test.hs
+++ b/src/Handler/Admin/Test.hs
@@ -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
diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs
index c5229cbfb..73d898959 100644
--- a/src/Handler/Allocation/Application.hs
+++ b/src/Handler/Allocation/Application.hs
@@ -260,7 +260,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
if
| BtnAllocationApply <- afAction
, allowAction afAction
- -> runDB $ do
+ -> runDB . setSerializable $ do
haveOld <- exists [ CourseApplicationCourse ==. cid
, CourseApplicationUser ==. uid
, CourseApplicationAllocation ==. maId
@@ -291,7 +291,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
, allowAction afAction
, Just appId <- mAppId
- -> runDB $ do
+ -> runDB . setSerializable $ do
now <- liftIO getCurrentTime
changes <- if
diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs
index 5e0165a1c..66b9b3566 100644
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@@ -175,8 +175,9 @@ postCRegisterR tid ssh csh = do
formResult regResult $ \CourseRegisterForm{..} -> do
cTime <- liftIO getCurrentTime
let
+ doApplication = courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
mkApplication
- | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
+ | doApplication
= void <$> do
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
appRes <- case appIds of
@@ -210,12 +211,12 @@ postCRegisterR tid ssh csh = do
]
case courseRegisterButton of
- BtnCourseRegister -> runDB $ do
+ BtnCourseRegister -> runDB . bool id setSerializable doApplication $ do
regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration
case regOk of
Nothing -> transactionUndo
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
- BtnCourseDeregister -> runDB $ do
+ BtnCourseDeregister -> runDB . setSerializable $ do
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
deregisterParticipant uid cid
@@ -237,7 +238,7 @@ postCRegisterR tid ssh csh = do
when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
- BtnCourseApply -> runDB $ do
+ BtnCourseApply -> runDB . setSerializable $ do
regOk <- mkApplication
case regOk of
Nothing -> transactionUndo
diff --git a/src/Handler/Sheet/Pseudonym.hs b/src/Handler/Sheet/Pseudonym.hs
index b9c055fa6..f269ef18c 100644
--- a/src/Handler/Sheet/Pseudonym.hs
+++ b/src/Handler/Sheet/Pseudonym.hs
@@ -7,8 +7,6 @@ import Import
import Handler.Utils
-import Utils.Sql
-
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs
index d808b501d..286481651 100644
--- a/src/Handler/Submission/Helper.hs
+++ b/src/Handler/Submission/Helper.hs
@@ -318,7 +318,7 @@ submissionHelper tid ssh csh shn mcid = do
, formEncoding = formEnctype
}
- mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
+ mCID <- fmap join . msgSubmissionErrors . runDBJobs . setSerializable $ do
(Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs
index 8ba5f5584..cc8405762 100644
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@@ -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)
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 39c639704..4e3b5f692 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -899,13 +899,14 @@ genericFileField mkOpts = Field{..}
handleUpload FileField{fieldMaxFileSize} mIdent
= C.filter (\File{..} -> maybe (const True) (>) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) fileContent)
.| sinkFiles
- .| maybe (C.map id) mkSessionFile mIdent
+ .| C.mapM mkSessionFile
where
- mkSessionFile ident = C.mapM $ \fRef@FileReference{..} -> fRef <$ do
+ mkSessionFile fRef@FileReference{..} = fRef <$ do
now <- liftIO getCurrentTime
sfId <- insert $ SessionFile fileReferenceContent now
- modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
- Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
+ whenIsJust mIdent $ \ident ->
+ modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
+ Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
_FileTitle :: Prism' Text FilePath
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 6a4daa12f..b4e43de5c 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -904,7 +904,7 @@ submissionDeleteRoute drRecords = DeleteRoute
subUsers <- selectList [SubmissionUserSubmission ==. subId] []
if
| length subUsers >= 1
- , maybe False (flip any subUsers . (. submissionUserUser . entityVal) . (==)) uid
+ , maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
-> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
| otherwise
-> return Nothing
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 98e18047d..8cccd7227 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -38,6 +38,7 @@ import Yesod.Core.Types.Instances as Import
import Utils as Import
import Utils.Frontend.I18n as Import
import Utils.DB as Import
+import Utils.Sql as Import
import Data.Fixed as Import
@@ -165,6 +166,7 @@ import Crypto.Random.Instances as Import ()
import Network.Minio.Instances as Import ()
import System.Clock.Instances as Import ()
import Data.Word.Word24.Instances as Import ()
+import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
import Crypto.Random as Import (ChaChaDRG, Seed)
diff --git a/src/Jobs.hs b/src/Jobs.hs
index e9e8a17c9..2947ec813 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -18,8 +18,6 @@ import Data.Aeson (fromJSON)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
-import Utils.Sql
-
import Control.Monad.Random (evalRand, mkStdGen, uniformMay)
import Cron
@@ -100,6 +98,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{..}
, ..
@@ -112,12 +111,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
@@ -255,7 +254,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
@@ -279,7 +278,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
@@ -291,13 +290,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
@@ -318,11 +320,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
diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs
index b9817f649..de85244c0 100644
--- a/src/Jobs/Handler/Files.hs
+++ b/src/Jobs/Handler/Files.hs
@@ -10,6 +10,7 @@ import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlCastAs)
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as C (mapMaybe)
@@ -20,6 +21,8 @@ import qualified Network.Minio as Minio
import qualified Crypto.Hash as Crypto
import qualified Data.ByteString.Base64.URL as Base64
+import Control.Monad.Memo (startEvalMemoT, memo)
+
dispatchJobPruneSessionFiles :: JobHandler UniWorX
dispatchJobPruneSessionFiles = JobHandlerAtomic . hoist lift $ do
@@ -37,35 +40,49 @@ fileReferences (E.just -> fHash)
, E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileContent E.==. fHash
, E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileContent E.==. fHash
, E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileContent E.==. fHash
- , E.from $ \matching -> E.where_ $ E.just (matching E.^. AllocationMatchingLog) E.==. fHash
+ , E.from $ \matching -> E.where_ $ E.just (matching E.^. AllocationMatchingLog) E.==. fHash
, E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileContent E.==. fHash
, E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileContent E.==. fHash
+ , E.from $ \lock -> E.where_ $ E.just (lock E.^. FileLockContent) E.==. fHash
]
dispatchJobPruneUnreferencedFiles :: JobHandler UniWorX
dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do
- interval <- getsYesod $ view _appPruneUnreferencedFiles
- Sum n <- runConduit $ getCandidates
- .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
- .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
- .| C.map (view $ _1 . _Value)
- .| C.mapM (\fRef -> Sum <$> deleteWhereCount [FileContentHash ==. fRef])
- .| C.fold
- $logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|]
- where
+ now <- liftIO getCurrentTime
+ interval <- fmap (fmap $ max 0) . getsYesod $ view _appPruneUnreferencedFiles
+ keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles
+
+ E.update $ \fileContent -> do
+ let isReferenced = E.any E.exists . fileReferences $ fileContent E.^. FileContentHash
+ now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now
+ shouldBe = E.bool (E.just . E.maybe now' (E.min now') $ fileContent E.^. FileContentUnreferencedSince) E.nothing isReferenced
+ E.set fileContent [ FileContentUnreferencedSince E.=. shouldBe ]
+
+ let
getCandidates = E.selectSource . E.from $ \fileContent -> do
- E.where_ . E.not_ . E.any E.exists $ fileReferences (fileContent E.^. FileContentHash)
+ E.where_ . E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) $ fileContent E.^. FileContentUnreferencedSince
return ( fileContent E.^. FileContentHash
, E.length_ $ fileContent E.^. FileContentContent
)
+
+ Sum deleted <- runConduit $
+ getCandidates
+ .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
+ .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
+ .| C.map (view $ _1 . _Value)
+ .| C.mapM (\fRef -> Sum <$> deleteWhereCount [FileContentHash ==. fRef])
+ .| C.fold
+ when (deleted > 0) $
+ $logInfoS "PruneUnreferencedFiles" [st|Deleted #{deleted} long-unreferenced files|]
dispatchJobInjectFiles :: JobHandler UniWorX
dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
uploadBucket <- getsYesod $ view _appUploadCacheBucket
interval <- getsYesod $ view _appInjectFiles
+ now <- liftIO getCurrentTime
let
extractReference (Minio.ListItemObject oi)
@@ -75,34 +92,33 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
extractReference _ = Nothing
injectOrDelete :: (Minio.Object, FileContentReference)
- -> Handler (Sum Int64, Sum Int64, Sum Int64) -- ^ Deleted, Injected, Existed
+ -> Handler (Sum Int64, Sum Int64) -- ^ Injected, Already existed
injectOrDelete (obj, fRef) = maybeT (return mempty) $ do
- res <- hoist runDB $ do
- isReferenced <- lift . E.selectExists . E.where_ . E.any E.exists . fileReferences $ E.val fRef
- if | isReferenced -> do
- alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ]
- if | alreadyInjected -> return (mempty, mempty, Sum 1)
- | otherwise -> do
- content <- (hoistMaybe =<<) . runAppMinio . runMaybeT $ do
- objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
- lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
- lift $ (mempty, Sum 1, mempty) <$ insert (FileContent fRef content)
- | otherwise -> return (Sum 1, mempty, mempty)
+ res <- hoist (startEvalMemoT . hoistStateCache (runDB . setSerializable)) $ do
+ alreadyInjected <- lift . lift $ exists [ FileContentHash ==. fRef ]
+ if | alreadyInjected -> return (mempty, Sum 1)
+ | otherwise -> do
+ content <- flip memo obj $ \obj' -> hoistMaybeM . runAppMinio . runMaybeT $ do
+ objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj' Minio.defaultGetObjectOptions
+ lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
+
+ fmap ((, mempty) . Sum) . lift. lift . E.insertSelectCount $
+ let isReferenced = E.any E.exists $ fileReferences (E.val fRef)
+ now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now
+ in return $ FileContent E.<# E.val fRef E.<&> E.val content E.<&> E.bool (E.just now') E.nothing isReferenced
runAppMinio . maybeT (return ()) . catchIfMaybeT minioIsDoesNotExist $ Minio.removeObject uploadBucket obj
return res
- (Sum del, Sum inj, Sum exc) <-
+ (Sum inj, Sum exc) <-
runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True)
.| C.mapMaybe extractReference
.| maybe (C.map id) (takeWhileTime . (/ 2)) interval
- .| transPipe (lift . runDB) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
+ .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
.| C.map (over _1 Minio.oiObject)
.| transPipe lift (C.mapM injectOrDelete)
.| C.fold
- when (del > 0) $
- $logInfoS "InjectFiles" [st|Deleted #{del} unreferenced files from upload cache|]
when (exc > 0) $
- $logInfoS "InjectFiles" [st|Deleted #{exc} files from upload cache because they were already referenced|]
+ $logInfoS "InjectFiles" [st|Deleted #{exc} files from upload cache because they were already injected|]
when (inj > 0) $
$logInfoS "InjectFiles" [st|Injected #{inj} files from upload cache into database|]
diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs
index 5275304d7..18c85be59 100644
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@@ -11,7 +11,6 @@ module Jobs.Queue
import Import hiding ((<>))
-import Utils.Sql
import Jobs.Types
import Control.Monad.Writer.Class (MonadWriter(..))
@@ -81,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`)
@@ -106,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
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index c2e97cf3f..e8ff249f0 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -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 }
@@ -233,6 +237,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)
@@ -254,6 +271,7 @@ data JobState = JobState
, jobPoolManager :: Async ()
, jobCron :: Async ()
, jobShutdown :: TMVar ()
+ , jobCurrentCrontab :: TVar (Maybe (UTCTime, [(CronNextMatch UTCTime, JobCtl)]))
}
jobWorkerNames :: JobState -> Set JobWorkerId
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index 6888a16a7..6b4c67ee8 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -71,6 +71,7 @@ migrateAll' :: Migration
migrateAll' = sequence_
[ migrateUniWorX
, migrateMemcachedSqlStorage
+ , migrateManual
]
migrateAll :: ( MonadLogger m
@@ -137,6 +138,35 @@ getMissingMigrations = do
appliedMigrations <- selectKeysList [] []
return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
+
+migrateManual :: Migration
+migrateManual = do
+ mapM_ (uncurry addIndex)
+ [ ("course_application_file_content", "CREATE INDEX course_application_file_content ON course_application_file (content)" )
+ , ("material_file_content", "CREATE INDEX material_file_content ON material_file (content)" )
+ , ("course_news_file_content", "CREATE INDEX course_news_file_content ON course_news_file (content)" )
+ , ("sheet_file_content", "CREATE INDEX sheet_file_content ON sheet_file (content)" )
+ , ("course_app_instruction_file_content", "CREATE INDEX course_app_instruction_file_content ON course_app_instruction_file (content)")
+ , ("allocation_matching_log", "CREATE INDEX allocation_matching_log ON allocation_matching (log)" )
+ , ("submission_file_content", "CREATE INDEX submission_file_content ON submission_file (content)" )
+ , ("session_file_content", "CREATE INDEX session_file_content ON session_file (content)" )
+ , ("file_lock_content", "CREATE INDEX file_lock_content ON file_lock (content)" )
+ , ("user_lower_display_email", "CREATE INDEX user_lower_display_email ON \"user\" (lower(display_email))" )
+ , ("user_lower_email", "CREATE INDEX user_lower_email ON \"user\" (lower(email))" )
+ , ("user_lower_ident", "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))" )
+ , ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" )
+ , ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" )
+ ]
+ where
+ addIndex :: Text -> Sql -> Migration
+ addIndex ixName ixDef = do
+ res <- lift $ lift [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|]
+ alreadyDefined <- case res of
+ [Single e] -> return e
+ _other -> return True
+ unless alreadyDefined $ addMigration False ixDef
+
+
{-
Confusion about quotes, from the PostgreSQL Manual:
Single quotes for string constants, double quotes for table/column names.
@@ -145,7 +175,6 @@ getMissingMigrations = do
#{anything} (escaped as value);
-}
-
customMigrations :: forall m.
MonadResource m
=> Map (Key AppliedMigration) (ReaderT SqlBackend m ())
diff --git a/src/Settings.hs b/src/Settings.hs
index 8198bd9f3..39b31d630 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -11,6 +11,7 @@ module Settings
, module Settings.Cluster
, module Settings.Mime
, module Settings.Cookies
+ , module Settings.Log
) where
import Import.NoModel
@@ -53,6 +54,7 @@ import Model
import Settings.Cluster
import Settings.Mime
import Settings.Cookies
+import Settings.Log
import qualified System.FilePath as FilePath
@@ -139,6 +141,7 @@ data AppSettings = AppSettings
, appSessionFilesExpire :: NominalDiffTime
, appPruneUnreferencedFiles :: Maybe NominalDiffTime
+ , appKeepUnreferencedFiles :: NominalDiffTime
, appInitialLogSettings :: LogSettings
@@ -190,23 +193,6 @@ newtype ServerSessionSettings
instance Show ServerSessionSettings where
showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
-data LogSettings = LogSettings
- { logAll, logDetailed :: Bool
- , logMinimumLevel :: LogLevel
- , logDestination :: LogDestination
- } deriving (Show, Read, Generic, Eq, Ord)
-
-data LogDestination = LogDestStderr | LogDestStdout | LogDestFile { logDestFile :: !FilePath }
- deriving (Show, Read, Generic, Eq, Ord)
-
-deriving instance Generic LogLevel
-instance Hashable LogLevel
-instance NFData LogLevel
-instance Hashable LogSettings
-instance NFData LogSettings
-instance Hashable LogDestination
-instance NFData LogDestination
-
data UserDefaultConf = UserDefaultConf
{ userDefaultTheme :: Theme
, userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int
@@ -308,17 +294,6 @@ deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 2
} ''TokenBucketConf
-deriveJSON defaultOptions
- { constructorTagModifier = camelToPathPiece' 2
- , fieldLabelModifier = camelToPathPiece' 2
- , sumEncoding = UntaggedValue
- , unwrapUnaryRecords = True
- } ''LogDestination
-
-deriveJSON defaultOptions
- { fieldLabelModifier = camelToPathPiece' 1
- } ''LogSettings
-
deriveFromJSON defaultOptions ''Ldap.Scope
deriveFromJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 2
@@ -351,13 +326,6 @@ deriveFromJSON
}
''ResourcePoolConf
-deriveJSON
- defaultOptions
- { constructorTagModifier = camelToPathPiece' 1
- , sumEncoding = UntaggedValue
- }
- ''LogLevel
-
instance FromJSON HaskellNet.PortNumber where
parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
Just int -> return $ fromIntegral (int :: Word16)
@@ -504,6 +472,7 @@ instance FromJSON AppSettings where
appSessionFilesExpire <- o .: "session-files-expire"
appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files"
+ appKeepUnreferencedFiles <- o .:? "keep-unreferenced-files" .!= 0
appInjectFiles <- o .:? "inject-files"
appMaximumContentLength <- o .: "maximum-content-length"
diff --git a/src/Settings/Log.hs b/src/Settings/Log.hs
new file mode 100644
index 000000000..112519e41
--- /dev/null
+++ b/src/Settings/Log.hs
@@ -0,0 +1,52 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Settings.Log
+ ( LogSettings(..)
+ , LogDestination(..)
+ , LogLevel(..)
+ , ReadLogSettings(..)
+ ) where
+
+import ClassyPrelude.Yesod
+import Numeric.Natural
+
+import Data.Aeson.TH
+import Utils.PathPiece
+
+
+data LogSettings = LogSettings
+ { logAll, logDetailed :: Bool
+ , logMinimumLevel :: LogLevel
+ , logDestination :: LogDestination
+ , logSerializableTransactionRetryLimit :: Maybe Natural
+ } deriving (Show, Read, Generic, Eq, Ord)
+
+data LogDestination = LogDestStderr | LogDestStdout | LogDestFile { logDestFile :: !FilePath }
+ deriving (Show, Read, Generic, Eq, Ord)
+
+deriving instance Generic LogLevel
+instance Hashable LogLevel
+instance NFData LogLevel
+instance Hashable LogSettings
+instance NFData LogSettings
+instance Hashable LogDestination
+instance NFData LogDestination
+
+deriveJSON defaultOptions
+ { constructorTagModifier = camelToPathPiece' 1
+ , sumEncoding = UntaggedValue
+ } ''LogLevel
+
+deriveJSON defaultOptions
+ { constructorTagModifier = camelToPathPiece' 2
+ , fieldLabelModifier = camelToPathPiece' 2
+ , sumEncoding = UntaggedValue
+ , unwrapUnaryRecords = True
+ } ''LogDestination
+
+deriveJSON defaultOptions
+ { fieldLabelModifier = camelToPathPiece' 1
+ } ''LogSettings
+
+class ReadLogSettings m where
+ readLogSettings :: m LogSettings
diff --git a/src/Utils.hs b/src/Utils.hs
index 42bbcf070..20bb69524 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -569,6 +569,9 @@ hoistMaybe :: MonadPlus m => Maybe a -> m a
-- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
hoistMaybe = maybe mzero return
+hoistMaybeM :: MonadPlus m => m (Maybe a) -> m a
+hoistMaybeM = (=<<) hoistMaybe
+
catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
catchIfMaybeT p act = catchIf p (lift act) (const mzero)
diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs
index 6eed49d4b..e8c51dae7 100644
--- a/src/Utils/Failover.hs
+++ b/src/Utils/Failover.hs
@@ -161,9 +161,10 @@ withFailover' testTarget' f@Failover{..} mode detAcceptable act = withFailoverRe
$logErrorS "withFailover'" $ tshow (hashUnique alreadyTested) <> " recording failure for item " <> failoverLabel
atomically . modifyTVar failover $ \failover' -> if
| views (P.focus . _failoverReferences) (Set.member currentlyTesting) failover'
- -> fromMaybe failover' $ P.next failover'
+ -> fromMaybe (goFirst failover') $ P.next failover'
| otherwise
-> failover'
+ where goFirst l = maybe l goFirst $ P.previous l
$logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " using item " <> failoverLabel
res' <- handleAll (\err -> $logErrorS "withFailover'" (tshow (hashUnique alreadyTested) <> " exception during act or detAcceptable: " <> tshow err) >> recordFailure >> throwM err) $
diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs
index b9121904e..8ccf64b13 100644
--- a/src/Utils/Files.hs
+++ b/src/Utils/Files.hs
@@ -24,20 +24,30 @@ import Control.Monad.State.Class (modify)
import Database.Persist.Sql (deleteWhereCount)
+import Control.Monad.Trans.Resource (allocate)
-sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
+
+sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
sinkFiles = C.mapM sinkFile
-sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => File -> SqlPersistT m FileReference
+sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File -> SqlPersistT m FileReference
sinkFile File{ fileContent = Nothing, .. } = return FileReference
{ fileReferenceContent = Nothing
, fileReferenceTitle = fileTitle
, fileReferenceModified = fileModified
}
sinkFile File{ fileContent = Just fileContentContent, .. } = do
+ void . withUnliftIO $ \UnliftIO{..} ->
+ let takeLock = do
+ fileLockTime <- liftIO getCurrentTime
+ fileLockInstance <- getsYesod appInstanceID
+ insert FileLock{ fileLockContent = fileContentHash, .. }
+ releaseLock lId = liftHandler . runDB $ (withReaderT projectBackend $ setSerializable (delete lId :: SqlPersistT (HandlerFor UniWorX) ()) :: YesodDB UniWorX ())
+ in unliftIO $ allocate (unliftIO takeLock) (unliftIO . releaseLock)
+
inDB <- exists [ FileContentHash ==. fileContentHash ]
- let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{..}
+ let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{ fileContentUnreferencedSince = Nothing, .. }
maybeT sinkFileDB $ do
let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
@@ -60,10 +70,10 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do
fileContentHash = Crypto.hash fileContentContent
-sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
+sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
sinkFiles' = C.mapM $ uncurry sinkFile'
-sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
+sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
sinkFile' file residual = do
reference <- sinkFile file
return $ _FileReference # (reference, residual)
diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs
index 47f90a449..b3ad49706 100644
--- a/src/Utils/Sql.hs
+++ b/src/Utils/Sql.hs
@@ -3,6 +3,8 @@ module Utils.Sql
) where
import ClassyPrelude.Yesod
+import Numeric.Natural
+import Settings.Log
import Database.PostgreSQL.Simple (SqlError)
import Database.PostgreSQL.Simple.Errors (isSerializationError)
@@ -16,23 +18,27 @@ import Control.Retry
import Control.Lens ((&))
-setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
+setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a
setSerializable = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6
-setSerializable' :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => RetryPolicyM (ReaderT SqlBackend m) -> ReaderT SqlBackend m a -> ReaderT SqlBackend m a
+setSerializable' :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => RetryPolicyM (SqlPersistT m) -> SqlPersistT m a -> ReaderT SqlBackend m a
setSerializable' policy act = do
+ LogSettings{logSerializableTransactionRetryLimit} <- readLogSettings
didCommit <- newTVarIO False
- recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry logRetry) $ act' didCommit
+ recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry (logRetry logSerializableTransactionRetryLimit)) $ act' didCommit
where
suggestRetry :: SqlError -> ReaderT SqlBackend m Bool
suggestRetry = return . isSerializationError
- logRetry :: Bool -- ^ Will retry
+ logRetry :: Maybe Natural
+ -> Bool -- ^ Will retry
-> SqlError
-> RetryStatus
-> ReaderT SqlBackend m ()
- logRetry shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
- logRetry shouldRetry@True err status = $logDebugS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
+ logRetry _ shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
+ logRetry (Just limit) shouldRetry err status
+ | fromIntegral limit <= rsIterNumber status = $logInfoS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
+ logRetry _ shouldRetry err status = $logDebugS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
act' :: TVar Bool -> RetryStatus -> ReaderT SqlBackend m a
act' didCommit RetryStatus{..} = do
diff --git a/templates/mail/sheetHint.hamlet b/templates/mail/sheetHint.hamlet
index 621f15227..a20ded146 100644
--- a/templates/mail/sheetHint.hamlet
+++ b/templates/mail/sheetHint.hamlet
@@ -11,11 +11,11 @@ $newline never
}
|