database-migrate 0.1.2 → 0.2.0

raw patch · 13 files changed

+297/−371 lines, 13 filesdep +lensPVP ok

version bump matches the API change (PVP)

Dependencies added: lens

API changes (from Hackage documentation)

Files

• database-migrate.cabal +8/−5
• src/Database/Migrate.hs +1/−4
• src/Database/Migrate/Data.hs +0/−73
• src/Database/Migrate/Kernel.hs +0/−52
• src/Database/Migrate/Loader.hs +0/−35
• src/Database/Migrate/Main.hs +0/−128
• src/Database/Migrate/Migration.hs +25/−0
• src/Database/Migrate/Migration/Ddl.hs +21/−0
• src/Database/Migrate/Migration/Directory.hs +43/−0
• src/Database/Migrate/Migration/File.hs +19/−0
• src/Database/Migrate/Migration/FileInferred.hs +42/−0
• src/Database/Migrate/Migration/FileStandard.hs +21/−0
• src/Database/Migrate/PostgreSQL.hs +117/−74

@@ -1,5 +1,5 @@ Name:               database-migrate-Version:            0.1.2+Version:            0.2.0 License:            BSD3 License-File:       LICENSE Author:             Mark Hibberd <mark@hibberd.id.au>@@ -40,6 +40,7 @@                     , either                        >= 3.0.2                     , transformers                  >= 0.2                     , cmdargs                       >= 0.9.3+                    , lens                          >= 3.9.0.2    GHC-Options:                     -Wall -fno-warn-orphans@@ -49,8 +50,10 @@    Exposed-Modules:                     Database.Migrate-                    Database.Migrate.Data-                    Database.Migrate.Kernel-                    Database.Migrate.Loader-                    Database.Migrate.Main                     Database.Migrate.PostgreSQL+                    Database.Migrate.Migration+                    Database.Migrate.Migration.Ddl+                    Database.Migrate.Migration.Directory+                    Database.Migrate.Migration.File+                    Database.Migrate.Migration.FileStandard+                    Database.Migrate.Migration.FileInferred

@@ -16,8 +16,5 @@ -- module Database.Migrate (module X) where -import Database.Migrate.Data as X-import Database.Migrate.Kernel as X-import Database.Migrate.Loader as X-import Database.Migrate.Main as X+import Database.Migrate.Migration as X import Database.Migrate.PostgreSQL as X

@@ -1,73 +0,0 @@-{-#LANGUAGE RankNTypes, ScopedTypeVariables #-}-module Database.Migrate.Data where--import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Maybe--import Data.Text hiding (foldr, filter, reverse, length)--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)--data MigrationLog =-    DatabaseInitialized-  | MigrationApplied Migration-  | MigrationFailed Migration String-  | MigrationRolledback Migration String-  deriving (Eq, Show)--data Migration =-  Migration {-      migrationId :: MigrationId-    , up :: Text-    , down :: Text-    } deriving (Eq, Show)--instance Ord Migration where-  compare a b = compare (migrationId a) (migrationId b)--data MigrationRecords =-    NotInitialized-  | Initialized [MigrationId]---- FIX should not be a list, want to index and sort migrations-data Migrations =-  Migrations { getMigrations :: [Migration] }--data Migrate c m a =-  Migrate { runMigrate :: ReaderT (Migrations, c) (MaybeT (WriterT [MigrationLog] m)) a }---- FIX consider adding history--- FIX add reverse engineer to extract current schema-data MigrateDatabase m c =-  MigrateDatabase {-      current :: Migrate c m MigrationRecords-    , initialize :: Migrate c m ()-    , runSql :: Text -> Migrate c m ()-    , recordInstall :: Migration -> Migrate c m ()-    , recordRollback :: Migration -> Migrate c m ()-    }--instance Monad f => Functor (Migrate c f) where-  fmap f a = a >>= \a' -> return (f a')--instance Monad m => Monad (Migrate c m) where-  return a = Migrate $ return a-  m >>= f = Migrate $ do-    a <- runMigrate m-    runMigrate (f a)--instance MonadTrans (Migrate c) where-  lift = Migrate . lift . lift . lift--instance MonadIO m => MonadIO (Migrate c m) where-  liftIO = lift . liftIO

@@ -1,52 +0,0 @@-{-#LANGUAGE RankNTypes, ScopedTypeVariables #-}-module Database.Migrate.Kernel where--import Database.Migrate.Data--import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer--import qualified Data.Set as S-import Data.Functor--mlog :: Monad m => MigrationLog -> Migrate c m ()-mlog l = Migrate . lift . lift $ tell [l]--connection :: (Functor m, Monad m) => Migrate c m c-connection = Migrate $ fmap snd ask--store :: (Functor m, Monad m) => Migrate c m Migrations-store = Migrate $ fmap fst ask--dryrun :: Monad m => MigrateDatabase m c -> MigrateDatabase m c-dryrun db =-  MigrateDatabase {-      current = current db-    , initialize = return ()-    , runSql = \_ -> return ()-    , recordInstall = \_ -> return ()-    , recordRollback = \_ -> return ()-    }--migrate :: (Functor m, Monad m) => MigrateDatabase m c -> Migrate c m ()-migrate db =-  do records <- current db-     ms <- store-     migrations <- case records of-       NotInitialized -> getMigrations ms <$ (mlog DatabaseInitialized >> initialize db)-       Initialized mids -> return $ missing ms mids-     forM_ migrations (\m -> mlog (MigrationApplied m) >> (runSql db (up m) >> recordInstall db m))--missing :: Migrations -> [MigrationId] -> [Migration]-missing ms applied =-  let migrations = getMigrations ms-      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--executeMigrate :: Monad m => Migrations -> c -> Migrate c m a -> m (Maybe a, [MigrationLog])-executeMigrate = \ms c m -> runWriterT (runMaybeT (runReaderT (runMigrate m) (ms, c)))

@@ -1,35 +0,0 @@-module Database.Migrate.Loader where--import Database.Migrate.Data--import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Either--import Data.List (sort)-import Data.Text hiding (filter, length)--import System.FilePath-import System.Directory-import System.IO--find :: FilePath -> EitherT String IO Migrations-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) ))) >>= \ms -> return $ Migrations ms--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

