From dc74456a6aff5f2d0abe8f906d4f5ef0b8511417 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Wed, 31 Aug 2016 16:51:02 +0000
Subject: [PATCH] Use the new migration system in place of persistent's one

---
 config/models             |  7 ++++
 src/Vervis/Application.hs |  4 ++-
 src/Vervis/Migration.hs   | 71 +++++++++++++++++++++++++++++++++++++++
 src/Vervis/Model.hs       |  2 +-
 vervis.cabal              |  1 +
 5 files changed, 83 insertions(+), 2 deletions(-)
 create mode 100644 src/Vervis/Migration.hs

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
 -- <http://creativecommons.org/publicdomain/zero/1.0/>.
 
+-------------------------------------------------------------------------------
+-- 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 <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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