From e54b985815fbbc637d8f4681ac55b3d46e2263a3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 09:27:12 +0100 Subject: [PATCH 001/514] fix(files): count personalised sheet files as alive --- src/Jobs/Handler/Files.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 10330e158..6c44b230d 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -65,6 +65,7 @@ fileReferences (E.just -> fHash) , E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileContent E.==. fHash , E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileContent E.==. fHash , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileContent E.==. fHash + , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. PersonalisedSheetFileContent E.==. fHash , E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileContent E.==. fHash , E.from $ \matching -> E.where_ $ E.just (matching E.^. AllocationMatchingLog) E.==. fHash , E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileContent E.==. fHash @@ -133,14 +134,15 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin $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 ) + [ (''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 ) + , (''PersonalisedSheetFile, E.from $ \personalisedSheetFile -> return $ personalisedSheetFile E.^. PersonalisedSheetFileContent ) + , (''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) ] From b4aa43ab46c29c916a17b53178ea1f868fc00227 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 09:28:20 +0100 Subject: [PATCH 002/514] chore(release): 24.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 666a082c3..53ba4da63 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. +## [24.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.0...v24.4.1) (2021-02-19) + + +### Bug Fixes + +* **files:** count personalised sheet files as alive ([e54b985](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e54b985815fbbc637d8f4681ac55b3d46e2263a3)) + ## [24.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.3.0...v24.4.0) (2021-02-17) diff --git a/package-lock.json b/package-lock.json index 19365fe20..1be2deb8e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.0", + "version": "24.4.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 17b66c824..7d622d0a9 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.0", + "version": "24.4.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 4a1966f2f..e374ff496 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 24.4.0 +version: 24.4.1 dependencies: - base - yesod From c272618aa6dd68a1acb5b959c6d905978b26eb07 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 13:42:23 +0100 Subject: [PATCH 003/514] fix(missing-files): properly account for workflows --- src/Jobs/Handler/Files.hs | 45 +++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 18 deletions(-) diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 6c44b230d..0427b001d 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -47,6 +47,8 @@ import Control.Concurrent.STM.TVar (stateTVar) import qualified Data.Foldable as F +import qualified Control.Monad.State.Class as State + dispatchJobPruneSessionFiles :: JobHandler UniWorX dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin @@ -76,10 +78,11 @@ fileReferences (E.just -> fHash) E.&&. chunkLock E.^. FileChunkLockHash E.==. E.subSelectForeign fileContentEntry FileContentEntryChunkHash (E.^. FileContentChunkHash) ] -workflowFileReferences :: MonadResource m => ConduitT () FileContentReference (SqlPersistT m) () -workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. SharedWorkflowGraphGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue) - , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue) - ] +workflowFileReferences :: MonadResource m => Map Text (ConduitT () FileContentReference (SqlPersistT m) ()) +workflowFileReferences = Map.fromList $ over (traverse . _1) nameToPathPiece + [ (''SharedWorkflowGraph, E.selectSource (E.from $ pure . (E.^. SharedWorkflowGraphGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)) + , (''WorkflowWorkflow, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)) + ] dispatchJobDetectMissingFiles :: JobHandler UniWorX @@ -89,15 +92,20 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin act = hoist lift $ do uploadBucket <- getsYesod $ view _appUploadCacheBucket - missingDb <- execWriterT $ do - tellM . 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 - tellM . fmap (Map.singleton "workflows") . runConduit $ workflowFileReferences .| C.foldMap Set.singleton + missingDb <- runConduit . execStateC Map.empty $ do + let insertRef refKind ref = State.modify' $ Map.alter (Just . Set.insert ref . fromMaybe Set.empty) refKind + + iforM_ trackedReferences $ \refKind refQuery -> do + let fileReferencesQuery = 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 + transPipe lift (E.selectSource fileReferencesQuery) .| C.mapMaybe E.unValue .| C.mapM_ (insertRef refKind) + + iforM_ workflowFileReferences $ \refKind refSource -> + transPipe lift (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind) let allMissingDb :: Set Minio.Object allMissingDb = setOf (folded . folded . re minioFileReference) missingDb @@ -123,12 +131,13 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin fin :: Map Text (NonNull (Set FileContentReference)) -> Handler () fin missingCounts = do - forM_ (Map.keysSet trackedReferences) $ \refIdent -> - observeMissingFiles refIdent . maybe 0 olength $ missingCounts Map.!? refIdent + imapM_ observeMissingFiles $ olength <$> missingCounts iforM_ missingCounts $ \refIdent missingFiles - -> let missingRefs = unlines . map tshow . Set.toList $ toNullable missingFiles - in $logErrorS "MissingFiles" [st|#{refIdent}: #{olength missingFiles}\n#{missingRefs}|] + -> let missingRefs = unlines . map (views _Wrapped tshow) . Set.toList $ toNullable missingFiles + newl :: Text + newl = "\n" + in $logErrorS "MissingFiles" [st|#{refIdent}: #{olength missingFiles}#{newl}#{missingRefs}|] when (Map.null missingCounts) $ $logInfoS "MissingFiles" [st|No missing files|] @@ -201,7 +210,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) chunkSize = 100 - in runConduit $ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles + in runConduit $ sequence_ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles let getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do From f44a11efa48705f06b1cc4056fa490ff29bd7d8f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 13:43:36 +0100 Subject: [PATCH 004/514] chore(release): 24.4.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 53ba4da63..d94c833b6 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. +## [24.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.1...v24.4.2) (2021-02-19) + + +### Bug Fixes + +* **missing-files:** properly account for workflows ([c272618](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c272618aa6dd68a1acb5b959c6d905978b26eb07)) + ## [24.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.0...v24.4.1) (2021-02-19) diff --git a/package-lock.json b/package-lock.json index 1be2deb8e..baafd3c2c 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.1", + "version": "24.4.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 7d622d0a9..8183804d7 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.1", + "version": "24.4.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index e374ff496..69e411ed1 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 24.4.1 +version: 24.4.2 dependencies: - base - yesod From 9e3b23ae848dc9c6a243e6d99bc88bfab0c42885 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 14:55:32 +0100 Subject: [PATCH 005/514] chore(gitlab-ci): try to prevent release without upload --- .gitlab-ci.yml | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3a0d7af36..70ad34045 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -107,6 +107,8 @@ yesod:build:dev: script: - stack build --test --copy-bins --local-bin-path $(pwd)/bin --fast --flag uniworx:-library-only --flag uniworx:dev --flag uniworx:pedantic --no-strip needs: + - job: npm install # transitive + artifacts: false - job: frontend:build artifacts: true before_script: &haskell @@ -143,6 +145,8 @@ yesod:build: script: - stack build --test --copy-bins --local-bin-path $(pwd)/bin --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --no-strip needs: + - job: npm install # transitive + artifacts: false - job: frontend:build artifacts: true before_script: *haskell @@ -170,6 +174,8 @@ yesod:build:profile: script: - stack build --profile --copy-bins --local-bin-path $(pwd)/bin --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --no-strip needs: + - job: npm install # transitive + artifacts: false - job: frontend:build artifacts: true before_script: *haskell @@ -247,6 +253,10 @@ upload: stage: upload packages image: curlimages/curl:latest needs: + - job: npm install # transitive + artifacts: false + - job: frontend:build # transitive + artifacts: false - job: yesod:build artifacts: true - job: parse-changelog @@ -275,6 +285,12 @@ release: needs: - job: upload artifacts: false + - job: npm install # transitive + artifacts: false + - job: frontend:build # transitive + artifacts: false + - job: yesod:build # transitive + artifacts: false - job: parse-changelog artifacts: true rules: From abb6dff076aeccbab6fb8743a5cd26fdf28070df Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 15:01:27 +0100 Subject: [PATCH 006/514] chore(gitlab-ci): depend on tests/lint for validation --- .gitlab-ci.yml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 70ad34045..aec0fe441 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -261,6 +261,10 @@ upload: artifacts: true - job: parse-changelog artifacts: true + - job: frontend:lint # validation + artifacts: false + - job: frontend:test # validation + artifacts: false rules: - if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ when: always @@ -293,6 +297,10 @@ release: artifacts: false - job: parse-changelog artifacts: true + - job: frontend:lint # validation + artifacts: false + - job: frontend:test # validation + artifacts: false rules: - if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ when: always From 24da2bd04c7ed5d1708a84dae6729c4dd725edbb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 15:44:30 +0100 Subject: [PATCH 007/514] chore(mailmap): introduce mailmap --- .mailmap | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 .mailmap diff --git a/.mailmap b/.mailmap new file mode 100644 index 000000000..bd23a6e51 --- /dev/null +++ b/.mailmap @@ -0,0 +1,6 @@ +Gregor Kleen +Gregor Kleen +Felix Hamann +Steffen Jost +Sarah Vaupel +Sarah Vaupel Sarah Vaupel <> \ No newline at end of file From ca22061e72abfc0db65ad51b8dc1780c577c4a81 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Feb 2021 17:46:30 +0100 Subject: [PATCH 008/514] chore(gitlab-ci): use npm ci and cache --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index aec0fe441..0100fab5b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,6 +9,7 @@ default: name: fpco/stack-build:lts-16.31 cache: &global_cache paths: + - .npm - node_modules - .stack - .stack-work @@ -44,7 +45,7 @@ npm install: stage: setup script: - ./.npmrc.gup - - npm install + - npm ci --cache .npm --prefer-offline before_script: &npm - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list From db48bbb7765604aaab8f8d5c540793b1ceaff16a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 20 Feb 2021 11:16:47 +0100 Subject: [PATCH 009/514] fix(jobs): use more read only/deferrable transactions --- src/Foundation/DB.hs | 3 ++- src/Jobs.hs | 28 +++++++++++---------- src/Jobs/Crontab.hs | 6 ++--- src/Jobs/Handler/Files.hs | 10 +++----- src/Jobs/Types.hs | 1 + src/Utils/Sql.hs | 51 +++++++++++++++++++++++++++++---------- 6 files changed, 63 insertions(+), 36 deletions(-) diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs index 5261af6a2..f871cc026 100644 --- a/src/Foundation/DB.hs +++ b/src/Foundation/DB.hs @@ -11,6 +11,7 @@ import qualified Control.Retry as Retry import GHC.IO.Exception (IOErrorType(OtherError)) import Database.Persist.Sql (runSqlPool, SqlReadBackend(..)) +import Database.Persist.Sql.Raw.QQ (executeQQ) runSqlPoolRetry :: forall m a backend. @@ -43,4 +44,4 @@ runSqlPoolRetry action pool = do runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a runDBRead action = do $logDebugS "YesodPersist" "runDBRead" - runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod + runSqlPoolRetry (withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) . appConnPool =<< getYesod diff --git a/src/Jobs.hs b/src/Jobs.hs index b6de74e24..b61556caa 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -339,8 +339,8 @@ execCrontab :: RWST JobState () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWo -- seen, wait for the time of the next job and fire it execCrontab = do let - mergeState :: MonadResource m => RWST _ () _ (ReaderT SqlBackend m) () - mergeState = do + mergeState :: (MonadResource m, BackendCompatible SqlReadBackend backend) => RWST _ () _ (ReaderT backend m) () + mergeState = mapRWST (withReaderT $ projectBackend @SqlReadBackend) $ do let mergeLastExec (Entity _leId CronLastExec{..}) | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob @@ -353,7 +353,7 @@ execCrontab = do | otherwise = return () runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued - mapRWST (liftHandler . runDB . setSerializableBatch) mergeState + mapRWST (liftHandler . runDBRead . setSerializableReadOnlyBatch) mergeState refT <- liftIO getCurrentTime settings <- getsYesod appSettings' @@ -555,16 +555,21 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker JobHandlerException act -> do act & withJobWorkerState wNum (JobWorkerExecJob content) runDB $ setSerializableBatch cleanup - JobHandlerAtomicWithFinalizer act fin -> do - res <- runDBJobs . setSerializableBatch $ do - res <- act & withJobWorkerState wNum (JobWorkerExecJob content) - hoist lift cleanup - return res - fin res + JobHandlerAtomicWithFinalizer act fin -> + withJobWorkerState wNum (JobWorkerExecJob content) $ do + fin <=< runDBJobs . setSerializableBatch $ + act <* hoist lift cleanup + JobHandlerAtomicDeferrableWithFinalizer act fin -> do + withJobWorkerState wNum (JobWorkerExecJob content) $ + fin =<< runDBRead (setSerializableDeferrableBatch act) + runDB $ setSerializableBatch cleanup handleCmd JobCtlDetermineCrontab = do $logDebugS logIdent "DetermineCrontab..." - newCTab <- liftHandler . runDB $ setSerializableBatch determineCrontab' + newCTab <- liftHandler . runDBRead $ setSerializableReadOnlyBatch determineCrontab $logInfoS logIdent "DetermineCrontab" + $logDebugS logIdent "PruneLastExecs..." + liftHandler . runDB $ pruneLastExecs newCTab + $logInfoS logIdent "PruneLastExecs" -- logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . flip writeTVar newCTab =<< asks jobCrontab @@ -713,9 +718,6 @@ pruneLastExecs crontab = do | otherwise -> return mempty -determineCrontab' :: DB (Crontab JobCtl) -determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab - performJob :: Job -> JobHandler UniWorX performJob = $(dispatchTH ''Job) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index f29d5e03d..d96247af0 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -33,7 +33,7 @@ import Data.List (iterate) prewarmCacheIntervalsCache :: TVar (Map Natural [(Maybe FileContentChunkReference, Maybe FileContentChunkReference)]) prewarmCacheIntervalsCache = unsafePerformIO $ newTVarIO Map.empty -determineCrontab :: DB (Crontab JobCtl) +determineCrontab :: ReaderT SqlReadBackend (HandlerFor UniWorX) (Crontab JobCtl) -- ^ Extract all future jobs from the database (sheet deadlines, ...) determineCrontab = execWriterT $ do UniWorX{ appSettings' = AppSettings{..} } <- getYesod @@ -61,7 +61,7 @@ determineCrontab = execWriterT $ do Nothing -> mempty let - tellPrewarmJobs :: JobCtlPrewarmSource -> UTCTime -> WriterT (Crontab JobCtl) (YesodDB UniWorX) () + tellPrewarmJobs :: JobCtlPrewarmSource -> UTCTime -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) () tellPrewarmJobs jcPrewarmSource jcTargetTime = maybeT (return ()) $ do PrewarmCacheConf{..} <- hoistMaybe appFileSourcePrewarmConf @@ -361,7 +361,7 @@ determineCrontab = execWriterT $ do } let - correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) DB () + correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) () correctorNotifications = (tell .) . Map.foldMapWithKey $ \(nUser, nSheet) (Max time) -> HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } ) Cron diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 0427b001d..f4e06a475 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -36,8 +36,6 @@ import System.Clock import qualified Data.Set as Set import qualified Data.Sequence as Seq -import Jobs.Queue (YesodJobDB) - import Jobs.Handler.Intervals.Utils import Data.IntervalMap.Strict (IntervalMap) @@ -86,10 +84,10 @@ workflowFileReferences = Map.fromList $ over (traverse . _1) nameToPathPiece dispatchJobDetectMissingFiles :: JobHandler UniWorX -dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin +dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin where - act :: YesodJobDB UniWorX (Map Text (NonNull (Set FileContentReference))) - act = hoist lift $ do + act :: ReaderT SqlReadBackend (HandlerFor UniWorX) (Map Text (NonNull (Set FileContentReference))) + act = do uploadBucket <- getsYesod $ view _appUploadCacheBucket missingDb <- runConduit . execStateC Map.empty $ do @@ -105,7 +103,7 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin transPipe lift (E.selectSource fileReferencesQuery) .| C.mapMaybe E.unValue .| C.mapM_ (insertRef refKind) iforM_ workflowFileReferences $ \refKind refSource -> - transPipe lift (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind) + transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind) let allMissingDb :: Set Minio.Object allMissingDb = setOf (folded . folded . re minioFileReference) missingDb diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index f83311d34..7ebb4bf4c 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -241,6 +241,7 @@ data JobHandler site = JobHandlerAtomic (YesodJobDB site ()) | JobHandlerException (HandlerFor site ()) | forall a. JobHandlerAtomicWithFinalizer (YesodJobDB site a) (a -> HandlerFor site ()) + | forall a. JobHandlerAtomicDeferrableWithFinalizer (ReaderT SqlReadBackend (HandlerFor site) a) (a -> HandlerFor site ()) deriving (Typeable) makePrisms ''JobHandler diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index c892e56fa..dfc09d8ac 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -1,5 +1,7 @@ module Utils.Sql - ( setSerializable, setSerializableBatch, setSerializable' + ( setSerializable + , setSerializableBatch, setSerializableReadOnlyBatch, setSerializableDeferrableBatch + , SerializableMode(..), setSerializable' , catchSql, handleSql , isUniqueConstraintViolation , catchIfSql, handleIfSql @@ -13,7 +15,9 @@ import Database.PostgreSQL.Simple (SqlError(..)) import Database.PostgreSQL.Simple.Errors (isSerializationError) import Control.Monad.Catch -import Database.Persist.Sql +import Database.Persist.Sql hiding (IsolationLevel(..)) +import qualified Database.Persist.Sql as Persist (IsolationLevel(..)) +import Database.Persist.Sql.Types.Instances () import Database.Persist.Sql.Raw.QQ import qualified Data.ByteString as ByteString @@ -29,6 +33,10 @@ import Text.Shakespeare.Text (st) import Control.Concurrent.Async (ExceptionInLinkedThread(..)) +import Data.Universe + +import Control.Monad.Trans.Reader (withReaderT) + fromExceptionWrapped :: Exception exc => SomeException -> Maybe exc fromExceptionWrapped (fromException -> Just exc) = Just exc @@ -36,43 +44,60 @@ fromExceptionWrapped (fromException >=> \(ExceptionInLinkedThread _ exc') -> fro fromExceptionWrapped _ = Nothing +data SerializableMode = Serializable + | SerializableReadOnly + | SerializableReadOnlyDeferrable + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a -setSerializable = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 +setSerializable = setSerializable' Serializable $ 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 +setSerializableBatch = setSerializable' Serializable $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 3600e6 + +setSerializableReadOnlyBatch :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (ReaderT SqlReadBackend m)) => ReaderT SqlReadBackend m a -> ReaderT SqlReadBackend m a +setSerializableReadOnlyBatch = setSerializable' SerializableReadOnly $ 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 +setSerializableDeferrableBatch :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (ReaderT SqlReadBackend m)) => ReaderT SqlReadBackend m a -> ReaderT SqlReadBackend m a +setSerializableDeferrableBatch = setSerializable' SerializableReadOnlyDeferrable $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 3600e6 + +setSerializable' :: forall backend m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (ReaderT backend m), BackendCompatible SqlBackend backend) => SerializableMode -> RetryPolicyM (ReaderT backend m) -> ReaderT backend m a -> ReaderT backend m a +setSerializable' mode policy act = do LogSettings{logSerializableTransactionRetryLimit} <- readLogSettings didCommit <- newTVarIO False recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry (logRetry logSerializableTransactionRetryLimit)) $ act' didCommit where - suggestRetry :: SomeException -> ReaderT SqlBackend m Bool + suggestRetry :: SomeException -> ReaderT backend m Bool suggestRetry = return . maybe False isSerializationError . fromExceptionWrapped logRetry :: Maybe Natural -> Bool -- ^ Will retry -> SomeException -> RetryStatus - -> ReaderT SqlBackend m () + -> ReaderT backend m () logRetry _ shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status logRetry (Just limit) shouldRetry err status | fromIntegral limit <= rsIterNumber status = $logInfoS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status logRetry _ shouldRetry err status = $logDebugS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status - act' :: TVar Bool -> RetryStatus -> ReaderT SqlBackend m a + (setTransactionLevel, beginTransactionLevel) = case mode of + Serializable -> ([executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|], [executeQQ|BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE|] ) + SerializableReadOnly -> ([executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE, READ ONLY|], [executeQQ|BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE, READ ONLY|] ) + SerializableReadOnlyDeferrable -> ([executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE, READ ONLY, DEFERRABLE|], [executeQQ|BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE, READ ONLY, DEFERRABLE|]) + + act' :: TVar Bool -> RetryStatus -> ReaderT backend m a act' didCommit RetryStatus{..} = do prevCommited <- atomically $ swapTVar didCommit False $logDebugS "SQL.setSerializable" $ "prevCommited = " <> tshow prevCommited <> "; rsIterNumber = " <> tshow rsIterNumber if - | rsIterNumber == 0 -> [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act'' - | prevCommited -> [executeQQ|BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act'' - | otherwise -> transactionUndoWithIsolation Serializable *> act'' + | rsIterNumber == 0 -> setTransactionLevel *> act'' + | prevCommited -> beginTransactionLevel *> act'' + | otherwise -> withReaderT projectBackend transactionUndo *> setTransactionLevel *> act'' where act'' = do res <- act atomically $ writeTVar didCommit True - transactionSaveWithIsolation ReadCommitted + withReaderT projectBackend $ transactionSaveWithIsolation Persist.ReadCommitted return res catchSql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => SqlPersistT m a -> (e -> SqlPersistT m a) -> SqlPersistT m a From 8b532a2b3ba4574ed18d3074c744eae6964d0d3c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 20 Feb 2021 11:32:47 +0100 Subject: [PATCH 010/514] chore(release): 24.4.3 --- 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 d94c833b6..f515f146c 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. +## [24.4.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.2...v24.4.3) (2021-02-20) + + +### Bug Fixes + +* **jobs:** use more read only/deferrable transactions ([db48bbb](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/db48bbb7765604aaab8f8d5c540793b1ceaff16a)) + ## [24.4.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.1...v24.4.2) (2021-02-19) diff --git a/package-lock.json b/package-lock.json index baafd3c2c..70e66425a 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.2", + "version": "24.4.3", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 8183804d7..741df4cfb 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.2", + "version": "24.4.3", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 69e411ed1..342546e28 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 24.4.2 +version: 24.4.3 dependencies: - base - yesod From fb6ae089c63174edc1d84512ea35378ab8cd0e0e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Feb 2021 13:39:47 +0100 Subject: [PATCH 011/514] feat(bot-mitigations): only logged in table sorting --- config/settings.yml | 3 ++ frontend/src/app.sass | 49 +++++++++++++++++++ frontend/src/utils/async-table/async-table.js | 5 +- .../utils/course-teaser/course-teaser.sass | 5 +- messages/uniworx/de-de-formal.msg | 4 +- messages/uniworx/en-eu.msg | 2 + src/Handler/Utils/Table/Pagination.hs | 5 ++ src/Settings.hs | 15 ++++++ templates/table/cell/header.hamlet | 23 +++++---- templates/table/course/colonnade.hamlet | 3 ++ templates/table/course/header.hamlet | 22 +++++---- 11 files changed, 113 insertions(+), 23 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 7c6181cc9..ea6d0dd97 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -281,3 +281,6 @@ file-source-prewarm: inhibit: 3600 # 60m steps: 20 max-speedup: 3 + +bot-mitigations: + - only-logged-in-table-sorting diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 365ac1f3e..0156fee16 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -993,6 +993,11 @@ th, td padding-right: 24px cursor: pointer +.table__th.presorted, +.table__th.presorted + position: relative + padding-right: 24px + .table__th.sortable::after, .table__th.sortable::before content: '' @@ -1022,6 +1027,28 @@ th, td .table__th.sorted-desc::after border-bottom-color: white !important +.table__th.presorted::before, +.table__th.presorted::after + content: '' + position: absolute + top: 50% + right: 4px + width: 0 + height: 0 + border-left: 8px solid transparent + border-right: 8px solid transparent + border-bottom: 8px solid rgba(255, 255, 255, 0.2) + +.table__th.presorted.sorted-asc::before, +.table__th.presorted.sorted-desc::after + border-bottom-color: white !important + +.table__th.presorted::before + transform: translateY(150%) scale(1, -1) + transform-origin: top +.table__th.presorted::after + transform: translateY(-150%) + \:root --color-grey-light: #efefef --color-grey-lighter: #f5f5f5 @@ -1043,6 +1070,22 @@ th, td border-left: 8px solid transparent border-right: 8px solid transparent border-bottom: 8px solid rgba(255, 255, 255, 0.4) + +.inactive-course-header::before, +.inactive-course-header::after + content: '' + position: absolute + right: 10px + top: 20px + width: 0 + height: 0 + border-left: 8px solid transparent + border-right: 8px solid transparent + border-bottom: 8px solid rgba(255,255,255, 0.2) + +.inactive-course-header.sorted-asc::before, +.inactive-course-header.sorted-desc::after + border-bottom-color: white !important .course-header::before // magic numbers to move arrow back in the right position after flipping it. @@ -1053,6 +1096,12 @@ th, td .course-header::after transform: translateY(-150%) +.inactive-course-header::before + transform: translateY(150%) scale(1, -1) + transform-origin: top +.inactive-course-header::after + transform: translateY(-150%) + .course-header:hover::before, .course-header:hover::after border-bottom-color: rgba(255, 255, 255, 0.7) diff --git a/frontend/src/utils/async-table/async-table.js b/frontend/src/utils/async-table/async-table.js index 52ee85e02..3dbaad95e 100644 --- a/frontend/src/utils/async-table/async-table.js +++ b/frontend/src/utils/async-table/async-table.js @@ -355,6 +355,9 @@ export class AsyncTable { _linkClickHandler = (event) => { event.preventDefault(); let url = this._getClickDestination(event.target); + if (!url) + return; + if (!url.match(/^http/)) { url = window.location.origin + window.location.pathname + url; } @@ -363,7 +366,7 @@ export class AsyncTable { _getClickDestination(el) { if (!el.matches('a') && !el.querySelector('a')) { - return ''; + return null; } return el.getAttribute('href') || el.querySelector('a').getAttribute('href'); } diff --git a/frontend/src/utils/course-teaser/course-teaser.sass b/frontend/src/utils/course-teaser/course-teaser.sass index 56831de4f..d8866b21f 100644 --- a/frontend/src/utils/course-teaser/course-teaser.sass +++ b/frontend/src/utils/course-teaser/course-teaser.sass @@ -216,7 +216,10 @@ line-height: 1.4 max-width: 85vw - .course-header + .explanation + clear: both + + .course-header, .inactive-course-header float: left background-color: var(--color-dark) position: relative diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 030c292fc..3dd02a5f9 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -3181,4 +3181,6 @@ UrlFieldCouldNotParseAbsolute: Konnte nicht als absolute URL interpretiert werde WGFTextInput: Textfeld WGFFileUpload: Dateifeld WorkflowGraphFormUploadIsDirectory: Upload ist Verzeichnis -WorkflowGraphFormInvalidNumberOfFiles: Es muss genau eine Datei hochgeladen werden \ No newline at end of file +WorkflowGraphFormInvalidNumberOfFiles: Es muss genau eine Datei hochgeladen werden + +CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle ist nur für eingeloggte Benutzer aktiv \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index d4dab1a62..0ab958e2c 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -3182,3 +3182,5 @@ WGFTextInput: Text field WGFFileUpload: File field WorkflowGraphFormUploadIsDirectory: Upload is a directory WorkflowGraphFormInvalidNumberOfFiles: You need to upload exactly one file + +CourseSortingOnlyLoggedIn: The user interface for sorting this table is only active for logged in users diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 11748f778..6c345303d 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -897,6 +897,10 @@ instance IsDBTable m a => IsString (DBCell m a) where -- | DB-backed tables with pagination, may short-circuit a handler if the frontend only asks for the table content, i.e. handler actions after calls to dbTable may not happen at all. dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x) dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do + doSorting <- or2M + (getsYesod . views _appBotMitigations $ Set.notMember SettingBotMitigationOnlyLoggedInTableSorting) + (is _Just <$> maybeAuthId) + let sortingOptions = mkOptionList [ Option t' (SortingSetting t d) t' @@ -951,6 +955,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit let + -- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..}) | FormSuccess pi <- piResult , not $ piIsUnset pi diff --git a/src/Settings.hs b/src/Settings.hs index 83846b1aa..9006adba0 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -77,6 +77,8 @@ import Data.Conduit.Algorithms.FastCDC import Utils.Lens.TH +import qualified Data.Set as Set + -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, @@ -217,6 +219,8 @@ data AppSettings = AppSettings , appFileSourceARCConf :: Maybe (ARCConf Int) , appFileSourcePrewarmConf :: Maybe PrewarmCacheConf + + , appBotMitigations :: Set SettingBotMitigation } deriving Show data JobMode = JobsLocal { jobsAcceptOffload :: Bool } @@ -352,6 +356,11 @@ data PrewarmCacheConf = PrewarmCacheConf , precMaxSpeedup :: Rational } deriving (Eq, Ord, Read, Show, Generic, Typeable) +data SettingBotMitigation + = SettingBotMitigationOnlyLoggedInTableSorting + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1 pathPieceJSON ''ApprootScope pathPieceJSONKey ''ApprootScope @@ -388,6 +397,10 @@ deriveJSON defaultOptions makeLenses_ ''PrewarmCacheConf +nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3 +pathPieceJSON ''SettingBotMitigation +pathPieceJSONKey ''SettingBotMitigation + instance FromJSON LdapConf where parseJSON = withObject "LdapConf" $ \o -> do ldapTls <- o .:? "tls" @@ -660,6 +673,8 @@ instance FromJSON AppSettings where ] appFileSourcePrewarmConf <- over (_Just . _precInhibit) (max 0) . assertM isValidPrewarmConf <$> o .:? "file-source-prewarm" + appBotMitigations <- o .:? "bot-mitigations" .!= Set.empty + return AppSettings{..} makeClassy_ ''AppSettings diff --git a/templates/table/cell/header.hamlet b/templates/table/cell/header.hamlet index ecc5ab994..97f08b3a1 100644 --- a/templates/table/cell/header.hamlet +++ b/templates/table/cell/header.hamlet @@ -1,12 +1,15 @@ $newline never - - $maybe flag <- sortableKey - $case directions - $of [SortAsc] - - ^{widget} - $of _ - - ^{widget} - $nothing + + $if doSorting + $maybe flag <- sortableKey + $case directions + $of [SortAsc] + + ^{widget} + $of _ + + ^{widget} + $nothing + ^{widget} + $else ^{widget} diff --git a/templates/table/course/colonnade.hamlet b/templates/table/course/colonnade.hamlet index d23c64020..f3436055d 100644 --- a/templates/table/course/colonnade.hamlet +++ b/templates/table/course/colonnade.hamlet @@ -3,6 +3,9 @@ $newline never $maybe wdgt <- wHeaders
^{wdgt} + $if not doSorting +

