module Database.Migrate.PostgreSQL (
psqlMain
, migrate
) where
import Control.Lens ((^.))
import Control.Monad (void, forM_)
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import qualified Data.Set as S
import Data.String (IsString(..))
import Data.Text hiding (length, foldr, filter)
import Data.Time
import Database.PostgreSQL.Simple
import Database.Migrate.Migration
import System.IO
import System.FilePath
data DbRead = DbRead { getConnection :: Connection, getDbName :: DbName, getBase :: FilePath }
type DbName = Text
type Db a = ReaderT DbRead IO a
psqlMain :: IO ()
psqlMain = putStrLn "hello"
migrate :: DbName -> Connection -> FilePath -> [Migration] -> IO ()
migrate n c b migrations =
runReaderT (run_ history >> run_ versions >> migrate' migrations) (DbRead c n b)
migrate' :: [Migration] -> Db ()
migrate' migrations = do
installed <- current
let nu = missing migrations installed
forM_ nu $ \m -> do
up m
liftIO . putStrLn $ "Installed <" ++ (unpack . _migrationId $ m) ++ ">"
history :: Query
history =
"CREATE TABLE IF NOT EXISTS migration_history (db VARCHAR(50), migration VARCHAR(50), action CHARACTER VARYING(20), at TIMESTAMPTZ, sql TEXT)"
versions :: Query
versions =
"CREATE TABLE IF NOT EXISTS migration_versions (db VARCHAR(50), migration VARCHAR(50) PRIMARY KEY)"
install :: Query
install =
"INSERT INTO migration_versions (db, migration) VALUES (?, ?)"
uninstall :: Query
uninstall =
"DELETE FROM migration_versions (db, migration) WHERE db = ? AND migration = ?"
addhistory :: Query
addhistory =
"INSERT INTO migration_history (db, migration, action, at, sql) VALUES (?, ?, ?, ?, ?)"
currentversions :: Query
currentversions =
"SELECT migration FROM migration_versions WHERE db = ?"
current :: Db [MigrationId]
current = do
n <- ask >>= return . getDbName
unonly $ list currentversions (Only n)
up :: Migration -> Db ()
up =
change "up" _upChange
down :: Migration -> Db ()
down =
change "down" _downChange
change :: Text -> (Migration -> Change) -> Migration -> Db ()
change mode getChange m = do
t <- now
n <- ask >>= return . getDbName
ch <- raw . getChange $ m
run addhistory (n, m^.migrationId, mode, t, ch)
run install (n, m^.migrationId)
run_ . mkquery $ ch
run :: ToRow a => Query -> a -> Db ()
run q a = do
c <- ask >>= return . getConnection
liftIO . void $ execute c q a
run_ :: Query -> Db ()
run_ q = do
c <- ask >>= return . getConnection
liftIO . void $ execute_ c q
list :: (ToRow a, FromRow b) => Query -> a -> Db [b]
list q a = do
c <- ask >>= return . getConnection
liftIO $ query c q a
now :: Db UTCTime
now = liftIO getCurrentTime
mkquery :: Text -> Query
mkquery = fromString . unpack
raw :: Change -> Db Text
raw (Ddl q) = return q
raw (Dud msg) = error . unpack $ msg
raw NoOp = return "select true;"
raw (DdlFile q) = do
b <- ask >>= return . getBase
liftIO $ readFile' (b </> q) >>= return . pack
readFile' :: FilePath -> IO String
readFile' p = withFile p ReadMode hGetContents'
hGetContents' :: Handle -> IO String
hGetContents' h = hGetContents h >>= \s -> length s `seq` return s
unonly :: Db [Only a] -> Db [a]
unonly = fmap (fmap (\(Only a) -> a))
missing :: [Migration] -> [MigrationId] -> [Migration]
missing migrations applied =
let available = foldr (S.insert . _migrationId) S.empty migrations
installed = S.fromList applied
torun = S.difference available installed
in filter (\m -> S.member (_migrationId m) torun) migrations