module Database.Migrate.Core where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Either
import qualified Data.Set as S
import Data.List (sort)
import Data.Text hiding (foldr, filter, reverse, length)
import System.FilePath
import System.Directory
import System.IO
data MigrationId =
MigrationId { extract :: Text } deriving (Eq, Show)
instance Ord MigrationId where
compare a b =
case (reads . unpack . extract $ a, reads . unpack . extract $ b) of
([(i :: Int, "")], [(j :: Int, "")]) -> compare i j
_ -> compare (extract a) (extract b)
type Ddl = Text
data Migration =
Migration {
migration :: MigrationId
, up :: Text
, down :: Text
, upsource :: Maybe FilePath
, downsource :: Maybe FilePath
} deriving (Eq, Show)
instance Ord Migration where
compare a b = compare (migration a) (migration b)
data Context = Context {
succeeded :: [MigrationId]
, failed :: MigrationId
, msg :: Text
, rolledback :: Bool
} deriving (Eq, Show)
type MigrationResultT = EitherT Context
class Monad m => MigrateDatabase m c where
initialize :: c -> m ()
runMigrations :: c -> (Migration -> Ddl) -> [Migration] -> MigrationResultT m [MigrationId]
getMigrations :: c -> m [MigrationId]
pick :: [Migration] -> [MigrationId] -> [Migration]
pick ms ids =
let available = foldr (S.insert . migration) S.empty ms
installed = S.fromList ids
torun = S.difference available installed
in filter (\m -> S.member (migration m) torun) ms
latest :: MigrateDatabase m c => c -> [Migration] -> MigrationResultT m [MigrationId]
latest c migrations =
lift (getMigrations c) >>= \installed -> runMigrations c up (pick migrations installed)
find :: FilePath -> EitherT String IO [Migration]
find b = liftIO (getDirectoryContents b) >>= \fs -> liftM sort (liftIO (migrationids b fs) >>=
mapM (\p ->
do downexists <- liftIO $ doesFileExist (b </> p <.> "down.sql")
unless downexists (left $ "no down.sql for migration [" ++ p ++ "]")
u <- liftIO . readFile $ b </> p <.> "up.sql"
d <- liftIO . readFile $ b </> p <.> "down.sql"
right (Migration (MigrationId . pack $ p) (pack u) (pack d) (Just $ b </> p <.> "up.sql") (Just $ b </> p <.> "down.sql"))))
migrationids :: FilePath -> [FilePath] -> IO [String]
migrationids b ps =
filterM (\p -> doesFileExist (b </> p)) ps >>= \files ->
((return . fmap dropExtensions)
(filter (\p -> takeExtensions p == ".up.sql") files))
readFile' :: FilePath -> IO String
readFile' p = withFile p ReadMode hGetContents
hGetContents' :: Handle -> IO String
hGetContents' h = hGetContents h >>= \s -> length s `seq` return s