{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hasql.Migration
(
runMigration
, loadMigrationFromFile
, loadMigrationsFromDirectory
, MigrationCommand(..)
, MigrationError(..)
, ScriptName
, Checksum
, getMigrations
, SchemaMigration(..)
) where
import Crypto.Hash (hashWith, MD5(..))
import Data.ByteArray.Encoding
import Data.Functor.Contravariant
import Data.List (isPrefixOf, sort)
import Data.Time (LocalTime)
import Data.Traversable (forM)
import Hasql.Migration.Util (existsTable)
import Hasql.Statement
import Hasql.Transaction
import System.Directory (getDirectoryContents)
import Data.Semigroup ((<>))
import qualified Data.ByteString as BS (ByteString, readFile)
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 (Maybe MigrationError)
runMigration cmd = case cmd of
MigrationInitialization ->
initializeSchema >> return Nothing
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 (Maybe MigrationError)
executeMigration name contents = do
let checksum = md5Hash contents
checkScript name checksum >>= \case
ScriptOk -> do
return Nothing
ScriptNotExecuted -> do
sql contents
statement (name, checksum) (Statement q enc Decoders.noResult False)
return Nothing
ScriptModified _ -> do
return (Just $ ScriptChanged name)
where
q = "insert into schema_migrations(filename, checksum) values($1, $2)"
enc = ((T.pack . fst) >$< Encoders.param (Encoders.nonNullable Encoders.text)) <> (snd >$< Encoders.param (Encoders.nonNullable Encoders.text))
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 (Maybe MigrationError)
executeValidation cmd = case cmd of
MigrationInitialization ->
existsTable "schema_migrations" >>= \r -> return $ if r
then Nothing
else (Just NotInitialised)
MigrationScript name contents ->
validate name contents
MigrationValidation _ ->
return Nothing
where
validate name contents =
checkScript name (md5Hash contents) >>= \case
ScriptOk -> do
return Nothing
ScriptNotExecuted -> do
return (Just $ ScriptMissing name)
ScriptModified _ -> do
return (Just $ ChecksumMismatch name)
checkScript :: ScriptName -> Checksum -> Transaction CheckScriptResult
checkScript name checksum =
statement name (Statement q (contramap T.pack (Encoders.param (Encoders.nonNullable Encoders.text)))
(Decoders.rowMaybe (Decoders.column (Decoders.nonNullable Decoders.text))) 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 . convertToBase Base64 . hashWith MD5
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 MigrationError = ScriptChanged String | NotInitialised | ScriptMissing String | ChecksumMismatch String deriving (Show, Eq, Read, Ord)
getMigrations :: Transaction [SchemaMigration]
getMigrations =
statement () $ Statement q Encoders.noParams (Decoders.rowList 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.column (Decoders.nonNullable Decoders.bytea)
<*> Decoders.column (Decoders.nonNullable Decoders.text)
<*> Decoders.column (Decoders.nonNullable Decoders.timestamp)