+ _{MsgCourseSortingOnlyLoggedIn} $if null wRows && (dbsEmptyStyle == DBESHeading)

_{dbsEmptyMessage} $else diff --git a/templates/table/course/header.hamlet b/templates/table/course/header.hamlet index 23ccf4a10..3970c200a 100644 --- a/templates/table/course/header.hamlet +++ b/templates/table/course/header.hamlet @@ -1,12 +1,14 @@ $newline never - $maybe flag <- sortableKey - - $case directions - $of [SortAsc] - - ^{widget} - $of _ - - ^{widget} -$nothing + $if doSorting + + $case directions + $of [SortAsc] + + ^{widget} + $of _ + + ^{widget} + $else + + ^{widget} From e4f10ec1f377831f32fb464961bbf4622ebf1a95 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Feb 2021 13:40:30 +0100 Subject: [PATCH 012/514] chore(release): 24.5.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 f515f146c..de9cefbff 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. +## [24.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.3...v24.5.0) (2021-02-21) + + +### Features + +* **bot-mitigations:** only logged in table sorting ([fb6ae08](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fb6ae089c63174edc1d84512ea35378ab8cd0e0e)) + ## [24.4.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.2...v24.4.3) (2021-02-20) diff --git a/package-lock.json b/package-lock.json index 70e66425a..6144e276e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.3", + "version": "24.5.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 741df4cfb..1326bacef 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.4.3", + "version": "24.5.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 342546e28..def51d09e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 24.4.3 +version: 24.5.0 dependencies: - base - yesod From 35ac503bf971ace21c49646aa15e8b94b7a3e823 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Feb 2021 20:44:45 +0100 Subject: [PATCH 013/514] feat(db): optionally disable some db connection pooling --- src/Application.hs | 76 ++++++++++++++++++--------------- src/Foundation/DB.hs | 15 ++++--- src/Foundation/Type.hs | 6 +-- src/Foundation/Yesod/Persist.hs | 5 ++- src/Settings.hs | 2 + test/Database.hs | 2 +- test/TestImport.hs | 2 +- 7 files changed, 60 insertions(+), 48 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index feb2980ec..03d798600 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -18,7 +18,7 @@ module Application import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, - pgPoolSize, runSqlPool, ConnectionPool) + pgPoolSize, runSqlPool, ConnectionPool, runSqlConn, withPostgresqlConn) import Import hiding (cancel, respond) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) @@ -202,25 +202,28 @@ makeFoundation appSettings''@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} - -- The UniWorX {..} syntax is an example of record wild cards. For more - -- information, see: - -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html - tempFoundation = mkFoundation - (error "appSettings' forced in tempFoundation") - (error "connPool forced in tempFoundation") - (error "smtpPool forced in tempFoundation") - (error "ldapPool forced in tempFoundation") - (error "cryptoIDKey forced in tempFoundation") - (error "sessionStore forced in tempFoundation") - (error "secretBoxKey forced in tempFoundation") - (error "widgetMemcached forced in tempFoundation") - (error "JSONWebKeySet forced in tempFoundation") - (error "ClusterID forced in tempFoundation") - (error "memcached forced in tempFoundation") - (error "MinioConn forced in tempFoundation") - (error "VerpSecret forced in tempFoundation") - (error "AuthKey forced in tempFoundation") + let + mkFoundation :: _ -> _ -> (forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a) -> _ + mkFoundation appSettings' appDatabaseConnPool appDatabaseAccess appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} + -- The UniWorX {..} syntax is an example of record wild cards. For more + -- information, see: + -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + tempFoundation = mkFoundation + (error "appSettings' forced in tempFoundation") + (error "databaseConnPool forced in tempFoundation") + (error "databaseAccess forced in tempFoundation") + (error "smtpPool forced in tempFoundation") + (error "ldapPool forced in tempFoundation") + (error "cryptoIDKey forced in tempFoundation") + (error "sessionStore forced in tempFoundation") + (error "secretBoxKey forced in tempFoundation") + (error "widgetMemcached forced in tempFoundation") + (error "JSONWebKeySet forced in tempFoundation") + (error "ClusterID forced in tempFoundation") + (error "memcached forced in tempFoundation") + (error "MinioConn forced in tempFoundation") + (error "VerpSecret forced in tempFoundation") + (error "AuthKey forced in tempFoundation") runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID @@ -237,9 +240,14 @@ makeFoundation appSettings''@AppSettings{..} = do -- Create the database connection pool $logDebugS "setup" "PostgreSQL-Pool" - sqlPool <- createPostgresqlPool + appDatabaseConnPool <- createPostgresqlPool (pgConnStr appDatabaseConf) (pgPoolSize appDatabaseConf) + let + appDatabaseAccess :: forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a + appDatabaseAccess + | appDatabasePool = flip runSqlPool appDatabaseConnPool . withReaderT projectBackend + | otherwise = withPostgresqlConn (pgConnStr appDatabaseConf) . runSqlConn . withReaderT projectBackend ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do let ldapLabel = case ldapHost of @@ -254,33 +262,33 @@ makeFoundation appSettings''@AppSettings{..} = do if | appAutoDbMigrate -> do $logDebugS "setup" "Migration" - migrateAll `runSqlPool` sqlPool - | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do + appDatabaseAccess migrateAll + | otherwise -> whenM (appDatabaseAccess requiresMigration) $ do $logErrorS "setup" "Migration required" liftIO . exitWith $ ExitFailure 130 $logDebugS "setup" "Cluster-Config" - appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool - appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool - appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool - appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool - appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool - appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `runSqlPool` sqlPool + appCryptoIDKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterCryptoIDKey + appSecretBoxKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterSecretBoxKey + appJSONWebKeySet <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterJSONWebKeySet + appClusterID <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterId + appVerpSecret <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterVerpSecret + appAuthKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterAuthKey - needsRechunk <- exists [FileContentChunkContentBased !=. True] `runSqlPool` sqlPool + needsRechunk <- appDatabaseAccess @SqlReadBackend $ exists [FileContentChunkContentBased !=. True] let appSettings' = appSettings'' & _appRechunkFiles %~ guardOnM needsRechunk appMemcached <- for appMemcachedConf $ \memcachedConf -> do $logDebugS "setup" "Memcached" - memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `runSqlPool` sqlPool + memcachedKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterMemcachedKey memcached <- createMemcached memcachedConf when appClearCache $ do $logWarnS "setup" "Clearing memcached" liftIO $ Memcached.flushAll memcached return (memcachedKey, memcached) - appSessionStore <- mkSessionStore appSettings'' sqlPool `runSqlPool` sqlPool + appSessionStore <- appDatabaseAccess $ mkSessionStore appSettings'' appDatabaseConnPool appUploadCache <- for appUploadCacheConf $ \minioConf -> liftIO $ do conn <- Minio.connect minioConf @@ -293,7 +301,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshow appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey + let foundation = mkFoundation appSettings' appDatabaseConnPool appDatabaseAccess smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey -- Return the foundation $logDebugS "setup" "Done" @@ -644,7 +652,7 @@ shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m () shutdownApp app = do stopJobCtl app liftIO $ do - destroyAllResources $ appConnPool app + destroyAllResources $ appDatabaseConnPool app for_ (appSmtpPool app) destroyAllResources for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources for_ (appWidgetMemcached app) Memcached.close diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs index f871cc026..9730c3a5a 100644 --- a/src/Foundation/DB.hs +++ b/src/Foundation/DB.hs @@ -10,18 +10,18 @@ import Foundation.Type import qualified Control.Retry as Retry import GHC.IO.Exception (IOErrorType(OtherError)) -import Database.Persist.Sql (runSqlPool, SqlReadBackend(..)) +import Database.Persist.Sql (SqlReadBackend(..)) import Database.Persist.Sql.Raw.QQ (executeQQ) runSqlPoolRetry :: forall m a backend. - ( MonadUnliftIO m, BackendCompatible SqlBackend backend + ( MonadUnliftIO m , MonadLogger m, MonadMask m ) - => ReaderT backend m a - -> Pool backend + => (ReaderT backend m a -> m a) + -> ReaderT backend m a -> m a -runSqlPoolRetry action pool = do +runSqlPoolRetry dbAccess action = do let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6 handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry where suggestRetry :: IOException -> m Bool @@ -39,9 +39,10 @@ runSqlPoolRetry action pool = do Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber - runSqlPool action pool + dbAccess action runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a runDBRead action = do $logDebugS "YesodPersist" "runDBRead" - runSqlPoolRetry (withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) . appConnPool =<< getYesod + dbAccess <- getsYesod appDatabaseAccess + runSqlPoolRetry dbAccess . withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 9c525dfd6..3e70ec2ad 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -6,12 +6,11 @@ module Foundation.Type , SomeSessionStorage(..) , _SessionStorageMemcachedSql, _SessionStorageAcid , SMTPPool - , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey + , _appSettings', _appStatic, _appDatabaseConnPool, _appDatabaseAccess, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey , DB, Form, MsgRenderer, MailM, DBFile ) where import Import.NoFoundation -import Database.Persist.Sql (ConnectionPool) import Jobs.Types @@ -43,7 +42,8 @@ makePrisms ''SomeSessionStorage data UniWorX = UniWorX { appSettings' :: AppSettings , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appDatabaseConnPool :: Pool SqlBackend + , appDatabaseAccess :: forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a , appSmtpPool :: Maybe SMTPPool , appLdapPool :: Maybe (Failover (LdapConf, LdapPool)) , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index 98462eda7..e467da4fe 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -25,14 +25,15 @@ runDB action = do | dryRun = action <* transactionUndo | otherwise = action - runSqlPoolRetry action' . appConnPool =<< getYesod + dbAccess <- getsYesod appDatabaseAccess + runSqlPoolRetry dbAccess action' getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend , BearerAuthSite UniWorX ) => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ()) getDBRunner = do - (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool + (DBRunner{..}, cleanup) <- defaultGetDBRunner appDatabaseConnPool return . (, cleanup) $ DBRunner (\action -> do dryRun <- isDryRun diff --git a/src/Settings.hs b/src/Settings.hs index 9006adba0..893170a89 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -90,6 +90,7 @@ data AppSettings = AppSettings , appWellKnownDir :: FilePath , appWellKnownLinkFile :: FilePath , appDatabaseConf :: PostgresConf + , appDatabasePool :: Bool -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool , appLdapConf :: Maybe (PointedList LdapConf) @@ -516,6 +517,7 @@ instance FromJSON AppSettings where appWellKnownLinkFile <- o .: "well-known-link-file" appWebpackEntrypoints <- o .: "webpack-manifest" appDatabaseConf <- o .: "database" + appDatabasePool <- o .:? "database-pool" .!= True appAutoDbMigrate <- o .: "auto-db-migrate" let nonEmptyHost LdapConf{..} = case ldapHost of Ldap.Tls host _ -> not $ null host diff --git a/test/Database.hs b/test/Database.hs index 1317574a8..87f85aa84 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -48,7 +48,7 @@ main = do [executeQQ|drop owned by current_user|] :: ReaderT SqlBackend _ () DBTruncate -> db' $ do foundation <- getYesod - liftIO . destroyAllResources $ appConnPool foundation + liftIO . destroyAllResources $ appDatabaseConnPool foundation truncateDb DBMigrate -> db' $ return () DBFill -> db' $ fillDb diff --git a/test/TestImport.hs b/test/TestImport.hs index 348cd1c89..3cd9539d4 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -78,7 +78,7 @@ runDB query = do liftIO $ runDBWithApp app query runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a -runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app) +runDBWithApp app query = liftIO $ runSqlPersistMPool query (appDatabaseConnPool app) runHandler :: Handler a -> YesodExample UniWorX a runHandler handler = do From e48124a8b82c54b3347e818cbaa4a2e06a7cf101 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 21 Feb 2021 20:45:59 +0100 Subject: [PATCH 014/514] chore(release): 24.6.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 de9cefbff..cf10961cc 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. +## [24.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.5.0...v24.6.0) (2021-02-21) + + +### Features + +* **db:** optionally disable some db connection pooling ([35ac503](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/35ac503bf971ace21c49646aa15e8b94b7a3e823)) + ## [24.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.4.3...v24.5.0) (2021-02-21) diff --git a/package-lock.json b/package-lock.json index 6144e276e..a2fc39acf 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.5.0", + "version": "24.6.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 1326bacef..f426ae4ef 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.5.0", + "version": "24.6.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index def51d09e..13d1c6611 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 24.5.0 +version: 24.6.0 dependencies: - base - yesod From 50fdcb4540e6bfbc8da9ed10ed06d6f6ce443cf9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Feb 2021 16:30:24 +0100 Subject: [PATCH 015/514] feat(db): provide our own implementation of connection pooling Also allows monitoring pool status (available/in use connections, total number of takes from pool) This reverts commit 35ac503bf971ace21c49646aa15e8b94b7a3e823. --- src/Application.hs | 69 +++--- src/Foundation/DB.hs | 15 +- src/Foundation/Type.hs | 7 +- src/Foundation/Yesod/Persist.hs | 30 ++- src/Settings.hs | 2 - src/Utils/DB.hs | 7 + src/Utils/Metrics.hs | 43 ++++ src/Utils/Pool.hs | 223 ++++++++++++++++++ .../Backend/Persistent/Memcached.hs | 6 +- test/Database.hs | 6 +- test/TestImport.hs | 6 +- 11 files changed, 363 insertions(+), 51 deletions(-) create mode 100644 src/Utils/Pool.hs diff --git a/src/Application.hs b/src/Application.hs index 03d798600..d32a05f0e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -17,8 +17,10 @@ module Application ) where import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) -import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, - pgPoolSize, runSqlPool, ConnectionPool, runSqlConn, withPostgresqlConn) +import Database.Persist.Postgresql ( openSimpleConn, pgConnStr, connClose, pgPoolIdleTimeout + , pgPoolSize + ) +import qualified Database.PostgreSQL.Simple as PG import Import hiding (cancel, respond) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) @@ -108,6 +110,8 @@ import qualified Prometheus import qualified Data.IntervalMap.Strict as IntervalMap +import qualified Utils.Pool as Custom + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.News @@ -203,15 +207,14 @@ makeFoundation appSettings''@AppSettings{..} = do -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. let - mkFoundation :: _ -> _ -> (forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a) -> _ - mkFoundation appSettings' appDatabaseConnPool appDatabaseAccess appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} + mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool m SqlBackend) -> _ + mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html tempFoundation = mkFoundation (error "appSettings' forced in tempFoundation") - (error "databaseConnPool forced in tempFoundation") - (error "databaseAccess forced in tempFoundation") + (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation") (error "ldapPool forced in tempFoundation") (error "cryptoIDKey forced in tempFoundation") @@ -240,14 +243,22 @@ makeFoundation appSettings''@AppSettings{..} = do -- Create the database connection pool $logDebugS "setup" "PostgreSQL-Pool" - appDatabaseConnPool <- createPostgresqlPool - (pgConnStr appDatabaseConf) - (pgPoolSize appDatabaseConf) - let - appDatabaseAccess :: forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a - appDatabaseAccess - | appDatabasePool = flip runSqlPool appDatabaseConnPool . withReaderT projectBackend - | otherwise = withPostgresqlConn (pgConnStr appDatabaseConf) . runSqlConn . withReaderT projectBackend + logFunc <- askLoggerIO + sqlPool' <- + let create = do + $logDebugS "SqlPool" "Opening connection..." + conn <- liftIO . PG.connectPostgreSQL $ pgConnStr appDatabaseConf + backend <- liftIO $ openSimpleConn logFunc conn + $logInfoS "SqlPool" "Opened connection" + return backend + destroy conn = do + $logDebugS "SqlPool" "Closing connection..." + liftIO $ connClose conn + $logInfoS "SqlPool" "Closed connection" + in Custom.createPool (liftIO . flip runLoggingT logFunc) create destroy (Just . fromIntegral $ pgPoolIdleTimeout appDatabaseConf) (Just $ pgPoolSize appDatabaseConf) + let sqlPool :: forall m. MonadIO m => Custom.Pool m SqlBackend + sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool' + void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do let ldapLabel = case ldapHost of @@ -262,33 +273,33 @@ makeFoundation appSettings''@AppSettings{..} = do if | appAutoDbMigrate -> do $logDebugS "setup" "Migration" - appDatabaseAccess migrateAll - | otherwise -> whenM (appDatabaseAccess requiresMigration) $ do + migrateAll `customRunSqlPool` sqlPool + | otherwise -> whenM (requiresMigration `customRunSqlPool` sqlPool) $ do $logErrorS "setup" "Migration required" liftIO . exitWith $ ExitFailure 130 $logDebugS "setup" "Cluster-Config" - appCryptoIDKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterCryptoIDKey - appSecretBoxKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterSecretBoxKey - appJSONWebKeySet <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterJSONWebKeySet - appClusterID <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterId - appVerpSecret <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterVerpSecret - appAuthKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterAuthKey + appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `customRunSqlPool` sqlPool + appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `customRunSqlPool` sqlPool + appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `customRunSqlPool` sqlPool + appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `customRunSqlPool` sqlPool + appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `customRunSqlPool` sqlPool + appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool - needsRechunk <- appDatabaseAccess @SqlReadBackend $ exists [FileContentChunkContentBased !=. True] + needsRechunk <- exists [FileContentChunkContentBased !=. True] `customRunSqlPool` sqlPool let appSettings' = appSettings'' & _appRechunkFiles %~ guardOnM needsRechunk appMemcached <- for appMemcachedConf $ \memcachedConf -> do $logDebugS "setup" "Memcached" - memcachedKey <- appDatabaseAccess . clusterSetting $ Proxy @'ClusterMemcachedKey + memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `customRunSqlPool` sqlPool memcached <- createMemcached memcachedConf when appClearCache $ do $logWarnS "setup" "Clearing memcached" liftIO $ Memcached.flushAll memcached return (memcachedKey, memcached) - appSessionStore <- appDatabaseAccess $ mkSessionStore appSettings'' appDatabaseConnPool + appSessionStore <- mkSessionStore appSettings'' sqlPool `customRunSqlPool` sqlPool appUploadCache <- for appUploadCacheConf $ \minioConf -> liftIO $ do conn <- Minio.connect minioConf @@ -301,7 +312,7 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshow appSettings' - let foundation = mkFoundation appSettings' appDatabaseConnPool appDatabaseAccess smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey + let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret appAuthKey -- Return the foundation $logDebugS "setup" "Done" @@ -318,7 +329,9 @@ mkSessionStore :: forall m. , MonadThrow m , MonadResource m ) - => AppSettings -> ConnectionPool -> ReaderT SqlBackend m SomeSessionStorage + => AppSettings + -> (forall m'. MonadIO m' => Custom.Pool m' SqlBackend) + -> ReaderT SqlBackend m SomeSessionStorage mkSessionStore AppSettings{..} mcdSqlConnPool | Just mcdConf@MemcachedConf{..} <- appSessionMemcachedConf = do mcdSqlMemcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterServerSessionKey) @@ -652,7 +665,7 @@ shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m () shutdownApp app = do stopJobCtl app liftIO $ do - destroyAllResources $ appDatabaseConnPool app + Custom.purgePool $ appConnPool app for_ (appSmtpPool app) destroyAllResources for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources for_ (appWidgetMemcached app) Memcached.close diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs index 9730c3a5a..4d1e4d02f 100644 --- a/src/Foundation/DB.hs +++ b/src/Foundation/DB.hs @@ -13,15 +13,17 @@ import GHC.IO.Exception (IOErrorType(OtherError)) import Database.Persist.Sql (SqlReadBackend(..)) import Database.Persist.Sql.Raw.QQ (executeQQ) +import qualified Utils.Pool as Custom + runSqlPoolRetry :: forall m a backend. - ( MonadUnliftIO m + ( MonadUnliftIO m, BackendCompatible SqlBackend backend , MonadLogger m, MonadMask m ) - => (ReaderT backend m a -> m a) - -> ReaderT backend m a + => ReaderT backend m a + -> Custom.Pool m backend -> m a -runSqlPoolRetry dbAccess action = do +runSqlPoolRetry action pool = do let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6 handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry where suggestRetry :: IOException -> m Bool @@ -39,10 +41,9 @@ runSqlPoolRetry dbAccess action = do Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber - dbAccess action + customRunSqlPool action pool runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a runDBRead action = do $logDebugS "YesodPersist" "runDBRead" - dbAccess <- getsYesod appDatabaseAccess - runSqlPoolRetry dbAccess . withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action + runSqlPoolRetry (withReaderT SqlReadBackend $ [executeQQ|SET TRANSACTION READ ONLY|] *> action) . appConnPool =<< getYesod diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 3e70ec2ad..72f07d08f 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -6,7 +6,7 @@ module Foundation.Type , SomeSessionStorage(..) , _SessionStorageMemcachedSql, _SessionStorageAcid , SMTPPool - , _appSettings', _appStatic, _appDatabaseConnPool, _appDatabaseAccess, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey + , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey , DB, Form, MsgRenderer, MailM, DBFile ) where @@ -26,6 +26,8 @@ import Network.Minio (MinioConn) import Data.IntervalMap.Strict (IntervalMap) +import qualified Utils.Pool as Custom + type SMTPPool = Pool SMTPConnection @@ -42,8 +44,7 @@ makePrisms ''SomeSessionStorage data UniWorX = UniWorX { appSettings' :: AppSettings , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. - , appDatabaseConnPool :: Pool SqlBackend - , appDatabaseAccess :: forall backend m a. (MonadUnliftIO m, BackendCompatible backend SqlBackend, MonadLogger m) => ReaderT backend m a -> m a + , appConnPool :: forall m. MonadIO m => Custom.Pool m SqlBackend -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool , appLdapPool :: Maybe (Failover (LdapConf, LdapPool)) , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index e467da4fe..dc2c515aa 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -10,6 +10,11 @@ import Foundation.DB import Foundation.Authorization import Database.Persist.Sql (transactionUndo) +import qualified Database.Persist.Sql as SQL + +import qualified Utils.Pool as Custom + +import UnliftIO.Resource (allocate, unprotect) runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend @@ -25,15 +30,34 @@ runDB action = do | dryRun = action <* transactionUndo | otherwise = action - dbAccess <- getsYesod appDatabaseAccess - runSqlPoolRetry dbAccess action' + runSqlPoolRetry action' . appConnPool =<< getYesod getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend , BearerAuthSite UniWorX ) => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ()) getDBRunner = do - (DBRunner{..}, cleanup) <- defaultGetDBRunner appDatabaseConnPool + pool <- getsYesod appConnPool + UnliftIO{..} <- askUnliftIO + let withPrep conn f = f (persistBackend conn) (SQL.getStmtConn $ persistBackend conn) + (relKey, (conn, ident)) <- allocate + (do + (conn, ident) <- unliftIO $ Custom.takeResource pool + withPrep conn (\c f -> SQL.connBegin c f Nothing) + return (conn, ident) + ) + (\(conn, ident) -> do + withPrep conn SQL.connRollback + unliftIO $ Custom.releaseResource True pool (conn, ident) + ) + + let cleanup = liftIO $ do + withPrep conn SQL.connCommit + unliftIO $ Custom.releaseResource True pool (conn, ident) + void $ unprotect relKey + runDBRunner :: forall a. YesodDB UniWorX a -> HandlerFor UniWorX a + runDBRunner = flip runReaderT conn + return . (, cleanup) $ DBRunner (\action -> do dryRun <- isDryRun diff --git a/src/Settings.hs b/src/Settings.hs index 893170a89..9006adba0 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -90,7 +90,6 @@ data AppSettings = AppSettings , appWellKnownDir :: FilePath , appWellKnownLinkFile :: FilePath , appDatabaseConf :: PostgresConf - , appDatabasePool :: Bool -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool , appLdapConf :: Maybe (PointedList LdapConf) @@ -517,7 +516,6 @@ instance FromJSON AppSettings where appWellKnownLinkFile <- o .: "well-known-link-file" appWebpackEntrypoints <- o .: "webpack-manifest" appDatabaseConf <- o .: "database" - appDatabasePool <- o .:? "database-pool" .!= True appAutoDbMigrate <- o .: "auto-db-migrate" let nonEmptyHost LdapConf{..} = case ldapHost of Ldap.Tls host _ -> not $ null host diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 5a95de49f..5d80d7c00 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -14,6 +14,10 @@ import Control.Lens.Extras (is) import Control.Monad.Catch +import qualified Utils.Pool as Custom + +import Database.Persist.Sql (runSqlConn) + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) @@ -154,3 +158,6 @@ selectMaybe fltrs opts = listToMaybe <$> selectList fltrs (LimitTo 1 : opts') LimitTo _ -> True _other -> False + +customRunSqlPool :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Custom.Pool m backend -> m a +customRunSqlPool act p = Custom.withResource p $ runSqlConn act diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 19f51277b..738be7aaf 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -20,6 +20,8 @@ module Utils.Metrics , LRUMetrics, LRULabel(..) , lruMetrics , InjectInhibitMetrics, injectInhibitMetrics + , PoolMetrics, PoolLabel(..) + , poolMetrics ) where import Import.NoModel hiding (Vector, Info) @@ -50,6 +52,8 @@ import qualified Data.IntervalMap.Strict as IntervalMap import qualified Data.Foldable as F +import qualified Utils.Pool as Custom + {-# ANN module ("HLint: ignore Use even" :: String) #-} @@ -328,6 +332,45 @@ injectInhibitMetrics tvar = Metric $ return (InjectInhibitMetrics, collectInject "Number of distinct time intervals in which we don't transfer some files from upload cache to db" hashesInfo = Info "uni2work_inject_inhibited_hashes_count" "Number of files which we don't transfer from upload cache to db during some interval" + +data PoolMetrics = PoolMetrics + +data PoolLabel = PoolDatabaseConnections + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''PoolLabel $ camelToPathPiece' 1 + +poolMetrics :: PoolLabel + -> Custom.Pool m a + -> Metric PoolMetrics +poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics) + where + labelPool = relabel "pool" $ toPathPiece lbl + + collectPoolMetrics = map labelPool <$> do + (available, inUse, usesCount) <- atomically $ (,,) + <$> Custom.getPoolAvailableCount pool + <*> Custom.getPoolInUseCount pool + <*> Custom.getPoolUsesCount pool + return + [ SampleGroup availableInfo GaugeType + [ Sample "uni2work_pool_available_count" [] . encodeUtf8 $ tshow available + ] + , SampleGroup inUseInfo GaugeType + [ Sample "uni2work_pool_in_use_count" [] . encodeUtf8 $ tshow inUse + ] + , SampleGroup usesInfo CounterType + [ Sample "uni2work_pool_uses_count" [] . encodeUtf8 $ tshow usesCount + ] + ] + + availableInfo = Info "uni2work_pool_available_count" + "Number of open resources available for taking" + inUseInfo = Info "uni2work_pool_in_use_count" + "Number of resources currently in use" + usesInfo = Info "uni2work_pool_uses_count" + "Number of takes executed against the pool" withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport diff --git a/src/Utils/Pool.hs b/src/Utils/Pool.hs new file mode 100644 index 000000000..3308a12ca --- /dev/null +++ b/src/Utils/Pool.hs @@ -0,0 +1,223 @@ +{-# OPTIONS_GHC -Wno-error=unused-top-binds #-} + +module Utils.Pool + ( Pool, hoistPool + , getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount + , createPool + , purgePool + , withResource + , destroyResources + , takeResource, releaseResource + ) where + +import ClassyPrelude + +import qualified Data.IntMap.Strict as IntMap + +import UnliftIO.Async.Utils +import UnliftIO.Resource (MonadResource, register, release) +import UnliftIO.Concurrent (forkIO) + +import Data.Fixed + +import System.Clock + +import Control.Concurrent.STM.Delay +import Control.Concurrent.STM.TVar (stateTVar) + +import Control.Monad.Writer.Strict (runWriter) +import Control.Monad.Writer.Class (MonadWriter(..)) + +import Data.Semigroup (First(..)) + +import Utils.NTop + +-- + + +newtype PoolResourceIdent = PoolResourceIdent Int + deriving (Eq, Ord, Show, Typeable) + + +data Pool m a = Pool + { create :: m a + , destroy :: a -> m () + , idleTime :: !(Maybe Int) + , maxAvailable :: !(Maybe Int) + , resources :: !(TVar (PoolResources a)) + , aliveRef :: !(IORef ()) + } + +data PoolResources a = PoolResources + { inUseCount, availableCount :: !Int + , inUse :: !(IntMap a) + , available :: !(IntMap [a]) + , inUseTick :: !Int + } deriving (Functor) + + +hoistPool :: (forall b. m b -> n b) -> Pool m a -> Pool n a +hoistPool nat Pool{..} = Pool + { create = nat create + , destroy = nat . destroy + , .. + } + +getPoolAvailableCount, getPoolInUseCount, getPoolUsesCount :: Pool m a -> STM Int +getPoolAvailableCount Pool{..} = availableCount <$> readTVar resources +getPoolInUseCount Pool{..} = inUseCount <$> readTVar resources +getPoolUsesCount Pool{..} = inUseTick <$> readTVar resources + + +toSecond :: TimeSpec -> Int +toSecond = fromIntegral . sec + +currentSecond :: MonadIO m => m Int +currentSecond = liftIO $ toSecond <$> getTime Monotonic + + +createPool :: (MonadResource m, MonadUnliftIO m, MonadUnliftIO m') + => (forall b. m' b -> m b) + -> m' a -- ^ Create + -> (a -> m' ()) -- ^ Destroy + -> Maybe Int -- ^ Timeout in seconds + -> Maybe Int -- ^ Max available + -> m (Pool m' a) +createPool nat create destroy (fmap $ max 0 -> idleTime) (fmap $ max 0 -> maxAvailable) = do + let + inUseCount = 0 + availableCount = 0 + inUseTick = 0 + inUse = IntMap.empty + available = IntMap.empty + aliveRef <- newIORef () + resources <- newTVarIO PoolResources{..} + let pool = Pool{..} + + reaper' <- for idleTime $ allocateLinkedAsync . nat . reaper destroy resources + relKey <- withRunInIO $ \runInIO -> runInIO . register . runInIO $ do + traverse_ cancel reaper' + nat $ purgePool pool + void . mkWeakIORef aliveRef $ release relKey + + return pool + +purgePool :: MonadUnliftIO m => Pool m a -> m () +purgePool = destroyResources $ const True + +reaper :: MonadUnliftIO m => (a -> m ()) -> TVar (PoolResources a) -> Int -> m () +reaper destroy' resources' t = forever $ do + atomically . waitDelay =<< liftIO (newDelay i) + + cutoff <- subtract t <$> currentSecond + toDestroy <- atomically $ do + res@PoolResources{..} <- readTVar resources' + let (toDestroy, pivot, available'') = IntMap.splitLookup cutoff available + available' = maybe id (IntMap.insert cutoff) pivot available'' + writeTVar resources' res + { available = available' + , availableCount = availableCount - IntMap.size toDestroy + } + return toDestroy + forM_ toDestroy . mapM_ $ void . destroy' + + where + MkFixed (fromIntegral -> i) = 1 :: Micro + +takeResource :: MonadIO m => Pool m a -> m (a, PoolResourceIdent) +takeResource Pool{..} = do + takenAvailable <- atomically $ do + PoolResources{..} <- readTVar resources + case IntMap.maxViewWithKey available of + Just ((t, av : avs), available') -> do + let available'' + | null avs = available' + | otherwise = IntMap.insert t avs available' + availableCount' = pred availableCount + inUse' = IntMap.insert inUseTick av inUse + inUseCount' = succ inUseCount + inUseTick' = succ inUseTick + writeTVar resources PoolResources + { inUseCount = inUseCount' + , availableCount = availableCount' + , available = available'' + , inUseTick = inUseTick' + , inUse = inUse' + } + return $ Just (av, inUseTick) + _other -> return Nothing + case takenAvailable of + Just (av, resTick) -> return (av, PoolResourceIdent resTick) + Nothing -> do + newResource <- create + resTick <- atomically . stateTVar resources $ \res@PoolResources{..} -> + let inUseTick' = succ inUseTick + inUseCount' = succ inUseCount + inUse' = IntMap.insert inUseTick newResource inUse + in ( inUseTick + , res{ inUseCount = inUseCount', inUse = inUse', inUseTick = inUseTick' } + ) + return (newResource, PoolResourceIdent resTick) + +releaseResource :: MonadUnliftIO m + => Bool -- ^ Destroy resource and don't return to pool? + -> Pool m a + -> (a, PoolResourceIdent) + -> m () +releaseResource isLost p@Pool{..} (x, ident) + | isLost = do + markResourceLost p ident + void . forkIO $ destroy x + | otherwise + = markResourceAvailable p ident + +markResourceAvailable, markResourceLost :: MonadUnliftIO m => Pool m a -> PoolResourceIdent -> m () +markResourceAvailable = returnResource True +markResourceLost = returnResource False + +returnResource :: MonadUnliftIO m + => Bool -- ^ return to available + -> Pool m a + -> PoolResourceIdent + -> m () +returnResource toAvailable Pool{..} (PoolResourceIdent inUseKey) = do + now <- if | toAvailable -> Just <$> currentSecond + | otherwise -> return Nothing + toDestroy <- atomically . stateTVar resources $ \res@PoolResources{..} -> case deleteView inUseKey inUse of + Nothing -> (Nothing, res) + Just (u, us) | NTop (Just availableCount) >= NTop maxAvailable + -> (Just u,) res + { inUse = us + , inUseCount = pred inUseCount + } + Just (u, us) + -> (Nothing, ) PoolResources + { inUse = us + , inUseCount = pred inUseCount + , availableCount = bool id succ toAvailable availableCount + , available = maybe id (IntMap.alter $ Just . (u :) . fromMaybe []) now available + , inUseTick + } + + forM_ toDestroy $ void . forkIO . destroy + where + deleteView :: Int -> IntMap a -> Maybe (a, IntMap a) + deleteView k vs = (, vs') <$> fmap getFirst fv + where (vs', fv) = runWriter $ IntMap.alterF (\old -> Nothing <$ tell (First <$> old)) k vs + + +withResource :: forall b m a. MonadUnliftIO m => Pool m a -> (a -> m b) -> m b +withResource p act = bracketOnError (takeResource p) (releaseResource True p) (\x'@(x, _) -> act x <* releaseResource False p x') + +destroyResources :: MonadUnliftIO m => (a -> Bool) -> Pool m a -> m () +destroyResources p Pool{..} = do + toDestroy <- atomically . stateTVar resources $ \res@PoolResources{..} + -> let partitioned = partition p <$> available + toDel = foldMap fst partitioned + toKeep = IntMap.mapMaybe (\(_, toKeep') -> toKeep' <$ guard (not $ null toKeep')) partitioned + in (toDel, ) res + { availableCount = availableCount - length toDel + , available = toKeep + } + + forM_ toDestroy $ void . forkIO . destroy diff --git a/src/Web/ServerSession/Backend/Persistent/Memcached.hs b/src/Web/ServerSession/Backend/Persistent/Memcached.hs index b2a56a396..9b6753ce7 100644 --- a/src/Web/ServerSession/Backend/Persistent/Memcached.hs +++ b/src/Web/ServerSession/Backend/Persistent/Memcached.hs @@ -14,7 +14,7 @@ import Utils.Lens import Web.ServerSession.Core -import Database.Persist.Sql (ConnectionPool, runSqlPool) +import qualified Utils.Pool as Custom import qualified Data.Binary as Binary @@ -46,7 +46,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateMemcachedSqlStorage"] data MemcachedSqlStorage sess = MemcachedSqlStorage - { mcdSqlConnPool :: ConnectionPool + { mcdSqlConnPool :: forall m. MonadIO m => Custom.Pool m SqlBackend , mcdSqlMemcached :: Memcached.Connection , mcdSqlMemcachedKey :: AEAD.Key , mcdSqlMemcachedExpiration :: Maybe NominalDiffTime @@ -108,7 +108,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql type SessionData (MemcachedSqlStorage sess) = sess type TransactionM (MemcachedSqlStorage sess) = SqlPersistT IO - runTransactionM MemcachedSqlStorage{..} = flip runSqlPool mcdSqlConnPool + runTransactionM MemcachedSqlStorage{..} = flip customRunSqlPool mcdSqlConnPool getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do encSession <- catchIfExceptT (const Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached diff --git a/test/Database.hs b/test/Database.hs index 87f85aa84..72fe69707 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -7,8 +7,6 @@ module Database import "uniworx" Import hiding (Option(..), getArgs) import "uniworx" Application (db', getAppSettings) -import UnliftIO.Pool (destroyAllResources) - import Database.Persist.Postgresql import Control.Monad.Logger @@ -21,6 +19,8 @@ import Database.Persist.Sql.Raw.QQ import Database.Fill (fillDb) +import qualified Utils.Pool as Custom + data DBAction = DBClear | DBTruncate @@ -48,7 +48,7 @@ main = do [executeQQ|drop owned by current_user|] :: ReaderT SqlBackend _ () DBTruncate -> db' $ do foundation <- getYesod - liftIO . destroyAllResources $ appDatabaseConnPool foundation + Custom.purgePool $ appConnPool foundation truncateDb DBMigrate -> db' $ return () DBFill -> db' $ fillDb diff --git a/test/TestImport.hs b/test/TestImport.hs index 3cd9539d4..be362d41d 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -13,7 +13,6 @@ import ClassyPrelude as X ) import Database.Persist as X hiding (get) import Database.Persist.Sql as X (SqlPersistM) -import Database.Persist.Sql (runSqlPersistMPool) import Foundation as X import Model as X import Test.Hspec as X @@ -71,6 +70,9 @@ import Utils.Parameters (GlobalPostParam(PostLoginDummy)) import Control.Monad.Morph as X (generalize) +import Control.Monad.Logger (runNoLoggingT) +import Utils.DB (customRunSqlPool) + runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do @@ -78,7 +80,7 @@ runDB query = do liftIO $ runDBWithApp app query runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a -runDBWithApp app query = liftIO $ runSqlPersistMPool query (appDatabaseConnPool app) +runDBWithApp app query = liftIO . runResourceT . runNoLoggingT . customRunSqlPool query $ appConnPool app runHandler :: Handler a -> YesodExample UniWorX a runHandler handler = do From 4025b49c88cb11379caa12615d0697d4f08a7ec3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Feb 2021 16:45:42 +0100 Subject: [PATCH 016/514] chore(release): 24.7.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 cf10961cc..f4a562d14 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. +## [24.7.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.6.0...v24.7.0) (2021-02-23) + + +### Features + +* **db:** provide our own implementation of connection pooling ([50fdcb4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/50fdcb4540e6bfbc8da9ed10ed06d6f6ce443cf9)) + ## [24.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v24.5.0...v24.6.0) (2021-02-21) diff --git a/package-lock.json b/package-lock.json index a2fc39acf..2b2c3e055 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.6.0", + "version": "24.7.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index f426ae4ef..900bc3b42 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "24.6.0", + "version": "24.7.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 13d1c6611..d91aaf4ab 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 24.6.0 +version: 24.7.0 dependencies: - base - yesod From 0e92d71b310e25d73261e82829d47b32c9127c94 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Feb 2021 19:18:19 +0100 Subject: [PATCH 017/514] style: fix metrics label display --- templates/metrics.hamlet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/metrics.hamlet b/templates/metrics.hamlet index 096c6c0d7..bfd61c0b8 100644 --- a/templates/metrics.hamlet +++ b/templates/metrics.hamlet @@ -21,7 +21,7 @@ $maybe t <- metricsBearer $case lPairs $of [] $of _ -