diff --git a/config/models b/config/models
index 7346f03..e4ffe6d 100644
--- a/config/models
+++ b/config/models
@@ -12,6 +12,13 @@
-- with this software. If not, see
-- .
+-------------------------------------------------------------------------------
+-- Meta
+-------------------------------------------------------------------------------
+
+SchemaVersion
+ number Int
+
-------------------------------------------------------------------------------
-- People
-------------------------------------------------------------------------------
diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs
index b95b96c..f538c80 100644
--- a/src/Vervis/Application.hs
+++ b/src/Vervis/Application.hs
@@ -65,6 +65,7 @@ import Vervis.Handler.Ticket
import Vervis.Handler.Wiki
import Vervis.Handler.Workflow
+import Vervis.Migration (migrateDB)
import Vervis.Ssh (runSsh)
-- This line actually creates our YesodDispatch instance. It is the second half
@@ -107,7 +108,8 @@ makeFoundation appSettings = do
(pgPoolSize $ appDatabaseConf appSettings)
-- Perform database migration using our application's logging settings.
- runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
+ --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
+ runLoggingT (runSqlPool migrateDB pool) logFunc
-- Return the foundation
return $ mkFoundation pool
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
new file mode 100644
index 0000000..c341b9e
--- /dev/null
+++ b/src/Vervis/Migration.hs
@@ -0,0 +1,71 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover .
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - .
+ -}
+
+module Vervis.Migration
+ ( migrateDB
+ )
+where
+
+import Prelude
+
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Reader (ReaderT, runReaderT)
+import Data.Maybe (fromMaybe)
+import Database.Persist
+import Database.Persist.Sql (SqlBackend, toSqlKey)
+
+import Database.Persist.Schema
+import Database.Persist.Schema.PostgreSQL (schemaBackend)
+
+import Vervis.Model
+
+key :: SchemaVersionId
+key = toSqlKey 1
+
+getDbSchemaVersion :: MonadIO m => ReaderT SqlBackend m (Maybe Int)
+getDbSchemaVersion = fmap schemaVersionNumber <$> get key
+
+setDbSchemaVersion :: MonadIO m => Int -> ReaderT SqlBackend m ()
+setDbSchemaVersion v = update key [SchemaVersionNumber =. v]
+
+-- | Run the migration system. The second parameter is the list of migration
+-- actions in chronological order. The migration process is:
+--
+-- * Check the schema version of the DB
+-- * Compare to the schema version of the app, which is the length of the list
+-- * If any migrations are required, run them
+-- * Update the schema version in the DB
+runMigrations
+ :: MonadIO m
+ => SchemaBackend SqlBackend
+ -> [SchemaT SqlBackend m ()]
+ -> ReaderT SqlBackend m ()
+runMigrations sb migrations = do
+ dver <- fromMaybe 0 <$> getDbSchemaVersion
+ let aver = length migrations
+ if aver < dver
+ then error "Older app version running with newer DB schema version"
+ else do
+ let migs = drop dver migrations
+ runReaderT (sequence migs) sb
+ setDbSchemaVersion aver
+
+changes :: MonadIO m => [SchemaT SqlBackend m ()]
+changes =
+ [
+ ]
+
+migrateDB :: MonadIO m => ReaderT SqlBackend m ()
+migrateDB = runMigrations schemaBackend changes
diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs
index 67dc083..8f22ac9 100644
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@@ -35,7 +35,7 @@ import Vervis.Model.Workflow
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities at:
-- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings, mkMigrate "migrateAll"]
+share [mkPersist sqlSettings{-, mkMigrate "migrateAll"-}]
$(persistFileWith lowerCaseSettings "config/models")
instance HashDBUser Person where
diff --git a/vervis.cabal b/vervis.cabal
index f8dedf1..78c26ad 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -146,6 +146,7 @@ library
Vervis.Import
Vervis.Import.NoFoundation
Vervis.MediaType
+ Vervis.Migration
Vervis.Model
Vervis.Model.Entity
Vervis.Model.Group