module Database.PostgreSQL.Simple.Migration
(
runMigration
, runMigrations
, sequenceMigrations
, MigrationContext(..)
, MigrationCommand(..)
, MigrationResult(..)
, ScriptName
, Checksum
, getMigrations
, SchemaMigration(..)
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Monad (void, when)
import qualified Crypto.Hash.MD5 as MD5 (hash)
import qualified Data.ByteString as BS (ByteString, readFile)
import qualified Data.ByteString.Base64 as B64 (encode)
import Data.Foldable (Foldable)
import Data.List (isPrefixOf, sort)
import Data.Traversable (Traversable)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid (..))
#endif
import Data.Time (LocalTime)
import Database.PostgreSQL.Simple (Connection, Only (..),
execute, execute_, query,
query_)
import Database.PostgreSQL.Simple.FromRow (FromRow (..), field)
import Database.PostgreSQL.Simple.ToField (ToField (..))
import Database.PostgreSQL.Simple.ToRow (ToRow (..))
import Database.PostgreSQL.Simple.Types (Query (..))
import Database.PostgreSQL.Simple.Util (existsTable)
import System.Directory (getDirectoryContents)
runMigration :: MigrationContext -> IO (MigrationResult String)
runMigration (MigrationContext cmd verbose con) = case cmd of
MigrationInitialization ->
initializeSchema con verbose >> return MigrationSuccess
MigrationDirectory path ->
executeDirectoryMigration con verbose path
MigrationScript name contents ->
executeMigration con verbose name contents
MigrationFile name path ->
executeMigration con verbose name =<< BS.readFile path
MigrationValidation validationCmd ->
executeValidation con verbose validationCmd
MigrationCommands commands ->
runMigrations verbose con commands
runMigrations
:: Bool
-> Connection
-> [MigrationCommand]
-> IO (MigrationResult String)
runMigrations verbose con commands =
sequenceMigrations [runMigration (MigrationContext c verbose con) | c <- commands]
sequenceMigrations :: Monad m => [m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations = \case
[] -> return MigrationSuccess
c:cs -> do
r <- c
case r of
MigrationError s -> return (MigrationError s)
MigrationSuccess -> sequenceMigrations cs
executeDirectoryMigration :: Connection -> Bool -> FilePath -> IO (MigrationResult String)
executeDirectoryMigration con verbose dir =
scriptsInDirectory dir >>= go
where
go fs = sequenceMigrations (executeMigrationFile <$> fs)
executeMigrationFile f = executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f)
scriptsInDirectory :: FilePath -> IO [String]
scriptsInDirectory dir =
fmap (sort . filter (\x -> not $ "." `isPrefixOf` x))
(getDirectoryContents dir)
executeMigration :: Connection -> Bool -> ScriptName -> BS.ByteString -> IO (MigrationResult String)
executeMigration con verbose name contents = do
let checksum = md5Hash contents
checkScript con name checksum >>= \case
ScriptOk -> do
when verbose $ putStrLn $ "Ok:\t" ++ name
return MigrationSuccess
ScriptNotExecuted -> do
void $ execute_ con (Query contents)
void $ execute con q (name, checksum)
when verbose $ putStrLn $ "Execute:\t" ++ name
return MigrationSuccess
ScriptModified _ -> do
when verbose $ putStrLn $ "Fail:\t" ++ name
return (MigrationError name)
where
q = "insert into schema_migrations(filename, checksum) values(?, ?)"
initializeSchema :: Connection -> Bool -> IO ()
initializeSchema con verbose = do
when verbose $ putStrLn "Initializing schema"
void $ execute_ con $ mconcat
[ "create table if not exists schema_migrations "
, "( filename varchar(512) not null"
, ", checksum varchar(32) not null"
, ", executed_at timestamp without time zone not null default now() "
, ");"
]
executeValidation :: Connection -> Bool -> MigrationCommand -> IO (MigrationResult String)
executeValidation con verbose cmd = case cmd of
MigrationInitialization ->
existsTable con "schema_migrations" >>= \r -> return $ if r
then MigrationSuccess
else MigrationError "No such table: schema_migrations"
MigrationDirectory path ->
scriptsInDirectory path >>= goScripts path
MigrationScript name contents ->
validate name contents
MigrationFile name path ->
validate name =<< BS.readFile path
MigrationValidation _ ->
return MigrationSuccess
MigrationCommands cs ->
sequenceMigrations (executeValidation con verbose <$> cs)
where
validate name contents =
checkScript con name (md5Hash contents) >>= \case
ScriptOk -> do
when verbose $ putStrLn $ "Ok:\t" ++ name
return MigrationSuccess
ScriptNotExecuted -> do
when verbose $ putStrLn $ "Missing:\t" ++ name
return (MigrationError $ "Missing: " ++ name)
ScriptModified _ -> do
when verbose $ putStrLn $ "Checksum mismatch:\t" ++ name
return (MigrationError $ "Checksum mismatch: " ++ name)
goScripts path xs = sequenceMigrations (goScript path <$> xs)
goScript path x = validate x =<< BS.readFile (path ++ "/" ++ x)
checkScript :: Connection -> ScriptName -> Checksum -> IO CheckScriptResult
checkScript con name checksum =
query con q (Only name) >>= \case
[] ->
return ScriptNotExecuted
Only actualChecksum:_ | checksum == actualChecksum ->
return ScriptOk
Only actualChecksum:_ ->
return (ScriptModified actualChecksum)
where
q = mconcat
[ "select checksum from schema_migrations "
, "where filename = ? limit 1"
]
md5Hash :: BS.ByteString -> Checksum
md5Hash = B64.encode . MD5.hash
type Checksum = BS.ByteString
type ScriptName = String
data MigrationCommand
= MigrationInitialization
| MigrationDirectory FilePath
| MigrationFile ScriptName FilePath
| MigrationScript ScriptName BS.ByteString
| MigrationValidation MigrationCommand
| MigrationCommands [MigrationCommand]
deriving (Show, Eq, Read, Ord)
instance Monoid MigrationCommand where
mempty = MigrationCommands []
mappend (MigrationCommands xs) (MigrationCommands ys) = MigrationCommands (xs ++ ys)
mappend (MigrationCommands xs) y = MigrationCommands (xs ++ [y])
mappend x (MigrationCommands ys) = MigrationCommands (x : ys)
mappend x y = MigrationCommands [x, y]
data CheckScriptResult
= ScriptOk
| ScriptModified Checksum
| ScriptNotExecuted
deriving (Show, Eq, Read, Ord)
data MigrationResult a
= MigrationError a
| MigrationSuccess
deriving (Show, Eq, Read, Ord, Functor, Foldable, Traversable)
data MigrationContext = MigrationContext
{ migrationContextCommand :: MigrationCommand
, migrationContextVerbose :: Bool
, migrationContextConnection :: Connection
}
getMigrations :: Connection -> IO [SchemaMigration]
getMigrations = flip query_ q
where q = mconcat
[ "select filename, checksum, executed_at "
, "from schema_migrations order by executed_at asc"
]
data SchemaMigration = SchemaMigration
{ schemaMigrationName :: BS.ByteString
, schemaMigrationChecksum :: Checksum
, schemaMigrationExecutedAt :: LocalTime
} deriving (Show, Eq, Read)
instance Ord SchemaMigration where
compare (SchemaMigration nameLeft _ _) (SchemaMigration nameRight _ _) =
compare nameLeft nameRight
instance FromRow SchemaMigration where
fromRow = SchemaMigration <$>
field <*> field <*> field
instance ToRow SchemaMigration where
toRow (SchemaMigration name checksum executedAt) =
[toField name, toField checksum, toField executedAt]