module Genesis.Persist.Migrate (runMigrations, runMigrations') where
import qualified Data.Text.IO as T
import Control.Monad (filterM, forM, forM_, unless, when)
import Control.Monad.Logger (MonadLogger, logDebugNS, logInfoNS)
import Control.Monad.Persist (MonadSqlPersist, insert_, rawExecute, runMigrationSilent, selectList, transactionSave)
import System.Directory (doesDirectoryExist, doesFileExist, doesPathExist, listDirectory)
import System.FilePath ((</>))
import Data.FileEmbed (makeRelativeToProject)
import Data.List (isSuffixOf, sort)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Conversions (toText)
import Database.Persist.Sql (Entity(..))
import Database.Persist.TH (share, mkPersist, sqlSettings, mkMigrate, persistLowerCase)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
share [mkPersist sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase|
SchemaMigration
name FilePath
deriving Eq Show
|]
runMigrations :: FilePath -> Q Exp
runMigrations dir = do
migrationsDir <- makeRelativeToProject dir
migrationsDirExists <- runIO $ doesPathExist migrationsDir
unless migrationsDirExists $
fail $ "No such directory ‘" ++ dir ++ "’ exists at root of project.\n (Looking at ‘" ++ migrationsDir ++ "’)."
migrationsDirIsDir <- runIO $ doesDirectoryExist migrationsDir
unless migrationsDirIsDir $
fail $ "The file at ‘" ++ dir ++ "’ in root of project is not a directory.\n (Looking at ‘" ++ migrationsDir ++ "’)."
allFiles <- runIO $ listDirectory migrationsDir
nonDirectoryFiles <- runIO $ filterM (doesFileExist . (migrationsDir </>)) allFiles
let migrationFiles = sort $ filter (isSuffixOf ".sql") nonDirectoryFiles
forM_ migrationFiles (addDependentFile . (migrationsDir </>))
when (null migrationFiles) $
reportWarning $ "No migrations (files ending in .sql) in ‘" ++ dir ++ "’ at root of project.\n (Looking in ‘" ++ migrationsDir ++ "’.)\n"
migrations <- runIO $ forM migrationFiles $ \path -> (path,) <$> T.readFile (migrationsDir </> path)
[| runMigrations' migrations |]
runMigrations' :: (MonadLogger m, MonadSqlPersist m) => [(FilePath, Text)] -> m ()
runMigrations' allMigrations = do
messages <- runMigrationSilent migrateSchema
forM_ messages (logDebugNS "SQL")
transactionSave
existingMigrations <- map (schemaMigrationName . entityVal) <$> selectList [] []
let newMigrations = filter (\(path, _) -> path `notElem` existingMigrations) allMigrations
forM_ newMigrations $ \(path, sql) -> do
logInfoNS "migrate" $ "migrating ‘" <> toText path <> "’"
rawExecute sql []
insert_ (SchemaMigration path)
transactionSave