Use jtdaugherty/dbmigrations to upgrade the DB at app startup

Util.Migration.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Util.Migration (upgradeDatabase) where

import qualified Util.Config                           as Config

import           Control.Monad                         (forM_)
import           Database.Schema.Migrations
import           Database.Schema.Migrations.Backend
import           Database.Schema.Migrations.Filesystem (FilesystemStoreSettings (..),
                                                        filesystemStore)
import           Database.Schema.Migrations.Store      (loadMigrations)
import qualified Moo.CommandUtils                      as MooUtils
import qualified Moo.Core                              as MooCore
import           System.Exit                           (exitFailure)


upgradeDatabase :: Config.DbConfig -> IO ()
upgradeDatabase dbConfig = do
  dbMigrationsConfig <- MooCore.loadConfiguration Nothing
  case dbMigrationsConfig of
       Left err -> putStrLn err >> exitFailure
       Right configuration -> upgradeWithConfig dbConfig configuration


upgradeWithConfig :: Config.DbConfig -> MooCore.Configuration -> IO ()
upgradeWithConfig dbConfig dbMigrationsConfig = do
  let migrationsPath :: FilePath =
        MooCore._migrationStorePath dbMigrationsConfig
      store = filesystemStore $ FSStore { storePath = migrationsPath }
      dbConnDescriptor = MooCore.DbConnDescriptor
        ( "host="     ++ (Config.dbHost     dbConfig) ++ " " ++
          "dbname="   ++ (Config.db         dbConfig) ++ " " ++
          "user="     ++ (Config.dbUser     dbConfig) ++ " " ++
          "password=" ++ (Config.dbPassword dbConfig)
        )
  backend :: Backend <- MooUtils.makeBackend "postgresql" dbConnDescriptor
  loadedStoreData <- loadMigrations store
  case loadedStoreData of
       Left es -> do
         putStrLn "dbmigrations: There were errors in the migration store:"
         forM_ es $ \err -> putStrLn $ "  " ++ show err
         exitFailure
       Right storeData -> do
         ensureBootstrappedBackend backend >> commitBackend backend
         migrationNames <- missingMigrations backend storeData
         if (null migrationNames)
           then do
             putStrLn "dbmigrations: Database is up to date."
           else do
             forM_ migrationNames $ \migrationName -> do
                 m <- MooUtils.lookupMigration storeData migrationName
                 MooUtils.apply m storeData backend False
             commitBackend backend
             putStrLn "dbmigrations: Database successfully upgraded."