From dd235590b47a90d70753458ffc7ab61c771f3d9b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 17 Sep 2020 20:29:14 +0200 Subject: [PATCH 01/39] fix: migration --- src/Model/Migration.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 0d77f6da3..f82b909e2 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -166,6 +166,7 @@ migrateManual = do , ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" ) , ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" ) , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) + , ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" ) ] where addIndex :: Text -> Sql -> Migration @@ -945,7 +946,7 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE file_content_chunk ADD COLUMN content_based boolean NOT NULL DEFAULT false; UPDATE file_content_chunk SET content_based = true WHERE length(content) <= #{fastCDCMinBlockSize chunkingParams}; - CREATE TABLE file_content_entry (hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL); + CREATE TABLE file_content_entry (id bigserial NOT NULL PRIMARY KEY, hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL); INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk); |] ) From e5ae1521a0577df35abe13b6bcc602f3a38a6f9c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 17 Sep 2020 20:38:00 +0200 Subject: [PATCH 02/39] fix(metrics): sort metrics --- src/Handler/Metrics.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs index 0250e9851..cd1a6baa3 100644 --- a/src/Handler/Metrics.hs +++ b/src/Handler/Metrics.hs @@ -21,7 +21,8 @@ getMetricsR = selectRep $ do where metricsHtml :: Handler Html metricsHtml = do - samples <- collectMetrics + let metricSort = comparing $ \(SampleGroup Info{..} _ mSamples) -> (metricName, mSamples <&> \(Sample sampleName lbls _) -> (sampleName, lbls)) + samples <- sortBy metricSort <$> collectMetrics metricsBearer <- runMaybeT . hoist runDB $ do uid <- MaybeT maybeAuthId From e099e13816d2ca79cbcc6a84fe970052980c0feb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 17 Sep 2020 21:56:41 +0200 Subject: [PATCH 03/39] fix(file-jobs): improve log messages --- src/Jobs/Handler/Files.hs | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 55218e170..4190a1131 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -198,7 +198,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom .| C.mapM deleteChunk .| C.fold - when (deletedChunks > 0) $ + when (deletedChunks > 0 || deletedChunkSize > 0) $ $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|] @@ -211,9 +211,12 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do extractReference (Minio.ListItemObject oi) = (oi, ) <$> Minio.oiObject oi ^? minioFileReference extractReference _ = Nothing - injectOrDelete :: (Minio.Object, FileContentReference) - -> Handler (Sum Int64) -- ^ Injected - injectOrDelete (obj, fRef) = do + injectOrDelete :: (Minio.ObjectInfo, FileContentReference) + -> Handler (Sum Natural, Sum Word64) + injectOrDelete (objInfo, fRef) = do + let obj = Minio.oiObject objInfo + sz = fromIntegral $ Minio.oiSize objInfo + fRef' <- runDB . setSerializable $ do chunkVar <- newEmptyTMVarIO dbAsync <- allocateLinkedAsync $ do @@ -234,19 +237,18 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do maybeT (return ()) . runAppMinio . handleIf minioIsDoesNotExist (const $ return ()) $ Minio.removeObject uploadBucket obj | otherwise -> $logErrorS "InjectFiles" [st|Minio object “#{obj}”'s content does not match it's name (content hash: #{tshow fRef'} /= name hash: #{tshow fRef})|] - return . bool mempty (Sum 1) $ is _Just fRef' + return . bool mempty (Sum 1, Sum sz) $ is _Just fRef' - Sum inj <- + (Sum injectedFiles, Sum injectedSize) <- runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True) .| C.mapMaybe extractReference .| maybe (C.map id) (takeWhileTime . (/ 2)) interval .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize) - .| C.map (over _1 Minio.oiObject) - .| transPipe lift (C.mapM injectOrDelete) + .| C.mapM (lift . injectOrDelete) .| C.fold - when (inj > 0) $ - $logInfoS "InjectFiles" [st|Injected #{inj} files from upload cache into database|] + when (injectedFiles > 0 || injectedSize > 0) $ + $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{tshow injectedSize} bytes)|] data RechunkFileException @@ -281,7 +283,7 @@ dispatchJobRechunkFiles = JobHandlerAtomic . hoist lift $ do throwM $ RechunkFileExceptionHashMismatch fRef fRef' return (Sum 1, Sum sz) - (Sum rechunkedEntries, Sum rechunkedSize) <- runConduit $ + (Sum rechunkedFiles, Sum rechunkedSize) <- runConduit $ getEntryCandidates .| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz) .| maybe (C.map id) (takeWhileTime . (/ 2)) interval @@ -289,5 +291,5 @@ dispatchJobRechunkFiles = JobHandlerAtomic . hoist lift $ do .| C.mapM (uncurry rechunkFile) .| C.fold - when (rechunkedEntries > 0 || rechunkedSize > 0) $ - $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedEntries} files in database (#{tshow rechunkedSize} bytes)|] + when (rechunkedFiles > 0 || rechunkedSize > 0) $ + $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{tshow rechunkedSize} bytes)|] From 7038099389fcca684a9e1a3f28f76629e0c194bd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 18 Sep 2020 11:34:58 +0200 Subject: [PATCH 04/39] fix(jobs): delimit resource allocation to within handler Hopefully fixes memory leak in production --- src/Jobs.hs | 2 +- src/Utils.hs | 20 +++++++++++++++++++- src/Yesod/Core/Types/Instances.hs | 12 +++--------- src/Yesod/Core/Types/Instances/Catch.hs | 18 ++++++++++++++++++ 4 files changed, 41 insertions(+), 11 deletions(-) create mode 100644 src/Yesod/Core/Types/Instances/Catch.hs diff --git a/src/Jobs.hs b/src/Jobs.hs index 7e849400f..5703bff62 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -383,7 +383,7 @@ mkLogIdent :: JobWorkerId -> Text mkLogIdent wId = "Job-Executor " <> showWorkerId wId handleJobs' :: JobWorkerId -> ConduitT JobCtl Void (ReaderT JobContext Handler) () -handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do +handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorkerState wNum JobWorkerBusy $ do $logDebugS logIdent $ tshow jctl res <- fmap (either Just $ const Nothing) . withJobWorkerState wNum (JobWorkerExecJobCtl jctl) . try' $ handleCmd jctl sentRes <- mapReaderT (liftIO . atomically) $ do diff --git a/src/Utils.hs b/src/Utils.hs index 5f25e1ac3..446f66d30 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -3,7 +3,7 @@ module Utils , List.nub, List.nubBy ) where -import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch) +import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold @@ -117,6 +117,11 @@ import Unsafe.Coerce import System.FilePath as Utils (addExtension, isExtensionOf) import System.FilePath (dropDrive) +import Yesod.Core.Types +import Yesod.Core.Types.Instances.Catch () +import Control.Monad.Trans.Resource +import Control.Monad.Reader.Class (MonadReader(local)) + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -187,6 +192,19 @@ instance HasContentType YamlValue where toYAML :: ToJSON a => a -> YamlValue toYAML = YamlValue . toJSON + +delimitInternalState :: forall site a. HandlerFor site a -> HandlerFor site a +-- | Switches the `InternalState` contained within the environment of `HandlerFor` to new one created with `bracket` +-- +-- Therefor all `ResourceT`-Resources allocated within the inner `HandlerFor`-Action are collected at the end of it. +delimitInternalState act = bracket createInternalState closeInternalState $ \newInternalState -> local (renewEnviron newInternalState) act + where + renewEnviron newInternalState HandlerData{..} + = HandlerData { handlerResource = newInternalState + , .. + } + + --------------------- -- Text and String -- --------------------- diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 924c27673..50f96b0ad 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -24,24 +24,18 @@ import Language.Haskell.TH import Control.Monad.Reader (MonadReader(..)) import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Base (MonadBase) -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Catch (MonadMask, MonadCatch) +import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Random.Class (MonadRandom) import Control.Monad.Morph (MFunctor, MMonad) + +import Yesod.Core.Types.Instances.Catch () deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadFix (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadFix (WidgetFor site) -deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site) -deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site) -deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site) - -deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site) -deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site) -deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site) - deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadBase IO (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site) diff --git a/src/Yesod/Core/Types/Instances/Catch.hs b/src/Yesod/Core/Types/Instances/Catch.hs new file mode 100644 index 000000000..8e2a8388b --- /dev/null +++ b/src/Yesod/Core/Types/Instances/Catch.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Yesod.Core.Types.Instances.Catch + () where + +import ClassyPrelude.Yesod +import Yesod.Core.Types + +import Control.Monad.Catch (MonadMask, MonadCatch) + + +deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site) +deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site) +deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site) + +deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site) +deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site) +deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site) From d8d6ae1ce1b087fcff0a985df0809d7f9684432d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 18 Sep 2020 12:16:46 +0200 Subject: [PATCH 05/39] chore(release): 20.1.1 --- CHANGELOG.md | 10 ++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 13 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 67e64602c..e8743a2af 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ 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. +### [20.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.0...v20.1.1) (2020-09-18) + + +### Bug Fixes + +* **file-jobs:** improve log messages ([e099e13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e099e13816d2ca79cbcc6a84fe970052980c0feb)) +* **jobs:** delimit resource allocation to within handler ([7038099](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7038099389fcca684a9e1a3f28f76629e0c194bd)) +* **metrics:** sort metrics ([e5ae152](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e5ae1521a0577df35abe13b6bcc602f3a38a6f9c)) +* migration ([dd23559](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dd235590b47a90d70753458ffc7ab61c771f3d9b)) + ## [20.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.0.0...v20.1.0) (2020-09-17) diff --git a/package-lock.json b/package-lock.json index 5a78f8bad..d01f3d98c 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.1.0", + "version": "20.1.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 92a1f56d5..85488cde9 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.1.0", + "version": "20.1.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index fe4f0c6ce..8d93a2610 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.1.0 +version: 20.1.1 dependencies: - base From 6d475497c0caee49ad34c5c3c6e7b1bf91ca0ba2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 18 Sep 2020 15:16:55 +0200 Subject: [PATCH 06/39] fix(exam-form): sort occurrences and parts --- src/Handler/Exam/Form.hs | 24 ++++++++++++++++++++++-- test/Handler/Exam/FormSpec.hs | 35 +++++++++++++++++++++++++++++++++++ test/Model/TypesSpec.hs | 7 +++++++ 3 files changed, 64 insertions(+), 2 deletions(-) create mode 100644 test/Handler/Exam/FormSpec.hs diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 1bfa7f79a..7674d6ef3 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -52,7 +52,18 @@ data ExamOccurrenceForm = ExamOccurrenceForm , eofStart :: UTCTime , eofEnd :: Maybe UTCTime , eofDescription :: Maybe Html - } deriving (Read, Show, Eq, Ord, Generic, Typeable) + } deriving (Read, Show, Eq, Generic, Typeable) + +instance Ord ExamOccurrenceForm where + compare = mconcat + [ comparing eofName + , comparing eofStart + , comparing eofRoom + , comparing eofEnd + , comparing eofCapacity + , comparing eofDescription + , comparing eofId + ] data ExamPartForm = ExamPartForm { epfId :: Maybe CryptoUUIDExamPart @@ -60,7 +71,16 @@ data ExamPartForm = ExamPartForm , epfName :: Maybe ExamPartName , epfMaxPoints :: Maybe Points , epfWeight :: Rational - } deriving (Read, Show, Eq, Ord, Generic, Typeable) + } deriving (Read, Show, Eq, Generic, Typeable) + +instance Ord ExamPartForm where + compare = mconcat + [ comparing epfNumber + , comparing epfName + , comparing epfMaxPoints + , comparing epfWeight + , comparing epfId + ] makeLenses_ ''ExamForm diff --git a/test/Handler/Exam/FormSpec.hs b/test/Handler/Exam/FormSpec.hs new file mode 100644 index 000000000..d49dbac6c --- /dev/null +++ b/test/Handler/Exam/FormSpec.hs @@ -0,0 +1,35 @@ +module Handler.Exam.FormSpec where + +import TestImport +import ModelSpec () +import CryptoID + +import Handler.Exam.Form + + +instance Arbitrary ExamOccurrenceForm where + arbitrary = ExamOccurrenceForm + <$> (fmap (view _2) <$> (arbitrary :: Gen (Maybe (ExamOccurrenceId, CryptoUUIDExamOccurrence)))) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary ExamPartForm where + arbitrary = ExamPartForm + <$> (fmap (view _2) <$> (arbitrary :: Gen (Maybe (ExamPartId, CryptoUUIDExamPart)))) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + + +spec :: Spec +spec = do + parallel $ do + lawsCheckHspec (Proxy @ExamOccurrenceForm) + [ eqLaws, ordLaws, showReadLaws ] + lawsCheckHspec (Proxy @ExamPartForm) + [ eqLaws, ordLaws ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 9606efd6b..5c975a6d0 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -37,6 +37,8 @@ import Data.Word.Word24 import qualified Data.Binary as Binary import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -287,6 +289,9 @@ instance Arbitrary Sex where instance Arbitrary Word24 where arbitrary = arbitraryBoundedRandom +instance Arbitrary ExamPartNumber where + arbitrary = review _ExamPartNumber . CI.mk . pack . getPrintableString <$> arbitrary + shrink = map (review _ExamPartNumber) . shrink . view _ExamPartNumber spec :: Spec @@ -380,6 +385,8 @@ spec = do [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] lawsCheckHspec (Proxy @Word24) [ persistFieldLaws, jsonLaws, binaryLaws ] + lawsCheckHspec (Proxy @ExamPartNumber) + [ persistFieldLaws, jsonLaws, pathPieceLaws, csvFieldLaws, eqLaws, ordLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ From 4801d22cb360dcd936c57494ff2ff02655431409 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Sep 2020 12:16:47 +0200 Subject: [PATCH 07/39] feat(metrics): measure file i/o --- src/Handler/Utils/Files.hs | 13 +++++++---- src/Jobs.hs | 1 + src/Utils/Files.hs | 10 +++++++-- src/Utils/Metrics.hs | 44 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 62 insertions(+), 6 deletions(-) diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index aa0d280bc..8d8ca5dd8 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -40,9 +40,11 @@ sourceFileDB fileReference = do return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) case chunk of Nothing -> throwM SourceFilesContentUnavailable - Just (E.Value c) -> return . Just . (c, ) $ if - | olength c >= dbChunksize -> Just $ start + dbChunksize - | otherwise -> Nothing + Just (E.Value c) -> do + observeSourcedChunk StorageDB $ olength c + return . Just . (c, ) $ if + | olength c >= dbChunksize -> Just $ start + dbChunksize + | otherwise -> Nothing chunkHashes = E.selectSource . E.from $ \fileContentEntry -> do E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryIx ] @@ -65,7 +67,10 @@ sourceFileMinio fileReference = do mChunk <- atomically $ Right <$> takeTMVar chunkVar <|> Left <$> waitCatchSTM minioAsync case mChunk of - Right chunk -> yield chunk >> go + Right chunk -> do + observeSourcedChunk StorageMinio $ olength chunk + yield chunk + go Left (Right ()) -> return () Left (Left exc) -> throwM exc in go diff --git a/src/Jobs.hs b/src/Jobs.hs index 5703bff62..91e8cf605 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -101,6 +101,7 @@ handleJobs foundation@UniWorX{..} jobShutdown <- liftIO newEmptyTMVarIO jobCurrentCrontab <- liftIO $ newTVarIO Nothing jobHeldLocks <- liftIO $ newTVarIO Set.empty + registerJobHeldLocksCount jobHeldLocks atomically $ putTMVar appJobState JobState { jobContext = JobContext{..} , .. diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 3119313da..3b334391c 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -7,6 +7,7 @@ module Utils.Files ) where import Import.NoFoundation +import Utils.Metrics import Foundation.Type import Handler.Utils.Minio import qualified Network.Minio as Minio @@ -46,6 +47,8 @@ sinkFileDB doReplace fileContentContent = do fileChunkLockTime <- liftIO getCurrentTime fileChunkLockInstance <- getsYesod appInstanceID + observeSunkChunk StorageDB $ olength fileContentChunkContent + tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. } existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash] let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased] @@ -98,8 +101,11 @@ sinkFileMinio fileContentContent = do case nextChunk of Nothing -> putMVar chunk Nothing - Just nextChunk' - -> putMVar chunk (Just nextChunk') >> yield nextChunk' >> putChunks + Just nextChunk' -> do + observeSunkChunk StorageMinio $ olength nextChunk' + putMVar chunk $ Just nextChunk' + yield nextChunk' + putChunks sinkAsync <- lift . allocateLinkedAsync . runConduit $ fileContentContent .| putChunks diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 34265c36a..301d1aae9 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -3,10 +3,12 @@ module Utils.Metrics , registerGHCMetrics , observeHTTPRequestLatency , registerReadyMetric + , registerJobHeldLocksCount , withJobWorkerStateLbls , observeYesodCacheSize , observeFavouritesQuickActionsDuration , LoginOutcome(..), observeLoginOutcome + , FileChunkStorage(..), observeSourcedChunk, observeSunkChunk ) where import Import.NoModel hiding (Vector, Info) @@ -25,6 +27,8 @@ import qualified Network.HTTP.Types as HTTP import Yesod.Core.Types (HandlerData(..), GHState(..)) +import qualified Data.Set as Set + {-# ANN module ("HLint: ignore Use even" :: String) #-} @@ -110,6 +114,31 @@ loginOutcomes = unsafeRegister . vector ("plugin", "outcome") $ counter info where info = Info "uni2work_login_attempts_total" "Number of login attempts" +data JobHeldLocksCount = MkJobHeldLocksCount + +jobHeldLocksCount :: TVar (Set QueuedJobId) -> Metric JobHeldLocksCount +jobHeldLocksCount heldLocks = Metric $ return (MkJobHeldLocksCount, collectJobHeldLocksCount) + where + collectJobHeldLocksCount = do + nLocks <- Set.size <$> readTVarIO heldLocks + let sample = encodeUtf8 $ tshow nLocks + return [SampleGroup info GaugeType [Sample "uni2work_jobs_held_locks_count" [] sample]] + info = Info "uni2work_jobs_held_locks_count" + "Number of job locks currently held by this Uni2work-instance" + +{-# NOINLINE sourcedFileChunkSizes #-} +sourcedFileChunkSizes :: Vector Label1 Histogram +sourcedFileChunkSizes = unsafeRegister . vector ("storage") $ histogram info buckets + where info = Info "uni2work_sourced_file_chunks_bytes" + "Sizes of files chunks sourced" + buckets = 0 : histogramBuckets 1 20000000 + +{-# NOINLINE sunkFileChunkSizes #-} +sunkFileChunkSizes :: Vector Label1 Histogram +sunkFileChunkSizes = unsafeRegister . vector ("storage") $ histogram info buckets + where info = Info "uni2work_sunk_file_chunks_bytes" + "Sizes of files chunks sunk" + buckets = 0 : histogramBuckets 1 100000000 withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics act = do @@ -196,3 +225,18 @@ observeLoginOutcome :: MonadHandler m -> m () observeLoginOutcome plugin outcome = liftIO $ withLabel loginOutcomes (plugin, toPathPiece outcome) incCounter + +registerJobHeldLocksCount :: MonadIO m => TVar (Set QueuedJobId) -> m () +registerJobHeldLocksCount = liftIO . void . register . jobHeldLocksCount + +data FileChunkStorage = StorageMinio | StorageDB + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''FileChunkStorage $ camelToPathPiece' 1 + +observeSunkChunk, observeSourcedChunk :: (Integral n, MonadIO m) => FileChunkStorage -> n -> m () +observeSunkChunk store = liftIO . observeChunkSize sunkFileChunkSizes store . fromIntegral +observeSourcedChunk store = liftIO . observeChunkSize sourcedFileChunkSizes store . fromIntegral + +observeChunkSize :: Vector Label1 Histogram -> FileChunkStorage -> Integer -> IO () +observeChunkSize metric (toPathPiece -> storageLabel) = withLabel metric storageLabel . flip observe . fromInteger From 8afacdd6b742d7a918d269ea6a9a056ba7ee24cc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Sep 2020 12:24:31 +0200 Subject: [PATCH 08/39] refactor: hlint --- src/Utils/Metrics.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 301d1aae9..443b816ea 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -128,14 +128,14 @@ jobHeldLocksCount heldLocks = Metric $ return (MkJobHeldLocksCount, collectJobHe {-# NOINLINE sourcedFileChunkSizes #-} sourcedFileChunkSizes :: Vector Label1 Histogram -sourcedFileChunkSizes = unsafeRegister . vector ("storage") $ histogram info buckets +sourcedFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets where info = Info "uni2work_sourced_file_chunks_bytes" "Sizes of files chunks sourced" buckets = 0 : histogramBuckets 1 20000000 {-# NOINLINE sunkFileChunkSizes #-} sunkFileChunkSizes :: Vector Label1 Histogram -sunkFileChunkSizes = unsafeRegister . vector ("storage") $ histogram info buckets +sunkFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets where info = Info "uni2work_sunk_file_chunks_bytes" "Sizes of files chunks sunk" buckets = 0 : histogramBuckets 1 100000000 From d21faf4de0d40a3683ff2a7a3020bc85717f827c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Sep 2020 13:31:53 +0200 Subject: [PATCH 09/39] feat: improve logging/metrics wrt. batch jobs --- src/Jobs.hs | 7 + src/Jobs/Handler/Files.hs | 326 +++++++++++---------- src/Jobs/Handler/PersonalisedSheetFiles.hs | 12 +- src/Jobs/Handler/PruneInvitations.hs | 10 +- src/Jobs/Handler/TransactionLog.hs | 40 +-- src/Jobs/Types.hs | 29 +- src/Utils/Metrics.hs | 116 +++++++- 7 files changed, 327 insertions(+), 213 deletions(-) diff --git a/src/Jobs.hs b/src/Jobs.hs index 91e8cf605..17ec46921 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -102,6 +102,7 @@ handleJobs foundation@UniWorX{..} jobCurrentCrontab <- liftIO $ newTVarIO Nothing jobHeldLocks <- liftIO $ newTVarIO Set.empty registerJobHeldLocksCount jobHeldLocks + registerJobWorkerQueueDepth appJobState atomically $ putTMVar appJobState JobState { jobContext = JobContext{..} , .. @@ -452,6 +453,12 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker JobHandlerException act -> do act & withJobWorkerState wNum (JobWorkerExecJob content) runDB $ setSerializable cleanup + JobHandlerAtomicWithFinalizer act fin -> do + res <- runDBJobs . setSerializable $ do + res <- act & withJobWorkerState wNum (JobWorkerExecJob content) + hoist lift cleanup + return res + fin res handleCmd JobCtlDetermineCrontab = do newCTab <- liftHandler . runDB $ setSerializable determineCrontab' -- logDebugS logIdent $ tshow newCTab diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 4190a1131..c3e24551d 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -34,11 +34,13 @@ import Handler.Utils.Files (sourceFileDB) dispatchJobPruneSessionFiles :: JobHandler UniWorX -dispatchJobPruneSessionFiles = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - expires <- getsYesod $ view _appSessionFilesExpire - n <- deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ] - $logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|] +dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + expires <- getsYesod $ view _appSessionFilesExpire + deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ] + fin n = $logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|] @@ -64,142 +66,146 @@ pruneUnreferencedFilesIntervalsCache :: TVar (Map Natural [(Maybe FileContentChu pruneUnreferencedFilesIntervalsCache = unsafePerformIO $ newTVarIO Map.empty dispatchJobPruneUnreferencedFiles :: Natural -> Natural -> Natural -> JobHandler UniWorX -dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - interval <- getsYesod $ view _appPruneUnreferencedFilesInterval - keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles +dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + interval <- getsYesod $ view _appPruneUnreferencedFilesInterval + keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles - let - chunkHashBytes :: forall h. - ( Unwrapped FileContentChunkReference ~ Digest h ) - => Integer - chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h)) - chunkHashBits = chunkHashBytes * 8 - base :: Integer - base = 2 ^ chunkHashBits - intervals :: [Integer] - -- | Exclusive upper bounds - intervals - | numIterations <= 0 = pure base - | otherwise = go protoIntervals ^.. folded . _1 - where - go [] = [] - go ints - | maximumOf (folded . _1) ints == Just base = ints - | otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts - where - closest = maximumBy (comparing $ view _2) ints - (lts, geqs) = partition (((>) `on` view _1) closest) ints - gts = filter (((<) `on` view _1) closest) geqs + let + chunkHashBytes :: forall h. + ( Unwrapped FileContentChunkReference ~ Digest h ) + => Integer + chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h)) + chunkHashBits = chunkHashBytes * 8 + base :: Integer + base = 2 ^ chunkHashBits + intervals :: [Integer] -- | Exclusive upper bounds - protoIntervals :: [(Integer, Integer)] - protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations - | i <- [1 .. toInteger numIterations] - ] + intervals + | numIterations <= 0 = pure base + | otherwise = go protoIntervals ^.. folded . _1 + where + go [] = [] + go ints + | maximumOf (folded . _1) ints == Just base = ints + | otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts + where + closest = maximumBy (comparing $ view _2) ints + (lts, geqs) = partition (((>) `on` view _1) closest) ints + gts = filter (((<) `on` view _1) closest) geqs + -- | Exclusive upper bounds + protoIntervals :: [(Integer, Integer)] + protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations + | i <- [1 .. toInteger numIterations] + ] - intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals + intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals - toDigest :: Integer -> Maybe FileContentChunkReference - toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step - where step i - | i <= 0 = Nothing - | otherwise = Just (fromIntegral i, i `shiftR` 8) - pad bs - | toInteger (ByteString.length bs) >= chunkHashBytes = bs - | otherwise = pad $ ByteString.cons 0 bs + toDigest :: Integer -> Maybe FileContentChunkReference + toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step + where step i + | i <= 0 = Nothing + | otherwise = Just (fromIntegral i, i `shiftR` 8) + pad bs + | toInteger (ByteString.length bs) >= chunkHashBytes = bs + | otherwise = pad $ ByteString.cons 0 bs - intervalsDgsts <- atomically $ do - cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache - case Map.lookup numIterations cachedDgsts of - Just c -> return c - Nothing -> do - modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts' - return intervalsDgsts' + intervalsDgsts <- atomically $ do + cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache + case Map.lookup numIterations cachedDgsts of + Just c -> return c + Nothing -> do + modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts' + return intervalsDgsts' - let - permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch) - - (minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts) - chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool) - chunkIdFilter cRef = E.and $ catMaybes - [ minBoundDgst <&> \b -> cRef E.>=. E.val b - , maxBoundDgst <&> \b -> cRef E.<. E.val b - ] + let + permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch) - $logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst) - - E.insertSelectWithConflict - (UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint") - (E.from $ \fileContentChunk -> do - E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId + (minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts) + chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool) + chunkIdFilter cRef = E.and $ catMaybes + [ minBoundDgst <&> \b -> cRef E.>=. E.val b + , maxBoundDgst <&> \b -> cRef E.<. E.val b + ] + + $logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst) + + E.insertSelectWithConflict + (UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint") + (E.from $ \fileContentChunk -> do + E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId + return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash + E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash + return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now + ) + (\current excluded -> + [ FileContentChunkUnreferencedSince E.=. E.min (current E.^. FileContentChunkUnreferencedSince) (excluded E.^. FileContentChunkUnreferencedSince) ] + ) + + E.delete . E.from $ \fileContentChunkUnreferenced -> do + E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash - E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash - return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now - ) - (\current excluded -> - [ FileContentChunkUnreferencedSince E.=. E.min (current E.^. FileContentChunkUnreferencedSince) (excluded E.^. FileContentChunkUnreferencedSince) ] - ) + E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) - E.delete . E.from $ \fileContentChunkUnreferenced -> do - E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + let + getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do + let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do + E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash + E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince + E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince - let - getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do - let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do - E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) - return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince - E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince + E.groupBy $ fileContentEntry E.^. FileContentEntryHash + E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryHash ] - E.groupBy $ fileContentEntry E.^. FileContentEntryHash - E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryHash ] - - return $ fileContentEntry E.^. FileContentEntryHash + return $ fileContentEntry E.^. FileContentEntryHash - deleteEntry :: _ -> DB (Sum Natural) - deleteEntry (E.Value fRef) = - bool 0 1 . (> 0) <$> deleteWhereCount [FileContentEntryHash ==. fRef] - - Sum deletedEntries <- runConduit $ - getEntryCandidates - .| takeWhileTime (interval / 3) - .| C.mapM deleteEntry - .| C.fold - - when (deletedEntries > 0) $ - $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|] - - let - getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do - E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now) - E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry -> - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + deleteEntry :: _ -> DB (Sum Natural) + deleteEntry (E.Value fRef) = + bool 0 1 . (> 0) <$> deleteWhereCount [FileContentEntryHash ==. fRef] - return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - , E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent) - ) + Sum deletedEntries <- runConduit $ + getEntryCandidates + .| takeWhileTime (interval / 3) + .| C.mapM deleteEntry + .| C.fold - deleteChunk :: _ -> DB (Sum Natural, Sum Word64) - deleteChunk (E.Value cRef, E.Value size) = do - deleteWhere [ FileContentChunkUnreferencedHash ==. cRef ] - (, Sum size) . fromIntegral <$> deleteWhereCount [FileContentChunkHash ==. unFileContentChunkKey cRef] + let + getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do + E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now) + E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry -> + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - (Sum deletedChunks, Sum deletedChunkSize) <- runConduit $ - getChunkCandidates - .| takeWhileTime (interval / 3) - .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64) - .| C.mapM deleteChunk - .| C.fold + E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) - when (deletedChunks > 0 || deletedChunkSize > 0) $ - $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|] + return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + , E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent) + ) + + deleteChunk :: _ -> DB (Sum Natural, Sum Word64) + deleteChunk (E.Value cRef, E.Value size) = do + deleteWhere [ FileContentChunkUnreferencedHash ==. cRef ] + (, Sum size) . fromIntegral <$> deleteWhereCount [FileContentChunkHash ==. unFileContentChunkKey cRef] + + (Sum deletedChunks, Sum deletedChunkSize) <- runConduit $ + getChunkCandidates + .| takeWhileTime (interval / 3) + .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64) + .| C.mapM deleteChunk + .| C.fold + + return (deletedEntries, deletedChunks, deletedChunkSize) + + fin (deletedEntries, deletedChunks, deletedChunkSize) = do + observeDeletedUnreferencedFiles deletedEntries + $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|] + observeDeletedUnreferencedChunks deletedChunks deletedChunkSize + $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|] dispatchJobInjectFiles :: JobHandler UniWorX @@ -245,10 +251,10 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do .| maybe (C.map id) (takeWhileTime . (/ 2)) interval .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize) .| C.mapM (lift . injectOrDelete) + .| C.mapM (\res@(Sum inj, Sum sz) -> res <$ observeRechunkedFiles inj sz) .| C.fold - when (injectedFiles > 0 || injectedSize > 0) $ - $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{tshow injectedSize} bytes)|] + $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{tshow injectedSize} bytes)|] data RechunkFileException @@ -258,38 +264,42 @@ data RechunkFileException deriving anyclass (Exception) dispatchJobRechunkFiles :: JobHandler UniWorX -dispatchJobRechunkFiles = JobHandlerAtomic . hoist lift $ do - interval <- getsYesod $ view _appRechunkFiles - let - getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do - E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do - E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash - E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash - E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased - - let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do +dispatchJobRechunkFiles = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + interval <- getsYesod $ view _appRechunkFiles + let + getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do + E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash - return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64)) - - return ( fileContentEntry E.^. FileContentEntryHash - , size - ) + E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased - rechunkFile :: FileContentReference -> Word64 -> DB (Sum Natural, Sum Word64) - rechunkFile fRef sz = do - fRef' <- sinkFileDB True $ sourceFileDB fRef - unless (fRef == fRef') $ - throwM $ RechunkFileExceptionHashMismatch fRef fRef' - return (Sum 1, Sum sz) + let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do + E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash + E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash + return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64)) - (Sum rechunkedFiles, Sum rechunkedSize) <- runConduit $ - getEntryCandidates - .| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz) - .| maybe (C.map id) (takeWhileTime . (/ 2)) interval - .| persistentTokenBucketTakeC' TokenBucketRechunkFiles (view _2 :: _ -> Word64) - .| C.mapM (uncurry rechunkFile) - .| C.fold - - when (rechunkedFiles > 0 || rechunkedSize > 0) $ - $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{tshow rechunkedSize} bytes)|] + return ( fileContentEntry E.^. FileContentEntryHash + , size + ) + + rechunkFile :: FileContentReference -> Word64 -> DB (Sum Natural, Sum Word64) + rechunkFile fRef sz = do + fRef' <- sinkFileDB True $ sourceFileDB fRef + unless (fRef == fRef') $ + throwM $ RechunkFileExceptionHashMismatch fRef fRef' + return (Sum 1, Sum sz) + + (Sum rechunkedFiles, Sum rechunkedSize) <- runConduit $ + getEntryCandidates + .| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz) + .| maybe (C.map id) (takeWhileTime . (/ 2)) interval + .| persistentTokenBucketTakeC' TokenBucketRechunkFiles (view _2 :: _ -> Word64) + .| C.mapM (uncurry rechunkFile) + .| C.fold + + return (rechunkedFiles, rechunkedSize) + fin (rechunkedFiles, rechunkedSize) = do + observeRechunkedFiles rechunkedFiles rechunkedSize + $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{tshow rechunkedSize} bytes)|] diff --git a/src/Jobs/Handler/PersonalisedSheetFiles.hs b/src/Jobs/Handler/PersonalisedSheetFiles.hs index 35bd8cd61..af906e61f 100644 --- a/src/Jobs/Handler/PersonalisedSheetFiles.hs +++ b/src/Jobs/Handler/PersonalisedSheetFiles.hs @@ -8,8 +8,10 @@ import Database.Persist.Sql (deleteWhereCount) dispatchJobPruneFallbackPersonalisedSheetFilesKeys :: JobHandler UniWorX -dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire - n <- deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ] - $logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|] +dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire + deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ] + fin n = $logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|] diff --git a/src/Jobs/Handler/PruneInvitations.hs b/src/Jobs/Handler/PruneInvitations.hs index e7516f204..756b56d0a 100644 --- a/src/Jobs/Handler/PruneInvitations.hs +++ b/src/Jobs/Handler/PruneInvitations.hs @@ -7,7 +7,9 @@ import Import import Database.Persist.Sql (deleteWhereCount) dispatchJobPruneInvitations :: JobHandler UniWorX -dispatchJobPruneInvitations = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - n <- deleteWhereCount [ InvitationExpiresAt <. Just now ] - $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|] +dispatchJobPruneInvitations = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + deleteWhereCount [ InvitationExpiresAt <. Just now ] + fin n = $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|] diff --git a/src/Jobs/Handler/TransactionLog.hs b/src/Jobs/Handler/TransactionLog.hs index 131ba2491..ae8d8fa96 100644 --- a/src/Jobs/Handler/TransactionLog.hs +++ b/src/Jobs/Handler/TransactionLog.hs @@ -9,23 +9,27 @@ import Handler.Utils.DateTime import Database.Persist.Sql (updateWhereCount, deleteWhereCount) dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: JobHandler UniWorX -dispatchJobTruncateTransactionLog = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - let localNow = utcToLocalTime now - (localCurrentYear, _, _) = toGregorian $ localDay localNow - localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight - (currentYear, _, _) = toGregorian $ utctDay now - startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0 - startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of - LTUUnique utc' _ -> utc' - _other -> startOfPreviousYear +dispatchJobTruncateTransactionLog = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + let localNow = utcToLocalTime now + (localCurrentYear, _, _) = toGregorian $ localDay localNow + localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight + (currentYear, _, _) = toGregorian $ utctDay now + startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0 + startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of + LTUUnique utc' _ -> utc' + _other -> startOfPreviousYear - n <- deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ] - $logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|] -dispatchJobDeleteTransactionLogIPs = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime - let cutoff = addUTCTime (- retentionTime) now + deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ] + fin n = $logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|] +dispatchJobDeleteTransactionLogIPs = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime + let cutoff = addUTCTime (- retentionTime) now - n <- updateWhereCount [ TransactionLogTime <. cutoff, TransactionLogRemote !=. Nothing ] [ TransactionLogRemote =. Nothing ] - $logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|] + updateWhereCount [ TransactionLogTime <. cutoff, TransactionLogRemote !=. Nothing ] [ TransactionLogRemote =. Nothing ] + fin n = $logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|] diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 59a15c99a..ee1c9aa3b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -11,11 +11,10 @@ module Jobs.Types , JobContext(..) , JobState(..) , jobWorkerNames - , JobWorkerState(..) - , withJobWorkerState + , JobWorkerState(..), _jobWorkerJobCtl, _jobWorkerJob , JobWorkerId , showWorkerId, newWorkerId - , JobQueue, jqInsert, jqDequeue + , JobQueue, jqInsert, jqDequeue, jqDepth , JobPriority(..), prioritiseJob , jobNoQueueSame , module Cron @@ -38,10 +37,6 @@ import qualified Data.Set as Set import Data.PQueue.Prio.Max (MaxPQueue) import qualified Data.PQueue.Prio.Max as PQ -import Utils.Metrics (withJobWorkerStateLbls) - -import qualified Prometheus (Label4) - import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone) @@ -179,7 +174,8 @@ type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJo data JobHandler site = JobHandlerAtomic (YesodJobDB site ()) | JobHandlerException (HandlerFor site ()) - deriving (Generic, Typeable) + | forall a. JobHandlerAtomicWithFinalizer (YesodJobDB site a) (a -> HandlerFor site ()) + deriving (Typeable) makePrisms ''JobHandler @@ -199,20 +195,6 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "state" "data" } ''JobWorkerState -classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4 -classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob) - where - Aeson.Object obj = Aeson.toJSON jws - Aeson.String tag = obj HashMap.! "state" - mJobCtl = asum - [ classifyJobCtl <$> jws ^? _jobWorkerJobCtl - , "perform" <$ jws ^? _jobWorkerJob - ] - mJob = classifyJob <$> jws ^? _jobWorkerJob - -withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a -withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt - newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique } deriving (Eq, Ord) @@ -273,6 +255,9 @@ jqInsert job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job) job jqDequeue :: JobQueue -> Maybe (JobCtl, JobQueue) jqDequeue = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxView . getJobQueue +jqDepth :: Integral n => JobQueue -> n +jqDepth = fromIntegral . PQ.size . getJobQueue + data JobState = JobState { jobWorkers :: Map (Async ()) (TVar JobQueue) diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 443b816ea..16c6f994c 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -1,14 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + module Utils.Metrics ( withHealthReportMetrics , registerGHCMetrics , observeHTTPRequestLatency , registerReadyMetric - , registerJobHeldLocksCount - , withJobWorkerStateLbls + , withJobWorkerState , observeYesodCacheSize , observeFavouritesQuickActionsDuration , LoginOutcome(..), observeLoginOutcome + , registerJobHeldLocksCount , FileChunkStorage(..), observeSourcedChunk, observeSunkChunk + , observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles + , registerJobWorkerQueueDepth ) where import Import.NoModel hiding (Vector, Info) @@ -29,6 +33,11 @@ import Yesod.Core.Types (HandlerData(..), GHState(..)) import qualified Data.Set as Set +import Jobs.Types + +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap + {-# ANN module ("HLint: ignore Use even" :: String) #-} @@ -130,15 +139,75 @@ jobHeldLocksCount heldLocks = Metric $ return (MkJobHeldLocksCount, collectJobHe sourcedFileChunkSizes :: Vector Label1 Histogram sourcedFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets where info = Info "uni2work_sourced_file_chunks_bytes" - "Sizes of files chunks sourced" - buckets = 0 : histogramBuckets 1 20000000 + "Sizes of file chunks sourced" + buckets = 0 : histogramBuckets 1 1000000000 {-# NOINLINE sunkFileChunkSizes #-} sunkFileChunkSizes :: Vector Label1 Histogram sunkFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets where info = Info "uni2work_sunk_file_chunks_bytes" - "Sizes of files chunks sunk" - buckets = 0 : histogramBuckets 1 100000000 + "Sizes of file chunks sunk" + buckets = 0 : histogramBuckets 1 1000000000 + +{-# NOINLINE deletedUnreferencedFiles #-} +deletedUnreferencedFiles :: Counter +deletedUnreferencedFiles = unsafeRegister $ counter info + where info = Info "uni2work_deleted_unreferenced_files_count" + "Number of unreferenced files deleted" + +{-# NOINLINE deletedUnreferencedChunks #-} +deletedUnreferencedChunks :: Counter +deletedUnreferencedChunks = unsafeRegister $ counter info + where info = Info "uni2work_deleted_unreferenced_chunks_count" + "Number of unreferenced chunks deleted" + +{-# NOINLINE deletedUnreferencedChunksBytes #-} +deletedUnreferencedChunksBytes :: Counter +deletedUnreferencedChunksBytes = unsafeRegister $ counter info + where info = Info "uni2work_deleted_unreferenced_chunks_bytes" + "Size of unreferenced chunks deleted" + +{-# NOINLINE injectedFiles #-} +injectedFiles :: Counter +injectedFiles = unsafeRegister $ counter info + where info = Info "uni2work_injected_files_count" + "Number of files injected from upload cache into database" + +{-# NOINLINE injectedFilesBytes #-} +injectedFilesBytes :: Counter +injectedFilesBytes = unsafeRegister $ counter info + where info = Info "uni2work_injected_files_bytes" + "Size of files injected from upload cache into database" + +{-# NOINLINE rechunkedFiles #-} +rechunkedFiles :: Counter +rechunkedFiles = unsafeRegister $ counter info + where info = Info "uni2work_rechunked_files_count" + "Number of files rechunked within database" + +{-# NOINLINE rechunkedFilesBytes #-} +rechunkedFilesBytes :: Counter +rechunkedFilesBytes = unsafeRegister $ counter info + where info = Info "uni2work_rechunked_files_bytes" + "Size of files rechunked within database" + +data JobWorkerQueueDepth = MkJobWorkerQueueDepth + +jobWorkerQueueDepth :: TMVar JobState -> Metric JobWorkerQueueDepth +jobWorkerQueueDepth jSt = Metric $ return (MkJobWorkerQueueDepth, collectJobWorkerQueueDepth) + where + collectJobWorkerQueueDepth = maybeT (return []) $ do + wQueues <- hoist atomically $ do + JobState{..} <- MaybeT $ tryReadTMVar jSt + flip ifoldMapM jobWorkers $ \wAsync wQueue + -> lift $ pure . (jobWorkerName wAsync, ) . jqDepth <$> readTVar wQueue + return [ SampleGroup info GaugeType + [ Sample "uni2work_queued_jobs_count" [("worker", showWorkerId wName)] . encodeUtf8 $ tshow wDepth + | (wName, wDepth) <- wQueues + ] + ] + info = Info "uni2work_queued_jobs_count" + "Number of JobQueue entries in this Uni2work-instance" withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics act = do @@ -181,6 +250,20 @@ observeHTTPRequestLatency classifyHandler app req respond' = do registerReadyMetric :: MonadIO m => m () registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime +classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4 +classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob) + where + Aeson.Object obj = Aeson.toJSON jws + Aeson.String tag = obj HashMap.! "state" + mJobCtl = asum + [ classifyJobCtl <$> jws ^? _jobWorkerJobCtl + , "perform" <$ jws ^? _jobWorkerJob + ] + mJob = classifyJob <$> jws ^? _jobWorkerJob + +withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a +withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt + withJobWorkerStateLbls :: (MonadIO m, MonadMask m) => Label4 -> m a -> m a withJobWorkerStateLbls newLbls act = do liftIO $ withLabel jobWorkerStateTransitions newLbls incCounter @@ -240,3 +323,24 @@ observeSourcedChunk store = liftIO . observeChunkSize sourcedFileChunkSizes stor observeChunkSize :: Vector Label1 Histogram -> FileChunkStorage -> Integer -> IO () observeChunkSize metric (toPathPiece -> storageLabel) = withLabel metric storageLabel . flip observe . fromInteger + +observeDeletedUnreferencedFiles :: MonadIO m => Natural -> m () +observeDeletedUnreferencedFiles = liftIO . void . addCounter deletedUnreferencedFiles . fromIntegral + +observeDeletedUnreferencedChunks :: MonadIO m => Natural -> Word64 -> m () +observeDeletedUnreferencedChunks num size = liftIO $ do + void . addCounter deletedUnreferencedChunks $ fromIntegral num + void . addCounter deletedUnreferencedChunksBytes $ fromIntegral size + +observeInjectedFiles :: MonadIO m => Natural -> Word64 -> m () +observeInjectedFiles num size = liftIO $ do + void . addCounter injectedFiles $ fromIntegral num + void . addCounter injectedFilesBytes $ fromIntegral size + +observeRechunkedFiles :: MonadIO m => Natural -> Word64 -> m () +observeRechunkedFiles num size = liftIO $ do + void . addCounter rechunkedFiles $ fromIntegral num + void . addCounter rechunkedFilesBytes $ fromIntegral size + +registerJobWorkerQueueDepth :: MonadIO m => TMVar JobState -> m () +registerJobWorkerQueueDepth = liftIO . void . register . jobWorkerQueueDepth From cbf41b2ea061aa276f455dde1e31464d106cd3d7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Sep 2020 13:59:57 +0200 Subject: [PATCH 10/39] feat(logging): additional logging for inject-files --- src/Jobs/Handler/Files.hs | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index c3e24551d..c3559482e 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + module Jobs.Handler.Files ( dispatchJobPruneSessionFiles , dispatchJobPruneUnreferencedFiles @@ -32,6 +34,8 @@ import System.IO.Unsafe import Handler.Utils.Files (sourceFileDB) +import Control.Monad.Logger (askLoggerIO, runLoggingT) + dispatchJobPruneSessionFiles :: JobHandler UniWorX dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin @@ -229,9 +233,24 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do atomically $ isEmptyTMVar chunkVar >>= guard . not sinkFileDB False $ C.unfoldM (\x -> fmap (, x) <$> atomically (takeTMVar chunkVar)) () + logger <- askLoggerIO didSend <- maybeT (return False) . hoistMaybeM . runAppMinio . runMaybeT $ do objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions - lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar . Just) + let sendChunks = go 0 0 + where + go :: forall m. MonadIO m => Natural -> Int64 -> ConduitT ByteString Void m () + go c accsz = do + chunk' <- await + whenIsJust chunk' $ \chunk -> do + let csz = fromIntegral $ olength chunk + !sz' = accsz + csz + p :: Centi + p = realToFrac $ (toInteger sz' % toInteger sz) * 100 + !c' = succ c + runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{tshow csz}): #{tshow sz'}/#{tshow sz} (#{tshow p}%)...|] + atomically . putTMVar chunkVar $ Just chunk + go c' sz' + lift . runConduit $ Minio.gorObjectStream objRes .| sendChunks return True if | not didSend -> Nothing <$ cancel dbAsync From 967ec26fffc7f3144467f6f6b32ae9799d2db8a9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Sep 2020 14:10:18 +0200 Subject: [PATCH 11/39] chore(release): 20.2.0 --- CHANGELOG.md | 14 ++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 17 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e8743a2af..aa6713c34 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. +## [20.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.1...v20.2.0) (2020-09-21) + + +### Features + +* **logging:** additional logging for inject-files ([cbf41b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbf41b2ea061aa276f455dde1e31464d106cd3d7)) +* improve logging/metrics wrt. batch jobs ([d21faf4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d21faf4de0d40a3683ff2a7a3020bc85717f827c)) +* **metrics:** measure file i/o ([4801d22](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4801d22cb360dcd936c57494ff2ff02655431409)) + + +### Bug Fixes + +* **exam-form:** sort occurrences and parts ([6d47549](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6d475497c0caee49ad34c5c3c6e7b1bf91ca0ba2)) + ### [20.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.0...v20.1.1) (2020-09-18) diff --git a/package-lock.json b/package-lock.json index d01f3d98c..1461a359b 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.1.1", + "version": "20.2.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 85488cde9..b5575a3e2 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.1.1", + "version": "20.2.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 8d93a2610..e01561661 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.1.1 +version: 20.2.0 dependencies: - base From 284aae12135ad97b1cf85b45f1176da6930876ee Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Sep 2020 23:14:37 +0200 Subject: [PATCH 12/39] feat(jobs): move held-up jobs to different workers --- config/settings.yml | 3 +- src/Control/Monad/Catch/Instances.hs | 10 +++ src/Import/NoModel.hs | 1 + src/Jobs.hs | 101 ++++++++++++++++++++------- src/Jobs/Handler/Files.hs | 19 +++-- src/Jobs/Queue.hs | 14 +++- src/Jobs/Types.hs | 36 ++++++++-- src/Settings.hs | 2 + src/System/Clock/Instances.hs | 29 ++++++++ src/UnliftIO/Async/Utils.hs | 41 +++++++++-- src/Utils.hs | 18 ++++- src/Utils/Form.hs | 2 +- src/Utils/Sql.hs | 5 +- 13 files changed, 232 insertions(+), 49 deletions(-) create mode 100644 src/Control/Monad/Catch/Instances.hs diff --git a/config/settings.yml b/config/settings.yml index d8b8b0330..252507577 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -26,7 +26,8 @@ mail-support: job-workers: "_env:JOB_WORKERS:10" job-flush-interval: "_env:JOB_FLUSH:30" job-cron-interval: "_env:CRON_INTERVAL:60" -job-stale-threshold: 300 +job-stale-threshold: 1800 +job-move-threshold: 30 notification-rate-limit: 3600 notification-collate-delay: 7200 notification-expiration: 259200 diff --git a/src/Control/Monad/Catch/Instances.hs b/src/Control/Monad/Catch/Instances.hs new file mode 100644 index 000000000..c0d1c3345 --- /dev/null +++ b/src/Control/Monad/Catch/Instances.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Control.Monad.Catch.Instances + () where + +import ClassyPrelude +import Control.Monad.Catch + + +deriving instance Functor ExitCase diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 7c03533a4..0f29237c5 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -174,6 +174,7 @@ import System.Clock.Instances as Import () import Data.Word.Word24.Instances as Import () import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache) import Database.Persist.Sql.Types.Instances as Import () +import Control.Monad.Catch.Instances as Import () 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 17ec46921..d461b539b 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -40,10 +40,10 @@ import qualified Control.Monad.Catch as Exc import Data.Time.Zones -import Control.Concurrent.STM (retry) +import Control.Concurrent.STM (stateTVar, retry) import Control.Concurrent.STM.Delay -import UnliftIO.Concurrent (forkIO, myThreadId) +import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay) import Jobs.Handler.SendNotification @@ -68,6 +68,8 @@ import Control.Exception.Base (AsyncException) import Type.Reflection (typeOf) +import System.Clock + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime @@ -143,11 +145,17 @@ manageJobPool :: forall m. => UniWorX -> (forall a. m a -> m a) -> m () manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> flip runContT return . callCC $ \terminate' -> - forever . join . lift . routeExc . atomically $ asum - [ spawnMissingWorkers - , reapDeadWorkers - , terminateGracefully terminate' - ] + forever . join . lift . routeExc $ do + transferInfo <- runMaybeT $ do + moveThreshold <- hoistMaybe $ appJobMoveThreshold appSettings' + let MkFixed (fromInteger -> delayTime) = realToFrac moveThreshold / 2 :: Micro + liftIO $ (,) <$> getTime Monotonic <*> newDelay delayTime + atomically . asum $ + [ spawnMissingWorkers + , reapDeadWorkers + ] ++ maybe [] (\(cTime, delay) -> [return () <$ waitDelay delay, transferJobs cTime]) transferInfo ++ + [ terminateGracefully terminate' + ] where shutdownOnException :: ((forall m'. Monad m' => m (m' ()) -> m (m' ())) -> m a) -> m a shutdownOnException act = do @@ -193,10 +201,8 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> | shouldTerminate -> return $ return () | otherwise -> do - queue <- readTVar chan - nextVal <- case jqDequeue queue of - Nothing -> retry - Just (j, q) -> j <$ writeTVar chan q + mNext <- stateTVar chan $ \q -> maybe (Nothing, q) (over _1 Just) $ jqDequeue q + nextVal <- hoistMaybe mNext return $ yield nextVal >> streamChan runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) $ do $logInfoS logIdent "Started" @@ -231,10 +237,11 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers' return (nextVal, receiver) whenIsJust next $ \(nextVal, receiver) -> do - atomically . modifyTVar' receiver $ jqInsert nextVal + atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!) go in go + terminateGracefully :: (() -> ContT () m ()) -> STM (ContT () m ()) terminateGracefully terminate = do shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown guard shouldTerminate @@ -246,6 +253,37 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> $logInfoS "JobPoolManager" "Shutting down" terminate () + transferJobs :: TimeSpec -> STM (ContT () m ()) + transferJobs oldTime = do + moveThreshold <- hoistMaybe $ appJobMoveThreshold appSettings' + let isOld ts = oldTime - ts >= realToFrac moveThreshold + + oldState <- readTMVar appJobState + wState <- mapM readTVar $ jobWorkers oldState + + let receivers = Map.keysSet $ Map.filter ((== 0) . jqDepth) wState + senders' = Map.keysSet $ Map.filter (ianyOf jqContents $ \(_, Down qTime) _ -> isOld qTime) wState + senders = senders' `Set.difference` receivers + sendJobs = Map.restrictKeys wState senders ^.. folded . backwards jqContents . filtered jobMovable + + guard $ not (null receivers) + && not (null senders) + && not (null sendJobs) + + let movePairs = flip zip sendJobs . evalRand (uniforms receivers) . mkStdGen $ hash oldTime + + iforMOf_ (_jobWorkers .> itraversed) oldState $ \w tv -> if + | w `elem` senders + -> writeTVar tv mempty + | w `elem` receivers + -> forM_ movePairs $ \(recv, j) -> if + | recv == w -> readTVar tv >>= jqInsert j >>= (writeTVar tv $!) + | otherwise -> return () + | otherwise + -> return () + + return $ $logWarnS "JobPoolManager" [st|Moved #{tshow (olength movePairs)} long-unadressed jobs from #{tshow (olength senders)} senders to #{tshow (olength receivers)} receivers|] + stopJobCtl :: MonadUnliftIO m => UniWorX -> m () -- ^ Stop all worker threads currently running stopJobCtl UniWorX{appJobState} = do @@ -278,7 +316,7 @@ execCrontab = do | otherwise = return () runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued - mapRWST (liftHandler . runDB . setSerializable) mergeState + mapRWST (liftHandler . runDB . setSerializableBatch) mergeState refT <- liftIO getCurrentTime settings <- getsYesod appSettings' @@ -300,7 +338,7 @@ execCrontab = do atomically . writeTVar crontabTVar $ Just (now, currentCrontab') $logDebugS "Crontab" . intercalate "\n" $ "Current crontab:" : map tshow currentCrontab' - let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do + let doJob = mapRWST (liftHandler . runDBJobs . setSerializableBatch) $ do newCrontab <- lift $ hoist lift determineCrontab' when (newCrontab /= currentCrontab) $ mapRWST (liftIO . atomically) $ @@ -416,9 +454,15 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) - handleCmd JobCtlTest = return () - handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod) - handleCmd (JobCtlQueue job) = lift $ queueJob' job + handleCmd JobCtlTest = $logDebugS logIdent "JobCtlTest" + handleCmd JobCtlFlush = do + $logDebugS logIdent "JobCtlFlush..." + void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod) + $logInfoS logIdent "JobCtlFlush" + handleCmd (JobCtlQueue job) = do + $logDebugS logIdent "JobCtlQueue..." + lift $ queueJob' job + $logInfoS logIdent "JobCtlQueue" handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \(Entity _ j@QueuedJob{..}) -> lift $ do content <- case fromJSON queuedJobContent of Aeson.Success c -> return c @@ -447,42 +491,49 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker delete jId case performJob content of - JobHandlerAtomic act -> runDBJobs . setSerializable $ do + JobHandlerAtomic act -> runDBJobs . setSerializableBatch $ do act & withJobWorkerState wNum (JobWorkerExecJob content) hoist lift cleanup JobHandlerException act -> do act & withJobWorkerState wNum (JobWorkerExecJob content) - runDB $ setSerializable cleanup + runDB $ setSerializableBatch cleanup JobHandlerAtomicWithFinalizer act fin -> do - res <- runDBJobs . setSerializable $ do + res <- runDBJobs . setSerializableBatch $ do res <- act & withJobWorkerState wNum (JobWorkerExecJob content) hoist lift cleanup return res fin res handleCmd JobCtlDetermineCrontab = do - newCTab <- liftHandler . runDB $ setSerializable determineCrontab' + $logDebugS logIdent "DetermineCrontab..." + newCTab <- liftHandler . runDB $ setSerializableBatch determineCrontab' + $logInfoS logIdent "DetermineCrontab" -- logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . void . flip swapTVar newCTab =<< asks jobCrontab handleCmd (JobCtlGenerateHealthReport kind) = do hrStorage <- getsYesod appHealthReport + $logDebugS logIdent [st|#{tshow kind}...|] newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind - $logInfoS (tshow kind) $ toPathPiece newStatus + $logInfoS logIdent [st|#{tshow kind}: #{toPathPiece newStatus}|] unless (newStatus == HealthSuccess) $ do - $logErrorS (tshow kind) $ tshow newReport + $logErrorS logIdent [st|#{tshow kind}: #{tshow newReport}|] liftIO $ do now <- getCurrentTime let updateReports = Set.insert (now, newReport) . Set.filter (((/=) `on` classifyHealthReport) newReport . snd) atomically . modifyTVar' hrStorage $ force . updateReports + handleCmd (JobCtlSleep secs@(MkFixed (fromIntegral -> msecs))) = do + $logInfoS logIdent [st|Sleeping #{tshow secs}s...|] + threadDelay msecs + $logInfoS logIdent [st|Slept #{tshow secs}s.|] jLocked :: QueuedJobId -> (Entity QueuedJob -> ReaderT JobContext Handler a) -> ReaderT JobContext Handler a jLocked jId act = flip evalStateT False $ do let lock :: StateT Bool (ReaderT JobContext Handler) (Entity QueuedJob) - lock = hoist (hoist $ runDB . setSerializable) $ do + lock = hoist (hoist $ runDB . setSerializableBatch) $ do qj@QueuedJob{..} <- lift . lift $ maybe (throwM $ JNonexistant jId) return =<< get jId instanceID' <- getsYesod $ view instanceID threshold <- getsYesod $ view _appJobStaleThreshold @@ -511,7 +562,7 @@ jLocked jId act = flip evalStateT False $ do unlock :: Entity QueuedJob -> StateT Bool (ReaderT JobContext Handler) () unlock (Entity jId' _) = whenM State.get $ do atomically . flip modifyTVar' (Set.delete jId') =<< asks jobHeldLocks - lift . lift . runDB . setSerializable $ + lift . lift . runDB . setSerializableBatch $ update jId' [ QueuedJobLockInstance =. Nothing , QueuedJobLockTime =. Nothing ] diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index c3559482e..17862fec9 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -36,6 +36,8 @@ import Handler.Utils.Files (sourceFileDB) import Control.Monad.Logger (askLoggerIO, runLoggingT) +import System.Clock + dispatchJobPruneSessionFiles :: JobHandler UniWorX dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin @@ -236,10 +238,11 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do logger <- askLoggerIO didSend <- maybeT (return False) . hoistMaybeM . runAppMinio . runMaybeT $ do objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions - let sendChunks = go 0 0 + let sendChunks = go 0 0 Nothing . toNanoSecs =<< liftIO (getTime Monotonic) where - go :: forall m. MonadIO m => Natural -> Int64 -> ConduitT ByteString Void m () - go c accsz = do + go :: forall m. MonadIO m => Natural -> Int64 -> Maybe Integer -> Integer -> ConduitT ByteString Void m () + go c accsz lastReport startT = do + currT <- liftIO $ toNanoSecs <$> getTime Monotonic chunk' <- await whenIsJust chunk' $ \chunk -> do let csz = fromIntegral $ olength chunk @@ -247,9 +250,15 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do p :: Centi p = realToFrac $ (toInteger sz' % toInteger sz) * 100 !c' = succ c - runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{tshow csz}): #{tshow sz'}/#{tshow sz} (#{tshow p}%)...|] + eta :: Integer + eta = ceiling $ ((currT - startT) % fromIntegral accsz) * fromIntegral (sz - fromIntegral accsz) + !lastReport' + | currT - fromMaybe startT lastReport > 5e9 = Just currT + | otherwise = lastReport + when (lastReport' /= lastReport) $ + runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{tshow csz}): #{tshow sz'}/#{tshow sz} (#{tshow p}%) ETA #{tshow eta}s...|] atomically . putTMVar chunkVar $ Just chunk - go c' sz' + go c' sz' lastReport' startT lift . runConduit $ Minio.gorObjectStream objRes .| sendChunks return True if diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index bb2faf762..491ce98b7 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -30,6 +30,8 @@ import UnliftIO.Concurrent (myThreadId) import Control.Monad.Trans.Resource (register) +import System.Clock (getTime, Clock(Monotonic)) + data JobQueueException = JobQueuePoolEmpty | JobQueueWorkerNotFound @@ -46,7 +48,7 @@ writeJobCtl' target cmd = do | null jobWorkers -> throwM JobQueuePoolEmpty | [(_, chan)] <- filter ((== target) . jobWorkerName . view _1) $ Map.toList jobWorkers - -> atomically . modifyTVar' chan $ jqInsert cmd + -> atomically $ readTVar chan >>= jqInsert cmd >>= (writeTVar chan $!) | otherwise -> throwM JobQueueWorkerNotFound @@ -56,9 +58,15 @@ writeJobCtl :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m ( -- Instructions are assigned deterministically and pseudo-randomly to one specific worker. -- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others writeJobCtl cmd = do - names <- fmap jobWorkerNames $ asks appJobState >>= atomically . readTMVar + jSt <- asks appJobState + names <- atomically $ jobWorkerNames <$> readTMVar jSt + when (null names) $ throwM JobQueuePoolEmpty tid <- myThreadId - let target = evalRand ?? mkStdGen (hash tid `hashWithSalt` cmd) $ uniform names + cTime <- liftIO $ getTime Monotonic + let + epoch :: Int64 + epoch = round cTime `div` 3600 + target = evalRand ?? mkStdGen (hash epoch `hashWithSalt` tid `hashWithSalt` cmd) $ uniform names writeJobCtl' target cmd diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index ee1c9aa3b..851ad9ac7 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -9,14 +9,14 @@ module Jobs.Types , YesodJobDB , JobHandler(..), _JobHandlerAtomic, _JobHandlerException , JobContext(..) - , JobState(..) + , JobState(..), _jobWorkers, _jobWorkerName, _jobContext, _jobPoolManager, _jobCron, _jobShutdown, _jobCurrentCrontab , jobWorkerNames , JobWorkerState(..), _jobWorkerJobCtl, _jobWorkerJob , JobWorkerId , showWorkerId, newWorkerId - , JobQueue, jqInsert, jqDequeue, jqDepth + , JobQueue, jqInsert, jqDequeue', jqDequeue, jqDepth, jqContents , JobPriority(..), prioritiseJob - , jobNoQueueSame + , jobNoQueueSame, jobMovable , module Cron ) where @@ -39,6 +39,9 @@ import qualified Data.PQueue.Prio.Max as PQ import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone) +import System.Clock (getTime, Clock(Monotonic), TimeSpec) +import GHC.Conc (unsafeIOToSTM) + data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } @@ -150,8 +153,11 @@ data JobCtl = JobCtlFlush | JobCtlQueue Job | JobCtlGenerateHealthReport HealthCheck | JobCtlTest + | JobCtlSleep Micro -- | For debugging deriving (Eq, Ord, Read, Show, Generic, Typeable) +makePrisms ''JobCtl + instance Hashable JobCtl instance NFData JobCtl @@ -242,22 +248,36 @@ jobNoQueueSame = \case JobRechunkFiles{} -> True _ -> False +jobMovable :: JobCtl -> Bool +jobMovable = isn't _JobCtlTest -newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue JobPriority JobCtl } + +newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue (JobPriority, Down TimeSpec) JobCtl } deriving (Eq, Ord, Read, Show) deriving newtype (Semigroup, Monoid, NFData) makePrisms ''JobQueue -jqInsert :: JobCtl -> JobQueue -> JobQueue -jqInsert job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job) job +jqInsert' :: TimeSpec -> JobCtl -> JobQueue -> JobQueue +jqInsert' cTime job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job, Down cTime) job + +jqInsert :: JobCtl -> JobQueue -> STM JobQueue +jqInsert job queue = do + cTime <- unsafeIOToSTM $ getTime Monotonic + return $ jqInsert' cTime job queue + +jqDequeue' :: JobQueue -> Maybe (((JobPriority, Down TimeSpec), JobCtl), JobQueue) +jqDequeue' = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxViewWithKey . getJobQueue jqDequeue :: JobQueue -> Maybe (JobCtl, JobQueue) -jqDequeue = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxView . getJobQueue +jqDequeue = fmap (over _1 $ view _2) . jqDequeue' jqDepth :: Integral n => JobQueue -> n jqDepth = fromIntegral . PQ.size . getJobQueue +jqContents :: IndexedTraversal' (JobPriority, Down TimeSpec) JobQueue JobCtl +jqContents = _JobQueue . PQ.traverseWithKey . indexed + data JobState = JobState { jobWorkers :: Map (Async ()) (TVar JobQueue) @@ -271,3 +291,5 @@ data JobState = JobState jobWorkerNames :: JobState -> Set JobWorkerId jobWorkerNames JobState{..} = Set.map jobWorkerName $ Map.keysSet jobWorkers + +makeLenses_ ''JobState diff --git a/src/Settings.hs b/src/Settings.hs index acedff5c4..b1b37557b 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -117,6 +117,7 @@ data AppSettings = AppSettings , appJobFlushInterval :: Maybe NominalDiffTime , appJobCronInterval :: Maybe NominalDiffTime , appJobStaleThreshold :: NominalDiffTime + , appJobMoveThreshold :: Maybe DiffTime , appNotificationRateLimit :: NominalDiffTime , appNotificationCollateDelay :: NominalDiffTime , appNotificationExpiration :: NominalDiffTime @@ -454,6 +455,7 @@ instance FromJSON AppSettings where appJobFlushInterval <- o .:? "job-flush-interval" appJobCronInterval <- o .:? "job-cron-interval" appJobStaleThreshold <- o .: "job-stale-threshold" + appJobMoveThreshold <- o .:? "job-move-threshold" appNotificationRateLimit <- o .: "notification-rate-limit" appNotificationCollateDelay <- o .: "notification-collate-delay" appNotificationExpiration <- o .: "notification-expiration" diff --git a/src/System/Clock/Instances.hs b/src/System/Clock/Instances.hs index 16082a700..936d6ea38 100644 --- a/src/System/Clock/Instances.hs +++ b/src/System/Clock/Instances.hs @@ -8,6 +8,35 @@ import ClassyPrelude import System.Clock import Data.Ratio ((%)) +import Data.Fixed + +import Control.Lens + instance Real TimeSpec where toRational TimeSpec{..} = fromIntegral sec + fromIntegral nsec % 1e9 + +instance Fractional TimeSpec where + a / b = fromRational $ toRational a / toRational b + fromRational n = fromNanoSecs n' + where MkFixed n' = fromRational n :: Nano + +instance RealFrac TimeSpec where + properFraction = over _2 fromRational . properFraction . toRational + + round x = let (n,r) = properFraction x + m = bool (n + 1) (n -1) $ r < fromRational 0 + s = signum (abs r - fromRational 0.5) + in if | s == fromRational (-1) -> n + | s == fromRational 0 -> bool m n $ even n + | s == fromRational 1 -> m + | otherwise -> error "round @TimeSpec: Bad value" + + ceiling x = bool n (n + 1) $ r > 0 + where (n,r) = properFraction x + + floor x = bool n (n - 1) $ r > 0 + where (n,r) = properFraction x + +instance NFData TimeSpec +instance Hashable TimeSpec diff --git a/src/UnliftIO/Async/Utils.hs b/src/UnliftIO/Async/Utils.hs index 3e0184997..851a72367 100644 --- a/src/UnliftIO/Async/Utils.hs +++ b/src/UnliftIO/Async/Utils.hs @@ -4,35 +4,66 @@ module UnliftIO.Async.Utils , allocateAsyncMasked, allocateLinkedAsyncMasked ) where -import ClassyPrelude hiding (cancel, async, link) +import ClassyPrelude hiding (cancel, async, link, finally, mask) import Control.Lens +import Control.Lens.Extras (is) import qualified UnliftIO.Async as UnliftIO import qualified Control.Concurrent.Async as A import Control.Monad.Trans.Resource +import qualified Control.Monad.Trans.Resource.Internal as ResourceT.Internal +import Data.Acquire + +import Control.Monad.Catch + + +withReference :: forall m a. (MonadUnliftIO m, MonadResource m) => ((IO (), IO ()) -> m a) -> m a +withReference act = do + releaseAct <- newEmptyTMVarIO + + let doAlloc = do + iSt <- liftResourceT getInternalState + liftIO $ mask $ \_ -> do + ResourceT.Internal.stateAlloc iSt + atomically $ putTMVar releaseAct () + return iSt + doRelease iSt eCase = liftIO . whenM (atomically $ is _Just <$> tryTakeTMVar releaseAct) $ do + flip ResourceT.Internal.stateCleanup iSt $ case eCase of + ExitCaseSuccess _ -> ReleaseNormal + ExitCaseException _ -> ReleaseException + ExitCaseAbort -> ReleaseEarly + + withRunInIO $ \run -> + fmap fst . generalBracket (run doAlloc) doRelease $ \iSt -> do + res <- run $ act + ( atomically $ takeTMVar releaseAct + , ResourceT.Internal.stateCleanup ReleaseNormal iSt + ) + atomically $ guard =<< isEmptyTMVar releaseAct + return res allocateAsync :: forall m a. ( MonadUnliftIO m, MonadResource m ) => m a -> m (Async a) -allocateAsync act = withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel . A.async $ run act +allocateAsync act = withReference $ \(signalReady, releaseRef) -> withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel . A.async . flip finally releaseRef $ signalReady >> run act allocateLinkedAsync :: forall m a. (MonadUnliftIO m, MonadResource m) => m a -> m (Async a) allocateLinkedAsync = uncurry (<$) . (id &&& UnliftIO.link) <=< allocateAsync allocateAsyncWithUnmask :: forall m a. - ( MonadUnliftIO m, MonadResource m ) + ( MonadUnliftIO m, MonadResource m) => ((forall b. m b -> m b) -> m a) -> m (Async a) -allocateAsyncWithUnmask act = withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel $ A.asyncWithUnmask $ \unmask -> run $ act (liftIO . unmask . run) +allocateAsyncWithUnmask act = withReference $ \(signalReady, releaseRef) -> withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel $ A.asyncWithUnmask $ \unmask -> flip finally releaseRef $ signalReady >> run (act $ liftIO . unmask . run) allocateLinkedAsyncWithUnmask :: forall m a. (MonadUnliftIO m, MonadResource m) => ((forall b. m b -> m b) -> m a) -> m (Async a) allocateLinkedAsyncWithUnmask act = uncurry (<$) . (id &&& UnliftIO.link) =<< allocateAsyncWithUnmask act allocateAsyncMasked :: forall m a. - ( MonadUnliftIO m, MonadResource m ) + ( MonadUnliftIO m, MonadResource m) => m a -> m (Async a) allocateAsyncMasked act = allocateAsyncWithUnmask (const act) diff --git a/src/Utils.hs b/src/Utils.hs index 446f66d30..654bd22c9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -106,8 +106,10 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -import Control.Monad.Random.Class (MonadRandom) +import Control.Monad.Random.Class (MonadSplit(getSplit), MonadRandom, MonadInterleave(interleave), uniform) +import Control.Monad.Random (RandomGen) import qualified System.Random.Shuffle as Rand (shuffleM) +import qualified Control.Monad.Random.Lazy as LazyRand import Data.Data (Data) import qualified Data.Text.Lazy.Builder as Builder @@ -739,6 +741,9 @@ throwExceptT :: ( Exception e, MonadThrow m ) => ExceptT e m a -> m a throwExceptT = exceptT throwM return +generalFinally :: MonadMask m => m a -> (ExitCase a -> m b) -> m a +generalFinally action finalizer = view _1 <$> generalBracket (return ()) (const finalizer) (const action) + ------------ -- Monads -- ------------ @@ -1192,6 +1197,10 @@ unstableSortOn = unstableSortBy . comparing unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a] unstableSort = unstableSortBy compare +uniforms :: (RandomGen g, MonadSplit g m, Foldable t) => t a -> m [a] +uniforms xs = LazyRand.evalRand go <$> getSplit + where go = (:) <$> interleave (uniform xs) <*> go + ---------- -- Lens -- ---------- @@ -1273,3 +1282,10 @@ infixr 4 () :: FilePath -> FilePath -> FilePath dir file = dir dropDrive file + + +---------------- +-- TH Dungeon -- +---------------- + +makePrisms ''ExitCase diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2fa06586a..307bd6fad 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- `WidgetT`, `HandlerT` module Utils.Form where diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index ad51820d0..c0470ba30 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -1,5 +1,5 @@ module Utils.Sql - ( setSerializable, setSerializable' + ( setSerializable, setSerializableBatch, setSerializable' , catchSql, handleSql , isUniqueConstraintViolation , catchIfSql, handleIfSql @@ -30,6 +30,9 @@ import Text.Shakespeare.Text (st) 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 + +setSerializableBatch :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a +setSerializableBatch = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 3600e6 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 From ffed57623f487bed8dbb1250fad88a56bf90626b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Sep 2020 23:28:19 +0200 Subject: [PATCH 13/39] chore(release): 20.3.0 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index aa6713c34..518df2729 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +## [20.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.2.0...v20.3.0) (2020-09-21) + + +### Features + +* **jobs:** move held-up jobs to different workers ([284aae1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/284aae12135ad97b1cf85b45f1176da6930876ee)) + ## [20.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.1...v20.2.0) (2020-09-21) diff --git a/package-lock.json b/package-lock.json index 1461a359b..084105183 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.2.0", + "version": "20.3.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b5575a3e2..13c2a1aa4 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.2.0", + "version": "20.3.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index e01561661..3c7bf4d79 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.2.0 +version: 20.3.0 dependencies: - base From 2a84edccb4cdfddc2bdc03ebdd2b934fd7f53884 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 22 Sep 2020 02:39:03 +0200 Subject: [PATCH 14/39] fix(jobs): improve job worker healthchecks & logging --- src/Jobs/Handler/Files.hs | 4 ++-- src/Jobs/Queue.hs | 24 +++++++++++++----------- src/Utils.hs | 13 +++++++++++++ 3 files changed, 28 insertions(+), 13 deletions(-) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 17862fec9..69f969538 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -251,12 +251,12 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do p = realToFrac $ (toInteger sz' % toInteger sz) * 100 !c' = succ c eta :: Integer - eta = ceiling $ ((currT - startT) % fromIntegral accsz) * fromIntegral (sz - fromIntegral accsz) + eta = ceiling $ (toRational (currT - startT) / fromIntegral accsz) * fromIntegral (sz - fromIntegral accsz) !lastReport' | currT - fromMaybe startT lastReport > 5e9 = Just currT | otherwise = lastReport when (lastReport' /= lastReport) $ - runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{tshow csz}): #{tshow sz'}/#{tshow sz} (#{tshow p}%) ETA #{tshow eta}s...|] + runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{tshow csz}): #{textBytes sz'}/#{textBytes sz} (#{tshow p}%) ETA #{textDuration eta}...|] atomically . putTMVar chunkVar $ Just chunk go c' sz' lastReport' startT lift . runConduit $ Minio.gorObjectStream objRes .| sendChunks diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index 491ce98b7..0a495194b 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -70,21 +70,23 @@ writeJobCtl cmd = do writeJobCtl' target cmd -writeJobCtlBlock' :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => (JobCtl -> m ()) -> JobCtl -> m () +writeJobCtlBlock' :: (MonadMask m, MonadIO m, MonadReader UniWorX m) => (JobCtl -> m ()) -> JobCtl -> m () -- | Pass an instruction to a `Job`-Worker using the provided callback and block until it was acted upon writeJobCtlBlock' writeCtl cmd = do getResVar <- fmap (jobConfirm . jobContext) $ asks appJobState >>= atomically . readTMVar - resVar <- atomically $ do - var <- newEmptyTMVar - modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var) - return var - writeCtl cmd - let - removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd - mExc <- atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar - maybe (return ()) throwM mExc -writeJobCtlBlock :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m () + let getResVar' = atomically $ do + var <- newEmptyTMVar + modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var) + return var + removeResVar resVar = modifyTVar' getResVar $ HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd + + bracket getResVar' (atomically . removeResVar) $ \resVar -> do + writeCtl cmd + mExc <- atomically $ takeTMVar resVar <* removeResVar resVar + maybe (return ()) throwM mExc + +writeJobCtlBlock :: (MonadMask m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m () -- | Pass an instruction to the `Job`-Workers and block until it was acted upon writeJobCtlBlock = writeJobCtlBlock' writeJobCtl diff --git a/src/Utils.hs b/src/Utils.hs index 654bd22c9..2aa71f0db 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -298,6 +298,19 @@ textBytes x rshow :: Double -> Text rshow = tshow . floorToDigits 1 +textDuration :: forall a. Integral a => a -> Text +textDuration n' = view _2 $ foldr acc (toInteger n', "") units + where units = sortOn (view _1) + [ (86400, "d") + , (3600, "h") + , (60, "m") + , (1, "s") + ] + acc (mult, unit) (n, t) + | unitCount > 0 = (unitRem, t <> tshow unitCount <> tshow unit) + | otherwise = (n, t) + where (unitCount, unitRem) = n `divMod` mult + stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounterCI = CI.map stepTextCounter From 23401570fea9386aec3e77777d2dcd07d5d4db66 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 22 Sep 2020 02:49:55 +0200 Subject: [PATCH 15/39] chore(release): 20.3.1 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 518df2729..f804bf2aa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +### [20.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.0...v20.3.1) (2020-09-22) + + +### Bug Fixes + +* **jobs:** improve job worker healthchecks & logging ([2a84edc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a84edccb4cdfddc2bdc03ebdd2b934fd7f53884)) + ## [20.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.2.0...v20.3.0) (2020-09-21) diff --git a/package-lock.json b/package-lock.json index 084105183..63eab15dd 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.3.0", + "version": "20.3.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 13c2a1aa4..c1fcadef6 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.3.0", + "version": "20.3.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 3c7bf4d79..da93c88cf 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.3.0 +version: 20.3.1 dependencies: - base From 2ca024b9351df800b57d3235c4a00776cd669952 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 22 Sep 2020 13:43:58 +0200 Subject: [PATCH 16/39] fix(files): don't inject serializable --- src/Jobs/Handler/Files.hs | 12 ++++++------ src/Utils.hs | 2 +- src/Utils/Sql.hs | 19 ++++++++++++++----- 3 files changed, 21 insertions(+), 12 deletions(-) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 69f969538..fa1eec303 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -211,7 +211,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom observeDeletedUnreferencedFiles deletedEntries $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|] observeDeletedUnreferencedChunks deletedChunks deletedChunkSize - $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|] + $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{textBytes deletedChunkSize})|] dispatchJobInjectFiles :: JobHandler UniWorX @@ -229,7 +229,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do let obj = Minio.oiObject objInfo sz = fromIntegral $ Minio.oiSize objInfo - fRef' <- runDB . setSerializable $ do + fRef' <- runDB $ do chunkVar <- newEmptyTMVarIO dbAsync <- allocateLinkedAsync $ do atomically $ isEmptyTMVar chunkVar >>= guard . not @@ -251,12 +251,12 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do p = realToFrac $ (toInteger sz' % toInteger sz) * 100 !c' = succ c eta :: Integer - eta = ceiling $ (toRational (currT - startT) / fromIntegral accsz) * fromIntegral (sz - fromIntegral accsz) + eta = ceiling $ ((toRational currT - toRational startT) / toRational accsz) * toRational (sz - fromIntegral accsz) !lastReport' | currT - fromMaybe startT lastReport > 5e9 = Just currT | otherwise = lastReport when (lastReport' /= lastReport) $ - runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{tshow csz}): #{textBytes sz'}/#{textBytes sz} (#{tshow p}%) ETA #{textDuration eta}...|] + runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{textBytes csz}): #{textBytes sz'}/#{textBytes sz} (#{tshow p}%) ETA #{textDuration eta}...|] atomically . putTMVar chunkVar $ Just chunk go c' sz' lastReport' startT lift . runConduit $ Minio.gorObjectStream objRes .| sendChunks @@ -282,7 +282,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do .| C.mapM (\res@(Sum inj, Sum sz) -> res <$ observeRechunkedFiles inj sz) .| C.fold - $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{tshow injectedSize} bytes)|] + $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{textBytes injectedSize})|] data RechunkFileException @@ -330,4 +330,4 @@ dispatchJobRechunkFiles = JobHandlerAtomicWithFinalizer act fin return (rechunkedFiles, rechunkedSize) fin (rechunkedFiles, rechunkedSize) = do observeRechunkedFiles rechunkedFiles rechunkedSize - $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{tshow rechunkedSize} bytes)|] + $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{textBytes rechunkedSize} bytes)|] diff --git a/src/Utils.hs b/src/Utils.hs index 2aa71f0db..4e0a169a5 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -307,7 +307,7 @@ textDuration n' = view _2 $ foldr acc (toInteger n', "") units , (1, "s") ] acc (mult, unit) (n, t) - | unitCount > 0 = (unitRem, t <> tshow unitCount <> tshow unit) + | unitCount > 0 = (unitRem, t <> tshow unitCount <> unit) | otherwise = (n, t) where (unitCount, unitRem) = n `divMod` mult diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index c0470ba30..19d9eda9f 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -27,6 +27,14 @@ import Control.Monad.Random.Class (MonadRandom(getRandom)) import Text.Shakespeare.Text (st) +import Control.Concurrent.Async (ExceptionInLinkedThread(..)) + + +fromExceptionWrapped :: Exception exc => SomeException -> Maybe exc +fromExceptionWrapped (fromException -> Just exc) = Just exc +fromExceptionWrapped ((fromException >=> \(ExceptionInLinkedThread _ exc') -> fromExceptionWrapped exc') -> Just exc) = Just exc +fromExceptionWrapped _ = Nothing + 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 @@ -40,12 +48,12 @@ setSerializable' policy act = do didCommit <- newTVarIO False recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry (logRetry logSerializableTransactionRetryLimit)) $ act' didCommit where - suggestRetry :: SqlError -> ReaderT SqlBackend m Bool - suggestRetry = return . isSerializationError + suggestRetry :: SomeException -> ReaderT SqlBackend m Bool + suggestRetry = return . maybe False isSerializationError . fromExceptionWrapped logRetry :: Maybe Natural -> Bool -- ^ Will retry - -> SqlError + -> SomeException -> RetryStatus -> ReaderT SqlBackend m () logRetry _ shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status @@ -74,10 +82,11 @@ handleSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> SqlPersistT m handleSql recover act = do savepointName <- liftIO $ UUID.toString <$> getRandom - let recover' :: SqlError -> SqlPersistT m a - recover' exc = do + let recover' :: SomeException -> SqlPersistT m a + recover' (fromExceptionWrapped -> Just exc) = do rawExecute [st|ROLLBACK TO SAVEPOINT "#{savepointName}"|] [] recover exc + recover' exc = throwM exc handle recover' $ do rawExecute [st|SAVEPOINT "#{savepointName}"|] [] From 513249b9eb3168b3d0639ce0bc7617e40916fc9b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 22 Sep 2020 14:14:25 +0200 Subject: [PATCH 17/39] refactor: hlint --- src/Utils/Sql.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 19d9eda9f..b88932062 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -32,7 +32,7 @@ import Control.Concurrent.Async (ExceptionInLinkedThread(..)) fromExceptionWrapped :: Exception exc => SomeException -> Maybe exc fromExceptionWrapped (fromException -> Just exc) = Just exc -fromExceptionWrapped ((fromException >=> \(ExceptionInLinkedThread _ exc') -> fromExceptionWrapped exc') -> Just exc) = Just exc +fromExceptionWrapped (fromException >=> \(ExceptionInLinkedThread _ exc') -> fromExceptionWrapped exc' -> Just exc) = Just exc fromExceptionWrapped _ = Nothing From 105069a24d23eab34ebde800eb1e841fee14fdba Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 22 Sep 2020 14:25:20 +0200 Subject: [PATCH 18/39] chore(release): 20.3.2 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f804bf2aa..23687131c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +### [20.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.1...v20.3.2) (2020-09-22) + + +### Bug Fixes + +* **files:** don't inject serializable ([2ca024b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2ca024b9351df800b57d3235c4a00776cd669952)) + ### [20.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.0...v20.3.1) (2020-09-22) diff --git a/package-lock.json b/package-lock.json index 63eab15dd..1b4e9454b 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.3.1", + "version": "20.3.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index c1fcadef6..331ca44b0 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.3.1", + "version": "20.3.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index da93c88cf..fe6acff95 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.3.1 +version: 20.3.2 dependencies: - base From e4416e7f0e2ea2cf9db0e61cf2d20c27260ccaf8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Sep 2020 14:05:30 +0200 Subject: [PATCH 19/39] fix(jobs): better flushing, correct metrics, better etas --- config/settings.yml | 4 ++-- src/Jobs.hs | 6 +++++- src/Jobs/Handler/Files.hs | 35 ++++++++++++++++++++++------------- src/Utils/Metrics.hs | 2 +- 4 files changed, 30 insertions(+), 17 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 252507577..9524f75b2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -161,8 +161,8 @@ upload-cache: disable-cert-validation: "_env:UPLOAD_S3_DISABLE_CERT_VALIDATION:false" upload-cache-bucket: "uni2work-uploads" -inject-files: 307 -rechunk-files: 601 +inject-files: 601 +rechunk-files: 1201 file-upload-db-chunksize: 4194304 # 4MiB file-chunking-target-exponent: 21 # 2MiB diff --git a/src/Jobs.hs b/src/Jobs.hs index d461b539b..37428a84c 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -454,10 +454,14 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) + handleCmd :: JobCtl -> ReaderT JobContext Handler () handleCmd JobCtlTest = $logDebugS logIdent "JobCtlTest" handleCmd JobCtlFlush = do $logDebugS logIdent "JobCtlFlush..." - void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod) + heldLocks <- asks jobHeldLocks >>= readTVarIO + void . lift . runDB . runConduit + $ selectKeys [ QueuedJobId /<-. Set.toList heldLocks ] [ Asc QueuedJobCreationTime ] + .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod) $logInfoS logIdent "JobCtlFlush" handleCmd (JobCtlQueue job) = do $logDebugS logIdent "JobCtlQueue..." diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index fa1eec303..2648edd05 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-error=deprecations #-} + {-# LANGUAGE BangPatterns #-} module Jobs.Handler.Files @@ -238,26 +240,33 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do logger <- askLoggerIO didSend <- maybeT (return False) . hoistMaybeM . runAppMinio . runMaybeT $ do objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions - let sendChunks = go 0 0 Nothing . toNanoSecs =<< liftIO (getTime Monotonic) + let sendChunks = go 0 0 Nothing =<< liftIO (getTime Monotonic) where - go :: forall m. MonadIO m => Natural -> Int64 -> Maybe Integer -> Integer -> ConduitT ByteString Void m () + go :: forall m. MonadIO m => Natural -> Int64 -> Maybe TimeSpec -> TimeSpec -> ConduitT ByteString Void m () go c accsz lastReport startT = do - currT <- liftIO $ toNanoSecs <$> getTime Monotonic + currT <- liftIO $ getTime Monotonic chunk' <- await whenIsJust chunk' $ \chunk -> do let csz = fromIntegral $ olength chunk - !sz' = accsz + csz - p :: Centi - p = realToFrac $ (toInteger sz' % toInteger sz) * 100 !c' = succ c - eta :: Integer - eta = ceiling $ ((toRational currT - toRational startT) / toRational accsz) * toRational (sz - fromIntegral accsz) + !sz' = accsz + csz !lastReport' - | currT - fromMaybe startT lastReport > 5e9 = Just currT + | toRational currT - toRational (fromMaybe startT lastReport) > 5 = Just currT | otherwise = lastReport - when (lastReport' /= lastReport) $ - runLoggingT ?? logger $ $logInfoS "InjectFiles" [st|Sinking chunk ##{tshow c} (#{textBytes csz}): #{textBytes sz'}/#{textBytes sz} (#{tshow p}%) ETA #{textDuration eta}...|] - atomically . putTMVar chunkVar $ Just chunk + when (csz > 0) $ do + let p :: Centi + p = realToFrac $ (toInteger sz' % toInteger sz) * 100 + eta :: Maybe Integer + eta = do + accsz' <- assertM' (/= 0) accsz + return . ceiling $ (toRational currT - toRational startT) / (fromIntegral accsz') * (fromIntegral sz - fromIntegral accsz) + when (lastReport' /= lastReport || sz' >= fromIntegral sz) $ + flip runLoggingT logger . $logInfoS "InjectFiles" . mconcat $ catMaybes + [ pure [st|Sinking chunk ##{tshow c} (#{textBytes csz}): #{textBytes sz'}/#{textBytes sz} (#{tshow p}%)|] + , eta <&> \eta' -> [st| ETA #{textDuration eta'}|] + , pure "..." + ] + atomically . putTMVar chunkVar $ Just chunk go c' sz' lastReport' startT lift . runConduit $ Minio.gorObjectStream objRes .| sendChunks return True @@ -279,7 +288,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do .| maybe (C.map id) (takeWhileTime . (/ 2)) interval .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize) .| C.mapM (lift . injectOrDelete) - .| C.mapM (\res@(Sum inj, Sum sz) -> res <$ observeRechunkedFiles inj sz) + .| C.mapM (\res@(Sum inj, Sum sz) -> res <$ observeInjectedFiles inj sz) .| C.fold $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{textBytes injectedSize})|] diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 16c6f994c..f9cfc0b2e 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -78,7 +78,7 @@ httpRequestLatency :: Vector Label3 Histogram httpRequestLatency = unsafeRegister . vector ("handler", "method", "status") $ histogram info buckets where info = Info "http_request_duration_seconds" "HTTP request latency" - buckets = histogramBuckets 50e-6 500 + buckets = histogramBuckets 50e-6 5000 data ReadySince = MkReadySince From fb0ae65ac5928443abc01de9b57c69849d6a6b21 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Sep 2020 16:48:41 +0200 Subject: [PATCH 20/39] feat(files): monitor missing files --- src/Jobs/Crontab.hs | 9 +++++ src/Jobs/Handler/Files.hs | 69 ++++++++++++++++++++++++++++++++++++++- src/Jobs/Types.hs | 2 ++ src/Utils/Metrics.hs | 11 +++++++ 4 files changed, 90 insertions(+), 1 deletion(-) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 8127e16e8..1663cb2fc 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -100,6 +100,15 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } + tell $ HashMap.singleton + (JobCtlQueue JobDetectMissingFiles) + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = 7200 + , cronNotAfter = Right CronNotScheduled + } + tell . flip foldMap universeF $ \kind -> case appHealthCheckInterval kind of Just int -> HashMap.singleton diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 2648edd05..b22a02af6 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -6,6 +6,7 @@ module Jobs.Handler.Files ( dispatchJobPruneSessionFiles , dispatchJobPruneUnreferencedFiles , dispatchJobInjectFiles, dispatchJobRechunkFiles + , dispatchJobDetectMissingFiles ) where import Import hiding (matching, maximumBy, init) @@ -30,7 +31,7 @@ import Data.Bits (Bits(shiftR)) import qualified Data.Map.Strict as Map -import Control.Monad.Random.Lazy +import Control.Monad.Random.Lazy (evalRand, mkStdGen) import System.Random.Shuffle (shuffleM) import System.IO.Unsafe @@ -40,6 +41,10 @@ import Control.Monad.Logger (askLoggerIO, runLoggingT) import System.Clock +import qualified Data.Set as Set + +import Jobs.Queue (YesodJobDB) + dispatchJobPruneSessionFiles :: JobHandler UniWorX dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin @@ -69,6 +74,68 @@ fileReferences (E.just -> fHash) ] +dispatchJobDetectMissingFiles :: JobHandler UniWorX +dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin + where + act :: YesodJobDB UniWorX (Map Text (NonNull (Set FileContentReference))) + act = hoist lift $ do + uploadBucket <- getsYesod $ view _appUploadCacheBucket + + missingDb <- forM trackedReferences $ \refQuery -> + fmap (Set.fromList . mapMaybe E.unValue) . E.select $ do + ref <- refQuery + E.where_ . E.not_ $ E.isNothing ref + E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry -> + E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. ref + E.distinctOnOrderBy [E.asc ref] $ return ref + + let allMissingDb :: Set Minio.Object + allMissingDb = setOf (folded . folded . re minioFileReference) missingDb + filterMissingDb :: forall m. Monad m + => Set Minio.Object + -> ConduitT Minio.ListItem (Set Minio.Object) m () + filterMissingDb remaining = maybeT (yield remaining) $ do + nextMinio <- MaybeT await + remaining' <- case nextMinio of + Minio.ListItemObject oi -> do + let (missingMinio, remaining') = Set.split (Minio.oiObject oi) remaining + lift $ yield missingMinio + return remaining' + _other -> return remaining + lift $ filterMissingDb remaining' + + allMissingMinio <- maybeT (return $ fold missingDb) . hoistMaybeM . runAppMinio . runMaybeT . runConduit $ + transPipe lift (Minio.listObjects uploadBucket Nothing True) + .| filterMissingDb allMissingDb + .| C.foldMapE (setOf minioFileReference) + + return $ Map.mapMaybe (fromNullable . Set.intersection allMissingMinio) missingDb + + fin :: Map Text (NonNull (Set FileContentReference)) -> Handler () + fin missingCounts = do + forM_ (Map.keysSet trackedReferences) $ \refIdent -> + observeMissingFiles refIdent . maybe 0 olength $ missingCounts Map.!? refIdent + + iforM_ missingCounts $ \refIdent missingFiles + -> let missingRefs = unlines . map tshow . Set.toList $ toNullable missingFiles + in $logErrorS "MissingFiles" [st|#{refIdent}: #{olength missingFiles}\n#{missingRefs}|] + + when (Map.null missingCounts) $ + $logInfoS "MissingFiles" [st|No missing files|] + + trackedReferences = Map.fromList $ over (traverse . _1) nameToPathPiece + [ (''CourseApplicationFile, E.from $ \appFile -> return $ appFile E.^. CourseApplicationFileContent ) + , (''MaterialFile, E.from $ \matFile -> return $ matFile E.^. MaterialFileContent ) + , (''CourseNewsFile, E.from $ \newsFile -> return $ newsFile E.^. CourseNewsFileContent ) + , (''SheetFile, E.from $ \sheetFile -> return $ sheetFile E.^. SheetFileContent ) + , (''CourseAppInstructionFile, E.from $ \appInstr -> return $ appInstr E.^. CourseAppInstructionFileContent) + , (''SubmissionFile, E.from $ \subFile -> return $ subFile E.^. SubmissionFileContent ) + , (''SessionFile, E.from $ \sessFile -> return $ sessFile E.^. SessionFileContent ) + , (''AllocationMatching, E.from $ \matching -> return . E.just $ matching E.^. AllocationMatchingLog ) + ] + + + {-# NOINLINE pruneUnreferencedFilesIntervalsCache #-} pruneUnreferencedFilesIntervalsCache :: TVar (Map Natural [(Maybe FileContentChunkReference, Maybe FileContentChunkReference)]) pruneUnreferencedFilesIntervalsCache = unsafePerformIO $ newTVarIO Map.empty diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 851ad9ac7..504264894 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -91,6 +91,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobInjectFiles | JobPruneFallbackPersonalisedSheetFilesKeys | JobRechunkFiles + | JobDetectMissingFiles deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } @@ -246,6 +247,7 @@ jobNoQueueSame = \case JobInjectFiles{} -> True JobPruneFallbackPersonalisedSheetFilesKeys{} -> True JobRechunkFiles{} -> True + JobDetectMissingFiles{} -> True _ -> False jobMovable :: JobCtl -> Bool diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index f9cfc0b2e..a722b5c94 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -13,6 +13,7 @@ module Utils.Metrics , FileChunkStorage(..), observeSourcedChunk, observeSunkChunk , observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles , registerJobWorkerQueueDepth + , observeMissingFiles ) where import Import.NoModel hiding (Vector, Info) @@ -209,6 +210,13 @@ jobWorkerQueueDepth jSt = Metric $ return (MkJobWorkerQueueDepth, collectJobWork info = Info "uni2work_queued_jobs_count" "Number of JobQueue entries in this Uni2work-instance" +{-# NOINLINE missingFiles #-} +missingFiles :: Vector Label1 Gauge +missingFiles = unsafeRegister . vector "ref" $ gauge info + where info = Info "uni2work_missing_files_count" + "Number of files referenced from within database that are missing" + + withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics act = do before <- liftIO $ getTime Monotonic @@ -344,3 +352,6 @@ observeRechunkedFiles num size = liftIO $ do registerJobWorkerQueueDepth :: MonadIO m => TMVar JobState -> m () registerJobWorkerQueueDepth = liftIO . void . register . jobWorkerQueueDepth + +observeMissingFiles :: MonadIO m => Text -> Int -> m () +observeMissingFiles refIdent = liftIO . withLabel missingFiles refIdent . flip setGauge . fromIntegral From 32b2314d0c28f4e613fc91a6c78373fd8130ab18 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Sep 2020 17:02:29 +0200 Subject: [PATCH 21/39] refactor: hlint --- src/Jobs/Handler/Files.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index b22a02af6..6fa139a45 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -326,7 +326,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do eta :: Maybe Integer eta = do accsz' <- assertM' (/= 0) accsz - return . ceiling $ (toRational currT - toRational startT) / (fromIntegral accsz') * (fromIntegral sz - fromIntegral accsz) + return . ceiling $ (toRational currT - toRational startT) / fromIntegral accsz' * (fromIntegral sz - fromIntegral accsz) when (lastReport' /= lastReport || sz' >= fromIntegral sz) $ flip runLoggingT logger . $logInfoS "InjectFiles" . mconcat $ catMaybes [ pure [st|Sinking chunk ##{tshow c} (#{textBytes csz}): #{textBytes sz'}/#{textBytes sz} (#{tshow p}%)|] From 8388d27aa439c7e10216b303874291340928b545 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Sep 2020 17:08:16 +0200 Subject: [PATCH 22/39] chore(release): 20.4.0 --- CHANGELOG.md | 12 ++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 15 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 23687131c..18cc16ceb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,18 @@ 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. +## [20.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.2...v20.4.0) (2020-09-23) + + +### Features + +* **files:** monitor missing files ([fb0ae65](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fb0ae65ac5928443abc01de9b57c69849d6a6b21)) + + +### Bug Fixes + +* **jobs:** better flushing, correct metrics, better etas ([e4416e7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e4416e7f0e2ea2cf9db0e61cf2d20c27260ccaf8)) + ### [20.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.1...v20.3.2) (2020-09-22) diff --git a/package-lock.json b/package-lock.json index 1b4e9454b..b65aea896 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.3.2", + "version": "20.4.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 331ca44b0..2d5fca65f 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.3.2", + "version": "20.4.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index fe6acff95..93f8b65e3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.3.2 +version: 20.4.0 dependencies: - base From 34a52653d71140bcc664cbe864cad069441b5c6e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Sep 2020 19:49:46 +0200 Subject: [PATCH 23/39] fix(metrics): larger range for worker_state_duration --- src/Utils/Metrics.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index a722b5c94..c1f6a7abf 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -79,7 +79,7 @@ httpRequestLatency :: Vector Label3 Histogram httpRequestLatency = unsafeRegister . vector ("handler", "method", "status") $ histogram info buckets where info = Info "http_request_duration_seconds" "HTTP request latency" - buckets = histogramBuckets 50e-6 5000 + buckets = histogramBuckets 50e-6 500 data ReadySince = MkReadySince @@ -96,7 +96,7 @@ jobWorkerStateDuration :: Vector Label4 Histogram jobWorkerStateDuration = unsafeRegister . vector ("worker", "state", "jobctl", "task") $ histogram info buckets where info = Info "uni2work_job_worker_state_duration_seconds" "Duration of time a Uni2work job executor spent in a certain state" - buckets = histogramBuckets 1e-6 500 + buckets = histogramBuckets 1e-6 5000 {-# NOINLINE jobWorkerStateTransitions #-} jobWorkerStateTransitions :: Vector Label4 Counter From ff17a4a4ca9da3796c55ba855fccb9505395045b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 23 Sep 2020 20:03:52 +0200 Subject: [PATCH 24/39] chore(release): 20.4.1 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 18cc16ceb..4d6174bff 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ 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. +### [20.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.0...v20.4.1) (2020-09-23) + + +### Bug Fixes + +* **metrics:** larger range for worker_state_duration ([34a5265](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/34a52653d71140bcc664cbe864cad069441b5c6e)) + ## [20.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.2...v20.4.0) (2020-09-23) diff --git a/package-lock.json b/package-lock.json index b65aea896..0f16b0ae5 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.4.0", + "version": "20.4.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2d5fca65f..565b85025 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.4.0", + "version": "20.4.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 93f8b65e3..cdc6fdba0 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.4.0 +version: 20.4.1 dependencies: - base From b35946859309fbb526043194c8620c5fc0844809 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 25 Sep 2020 12:02:59 +0200 Subject: [PATCH 25/39] feat(allocations): show staff descriptions --- src/Handler/Course/Edit.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 09e032bbb..a4ed224a0 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -243,6 +243,15 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB allocationOptions <- mkOptionList <$> mapM mkAllocationOption (availableAllocations ++ activeAllocations) let + explainedAllocationOptions = return allocationOptions `explainOptionList` \allocId -> hoistMaybe . listToMaybe $ do + (Entity allocId' Allocation{..}, _) <- availableAllocations' + guard $ allocId' == allocId + toWidget <$> hoistMaybe allocationStaffDescription + + doExplain = has (folded . _entityVal . _allocationStaffDescription . _Just) $ availableAllocations ++ activeAllocations + allocField | doExplain = explainedSelectionField Nothing explainedAllocationOptions + | otherwise = selectField' Nothing $ return allocationOptions + userAdmin = not $ null adminSchools mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable @@ -254,7 +263,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB | otherwise = aforcedJust in AllocationCourseForm - <$> ainp (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) + <$> ainp allocField (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) <*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation) From 18921e06d1deeb41d705eabacc2d348bac76197f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 24 Sep 2020 21:48:23 +0200 Subject: [PATCH 26/39] feat(allocations): notify about new courses --- messages/uniworx/de-de-formal.msg | 23 +++ messages/uniworx/en-eu.msg | 23 +++ models/allocations.model | 6 + package.yaml | 2 +- routes | 2 +- .../Universe/Instances/Reverse/WithIndex.hs | 2 +- src/Data/Void/Instances.hs | 3 + src/Handler/Allocation/Application.hs | 14 +- src/Handler/Allocation/Register.hs | 13 ++ src/Handler/Allocation/Show.hs | 79 +++++++++- src/Handler/Course/Edit.hs | 13 +- src/Handler/Profile.hs | 93 ++++++++++- src/Handler/Utils/Form.hs | 44 +++--- src/Import/NoModel.hs | 2 +- src/Jobs/Handler/QueueNotification.hs | 41 ++++- .../Handler/SendNotification/Allocation.hs | 22 +++ src/Jobs/Types.hs | 147 +++++++++--------- src/Model/Types/Mail.hs | 2 + src/Utils.hs | 64 +++++++- src/Utils/Form.hs | 2 + src/Utils/Icon.hs | 8 + stack.yaml | 3 + stack.yaml.lock | 21 +++ templates/allocation/show.hamlet | 14 +- templates/i18n/changelog/de-de-formal.hamlet | 7 + templates/i18n/changelog/en-eu.hamlet | 7 + templates/mail/allocationNewCourse.hamlet | 32 ++++ 27 files changed, 550 insertions(+), 139 deletions(-) create mode 100644 templates/mail/allocationNewCourse.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index ff7a2f644..cda88415c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -789,6 +789,15 @@ FormBehaviour: Verhalten FormCosmetics: Oberfläche FormPersonalAppearance: Öffentliche Daten FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen +FormAllocationNotifications: Benachrichtigungen für neue Zentralanmeldungskurse +FormAllocationNotificationsTip: Wollen Sie eine Benachrichtigung per E-Mail erhalten wenn ein neuer Kurs zur Zentralanmeldung eingetragen wird? „Ja“ und „Nein“ überschreiben die entsprechende systemweite Einstellung unter "Benachrichtigungen" + +AllocNotifyNewCourseDefault: Systemweite Einstellung +AllocNotifyNewCourseForceOff: Nein +AllocNotifyNewCourseForceOn: Ja + +BtnNotifyNewCourseForceOn: Benachrichtigen +BtnNotifyNewCourseForceOff: Nicht benachrichtigen PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momentan an dieser Stelle leider noch nicht unterstützt. PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt. @@ -1132,6 +1141,8 @@ NotificationTriggerCourseRegistered: Ein Kursverwalter hat mich zu einem Kurs an NotificationTriggerSubmissionUserCreated: Ich wurde als Mitabgebender zu einer Übungsblatt-Abgabe hinzugefügt NotificationTriggerSubmissionEdited: Eine meiner Übungsblatt-Abgaben wurde verändert NotificationTriggerSubmissionUserDeleted: Ich wurde als Mitabgebender von einer Übungsblatt-Abgabe entfernt +NotificationTriggerAllocationNewCourse: Es wurde ein neuer Kurs eingetragen zu einer Zentralanmeldungen, für die ich mich beworben habe +NotificationTriggerAllocationNewCourseTip: Kann pro Zentralanmeldung überschrieben werden NotificationTriggerKindAll: Für alle Benutzer NotificationTriggerKindCourseParticipant: Für Kursteilnehmer @@ -2200,6 +2211,13 @@ ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter ApplicationRatingSection: Bewertung ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren. +AllocationNotificationNewCourse: Benachrichtigung bei neuen Kursen +AllocationNotificationNewCourseTip: Wollen Sie per E-Mail benachrichtigt werden, wenn für diese Zentralanmeldung ein neuer Kurs eingetragen wird? Dies überschreibt die systemweite Einstellung in "Anpassen". +AllocationNotificationNewCourseSuccessForceOn: Sie werden benachrichtigt, wenn ein neuer Kurs eingetragen wird +AllocationNotificationNewCourseSuccessForceOff: Sie werden nicht benachrichtigt, wenn ein neuer Kurs eingetragen wird +AllocationNotificationNewCourseCurrentlyOff: Aktuell würden Sie keine Benachrichtigung erhalten. +AllocationNotificationNewCourseCurrentlyOn: Aktuell würden Sie benachrichtigt werden. +AllocationNotificationLoginFirst: Um Ihre Benachrichtigungseinstellungen zu ändern, loggen Sie sich bitte zunächst ein. AllocationSchoolShort: Institut Allocation: Zentralanmeldung @@ -2291,6 +2309,11 @@ MailAllocationUnratedApplicationsIntroMultiple n@Int: Es stehen noch Bewertungen MailAllocationUnratedApplications n@Int: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an den jeweiligen Kurs gestellt wurden, die entweder noch nicht bewertet wurden oder die nach der Bewertung noch verändert wurden und deswegen neu bewertet werden müssen. MailAllocationUnratedApplicationsCount i@Natural: #{i} #{pluralDE i "Bewerbung" "Bewerbungen"} +MailSubjectAllocationNewCourse allocation@AllocationName: Es wurde ein zusätzlicher Kurs zur Zentralanmeldung „#{allocation}” eingetragen +MailAllocationNewCourseTip: Es wurde der folgende Kurs zur Zentralanmeldung eingetragen: +MailAllocationNewCourseEditApplicationsHere: Sie können Ihre Bewerbung(en) hier anpassen: +MailAllocationNewCourseApplyHere: Sie können sich hier bewerben: + ExamOfficeSubscribedUsers: Benutzer ExamOfficeSubscribedUsersTip: Sie können mehrere Matrikelnummern mit Komma separieren diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 5a28dab5c..38b6f384f 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -786,6 +786,15 @@ FormBehaviour: Behaviour FormCosmetics: Interface FormPersonalAppearance: Public data FormFieldRequiredTip: Required fields +FormAllocationNotifications: Notifications for new central allocation courses +FormAllocationNotificationsTip: Do you want to receive a notification if a new course is added to the central allocation? “Yes” and “No” override the system wide setting under “Notifications” + +AllocNotifyNewCourseDefault: System wide setting +AllocNotifyNewCourseForceOff: No +AllocNotifyNewCourseForceOn: Yes + +BtnNotifyNewCourseForceOn: Notify me +BtnNotifyNewCourseForceOff: Do not notify me PersonalInfoExamAchievementsWip: The feature to display your exam achievements has not yet been implemented. PersonalInfoOwnTutorialsWip: The feature to display tutorials you have been assigned to as tutor has not yet been implemented. @@ -1133,6 +1142,8 @@ NotificationTriggerCourseRegistered: A course administrator has enrolled me in a NotificationTriggerSubmissionUserCreated: I was added to an exercise sheet submission NotificationTriggerSubmissionEdited: One of my exercise sheet submissions was changed NotificationTriggerSubmissionUserDeleted: I was removed from one of my exercise sheet submissions +NotificationTriggerAllocationNewCourse: A new course was added to a central allocation for which I have already made applications +NotificationTriggerAllocationNewCourseTip: Can be overridden per central allocation NotificationTriggerKindAll: For all users NotificationTriggerKindCourseParticipant: For course participants @@ -2199,6 +2210,13 @@ ApplicationRatingCommentVisibleTip: Feedback for the applicant ApplicationRatingCommentInvisibleTip: Currently only a note for course administrators ApplicationRatingSection: Grading ApplicationRatingSectionSelfTip: You are authorised to edit the application as well as it's grading. +AllocationNotificationNewCourse: Notifications for new courses +AllocationNotificationNewCourseTip: Do you want to be notified if a new course is added to this central allocation? This overrides the system wide setting under “Settings”. +AllocationNotificationNewCourseSuccessForceOn: You will be notified if a new course is added +AllocationNotificationNewCourseSuccessForceOff: You will not be notified if a new course is added +AllocationNotificationNewCourseCurrentlyOff: Currently you would not receive a notification. +AllocationNotificationNewCourseCurrentlyOn: Currently you would be notified. +AllocationNotificationLoginFirst: To change your notification settings, please log in first. AllocationSchoolShort: Department Allocation: Central allocation @@ -2291,6 +2309,11 @@ MailAllocationUnratedApplicationsIntroMultiple n: There are unrated applications MailAllocationUnratedApplications n: For there courses listed below, there exist applications made in the context of #{pluralEN n "the central allocation" "one of the central allocations"} which have either not yet been rated or which have changed since they were rated. MailAllocationUnratedApplicationsCount i: #{i} #{pluralDE i "application" "applications"} +MailSubjectAllocationNewCourse allocation: A new course was added to the central allocation “#{allocation}” +MailAllocationNewCourseTip: The following course was added to the central allocation: +MailAllocationNewCourseEditApplicationsHere: You can modify your application here: +MailAllocationNewCourseApplyHere: You can apply here: + ExamOfficeSubscribedUsers: Users ExamOfficeSubscribedUsersTip: You may specify multiple matriculations; comma-separated diff --git a/models/allocations.model b/models/allocations.model index 64f395a4d..f063a50ea 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -50,3 +50,9 @@ AllocationDeregister -- self-inflicted user-deregistrations from an allocated co course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) + +AllocationNotificationSetting + user UserId + allocation AllocationId + isOptOut Bool + UniqueAllocationNotificationSetting user allocation \ No newline at end of file diff --git a/package.yaml b/package.yaml index cdc6fdba0..3a0ae72e1 100644 --- a/package.yaml +++ b/package.yaml @@ -25,7 +25,7 @@ dependencies: - directory - warp - data-default - - aeson + - aeson >=1.5 - conduit - monad-logger - fast-logger diff --git a/routes b/routes index 810aeb824..6a60ab694 100644 --- a/routes +++ b/routes @@ -109,7 +109,7 @@ /allocation/ AllocationListR GET !free /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: - / AShowR GET !free + / AShowR GET POST !free /register ARegisterR POST !time /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered /users AUsersR GET POST !allocation-admin diff --git a/src/Data/Universe/Instances/Reverse/WithIndex.hs b/src/Data/Universe/Instances/Reverse/WithIndex.hs index ff6550058..66e6206cd 100644 --- a/src/Data/Universe/Instances/Reverse/WithIndex.hs +++ b/src/Data/Universe/Instances/Reverse/WithIndex.hs @@ -11,7 +11,7 @@ import Control.Lens.Indexed import Data.Universe.Instances.Reverse () -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map instance Finite a => FoldableWithIndex a ((->) a) where diff --git a/src/Data/Void/Instances.hs b/src/Data/Void/Instances.hs index a59e0cd39..fc0abbb22 100644 --- a/src/Data/Void/Instances.hs +++ b/src/Data/Void/Instances.hs @@ -10,3 +10,6 @@ instance ToContent Void where toContent = absurd instance ToTypedContent Void where toTypedContent = absurd + +instance RenderMessage site Void where + renderMessage _ _ = absurd diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index f48db411e..7996f3af3 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -19,10 +19,11 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as C -data AllocationApplicationButton = BtnAllocationApply - | BtnAllocationApplicationEdit - | BtnAllocationApplicationRetract - | BtnAllocationApplicationRate +data AllocationApplicationButton + = BtnAllocationApply + | BtnAllocationApplicationEdit + | BtnAllocationApplicationRetract + | BtnAllocationApplicationRate deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe AllocationApplicationButton instance Finite AllocationApplicationButton @@ -32,6 +33,11 @@ embedRenderMessage ''UniWorX ''AllocationApplicationButton id makePrisms ''AllocationApplicationButton instance Button UniWorX AllocationApplicationButton where + btnLabel BtnAllocationApply = [whamlet|#{iconApply True} _{MsgBtnAllocationApply}|] + btnLabel BtnAllocationApplicationRetract = [whamlet|#{iconApply False} _{MsgBtnAllocationApplicationRetract}|] + btnLabel BtnAllocationApplicationEdit = [whamlet|#{iconAllocationApplicationEdit} _{MsgBtnAllocationApplicationEdit}|] + btnLabel BtnAllocationApplicationRate = i18n BtnAllocationApplicationRate + btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger] btnClasses _ = [BCIsButton, BCPrimary] diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs index 9629335c7..3a6a4eb0c 100644 --- a/src/Handler/Allocation/Register.hs +++ b/src/Handler/Allocation/Register.hs @@ -36,6 +36,19 @@ nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''AllocationRegisterButton id instance Button UniWorX AllocationRegisterButton where + btnLabel BtnAllocationRegister + = [whamlet| + $newline never + #{iconAllocationRegister} \ + _{BtnAllocationRegister} + |] + btnLabel BtnAllocationRegistrationEdit + = [whamlet| + $newline never + #{iconAllocationRegistrationEdit} \ + _{BtnAllocationRegistrationEdit} + |] + btnClasses _ = [BCIsButton, BCPrimary] postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 1df2e5506..061e8aed8 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -1,5 +1,5 @@ module Handler.Allocation.Show - ( getAShowR + ( getAShowR, postAShowR ) where import Import @@ -15,9 +15,36 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html -getAShowR tid ssh ash = do - muid <- maybeAuthId +data NotifyNewCourseButton + = BtnNotifyNewCourseForceOn + | BtnNotifyNewCourseForceOff + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +embedRenderMessage ''UniWorX ''NotifyNewCourseButton id +nullaryPathPiece ''NotifyNewCourseButton $ camelToPathPiece' 2 + +instance Button UniWorX NotifyNewCourseButton where + btnLabel BtnNotifyNewCourseForceOn + = [whamlet| + $newline never + #{iconNotification} \ + _{BtnNotifyNewCourseForceOn} + |] + btnLabel BtnNotifyNewCourseForceOff + = [whamlet| + $newline never + #{iconNoNotification} \ + _{BtnNotifyNewCourseForceOff} + |] + + btnClasses _ = [BCIsButton] + + +getAShowR, postAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAShowR = postAShowR +postAShowR tid ssh ash = do + mAuth <- maybeAuth + let muid = entityKey <$> mAuth now <- liftIO getCurrentTime ata <- getSessionActiveAuthTags @@ -33,7 +60,7 @@ getAShowR tid ssh ash = do resultCourseVisible :: Simple Field5 a (E.Value Bool) => Lens' a Bool resultCourseVisible = _5 . _Value - (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do + (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration, notificationSetting) <- runDB $ do alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash school <- getJust allocationSchool @@ -58,7 +85,9 @@ getAShowR tid ssh ash = do isAnyLecturer <- hasWriteAccessTo CourseNewR - return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration) + notificationSetting <- fmap join . for muid $ getBy . flip UniqueAllocationNotificationSetting aId + + return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration, notificationSetting) MsgRenderer mr <- getMsgRenderer let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName @@ -67,7 +96,7 @@ getAShowR tid ssh ash = do -- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) -> -- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR - (registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration + (registerForm, registerEnctype) <- generateFormPost . identifyForm FIDAllocationRegister . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration let registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration registerForm' = wrapForm' registerBtn registerForm FormSettings @@ -79,6 +108,42 @@ getAShowR tid ssh ash = do , formAnchor = Nothing :: Maybe Text } + let wouldNotifyNewCourse = case (mAuth, notificationSetting) of + (_, Just (Entity _ AllocationNotificationSetting{..})) + -> not allocationNotificationSettingIsOptOut + (Just (Entity _ User{..}), _) + -> any (has $ _2 . _Just) courses && notificationAllowed userNotificationSettings NTAllocationNewCourse + _other + -> False + ((notificationResult, notificationForm), notificationEnctype) <- runFormPost . identifyForm FIDAllocationNotification . buttonForm' $ if + | wouldNotifyNewCourse + -> [BtnNotifyNewCourseForceOff] + | otherwise + -> [BtnNotifyNewCourseForceOn] + let + allocationNotificationIdent = "allocation-notification" :: Text + notificationForm' = wrapForm notificationForm FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ AllocationR tid ssh ash AShowR + , formEncoding = notificationEnctype + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Just allocationNotificationIdent + } + + whenIsJust muid $ \uid -> formResult notificationResult $ \notificationBtn -> do + let allocationNotificationSettingIsOptOut = case notificationBtn of + BtnNotifyNewCourseForceOn -> False + BtnNotifyNewCourseForceOff -> True + runDB . void $ upsertBy (UniqueAllocationNotificationSetting uid aId) AllocationNotificationSetting + { allocationNotificationSettingUser = uid + , allocationNotificationSettingAllocation = aId + , allocationNotificationSettingIsOptOut + } + [ AllocationNotificationSettingIsOptOut =. allocationNotificationSettingIsOptOut ] + addMessageI Success $ bool MsgAllocationNotificationNewCourseSuccessForceOn MsgAllocationNotificationNewCourseSuccessForceOff allocationNotificationSettingIsOptOut + redirect $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: allocationNotificationIdent + siteLayoutMsg title $ do setTitleI shortTitle diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index a4ed224a0..ab1548823 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -563,18 +563,18 @@ courseEditHandler miButtonAction mbCourseForm = do , formEncoding = formEnctype } -upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () +upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime Course{} <- getJust cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid - prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse - userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR) + prevAllocation <- fmap join . traverse getEntity $ allocationCourseAllocation . entityVal <$> prevAllocationCourse + userAdmin <- fromMaybe False <$> for prevAllocation (\(Entity _ Allocation{..}) -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR) doEdit <- if | userAdmin -> return True - | Just Allocation{allocationStaffRegisterTo} <- prevAllocation + | Just (Entity _ Allocation{allocationStaffRegisterTo}) <- prevAllocation , NTop allocationStaffRegisterTo <= NTop (Just now) -> let anyChanges | Just AllocationCourseForm{..} <- cfAllocation @@ -590,7 +590,7 @@ upsertAllocationCourse cid cfAllocation = do when doEdit $ case cfAllocation of - Just AllocationCourseForm{..} -> + Just AllocationCourseForm{..} -> do void $ upsert AllocationCourse { allocationCourseAllocation = acfAllocation , allocationCourseCourse = cid @@ -600,6 +600,9 @@ upsertAllocationCourse cid cfAllocation = do , AllocationCourseCourse =. cid , AllocationCourseMinCapacity =. acfMinCapacity ] + + when (Just acfAllocation /= fmap entityKey prevAllocation) $ + queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid Nothing | Just (Entity prevId _) <- prevAllocationCourse -> delete prevId diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 04518240d..a71375fc1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -45,6 +45,7 @@ data SettingsForm = SettingsForm , stgShowSex :: Bool , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings + , stgAllocationNotificationSettings :: Map AllocationId (Maybe Bool) } makeLenses_ ''SettingsForm @@ -79,6 +80,15 @@ instance RenderMessage UniWorX NotificationTriggerKind where where mr = renderMessage f ls +data AllocationNotificationState + = AllocNotifyNewCourseDefault + | AllocNotifyNewCourseForceOff + | AllocNotifyNewCourseForceOn + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +embedRenderMessage ''UniWorX ''AllocationNotificationState id +nullaryPathPiece ''AllocationNotificationState $ camelToPathPiece' 2 + makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template html = do @@ -108,6 +118,7 @@ makeSettingForm template html = do <* aformSection MsgFormNotifications <*> schoolsForm (stgSchools <$> template) <*> notificationForm (stgNotificationSettings <$> template) + <*> allocationNotificationForm (stgAllocationNotificationSettings <$> template) return (result, widget) -- no validation required here where themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF] @@ -196,13 +207,17 @@ notificationForm template = wFormToAForm $ do & fmap (!) let + ntfs nt = fslI nt & case nt of + NTAllocationNewCourse -> setTooltip MsgNotificationTriggerAllocationNewCourseTip + _other -> id + nsForm nt | maybe False ntHidden $ ntSection nt = pure $ notificationAllowed def nt | nt `elem` forcedTriggers - = aforced checkBoxField (fslI nt) (notificationAllowed def nt) + = aforced checkBoxField (ntfs nt) (notificationAllowed def nt) | otherwise - = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template) + = apopt checkBoxField (ntfs nt) (flip notificationAllowed nt <$> template) ntSection = \case NTSubmissionRatedGraded -> Just NTKCourseParticipant @@ -229,6 +244,7 @@ notificationForm template = wFormToAForm $ do NTAllocationOutdatedRatings -> Just NTKAllocationStaff NTAllocationUnratedApplications -> Just NTKAllocationStaff NTAllocationResults -> Just NTKAllocationParticipant + NTAllocationNewCourse -> Just NTKAllocationParticipant NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice NTCourseRegistered -> Just NTKAll @@ -238,6 +254,62 @@ notificationForm template = wFormToAForm $ do aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False +getAllocationNotifications :: UserId -> DB (Map AllocationId (Maybe Bool)) +getAllocationNotifications uid + = fmap (fmap (fmap getAny) . unMergeMap) . getAp $ foldMap (Ap . fmap (MergeMap . fmap (fmap Any))) + [ getBySettings + , getByApplications + , getByAllocationUser + ] + where + getBySettings = toMap <$> selectList [ AllocationNotificationSettingUser ==. uid ] [] + where toMap settings = Map.fromList [ ( allocationNotificationSettingAllocation + , Just $ not allocationNotificationSettingIsOptOut + ) + | Entity _ AllocationNotificationSetting{..} <- settings + ] + getByApplications = toMap <$> selectList [ CourseApplicationAllocation !=. Nothing, CourseApplicationUser ==. uid ] [] + where toMap applications = Map.fromList [ (alloc, Nothing) + | Entity _ CourseApplication{..} <- applications + , alloc <- hoistMaybe courseApplicationAllocation + ] + getByAllocationUser = toMap <$> selectList [ AllocationUserUser ==. uid ] [] + where toMap allocsUser = Map.fromList [ (allocationUserAllocation, Nothing) + | Entity _ AllocationUser{..} <- allocsUser + ] + +setAllocationNotifications :: forall m. MonadIO m => UserId -> Map AllocationId (Maybe Bool) -> SqlPersistT m () +setAllocationNotifications allocationNotificationSettingUser allocs = do + deleteWhere [ AllocationNotificationSettingUser ==. allocationNotificationSettingUser ] + void . insertMany $ do + (allocationNotificationSettingAllocation, settingSt) <- Map.toList allocs + allocationNotificationSettingIsOptOut <- not <$> hoistMaybe settingSt + return AllocationNotificationSetting{..} + +allocationNotificationForm :: Maybe (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool)) +allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . (fromNullable =<<) + where + allocationNotificationForm' :: NonNull (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool)) + allocationNotificationForm' (toNullable -> allocs) = funcForm' . flip imap allocs $ \allocId mPrev -> wFormToAForm $ do + let _AllocNotify :: Iso' (Maybe Bool) AllocationNotificationState + _AllocNotify = iso toNotify fromNotify + where fromNotify = \case + AllocNotifyNewCourseDefault -> Nothing + AllocNotifyNewCourseForceOn -> Just True + AllocNotifyNewCourseForceOff -> Just False + toNotify = \case + Nothing -> AllocNotifyNewCourseDefault + Just True -> AllocNotifyNewCourseForceOn + Just False -> AllocNotifyNewCourseForceOff + + Allocation{..} <- liftHandler . runDB $ getJust allocId + MsgRenderer mr <- getMsgRenderer + let allocDesc = [st|#{mr (ShortTermIdentifier $ unTermKey allocationTerm)}, #{unSchoolKey allocationSchool}, #{allocationName}|] + cID <- encrypt allocId :: _ CryptoUUIDAllocation + + fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify) + where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False + validateSettings :: User -> FormValidator SettingsForm Handler () validateSettings User{..} = do @@ -276,6 +348,7 @@ postProfileR = do E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId + allocs <- runDB $ getAllocationNotifications uid let settingsTemplate = Just SettingsForm { stgDisplayName = userDisplayName , stgDisplayEmail = userDisplayEmail @@ -290,6 +363,7 @@ postProfileR = do , stgNotificationSettings = userNotificationSettings , stgWarningDays = userWarningDays , stgShowSex = userShowSex + , stgAllocationNotificationSettings = allocs } ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate @@ -308,6 +382,7 @@ postProfileR = do , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] + setAllocationNotifications uid stgAllocationNotificationSettings updateFavourites Nothing when (stgDisplayEmail /= userDisplayEmail) $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail @@ -777,9 +852,13 @@ getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html getUserNotificationR = postUserNotificationR postUserNotificationR cID = do uid <- decrypt cID - User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid + (User{userNotificationSettings, userDisplayName}, allocs) <- runDB $ (,) + <$> get404 uid + <*> getAllocationNotifications uid - ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings + ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard $ (,) + <$> notificationForm (Just userNotificationSettings) + <*> allocationNotificationForm (Just allocs) mBearer <- askBearer isModal <- hasCustomHeader HeaderIsModal let formWidget = wrapForm nsInnerWdgt def @@ -788,8 +867,10 @@ postUserNotificationR cID = do , formAttrs = [ asyncSubmitAttr | isModal ] } - formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \ns -> do - lift . runDB $ update uid [ UserNotificationSettings =. ns ] + formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \(ns, ans) -> do + lift . runDB $ do + update uid [ UserNotificationSettings =. ns ] + setAllocationNotifications uid ans tell . pure =<< messageI Success MsgNotificationSettingsUpdate siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4be16133b..405ecd294 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1327,35 +1327,28 @@ boolField mkNone = radioGroupField mkNone $ do -sectionedFuncForm :: forall k v m sec. - ( Finite k, Ord k +sectionedFuncForm :: forall f k v m sec. + ( TraversableWithIndex k f , MonadHandler m , HandlerSite m ~ UniWorX , RenderMessage UniWorX sec , Ord sec ) - => (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) + => (k -> Maybe sec) -> f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v) sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty where - funcForm' :: AForm m (k -> v) - funcForm' = Set.fromList universeF - & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty - & fmap (Map.fromSet mkForm) - & fmap sequenceA - & Map.foldrWithKey accSections (pure Map.empty) - & fmap (!) - accSections mSection optsForm acc = wFormToAForm $ do - (res, fs) <- wFormFields $ aFormToWForm optsForm - if - | not $ null fs - , Just section <- mSection - -> wformSection section - | otherwise - -> return () - lift $ tell fs - aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc + funcForm' :: AForm m (f v) + funcForm' = wFormToAForm $ do + (res, MergeMap fs) <- runWriterT . ifor mkForm $ \k form + -> WriterT . fmap (over _2 $ MergeMap . Map.singleton (mkSection k)) . wFormFields $ aFormToWForm form - funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX]) + iforM_ fs $ \mSection secfs -> unless (null secfs) $ do + traverse_ wformSection mSection + lift $ tell secfs + + return $ sequenceA res + + funcFieldView :: (FormResult (f v), Widget) -> MForm m (FormResult (f v), [FieldView UniWorX]) funcFieldView (res, formView) = do mr <- getMessageRender fvId <- maybe newIdent return fsId @@ -1367,16 +1360,15 @@ sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} is | otherwise = Nothing fvInput = $(widgetFile "widgets/fields/funcField") return (res, pure FieldView{..}) - -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) -funcForm :: forall k v m. - ( Finite k, Ord k +funcForm :: forall f k v m. + ( TraversableWithIndex k f , MonadHandler m , HandlerSite m ~ UniWorX ) - => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) -funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text) + => f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v) +funcForm = sectionedFuncForm $ pure (Nothing :: Maybe Void) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 0f29237c5..23e4f09b3 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -65,7 +65,7 @@ import Data.List as Import (elemIndex) import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Min(..), Max(..)) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..)) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..), Ap(..)) import Data.Binary as Import (Binary) import Data.Binary.Instances as Import () diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 38fa2a3f0..d653faf3e 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -22,21 +22,24 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX dispatchJobQueueNotification jNotification = JobHandlerAtomic $ runConduit $ yield jNotification .| transPipe (hoist lift) determineNotificationCandidates - .| C.filterM (\(notification', Entity _ User{userNotificationSettings}) -> notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) - .| C.map (\(notification', Entity uid _) -> JobSendNotification uid notification') + .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings}) -> or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) + .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification') .| sinkDBJobs -determineNotificationCandidates :: ConduitT Notification (Notification, Entity User) DB () +determineNotificationCandidates :: ConduitT Notification (Notification, Bool, Entity User) DB () determineNotificationCandidates = awaitForever $ \notif -> do - let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Entity User) DB () - withNotif c = toProducer c .| C.map (notif, ) + let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB () + withNotif c = toProducer c .| C.map (notif, False, ) + + withNotifOverride :: ConduitT () (E.Value Bool, Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB () + withNotifOverride c = toProducer c .| C.map (\(E.Value override, user) -> (notif, override, user)) -- | Assumes that conduit produces output sorted by `UserId` separateTargets :: Ord target => (Set target -> Notification) -> ConduitT () (Entity User, E.Value target) DB () - -> ConduitT Notification (Notification, Entity User) DB () + -> ConduitT Notification (Notification, Bool, Entity User) DB () separateTargets mkNotif' c = toProducer c .| go Nothing Set.empty where go Nothing _ = do next <- await @@ -46,10 +49,10 @@ determineNotificationCandidates = awaitForever $ \notif -> do go (Just uent) ts = do next <- await case next of - Nothing -> yield (mkNotif' ts, uent) + Nothing -> yield (mkNotif' ts, False, uent) Just next'@(uent', E.Value t) | ((==) `on` entityKey) uent uent' -> go (Just uent) $ Set.insert t ts - | otherwise -> yield (mkNotif' ts, uent) >> leftover next' >> go Nothing Set.empty + | otherwise -> yield (mkNotif' ts, False, uent) >> leftover next' >> go Nothing Set.empty case notif of NotificationSubmissionRated{..} @@ -281,6 +284,27 @@ determineNotificationCandidates = awaitForever $ \notif -> do -> withNotif . yieldMMany $ getEntity nUser NotificationSubmissionUserDeleted{..} -> withNotif . yieldMMany $ getEntity nUser + NotificationAllocationNewCourse{..} + -> withNotifOverride . E.selectSource . E.from $ \user -> do + let hasOverride overrideVal = E.exists . E.from $ \allocationNotificationSetting -> + E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. user E.^. UserId + E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. E.val nAllocation + E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut E.==. E.val (not overrideVal) + + hasApplication = E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.justVal nAllocation + E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId + + E.where_ $ hasOverride True E.||. hasApplication + + E.where_ . E.not_ $ hasOverride False + + E.where_ . E.not_ . E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.justVal nAllocation + E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId + E.&&. application E.^. CourseApplicationCourse E.==. E.val nCourse + + return (hasOverride True, user) classifyNotification :: Notification -> DB NotificationTrigger @@ -315,3 +339,4 @@ classifyNotification NotificationCourseRegistered{} = return NTCou classifyNotification NotificationSubmissionEdited{} = return NTSubmissionEdited classifyNotification NotificationSubmissionUserCreated{} = return NTSubmissionUserCreated classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted +classifyNotification NotificationAllocationNewCourse{} = return NTAllocationNewCourse diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 0f9a50741..24c517239 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.Allocation , dispatchNotificationAllocationAllocation , dispatchNotificationAllocationUnratedApplications , dispatchNotificationAllocationResults + , dispatchNotificationAllocationNewCourse ) where import Import @@ -183,3 +184,24 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationResults.hamlet") + +dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler () +dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do + (Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,) + <$> getJust nAllocation + <*> getJust nCourse + <*> exists [CourseApplicationAllocation ==. Just nAllocation, CourseApplicationUser ==. jRecipient] + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationNewCourse allocationName + editNotifications <- mkEditNotifications jRecipient + + cID <- encrypt nCourse + mayApply <- orM + [ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True + , is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True + ] + + allocUrl <- toTextUrl $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID + + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationNewCourse.hamlet") diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 504264894..831d73366 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -43,83 +43,86 @@ import System.Clock (getTime, Clock(Monotonic), TimeSpec) import GHC.Conc (unsafeIOToSTM) -data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } - | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } - | JobQueueNotification { jNotification :: Notification } - | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId - , jRequestTime :: UTCTime - , jSubject :: Maybe Text - , jHelpRequest :: Maybe Html - , jReferer :: Maybe Text - , jError :: Maybe ErrorResponse - } - | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } - | JobDistributeCorrections { jSheet :: SheetId } - | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId - , jAllRecipientAddresses :: Set Address - , jCourse :: CourseId - , jSender :: UserId - , jMailObjectUUID :: UUID - , jSubject :: Maybe Text - , jMailContent :: Html - } - | JobInvitation { jInviter :: Maybe UserId - , jInvitee :: UserEmail - , jInvitationUrl :: Text - , jInvitationSubject :: Text - , jInvitationExplanation :: Html +data Job + = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } + | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } + | JobQueueNotification { jNotification :: Notification } + | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId + , jRequestTime :: UTCTime + , jSubject :: Maybe Text + , jHelpRequest :: Maybe Html + , jReferer :: Maybe Text + , jError :: Maybe ErrorResponse + } + | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } + | JobDistributeCorrections { jSheet :: SheetId } + | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId + , jAllRecipientAddresses :: Set Address + , jCourse :: CourseId + , jSender :: UserId + , jMailObjectUUID :: UUID + , jSubject :: Maybe Text + , jMailContent :: Html + } + | JobInvitation { jInviter :: Maybe UserId + , jInvitee :: UserEmail + , jInvitationUrl :: Text + , jInvitationSubject :: Text + , jInvitationExplanation :: Html + } + | JobSendPasswordReset { jRecipient :: UserId } - | JobSendPasswordReset { jRecipient :: UserId - } - | JobTruncateTransactionLog - | JobPruneInvitations - | JobDeleteTransactionLogIPs - | JobSynchroniseLdap { jNumIterations + | JobTruncateTransactionLog + | JobPruneInvitations + | JobDeleteTransactionLogIPs + | JobSynchroniseLdap { jNumIterations + , jEpoch + , jIteration :: Natural + } + | JobSynchroniseLdapUser { jUser :: UserId + } + | JobChangeUserDisplayEmail { jUser :: UserId + , jDisplayEmail :: UserEmail + } + | JobPruneSessionFiles + | JobPruneUnreferencedFiles { jNumIterations , jEpoch , jIteration :: Natural } - | JobSynchroniseLdapUser { jUser :: UserId - } - | JobChangeUserDisplayEmail { jUser :: UserId - , jDisplayEmail :: UserEmail - } - | JobPruneSessionFiles - | JobPruneUnreferencedFiles { jNumIterations - , jEpoch - , jIteration :: Natural - } - | JobInjectFiles - | JobPruneFallbackPersonalisedSheetFilesKeys - | JobRechunkFiles - | JobDetectMissingFiles + | JobInjectFiles + | JobPruneFallbackPersonalisedSheetFilesKeys + | JobRechunkFiles + | JobDetectMissingFiles deriving (Eq, Ord, Show, Read, Generic, Typeable) -data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } - | NotificationSheetActive { nSheet :: SheetId } - | NotificationSheetSoonInactive { nSheet :: SheetId } - | NotificationSheetInactive { nSheet :: SheetId } - | NotificationSheetHint { nSheet :: SheetId } - | NotificationSheetSolution { nSheet :: SheetId } - | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } - | NotificationCorrectionsNotDistributed { nSheet :: SheetId } - | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } - | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction } - | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } - | NotificationExamRegistrationActive { nExam :: ExamId } - | NotificationExamRegistrationSoonInactive { nExam :: ExamId } - | NotificationExamDeregistrationSoonInactive { nExam :: ExamId } - | NotificationExamResult { nExam :: ExamId } - | NotificationAllocationStaffRegister { nAllocations :: Set AllocationId } - | NotificationAllocationRegister { nAllocations :: Set AllocationId } - | NotificationAllocationAllocation { nAllocations :: Set AllocationId } - | NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId } - | NotificationExamOfficeExamResults { nExam :: ExamId } - | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId } - | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId } - | NotificationAllocationResults { nAllocation :: AllocationId } - | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId } - | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId } - | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } - | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } +data Notification + = NotificationSubmissionRated { nSubmission :: SubmissionId } + | NotificationSheetActive { nSheet :: SheetId } + | NotificationSheetSoonInactive { nSheet :: SheetId } + | NotificationSheetInactive { nSheet :: SheetId } + | NotificationSheetHint { nSheet :: SheetId } + | NotificationSheetSolution { nSheet :: SheetId } + | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } + | NotificationCorrectionsNotDistributed { nSheet :: SheetId } + | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } + | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction } + | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } + | NotificationExamRegistrationActive { nExam :: ExamId } + | NotificationExamRegistrationSoonInactive { nExam :: ExamId } + | NotificationExamDeregistrationSoonInactive { nExam :: ExamId } + | NotificationExamResult { nExam :: ExamId } + | NotificationAllocationStaffRegister { nAllocations :: Set AllocationId } + | NotificationAllocationRegister { nAllocations :: Set AllocationId } + | NotificationAllocationAllocation { nAllocations :: Set AllocationId } + | NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId } + | NotificationAllocationNewCourse { nAllocation :: AllocationId, nCourse :: CourseId } + | NotificationExamOfficeExamResults { nExam :: ExamId } + | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId } + | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId } + | NotificationAllocationResults { nAllocation :: AllocationId } + | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId } + | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId } + | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } + | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Hashable Job diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index cbb7af356..dca966dd4 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -43,6 +43,7 @@ data NotificationTrigger | NTAllocationStaffRegister | NTAllocationAllocation | NTAllocationRegister + | NTAllocationNewCourse | NTAllocationOutdatedRatings | NTAllocationUnratedApplications | NTAllocationResults @@ -72,6 +73,7 @@ instance Default NotificationSettings where defaultOff = HashSet.fromList [ NTSheetSoonInactive , NTExamRegistrationSoonInactive + , NTAllocationNewCourse ] instance ToJSON NotificationSettings where diff --git a/src/Utils.hs b/src/Utils.hs index 4e0a169a5..aa4906ed3 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -114,7 +114,7 @@ import qualified Control.Monad.Random.Lazy as LazyRand import Data.Data (Data) import qualified Data.Text.Lazy.Builder as Builder -import Unsafe.Coerce +import Data.Coerce import System.FilePath as Utils (addExtension, isExtensionOf) import System.FilePath (dropDrive) @@ -1258,8 +1258,8 @@ instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where mempty = MergeHashMap HashMap.empty instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where parseJSON = case Aeson.fromJSONKey of - Aeson.FromJSONKeyCoerce _ -> Aeson.withObject "HashMap ~Text" $ - uc . HashMap.traverseWithKey (\k v -> parseJSON v Aeson. Aeson.Key k) + Aeson.FromJSONKeyCoerce -> Aeson.withObject "HashMap ~Text" $ + coerce @(Aeson.Parser (HashMap k v)) @(Aeson.Parser (MergeHashMap k v)) . fmap HashMap.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson. Aeson.Key k) . HashMap.toList Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $ fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson. Aeson.Key k <*> m) (pure mempty) Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $ @@ -1267,9 +1267,6 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr -> fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr where - uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v) - uc = unsafeCoerce - parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b) parseIndexedJSONPair keyParser valParser idx value = p value Aeson. Aeson.Index idx where @@ -1284,6 +1281,61 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson. Aeson.Index idx + +newtype MergeMap k v = MergeMap { unMergeMap :: Map k v } + deriving (Show, Generic, Typeable, Data) + deriving newtype ( Eq, Ord + , Functor, Foldable, NFData + , ToJSON + ) + +makePrisms ''MergeMap +makeWrapped ''MergeMap + +type instance Element (MergeMap k v) = v + +instance MonoFoldable (MergeMap k v) +instance MonoFunctor (MergeMap k v) +instance MonoTraversable (MergeMap k v) + +instance Traversable (MergeMap k) where + traverse = _MergeMap . traverse + +instance FunctorWithIndex k (MergeMap k) +instance TraversableWithIndex k (MergeMap k) where + itraverse = _MergeMap .> itraverse +instance FoldableWithIndex k (MergeMap k) + +instance (Ord k, Semigroup v) => Semigroup (MergeMap k v) where + (MergeMap a) <> (MergeMap b) = MergeMap $ Map.unionWith (<>) a b +instance (Ord k, Semigroup v) => Monoid (MergeMap k v) where + mempty = MergeMap Map.empty +instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k v) where + parseJSON = case Aeson.fromJSONKey of + Aeson.FromJSONKeyCoerce -> Aeson.withObject "Map ~Text" $ + coerce @(Aeson.Parser (Map k v)) @(Aeson.Parser (MergeMap k v)) . fmap Map.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson. Aeson.Key k) . HashMap.toList + Aeson.FromJSONKeyText f -> Aeson.withObject "Map" $ + fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) (f k) <$> parseJSON v Aeson. Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList + Aeson.FromJSONKeyTextParser f -> Aeson.withObject "Map" $ + fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) <$> f k Aeson. Aeson.Key k <*> parseJSON v Aeson. Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList + Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr -> + fmap (MergeMap . Map.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr + where + parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b) + parseIndexedJSONPair keyParser valParser idx value = p value Aeson. Aeson.Index idx + where + p = Aeson.withArray "(k, v)" $ \ab -> + let n = V.length ab + in if n == 2 + then (,) <$> parseJSONElemAtIndex keyParser 0 ab + <*> parseJSONElemAtIndex valParser 1 ab + else fail $ "cannot unpack array of length " ++ + show n ++ " into a pair" + + parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a + parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson. Aeson.Index idx + + -------------- -- FilePath -- -------------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 307bd6fad..a87f20b21 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,6 +229,8 @@ data FormIdentifier | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDAllocationAccept | FIDTestDownload + | FIDAllocationRegister + | FIDAllocationNotification deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index e401f2db7..f8f8c9ca2 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -86,6 +86,9 @@ data Icon | IconFileUploadSession | IconStandaloneFieldError | IconFileUser + | IconNotification | IconNoNotification + | IconAllocationRegister | IconAllocationRegistrationEdit + | IconAllocationApplicationEdit deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) iconText :: Icon -> Text @@ -150,6 +153,11 @@ iconText = \case IconFileUploadSession -> "file-upload" IconStandaloneFieldError -> "exclamation" IconFileUser -> "file-user" + IconNotification -> "envelope" + IconNoNotification -> "times" + IconAllocationRegister -> "user-plus" + IconAllocationRegistrationEdit -> "pencil-alt" + IconAllocationApplicationEdit -> "pencil-alt" instance Universe Icon instance Finite Icon diff --git a/stack.yaml b/stack.yaml index fbbcd4aaa..9ea2e6ee1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -75,6 +75,9 @@ extra-deps: - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 - wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 - primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604 + - aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906 + - data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645 + - strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 resolver: nightly-2020-08-08 compiler: ghc-8.10.2 diff --git a/stack.yaml.lock b/stack.yaml.lock index 053ebc2d9..d36679f52 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -359,6 +359,27 @@ packages: sha256: 924e88629b493abb6b2f3c3029cef076554a2b627091e3bb6887ec03487a707d original: hackage: primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604 +- completed: + hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906 + pantry-tree: + size: 39759 + sha256: 6290ffac2ea3e52b57d869306d12dbf32c07d17099f695f035ff7f756677831d + original: + hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906 +- completed: + hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645 + pantry-tree: + size: 261 + sha256: 6cf43af344624e087dbe2f1e96e985de6142e85bb02db8449df6d72bee3c1013 + original: + hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645 +- completed: + hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 + pantry-tree: + size: 654 + sha256: fdf523b8990567d69277b999d68d492ed0b3a98a89b1acdfb3087e3b95eb9908 + original: + hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 snapshots: - completed: size: 524392 diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index ec3a41cce..b99a98218 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -65,7 +65,7 @@ $newline never

^{formatTimeW SelFormatDateTime toT} -

+

_{MsgAllocationParticipation} $if is _Nothing muid @@ -94,6 +94,18 @@ $newline never $# This redundant links prevents useless help requests from frantic users ^{allocationInfoModal} +
+

+ _{MsgAllocationNotificationNewCourse} + $if is _Just muid +

+ _{MsgAllocationNotificationNewCourseTip} +
+ _{bool MsgAllocationNotificationNewCourseCurrentlyOff MsgAllocationNotificationNewCourseCurrentlyOn wouldNotifyNewCourse} + ^{notificationForm'} + $else + _{MsgAllocationNotificationLoginFirst} + $if not (null courseWidgets)

diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet index e0e41fb22..7907b908a 100644 --- a/templates/i18n/changelog/de-de-formal.hamlet +++ b/templates/i18n/changelog/de-de-formal.hamlet @@ -1,5 +1,12 @@ $newline never
+
+ ^{formatGregorianW 2020 09 24} +
+
    +
  • + Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden +
    ^{formatGregorianW 2020 08 28}
    diff --git a/templates/i18n/changelog/en-eu.hamlet b/templates/i18n/changelog/en-eu.hamlet index ef3f6e194..12f4a739e 100644 --- a/templates/i18n/changelog/en-eu.hamlet +++ b/templates/i18n/changelog/en-eu.hamlet @@ -1,5 +1,12 @@ $newline never
    +
    + ^{formatGregorianW 2020 09 24} +
    +
      +
    • + Notifications for new courses being added to central allocations +
      ^{formatGregorianW 2020 08 28}
      diff --git a/templates/mail/allocationNewCourse.hamlet b/templates/mail/allocationNewCourse.hamlet new file mode 100644 index 000000000..8c0b2ed5b --- /dev/null +++ b/templates/mail/allocationNewCourse.hamlet @@ -0,0 +1,32 @@ +$newline never +\ + + + +