@@ -1,128 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-module Database.Migrate.Main (defaultMain, defaultMain') where----import qualified Paths_database_migrate as Program (version)--import Control.Monad-import Control.Monad.Trans.Either-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Maybe--import qualified Data.Text as T-import Data.Maybe---import Data.Version (showVersion)--import Database.Migrate.Data-import Database.Migrate.Kernel-import Database.Migrate.Loader-import Database.Migrate.PostgreSQL--import qualified Database.PostgreSQL.Simple as PG--import System.Console.CmdArgs.Explicit-import System.Directory-import System.FilePath-import System.Exit-import System.Environment (getArgs)-import System.IO--ignore :: Arg Arguments-ignore = flagArg (\_ a -> Right a) ""--e :: String-e = ""--usage = [-    "usage: db migrate [-v|--verbose] [-d|--dry-run]"-  , "       db up [-v|--verbose] [-d|--dry-run]"-  , "       db down [-v|--verbose] [-d|--dry-run]"-  , "       db apply [-v|--verbose] [-d|--dry-run]"-  , "       db -h|--help"-  , "       db -V|--version"-  ]---globalflags :: [Flag Arguments]-globalflags = [-    flagNone [ "h", "help" ]     (\a -> a { adbmode = HelpMode })    e-  , flagNone [ "V", "version" ]  (\a -> a { adbmode = VersionMode }) e-  ]--connectflags :: [Flag Arguments]-connectflags = [-    flagNone [ "v", "verbose" ]    (\a -> a { averbose = True }) e-  , flagNone [ "d", "dry-run" ]    (\a -> a { adry = True }) e-  ]--versionflag = (flagArg (\v a -> Right $ a { aversion = Just v }) "VERSION")--cmdmodes :: String -> Arguments -> Mode Arguments-cmdmodes cmd initial =-  modes cmd initial "" [-      mode "migrate" (initial { adbmode = MigrateMode }) "" ignore connectflags-    , mode "up" (initial { adbmode = UpMode }) "" versionflag connectflags-    , mode "down" (initial { adbmode = DownMode }) "" versionflag connectflags-    , mode "apply" (initial { adbmode = ApplyMode }) "" versionflag connectflags-    , mode "help" (initial { adbmode = HelpMode }) "" ignore []-    , mode "version" (initial { adbmode = VersionMode }) "" ignore []-    ]--data DbMode =-    HelpMode-  | VersionMode-  | MigrateMode-  | UpMode-  | DownMode-  | ApplyMode-  deriving (Eq, Show)--data Arguments = Arguments {-    adbmode :: DbMode-  , adry :: Bool-  , averbose :: Bool-  , ascripts :: String-  , aversion :: Maybe String-  } deriving (Eq, Show)--defaultArguments cwd = Arguments {-    adbmode = HelpMode-  , adry = False-  , averbose = False-  , ascripts = cwd </> "migrations"-  , aversion = Nothing-  }--defaultMain :: Migrations -> MigrateDatabase IO c -> IO c -> IO ()-defaultMain migrationstore db connector = getArgs >>= defaultMain' migrationstore db connector--defaultMain' :: Migrations -> MigrateDatabase IO c -> IO c -> [String] -> IO ()-defaultMain' migrationstore db connector args =-  getCurrentDirectory >>= \cwd ->-    case process ((cmdmodes "migrate" (defaultArguments cwd)) {modeGroupFlags = toGroup $ globalflags} ) args of-      Left x ->  hPutStrLn stderr x >> exitFailure-      Right x -> run migrationstore db connector x--run :: Migrations -> MigrateDatabase IO c -> IO c -> Arguments -> IO ()-run migrationstore db' connector args =-  let db = if adry args then dryrun db' else db'-  in case adbmode args of-    HelpMode -> mapM_ putStrLn usage-    VersionMode -> putStrLn $ "migrate 0.1.1" -- ++ showVersion Program.version-    MigrateMode -> connector  >>= \c -> (executeMigrate migrationstore c $ migrate db) >>= print-    UpMode -> connector >>= \c -> (executeMigrate migrationstore c $ upmode db) >>= print-    DownMode -> connector >>= \c -> (executeMigrate migrationstore c $ downmode db) >>= print-    ApplyMode -> connector >>= \c -> (executeMigrate migrationstore c $ applymode db) >>= print--bomb failwith =-  putStrLn failwith >> exitFailure--upmode :: MigrateDatabase m c -> Migrate c m ()-upmode = undefined--downmode :: MigrateDatabase m c -> Migrate c m ()-downmode = undefined--applymode :: MigrateDatabase m c -> Migrate c m ()-applymode = undefined

@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell, LiberalTypeSynonyms #-}+module Database.Migrate.Migration where++import Data.Text+import Control.Lens++type MigrationId = Text++data Change =+    Ddl Text+  | DdlFile FilePath+  | Dud Text+  | NoOp+  deriving (Show, Eq)+-- TODO | AddTable Text TableDef+-- TODO | AddColumn Text Text ColumnDef+-- TODO | DropTable Text+-- TODO | DropColumn Text+-- TODO | AlterColumn Text Text ColumnDef+++data Migration =+    Migration { _migrationId :: MigrationId, _upChange :: Change, _downChange :: Change }++makeLenses ''Migration

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Migrate.Migration.Ddl (+  migration+, up+, down+) where++import Database.Migrate.Migration+import Data.Text++migration :: MigrationId -> Text -> Text -> Migration+migration mid up' down' =+  Migration mid (Ddl up') (Ddl down')++up :: MigrationId -> Text -> Migration+up mid up' =+  Migration mid (Ddl up') NoOp++down :: MigrationId -> Text -> Migration+down mid down' =+  Migration mid NoOp (Ddl down')

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Migrate.Migration.Directory (+  migration+) where++import           Control.Applicative ((<$>))+import           Data.List (isSuffixOf, intercalate, groupBy)+import           Data.Text (Text, pack)++import           Database.Migrate.Migration+import qualified Database.Migrate.Migration.FileInferred as File+import           System.FilePath+import           System.Directory++-- TODO support baselines as well as change files++migration :: FilePath -> IO (Either Text [Migration])+migration path =+  (mkmigration . filter isMigrationFile) <$> getDirectoryContents path++unsuffix :: FilePath -> FilePath+unsuffix =+  dropExtension . dropExtension++isMigrationFile :: FilePath -> Bool+isMigrationFile p =+  isSuffixOf ".up.sql" p || isSuffixOf ".down.sql" p++isUp :: FilePath -> Bool+isUp =+  isMigrationType "up"++isMigrationType :: String -> FilePath -> Bool+isMigrationType t p =+  (takeExtension . takeExtension $ p) == t++mkmigration :: [FilePath] -> Either Text [Migration]+mkmigration paths =+  mapM (\group -> case group of+    a : _ : [] -> Right . File.migration $ unsuffix a+    a : [] ->  Right $ (if isUp a then File.up else File.down) (unsuffix a)+    _ -> Left . pack $ "Duplicate prefix detected in: " ++ (intercalate "," group)+  ) (groupBy (\a b -> unsuffix a == unsuffix b) paths)

