module Hasql.Migration
(
runMigration
, loadMigrationFromFile
, loadMigrationsFromDirectory
, MigrationCommand(..)
, MigrationResult(..)
, ScriptName
, Checksum
, getMigrations
, SchemaMigration(..)
) where
import Control.Arrow
import Control.Applicative
import Data.Default.Class
import Data.Functor.Contravariant
import Data.List (isPrefixOf, sort)
import Data.Monoid
import Data.Traversable (forM)
import Data.Time (LocalTime)
import Hasql.Migration.Util (existsTable)
import Hasql.Query
import Hasql.Transaction
import System.Directory (getDirectoryContents)
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 qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Encoders as Encoders
runMigration :: MigrationCommand -> Transaction (MigrationResult String)
runMigration cmd = case cmd of
MigrationInitialization ->
initializeSchema >> return MigrationSuccess
MigrationScript name contents ->
executeMigration name contents
MigrationValidation validationCmd ->
executeValidation validationCmd
loadMigrationsFromDirectory :: FilePath -> IO [MigrationCommand]
loadMigrationsFromDirectory dir = do
scripts <- scriptsInDirectory dir
forM scripts $ \f -> loadMigrationFromFile f (dir ++ "/" ++ f)
loadMigrationFromFile :: ScriptName -> FilePath -> IO MigrationCommand
loadMigrationFromFile name fp =
MigrationScript name <$> BS.readFile fp
scriptsInDirectory :: FilePath -> IO [String]
scriptsInDirectory dir =
fmap (sort . filter (\x -> not $ "." `isPrefixOf` x))
(getDirectoryContents dir)
executeMigration :: ScriptName -> BS.ByteString -> Transaction (MigrationResult String)
executeMigration name contents = do
let checksum = md5Hash contents
checkScript name checksum >>= \case
ScriptOk -> do
return MigrationSuccess
ScriptNotExecuted -> do
sql contents
query (name, checksum) (statement q (contramap (first T.pack) def) Decoders.unit False)
return MigrationSuccess
ScriptModified _ -> do
return (MigrationError name)
where
q = "insert into schema_migrations(filename, checksum) values($1, $2)"
initializeSchema :: Transaction ()
initializeSchema = do
sql $ 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 :: MigrationCommand -> Transaction (MigrationResult String)
executeValidation cmd = case cmd of
MigrationInitialization ->
existsTable "schema_migrations" >>= \r -> return $ if r
then MigrationSuccess
else MigrationError "No such table: schema_migrations"
MigrationScript name contents ->
validate name contents
MigrationValidation _ ->
return MigrationSuccess
where
validate name contents =
checkScript name (md5Hash contents) >>= \case
ScriptOk -> do
return MigrationSuccess
ScriptNotExecuted -> do
return (MigrationError $ "Missing: " ++ name)
ScriptModified _ -> do
return (MigrationError $ "Checksum mismatch: " ++ name)
checkScript :: ScriptName -> Checksum -> Transaction CheckScriptResult
checkScript name checksum =
query name (statement q (contramap T.pack (Encoders.value def)) (Decoders.maybeRow (Decoders.value def)) False) >>= \case
Nothing ->
return ScriptNotExecuted
Just actualChecksum | checksum == actualChecksum ->
return ScriptOk
Just actualChecksum ->
return (ScriptModified actualChecksum)
where
q = mconcat
[ "select checksum from schema_migrations "
, "where filename = $1 limit 1"
]
md5Hash :: BS.ByteString -> Checksum
md5Hash = T.decodeUtf8 . B64.encode . MD5.hash
type Checksum = T.Text
type ScriptName = String
data MigrationCommand
= MigrationInitialization
| MigrationScript ScriptName BS.ByteString
| MigrationValidation MigrationCommand
deriving (Show, Eq, Read, Ord)
data CheckScriptResult
= ScriptOk
| ScriptModified Checksum
| ScriptNotExecuted
deriving (Show, Eq, Read, Ord)
data MigrationResult a
= MigrationError a
| MigrationSuccess
deriving (Show, Eq, Read, Ord)
getMigrations :: Transaction [SchemaMigration]
getMigrations =
query () $ statement q def (Decoders.rowsList decodeSchemaMigration) False
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
decodeSchemaMigration :: Decoders.Row SchemaMigration
decodeSchemaMigration =
SchemaMigration
<$> Decoders.value def
<*> Decoders.value def
<*> Decoders.value def