From e80f7d7a89e205ce53a70178e0b44d9b0ddf5b97 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 7 Sep 2020 15:03:40 +0200 Subject: [PATCH] feat(files): avoid initial unnecessary rechunking --- src/Application.hs | 16 +++++++++------- src/Import.hs | 1 + src/Import/NoFoundation.hs | 1 - src/Model/Migration.hs | 20 +++++++++++++++++--- 4 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 490040eed..d4dd082fb 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -227,13 +227,15 @@ makeFoundation appSettings'@AppSettings{..} = do forM_ ldapPool $ registerFailoverMetrics "ldap" -- Perform database migration using our application's logging settings. - if - | appAutoDbMigrate -> do - $logDebugS "setup" "Migration" - migrateAll `runSqlPool` sqlPool - | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do - $logErrorS "setup" "Migration required" - liftIO . exitWith $ ExitFailure 2 + flip runReaderT tempFoundation $ + if + | appAutoDbMigrate -> do + $logDebugS "setup" "Migration" + migrateAll `runSqlPool` sqlPool + | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do + $logErrorS "setup" "Migration required" + liftIO . exitWith $ ExitFailure 2 + $logDebugS "setup" "Cluster-Config" appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool diff --git a/src/Import.hs b/src/Import.hs index b387f44ad..b18a9fe1e 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -4,6 +4,7 @@ module Import import Foundation as Import import Import.NoFoundation as Import +import Model.Migration as Import import Utils.SystemMessage as Import import Utils.Metrics as Import diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 0fdedc192..b86de7350 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -4,7 +4,6 @@ module Import.NoFoundation import Import.NoModel as Import import Model as Import -import Model.Migration as Import import Model.Rating as Import import Model.Submission as Import import Model.Tokens as Import diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 519944cc4..115cdddc3 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -7,6 +7,8 @@ module Model.Migration import Import.NoModel hiding (Max(..), Last(..)) import Model +import Settings +import Foundation.Type import Jobs.Types import Audit.Types import Model.Migration.Version @@ -40,6 +42,8 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Aeson as Aeson import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage) + +import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize)) -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) @@ -80,6 +84,7 @@ migrateAll' = sequence_ migrateAll :: ( MonadLogger m , MonadResource m , MonadUnliftIO m + , MonadReader UniWorX m ) => ReaderT SqlBackend m () migrateAll = do @@ -112,7 +117,7 @@ requiresMigration = mapReaderT (exceptT return return) $ do $logInfoS "Migration" $ intercalate "; " initial throwError True - customs <- mapReaderT lift $ getMissingMigrations @_ @m + customs <- mapReaderT lift $ getMissingMigrations @_ @(ReaderT UniWorX m) unless (Map.null customs) $ do $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs throwError True @@ -134,6 +139,7 @@ getMissingMigrations :: forall m m'. ( MonadLogger m , MonadIO m , MonadResource m' + , MonadReader UniWorX m' ) => ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ())) getMissingMigrations = do @@ -180,7 +186,9 @@ migrateManual = do -} customMigrations :: forall m. - MonadResource m + ( MonadResource m + , MonadReader UniWorX m + ) => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) customMigrations = Map.fromListWith (>>) [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|] @@ -923,14 +931,20 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|40.0.0|] [version|41.0.0|] - , whenM (tableExists "file_content") $ + , whenM (tableExists "file_content") $ do + chunkingParams <- lift $ view _appFileChunkingParams + [executeQQ| ALTER TABLE file_content RENAME TO file_content_chunk; + ALTER INDEX file_content_pkey RENAME TO file_content_chunk_pkey; CREATE TABLE file_content_chunk_unreferenced (id bigserial, hash bytea NOT NULL, since timestamp with time zone NOT NULL); INSERT INTO file_content_chunk_unreferenced (since, hash) (SELECT unreferenced_since as since, hash FROM file_content_chunk WHERE NOT (unreferenced_since IS NULL)); ALTER TABLE file_content_chunk DROP COLUMN unreferenced_since; + 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); INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk); |]