@@ -0,0 +1,19 @@+module Database.Migrate.Migration.File (+  migration+, up+, down+) where++import Database.Migrate.Migration++migration :: MigrationId -> FilePath -> FilePath -> Migration+migration mid up' down' =+  Migration mid (DdlFile up') (DdlFile down')++up :: MigrationId -> FilePath -> Migration+up mid up' =+  Migration mid (DdlFile up') NoOp++down :: MigrationId -> FilePath -> Migration+down mid down' =+  Migration mid NoOp (DdlFile down')

@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Migrate.Migration.FileInferred (+  migration+, up+, down+, directory+) where++import           Data.List (isSuffixOf, intercalate, groupBy)+import           Data.Text (Text, pack)++import           Database.Migrate.Migration+import qualified Database.Migrate.Migration.File         as File+import qualified Database.Migrate.Migration.FileStandard as FileStandard+import           System.FilePath+import           System.Directory++directory :: FilePath -> IO (Either Text [Migration])+directory path = do+  changes <- (filter (\p -> isSuffixOf ".up.sql" p || isSuffixOf ".down.sql" p)) `fmap` getDirectoryContents path+  return $ mapM (\group ->+    case group of+      a : _ : [] -> (Right $ migration (dropExtension . dropExtension $ a))+      a : [] -> (Right $ (if ((takeExtension . takeExtension $ a) == "up") then File.up else File.down) (infer a) a)+      _ -> (Left . pack $ "Duplicate prefix detected in: " ++ (intercalate "," group))+    ) $ groupBy (\a b -> (dropExtension . dropExtension $ a) == (dropExtension . dropExtension $ b)) changes++migration :: FilePath -> Migration+migration prefix =+  FileStandard.migration (infer prefix) prefix++up :: FilePath -> Migration+up prefix =+  FileStandard.up (infer prefix) prefix++down :: FilePath -> Migration+down prefix =+  FileStandard.down (infer prefix) prefix++infer :: FilePath -> MigrationId+infer =+  pack . dropExtensions . last . splitPath

@@ -0,0 +1,21 @@+module Database.Migrate.Migration.FileStandard (+  migration+, up+, down+) where++import           Database.Migrate.Migration+import qualified Database.Migrate.Migration.File as File+import           System.FilePath++migration :: MigrationId -> FilePath -> Migration+migration mid prefix =+  File.migration mid (prefix <.> "up.ddl") (prefix <.> "down.ddl")++up :: MigrationId -> FilePath -> Migration+up mid prefix =+  File.up mid (prefix <.> ".up.ddl")++down :: MigrationId -> FilePath -> Migration+down mid prefix =+  File.down mid (prefix <.> "down.ddl")

@@ -1,90 +1,133 @@-{-#LANGUAGE OverloadedStrings #-}-module Database.Migrate.PostgreSQL where+{-# LANGUAGE OverloadedStrings, LiberalTypeSynonyms #-}+module Database.Migrate.PostgreSQL (+  psqlMain+, migrate+) where -import Database.Migrate.Data-import Database.Migrate.Kernel+import           Control.Lens                    ((^.))+import           Control.Monad                   (void, forM_)+import           Control.Monad.Trans.Reader+import           Control.Monad.IO.Class -import Control.Exception (SomeException(..), handle)-import Control.Monad-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 Data.Maybe-import Data.Text hiding (filter, reverse, find, null)-import Data.String (IsString(..))+import           Database.PostgreSQL.Simple+import           Database.Migrate.Migration -import Database.PostgreSQL.Simple-import Database.PostgreSQL.Simple.FromField-import Database.PostgreSQL.Simple.ToField+import           System.IO+import           System.FilePath -instance FromField MigrationId where-  fromField f m = fmap MigrationId $ fromField f m -instance ToField MigrationId where-  toField (MigrationId m) = toField m+data DbRead = DbRead { getConnection :: Connection, getDbName :: DbName,  getBase :: FilePath }+type DbName = Text+type Db a = ReaderT DbRead IO a -data PsqlConnectInfo = PsqlConnectInfo+psqlMain :: IO ()+psqlMain = putStrLn "hello" -psqlMigrateDatabase :: MigrateDatabase IO Connection-psqlMigrateDatabase =-  MigrateDatabase {-    current = connection >>= \c ->-     liftIO (query_ c "SELECT TRUE FROM pg_tables WHERE schemaname='public' AND tablename = 'migration_info'") >>= \r ->-      return (maybe False fromOnly (listToMaybe r)) >>= \rr ->-      if rr-        then liftIO (fmap Initialized (fmap (fmap fromOnly) (query_ c "SELECT migration FROM migration_info")))-        else return NotInitialized-  , initialize = connection >>= \c -> liftIO . void $-      execute_ c "CREATE TABLE IF NOT EXISTS migration_info (migration VARCHAR(50) PRIMARY KEY)"-  , runSql = \sql -> connection >>= \c ->-     liftIO . void $ execute_ c (fromString . unpack $ sql)-  , recordInstall = \m -> connection >>= \c ->-     liftIO . void $ (begin c >> execute c "INSERT INTO migration_info (migration) VALUES (?)" (Only $ migrationId m) >> commit c)-  , recordRollback = \m -> connection >>= \c ->-     liftIO . void $ (begin c >> execute c "DELETE FROM migration_info WHERE migration = ?" (Only $ migrationId m) >> commit c)-  }+migrate :: DbName -> Connection -> FilePath -> [Migration] -> IO ()+migrate n c b migrations =+  runReaderT (run_ history >> run_ versions >> migrate' migrations) (DbRead c n b) -{--  testconn =  connection >>= \c ->  query_ c "SELECT TRUE" >>= \r -> return $ maybe False fromOnly (listToMaybe r)+migrate' :: [Migration] -> Db ()+migrate' migrations = do -  initialize = connection >>= \c -> void $ execute_ c "CREATE TABLE IF NOT EXISTS MIGRATION_INFO (MIGRATION VARCHAR(50) PRIMARY KEY)"-  initialized = connection >>= \c -> query_ c "SELECT TRUE FROM pg_tables WHERE schemaname='public' AND tablename = MIGRATION_INFO" >>= \r -> return $ maybe False fromOnly (listToMaybe r)-  runMigration = runall-  getMigrations c = fmap (fmap fromOnly) (query_ c "SELECT MIGRATION FROM MIGRATION_INFO")+  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)" -migratePostgres :: Connection -> FilePath -> (String -> IO ()) -> IO () -> IO ()-migratePostgres c path logger bomb = do-   initialize c-   ems <- runEitherT $ find path-   case ems of-     Left e -> logger e >> bomb-     Right ms -> runEitherT (latest c ms) >>= \er ->-       case er of-         Left (Context s f m r) ->-           forM_ s (\mid -> logger ("migration:applied: " ++ (unpack . extract $ mid))) >>-           logger ("migration:failed:" ++ (unpack . extract $ f) ++ ":" ++ unpack m) >>-           logger ("migration:rolledback:" ++ show r) >>-           bomb-         Right mids -> if null mids-                         then logger "migration:up-to-date"-                         else forM_ mids $ \mid -> logger $ "migration:applied: " ++ (unpack . extract $ mid)+versions :: Query+versions =+  "CREATE TABLE IF NOT EXISTS migration_versions (db VARCHAR(50), migration VARCHAR(50) PRIMARY KEY)" -record :: Connection -> MigrationId -> IO ()-record conn mid = void $ execute conn "INSERT INTO MIGRATION_INFO VALUES (?)" (Only mid)+install :: Query+install =+  "INSERT INTO migration_versions (db, migration) VALUES (?, ?)" -runall :: Connection -> (Migration -> Ddl) -> [Migration] -> MigrationResultT IO [MigrationId]-runall c f ms =-  liftIO (begin c) >>-    foldM (\rs m ->-             EitherT $-               do e <- runEitherT (saferun c f m)-                  case e of-                    Left emsg -> rollback c >> (return . Left $ Context (reverse rs) (migration m) emsg True)-                    Right r -> return . Right $ r:rs) [] ms >>= \result -> liftIO (commit c) >> return (reverse result)+uninstall :: Query+uninstall =+  "DELETE FROM migration_versions (db, migration) WHERE db = ? AND migration = ?" -saferun :: Connection -> (Migration -> Ddl) -> Migration -> EitherT Text IO MigrationId-saferun c f m = EitherT $ handle (\e -> return (Left (pack . show $ (e :: SomeException)))) (fmap Right $ run c f m)+addhistory :: Query+addhistory =+  "INSERT INTO migration_history (db, migration, action, at, sql) VALUES (?, ?, ?, ?, ?)" -run :: Connection -> (Migration -> Ddl) -> Migration -> IO MigrationId-run c f m = execute_ c (fromString . unpack $ f m) >> record c (migration m) >> return (migration m)--}+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 -- FIX+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