From 86916c1274dbfb570c59f2b8f7cb48c7ef87f133 Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Sat, 30 Sep 2023 03:25:48 -0400 Subject: [PATCH] Remove beam-migrate-cli (#684) --- beam-migrate-cli/BeamMigrate.hs | 77 -- .../Database/Beam/Migrate/Tool/Backend.hs | 61 -- .../Database/Beam/Migrate/Tool/Branch.hs | 46 -- .../Database/Beam/Migrate/Tool/CmdLine.hs | 261 ------- .../Database/Beam/Migrate/Tool/Database.hs | 55 -- .../Database/Beam/Migrate/Tool/Diff.hs | 168 ----- .../Database/Beam/Migrate/Tool/Init.hs | 38 - .../Database/Beam/Migrate/Tool/Log.hs | 43 -- .../Database/Beam/Migrate/Tool/Migrate.hs | 146 ---- .../Beam/Migrate/Tool/MigrationCmd.hs | 51 -- .../Database/Beam/Migrate/Tool/Registry.hs | 666 ------------------ .../Database/Beam/Migrate/Tool/Schema.hs | 480 ------------- .../Database/Beam/Migrate/Tool/Status.hs | 146 ---- beam-migrate-cli/LICENSE | 8 - beam-migrate-cli/beam-migrate-cli.cabal | 77 -- beam-migrate/Database/Beam/Migrate/Backend.hs | 5 +- beam-migrate/Database/Beam/Migrate/Log.hs | 2 +- beam-migrate/README.md | 5 - beam-migrate/beam-migrate.cabal | 6 - beam-sqlite/Database/Beam/Sqlite/Migrate.hs | 6 +- cabal.project | 1 - docs/about/faq.md | 5 +- docs/schema-guide/library.md | 1 - docs/schema-guide/migrations.md | 32 +- docs/schema-guide/tool.md | 1 - mkdocs.yml | 3 - nix/lib.nix | 3 - stack-8.10.yaml | 1 - stack.yaml | 1 - 29 files changed, 6 insertions(+), 2389 deletions(-) delete mode 100644 beam-migrate-cli/BeamMigrate.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Backend.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Branch.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/CmdLine.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Database.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Diff.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Init.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Log.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Migrate.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/MigrationCmd.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Registry.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Schema.hs delete mode 100644 beam-migrate-cli/Database/Beam/Migrate/Tool/Status.hs delete mode 100644 beam-migrate-cli/LICENSE delete mode 100644 beam-migrate-cli/beam-migrate-cli.cabal delete mode 100644 docs/schema-guide/library.md delete mode 100644 docs/schema-guide/tool.md diff --git a/beam-migrate-cli/BeamMigrate.hs b/beam-migrate-cli/BeamMigrate.hs deleted file mode 100644 index d5842a8f..00000000 --- a/beam-migrate-cli/BeamMigrate.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Main where - -import Database.Beam.Migrate.Tool.Branch -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Database -import Database.Beam.Migrate.Tool.Diff -import Database.Beam.Migrate.Tool.Init -import Database.Beam.Migrate.Tool.Log -import Database.Beam.Migrate.Tool.Migrate -import Database.Beam.Migrate.Tool.Registry -import Database.Beam.Migrate.Tool.Schema -import Database.Beam.Migrate.Tool.MigrationCmd -import Database.Beam.Migrate.Tool.Status - -import Data.Maybe - -import Options.Applicative - -main :: IO () -main = do - cmdLine@MigrateCmdLine { migrateSubcommand } <- execParser migrationCliOptions - - case migrateSubcommand of - MigrateCommandDatabases DatabaseCommandList -> - listDatabases cmdLine - MigrateCommandDatabases (DatabaseCommandAdd dbName beName url) -> - initDatabase cmdLine dbName beName url - MigrateCommandDatabases (DatabaseCommandRename from to) -> - renameDatabase cmdLine from to - MigrateCommandDatabases (DatabaseCommandShow dbName) -> - showDatabase cmdLine dbName - - MigrateCommandInit initCommand -> - initBeamMigrate cmdLine initCommand - - MigrateCommandClean _ -> fail "Unimplemented" --- cleanBeamMigrate cmdLine cleanCommand - - MigrateCommandLog -> - displayLog cmdLine - - MigrateCommandStatus -> - displayStatus cmdLine - - MigrateCommandDiff autogen expActual -> - let (actual, expected) = - maybe ("HEAD", "DB!") - (\(actualSrc, expSrc) -> (actualSrc,) . fromMaybe "HEAD" $ expSrc) expActual - in displayDiff cmdLine expected actual autogen - - MigrateCommandBranch BranchCommandList -> - listBranches cmdLine - MigrateCommandBranch (BranchCommandDelete branchNm) -> - deleteBranch cmdLine branchNm - MigrateCommandBranch (BranchCommandNew dontSwitch branchNm) -> - newBranch cmdLine dontSwitch branchNm - - MigrateCommandSchema (SchemaCommandImport _ dbName branchName doCommit doAutoMigrate) -> - importDb cmdLine dbName branchName doCommit doAutoMigrate - MigrateCommandSchema (SchemaCommandNew tmplSrc tmpFile) -> - beginNewSchema cmdLine tmplSrc tmpFile - MigrateCommandSchema (SchemaCommandCommit force overwrite commitMsg) -> - commitSchema cmdLine force overwrite commitMsg - - MigrateCommandMigration (MigrationCommandNew fromCommit toCommit autoGen leaveOpen fmts) -> - newMigrationCmd cmdLine fromCommit toCommit autoGen leaveOpen fmts - - MigrateCommandAbort force -> - abortEdits cmdLine force - - MigrateCommandSimple (SimpleCommandSchema backend connStr schemaKind) -> - showSimpleSchema cmdLine backend connStr schemaKind - - MigrateCommandMigrate -> - doMigrateDatabase cmdLine False diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Backend.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Backend.hs deleted file mode 100644 index d3ff3be7..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Backend.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Database.Beam.Migrate.Tool.Backend where - -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Registry -import Database.Beam.Migrate.Backend - -import Control.Monad.Catch - -import qualified Data.HashMap.Strict as HM -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif - -import Language.Haskell.Interpreter hiding (ModuleName) -import Language.Haskell.Interpreter.Unsafe - -import System.Exit -import System.IO - -loadBackend :: MigrateCmdLine -> MigrationRegistry - -> DatabaseName - -> IO (MigrationDatabase, MigrationFormat, SomeBeamMigrationBackend) -loadBackend cmdLine reg dbName = - case HM.lookup dbName (migrationRegistryDatabases reg) of - Nothing -> fail "No such database" - Just db@(MigrationDatabase backend _) -> do - be <- loadBackend' cmdLine backend - pure (db, MigrationFormatBackend (unModuleName backend), be) - -runBeamInterpreter :: (MonadIO m, MonadMask m) - => MigrateCmdLine -> InterpreterT m a - -> m (Either InterpreterError a) -runBeamInterpreter cmdLine action = - let ghciArgs = map (\p -> "-package-db " <> p) (migratePackagePath cmdLine) <> [ "-v" ]--, "-fno-code" ] - in unsafeRunInterpreterWithArgs ghciArgs $ do - unsafeSetGhcOption "-v3" - action - -loadBackend' :: MigrateCmdLine -> ModuleName -> IO SomeBeamMigrationBackend -loadBackend' cmdLine (ModuleName backend) = do - res <- runBeamInterpreter cmdLine $ do - setImports [ "Database.Beam.Migrate.Backend", backend ] - interpret "SomeBeamMigrationBackend migrationBackend" (undefined :: SomeBeamMigrationBackend) - - case res of - Right be -> pure be - Left e -> reportHintError e - -reportHintError :: InterpreterError -> IO a -reportHintError e = - do hPutStrLn stderr $ - case e of - WontCompile errs -> - "Plugin load error: " ++ unlines (map errMsg errs) - UnknownError err -> - "Unknown interpeter error: " ++ err - NotAllowed err -> - "Not allowed: " ++ err - GhcException err -> - "GHC exception: " ++ err - exitWith (ExitFailure 1) diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Branch.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Branch.hs deleted file mode 100644 index 5f11a06a..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Branch.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Database.Beam.Migrate.Tool.Branch where - -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Registry - -import Control.Monad - -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif -import qualified Data.Text as T - -import System.Console.ANSI - -listBranches :: MigrateCmdLine -> IO () -listBranches cmdLine = do - reg <- lookupRegistry cmdLine - - case migrationRegistryHead reg of - MigrationHeadDetached commitId -> do - setSGR [ SetColor Foreground Dull Green ] - putStrLn ("(Currently in detached HEAD mode at " ++ show commitId ++ ")") - setSGR [ Reset ] - _ -> pure () - - forM_ (migrationRegistryBranches reg) $ \branch -> do - let isCurrent = migrationRegistryHead reg == MigrationHeadBranch (migrationBranchName branch) - putStrLn ((if isCurrent then "* " <> setSGRCode [ SetColor Foreground Dull Green ] else " ") <> - T.unpack (migrationBranchName branch) <> - setSGRCode [ Reset ]) - -deleteBranch :: MigrateCmdLine -> T.Text -> IO () -deleteBranch cmdLine branchNm = - updatingRegistry cmdLine $ \reg -> - pure ((), reg { migrationRegistryBranches = - filter (\branch -> migrationBranchName branch /= branchNm) - (migrationRegistryBranches reg) }) - -newBranch :: MigrateCmdLine -> Bool -> T.Text -> IO () -newBranch cmdLine dontSwitch branchNm = - updatingRegistry cmdLine $ \reg -> - case lookupBranch reg branchNm of - Nothing -> - pure ((), reg { migrationRegistryBranches = MigrationBranch branchNm (registryHeadCommit reg):migrationRegistryBranches reg - , migrationRegistryHead = if dontSwitch then migrationRegistryHead reg else MigrationHeadBranch branchNm } ) - Just _ -> fail "Branch already exists" diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/CmdLine.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/CmdLine.hs deleted file mode 100644 index 65b12dec..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/CmdLine.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -module Database.Beam.Migrate.Tool.CmdLine where - -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif -import Data.Aeson -import Data.Hashable -import Data.Text (Text) -import Data.String (fromString) - -import GHC.Generics - -import Options.Applicative - -data MigrationFormat = MigrationFormatHaskell | MigrationFormatBackend String - deriving (Show, Eq, Ord, Generic) -instance Hashable MigrationFormat - -newtype ModuleName = ModuleName { unModuleName :: String } - deriving (Show, Eq, Ord, ToJSON, FromJSON) -newtype DatabaseName = DatabaseName { unDatabaseName :: String } - deriving (Show, Eq, Ord, ToJSONKey, FromJSONKey, Hashable) - -data InitCommand - = InitCommand - { initBackend :: Maybe ModuleName - , initConnectionString :: Maybe String - , initModule :: ModuleName - , initModulePath :: FilePath - - , initInteractive :: Bool - , initCreateSchema :: Bool - } deriving Show - -data CleanCommand - = CleanCommand - { cleanForce :: Bool - } deriving Show - -data DatabaseCommand - = DatabaseCommandList - | DatabaseCommandAdd DatabaseName ModuleName String - | DatabaseCommandShow DatabaseName - | DatabaseCommandRename DatabaseName DatabaseName - deriving Show - -data SchemaKind - = HsSchema | YamlSchema | BackendSchema - deriving Show - -data SimpleCommand - = SimpleCommandSchema ModuleName String SchemaKind - deriving Show - -data BranchCommand - = BranchCommandList - | BranchCommandDelete Text - | BranchCommandNew Bool {-^ Don't switch -} Text - deriving Show - -data SchemaCommand - = SchemaCommandImport !Bool DatabaseName (Maybe Text) !Bool {-^ Commit in database -} !Bool {-^ Do auto migrate -} - -- ^ Create a haskell migration for the given database - - | SchemaCommandNew Text {-^ The schema to iterate on -} - FilePath {-^ The temporary file to use -} - - | SchemaCommandCommit Bool {-^ Force creation of new schema -} - Bool {-^ Overwrite old schema if nothing has changed -} - (Maybe Text) {-^ Commit message -} - deriving Show - -data MigrationCommand - = MigrationCommandNew Text {-^ The schema to come from (default DB) -} - Text {-^ The schema to go to (default HEAD) -} - Bool {-^ Attempt to automatically generate a migration -} - Bool {-^ Leave migrations open for editing -} - [ MigrationFormat ] {-^ Formats to generate in. If empty, defaults to every backend registered for schemas + Haskell -} - deriving Show - -data MigrateCommand - = MigrateCommandInit InitCommand -- ^ Initialize a new beam migrate registry - | MigrateCommandClean CleanCommand -- ^ Remove beam-migrate tables from a database - - | MigrateCommandLog - | MigrateCommandStatus - - | MigrateCommandDatabases DatabaseCommand - | MigrateCommandBranch BranchCommand - - | MigrateCommandSchema SchemaCommand - | MigrateCommandMigration MigrationCommand - - | MigrateCommandAbort !Bool - - | MigrateCommandDiff Bool (Maybe (Text, Maybe Text)) - - | MigrateCommandMigrate - - | MigrateCommandSimple SimpleCommand - deriving Show - -data MigrateCmdLine - = MigrateCmdLine - { migrateRegistryPath :: Maybe FilePath - , migratePackagePath :: [ FilePath ] - , migrateDatabase :: Maybe DatabaseName - - , migrateSubcommand :: MigrateCommand - } deriving Show - -migrationArgParser :: Parser MigrateCmdLine -migrationArgParser = - MigrateCmdLine <$> optional (strOption (long "registry" <> short 'r' <> metavar "REGISTRY" <> help "Path to beam-migrate registry")) - <*> many (strOption (long "package-path" <> metavar "PACKAGE-PATH" <> help "Additional GHC package paths to search for backends")) - <*> optional (DatabaseName <$> strOption (long "database" <> short 'd' <> metavar "DATABASE" <> help "Name of database to use")) - <*> (subparser $ mconcat [ command "init" initCommand, command "clean" cleanCommand - - , command "log" logCommand, command "status" statusCommand - - , command "diff" diffCommand - - , command "database" databaseCommand - , command "branch" branchCommand - , command "simple" simpleCommand - - , command "schema" schemaCommand - , command "migration" migrationCommand - - , command "abort" abortCommand - - , command "migrate" migrateCommand ]) - where - initCommand = info (initParser <**> helper) (fullDesc <> progDesc "Initialize a beam-migrate registry in this directory, or in the given registration file") - cleanCommand = info (cleanParser <**> helper) (fullDesc <> progDesc "Remove all beam-migrate tables from the database") - - logCommand = info (pure MigrateCommandLog <**> helper) (fullDesc <> progDesc "Display migration history of the given database") - statusCommand = info (pure MigrateCommandStatus <**> helper) (fullDesc <> progDesc "Show status of beam migrations") - diffCommand = info (diffParser <**> helper) (fullDesc <> progDesc "Show diff between revisions") - databaseCommand = info (databasesParser <**> helper) (fullDesc <> progDesc "Create, update, list databases in the registry") - branchCommand = info (branchParser <**> helper) (fullDesc <> progDesc "Create, update, list branches in the registry") - schemaCommand = info (schemaParser <**> helper) (fullDesc <> progDesc "Create, update, import, and list schemas") - migrationCommand = info (migrationParser <**> helper) (fullDesc <> progDesc "Create, update, and list migrations") - simpleCommand = info (simpleParser <**> helper) (fullDesc <> progDesc "Simple utilities that do not require a full beam-migrate setup") - migrateCommand = info (migrateParser <**> helper) (fullDesc <> progDesc "Bring the given database up-to-date with the current branch") - abortCommand = info (abortParser <**> helper) (fullDesc <> progDesc "Abort any edits taking place") - - initParser = MigrateCommandInit <$> - (InitCommand <$> optional (ModuleName <$> strOption (long "backend" <> metavar "BACKEND" <> help "Backend module to use")) - <*> optional (strOption (long "connection" <> metavar "CONNECTION" <> help "Connection string for backend")) - <*> (ModuleName <$> strOption (long "module" <> metavar "MODULE" <> help "Module to use")) - <*> strOption (long "src-dir" <> metavar "SOURCEDIR" <> help "Directory containing source files" <> value ".") - <*> flag True False (long "no-prompt" <> help "Do not prompt; fail instead") - <*> flag True False (long "no-create" <> help "Do not create the beam-migrate schema in the database")) - - cleanParser = MigrateCommandClean <$> (CleanCommand <$> switch (long "force" <> short 'f' <> help "Do not prompt")) - - diffParser = MigrateCommandDiff <$> flag False True (long "auto-script" <> help "Display migration as an auto-generated script, if possible") - <*> optional ((,) <$> (fromString <$> strArgument (metavar "ACTUAL" <> help "Reference to use as actual predicate source (default: DB!)")) - <*> optional (fromString <$> strArgument (metavar "EXPECTED" <> help "Reference to use as correct predicate source (default: HEAD)"))) - - databasesParser = MigrateCommandDatabases <$> subparser (mconcat [ command "add" databasesAddCommand - , command "list" databasesListCommand - , command "show" databasesShowCommand - , command "rename" databasesRenameCommand ]) - databasesAddCommand = - info (databasesAddParser <**> helper) (fullDesc <> progDesc "Add a new database to the registry") - where databasesAddParser = DatabaseCommandAdd <$> (DatabaseName <$> strArgument (metavar "NAME" <> help "Name of new database")) - <*> (ModuleName <$> strArgument (metavar "BACKEND" <> help "Backend Haskell module")) - <*> strArgument (metavar "CONN" <> help "Connection string") - databasesListCommand = - info (databasesListParser <**> helper) (fullDesc <> progDesc "List databases in the registry") - where databasesListParser = pure DatabaseCommandList - databasesShowCommand = - info (databasesShowParser <**> helper) (fullDesc <> progDesc "Show database with given name") - where databasesShowParser = DatabaseCommandShow <$> (DatabaseName <$> strArgument (metavar "DATABASE" <> help "Database to show")) - databasesRenameCommand = - info (databasesRenameParser <**> helper) (fullDesc <> progDesc "Rename a database from OLDNAME to NEWNAME") - where databasesRenameParser = DatabaseCommandRename <$> (DatabaseName <$> strArgument (metavar "OLDNAME" <> help "Database to rename")) - <*> (DatabaseName <$> strArgument (metavar "NEWNAME" <> help "New name for database")) - - branchParser = MigrateCommandBranch <$> subparser (mconcat [ command "list" branchListCommand - , command "delete" branchDeleteCommand - , command "new" branchNewCommand ]) - - branchListCommand = - info (branchListParser <**> helper) (fullDesc <> progDesc "List branches in registry") - where branchListParser = pure BranchCommandList - branchDeleteCommand = - info (branchDeleteParser <**> helper) (fullDesc <> progDesc "Delete branch from registry") - where branchDeleteParser = BranchCommandDelete <$> (fromString <$> strArgument (metavar "BRANCH" <> help "Branch to delete")) - branchNewCommand = - info (branchNewParser <**> helper) (fullDesc <> progDesc "Create new branch starting from current HEAD") - where branchNewParser = BranchCommandNew <$> flag False True (long "dont-switch" <> help "Do not switch to the new branch") - <*> (fromString <$> strArgument (metavar "BRANCH" <> help "Name of new branch")) - - schemaParser = MigrateCommandSchema <$> subparser (mconcat [ command "import" schemaImportCommand - , command "new" schemaNewCommand - , command "commit" schemaCommitCommand ]) - - schemaImportCommand = info (importParser <**> helper) (fullDesc <> progDesc "Import a database schema into haskell") - where - importParser = SchemaCommandImport <$> flag True False (long "interactive" <> short 'i' <> help "Run in interactive mode") - <*> (DatabaseName <$> strArgument (metavar "DATABASE" <> help "Database to import from")) - <*> optional (fromString <$> strArgument (metavar "BRANCHNAME" <> help "Branch to import into")) - <*> flag True False (long "no-commit" <> help "Do not record commit in local change log") - <*> flag True False (long "no-migrate" <> help "Do not generate an automatic migration") - - schemaNewCommand = info (newParser <**> helper) (fullDesc <> progDesc "Create a new schema") - where - newParser = SchemaCommandNew <$> (fromString <$> strArgument (metavar "FROM" <> help "Schema to iterate on" <> value "HEAD")) - <*> strOption (long "tmp-file" <> metavar "TMPFILE" <> help "Temporary file to edit schema" <> value "BeamMigrateSchema.hs") - - - schemaCommitCommand = info (commitParser <**> helper) (fullDesc <> progDesc "Commit the schema currently being edited") - where - commitParser = SchemaCommandCommit <$> flag False True (long "force" <> short 'f' <> help "Force the creation of a new schema, even if nothing has changed") - <*> flag False True (long "overwrite" <> help "Overwrite the existing schema, only if nothing meaningful has changed") - <*> optional (fromString <$> strOption (short 'm' <> metavar "MESSAGE" <> help "Commit message")) - - migrationParser = MigrateCommandMigration <$> subparser (mconcat [ command "new" migrationNewCommand ]) - - migrationNewCommand = info (newParser <**> helper) (fullDesc <> progDesc "Create a new migration") - where - newParser = MigrationCommandNew <$> (fromString <$> strArgument (metavar "FROM" <> help "Schema to migrate from" <> value "DB")) - <*> (fromString <$> strArgument (metavar "TO" <> help "Schema to migrate to" <> value "HEAD")) - <*> flag False True (long "auto" <> help "Attempt to automatically generate appropriate migrations") - <*> flag True False (long "edit" <> short 'e' <> help "Leave the migration files available for editing before committing them to the registry") - <*> (many (option (eitherReader migrationFormatReader) (long "format" <> short 'f' <> help "Specify a list of formats desired for the given migration"))) - - simpleParser = MigrateCommandSimple <$> subparser (mconcat [ command "schema" simpleSchemaCommand ]) - - backendOption = ModuleName <$> strOption (long "backend" <> metavar "BACKEND" <> help "Backend module to use") - connectionOption = strOption (long "connection" <> metavar "CONNECTION" <> help "Connection string for backend") - - simpleSchemaCommand = - info (simpleSchemaParser <**> helper) (fullDesc <> progDesc "Extract a haskell schema from the given database") - where simpleSchemaParser = SimpleCommandSchema <$> backendOption - <*> connectionOption - <*> ( flag' YamlSchema - (long "yaml-schema" <> help "Dump schema in yaml format") <|> - flag' BackendSchema - (long "native-schema" <> help "Dump the schema in the native backend format") <|> - flag HsSchema HsSchema - (long "haskell-schema" <> help "Dump schema in Haskell format")) - - migrateParser = pure MigrateCommandMigrate - - abortParser = MigrateCommandAbort <$> flag False True (long "force" <> short 'f' <> help "Force this abort, even if the file has local changes") - -migrationCliOptions :: ParserInfo MigrateCmdLine -migrationCliOptions = - info (migrationArgParser <**> helper) - (fullDesc <> progDesc "Beam migrate command-line interface" <> - header "beam-migrate -- migrate database schemas for various beam backends") - -migrationFormatReader :: String -> Either String MigrationFormat -migrationFormatReader "hs" = pure MigrationFormatHaskell -migrationFormatReader backend = pure (MigrationFormatBackend backend) diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Database.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Database.hs deleted file mode 100644 index feb8bafb..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Database.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Database.Beam.Migrate.Tool.Database where - -import Database.Beam.Migrate.Backend -import Database.Beam.Migrate.Log -import Database.Beam.Migrate.Tool.Backend -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Registry - -import Control.Monad - -import qualified Data.HashMap.Strict as HM - -listDatabases :: MigrateCmdLine -> IO () -listDatabases cmdLine = do - reg <- lookupRegistry cmdLine - - forM_ (HM.toList (migrationRegistryDatabases reg)) $ \(DatabaseName dbName, _) -> - putStrLn dbName - -renameDatabase :: MigrateCmdLine -> DatabaseName -> DatabaseName -> IO () -renameDatabase cmdLine from to = - updatingRegistry cmdLine $ \reg -> - case HM.lookup from (migrationRegistryDatabases reg) of - Nothing -> fail ("No such database " ++ unDatabaseName from) - Just db -> - pure ((), reg { migrationRegistryDatabases = HM.insert to db $ - HM.delete from $ - migrationRegistryDatabases reg }) - -showDatabase :: MigrateCmdLine -> DatabaseName -> IO () -showDatabase cmdLine dbName@(DatabaseName dbNameStr) = do - reg <- lookupRegistry cmdLine - - case HM.lookup dbName (migrationRegistryDatabases reg) of - Nothing -> fail "No such database" - Just MigrationDatabase {..} -> do - putStrLn ("Database '" ++ dbNameStr ++ "'") - putStrLn (" Backend: " ++ unModuleName migrationDbBackend) - putStrLn (" Conn : " ++ migrationDbConnString) - -initDatabase :: MigrateCmdLine -> DatabaseName -> ModuleName -> String -> IO () -initDatabase cmdLine dbName moduleName connStr = - updatingRegistry cmdLine $ \reg -> do - case HM.lookup dbName (migrationRegistryDatabases reg) of - Just {} -> fail "Database already exists" - Nothing -> do - -- Get the constraints and see if the migration table already exists - SomeBeamMigrationBackend be@BeamMigrationBackend { backendTransact = transact } <- - loadBackend' cmdLine moduleName - _ <- transact connStr (ensureBackendTables be) - - let db = MigrationDatabase moduleName connStr - pure ((), reg { migrationRegistryDatabases = - HM.insert dbName db (migrationRegistryDatabases reg) }) - diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Diff.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Diff.hs deleted file mode 100644 index b1026e3c..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Diff.hs +++ /dev/null @@ -1,168 +0,0 @@ -module Database.Beam.Migrate.Tool.Diff where - -import Prelude hiding (pred) - -import Database.Beam hiding (timestamp) -import Database.Beam.Migrate hiding (p) - -import Database.Beam.Migrate.Backend -import Database.Beam.Migrate.Log -import Database.Beam.Migrate.Tool.Backend -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Registry - -import Control.Exception -import Control.Monad - -import qualified Data.HashSet as HS - -import Data.Text (Text) -import qualified Data.Text as T -import Data.UUID (UUID) - -import Text.Read - -data NoRecordedSchemas = NoRecordedSchemas - deriving Show -instance Exception NoRecordedSchemas - -data CouldNotFetchLog = CouldNotFetchLog DdlError - deriving Show -instance Exception CouldNotFetchLog - -data CouldNotFetchConstraints = CouldNotFetchConstraints DdlError - deriving Show -instance Exception CouldNotFetchConstraints - -data PredicateDiff - = PredicateDiff - { predicateDiffExpected :: HS.HashSet SomeDatabasePredicate - , predicateDiffActual :: HS.HashSet SomeDatabasePredicate - } deriving Show - -predicateDiffMissing, predicateDiffExtra :: PredicateDiff -> HS.HashSet SomeDatabasePredicate -predicateDiffMissing (PredicateDiff expected actual) = - expected `HS.difference` actual -predicateDiffExtra (PredicateDiff expected actual) = - actual `HS.difference` expected - -genDiff :: MigrateCmdLine -> MigrationRegistry - -> Text -> Text - -> IO (ModuleName, PredicateDiff) -genDiff cmdLine reg actualSpec expSpec = do - - actualSource <- parsePredicateFetchSourceSpec cmdLine reg actualSpec - expSource <- parsePredicateFetchSourceSpec cmdLine reg expSpec - - be <- - case ( predicateFetchSourceBackend actualSource - , predicateFetchSourceBackend expSource ) of - (Nothing, Nothing) -> - fail "Predicate sources do not specify a backend" - (Just be, Nothing) -> pure be - (Nothing, Just be) -> pure be - (Just be, Just be') - | be == be' -> pure be - | otherwise -> fail ("Cannot compare schemas from two different backends: " ++ show (be, be')) - - (be,) <$> genDiffFromSources cmdLine reg (predicateSourceWithBackend be actualSource) - (predicateSourceWithBackend be expSource) - -genDiffFromSources :: MigrateCmdLine -> MigrationRegistry - -> PredicateFetchSource - -> PredicateFetchSource - -> IO PredicateDiff -genDiffFromSources cmdLine reg actualSource expSource = - do (_, actual) <- getPredicatesFromSpec cmdLine reg actualSource - (_, expected) <- getPredicatesFromSpec cmdLine reg expSource - - pure (PredicateDiff (HS.fromList expected) (HS.fromList actual)) - -filterBeamMigratePreds :: SomeBeamMigrationBackend -> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -filterBeamMigratePreds (SomeBeamMigrationBackend (BeamMigrationBackend {} :: BeamMigrationBackend be m)) preds = - let beamMigrateDbSchema = collectChecks (beamMigratableDb @be @m) - in foldr (\pred@(SomeDatabasePredicate pred') preds' -> - if pred `elem` preds' - then filter (\p@(SomeDatabasePredicate p') -> p /= pred && not (predicateCascadesDropOn p' pred')) preds' - else preds') - preds beamMigrateDbSchema - -getPredicatesFromSpec :: MigrateCmdLine -> MigrationRegistry - -> PredicateFetchSource - -> IO (Maybe UUID, [ SomeDatabasePredicate ]) -getPredicatesFromSpec _ _ (PredicateFetchSourceCommit Nothing _) = fail "No backend to read commit with" -getPredicatesFromSpec cmdLine reg (PredicateFetchSourceCommit (Just modName) commitId) = do - SomeBeamMigrationBackend be <- loadBackend' cmdLine modName - - SchemaMetaData _ _ _ (Schema preds) <- readSchemaMetaData reg be commitId - - let applicablePreds = predsForBackend be preds - pure (Just commitId, applicablePreds) -getPredicatesFromSpec cmdLine reg (PredicateFetchSourceDbHead (MigrationDatabase modName connStr) ref) = do - be@(SomeBeamMigrationBackend - (BeamMigrationBackend { backendGetDbConstraints = getCs - , backendTransact = transact } :: - BeamMigrationBackend be m)) <- - loadBackend' cmdLine modName - - case ref of - Nothing -> do - cs <- transact connStr getCs - case cs of - Left err -> throwIO (CouldNotFetchConstraints err) - Right cs' -> pure (Nothing, filterBeamMigratePreds be cs') - Just fromHead -> do - logEntry <- transact connStr $ - runSelectReturningOne $ select $ - limit_ 1 $ offset_ (fromIntegral fromHead) $ - orderBy_ (desc_ . _logEntryId) $ - all_ (_beamMigrateLogEntries (beamMigrateDb @be @m)) - - case logEntry of - Left err -> throwIO (CouldNotFetchLog err) - Right Nothing -> throwIO NoRecordedSchemas - Right (Just logEntry') -> - case readMaybe (T.unpack (_logEntryCommitId logEntry')) of - Nothing -> throwIO (InvalidCommitId (_logEntryCommitId logEntry')) - Just commitId -> - getPredicatesFromSpec cmdLine reg (PredicateFetchSourceCommit (Just modName) commitId) -getPredicatesFromSpec _ _ PredicateFetchSourceEmpty = pure (Nothing, []) - -displayDiff :: MigrateCmdLine - -> Text -> Text - -> Bool -> IO () -displayDiff cmdLine expected actual autogen = do - reg <- lookupRegistry cmdLine - - (backendMod, diff) <- genDiff cmdLine reg actual expected - - let missing = predicateDiffMissing diff - extra = predicateDiffExtra diff - - if autogen - then displayScript cmdLine backendMod diff - else - if HS.null extra && HS.null missing - then putStrLn "Schemas match" - else do - when (not (HS.null extra)) $ do - putStrLn "The following constraints are extraneous:" - forM_ extra $ \(SomeDatabasePredicate p') -> - putStrLn (" - " ++ englishDescription p') - when (not (HS.null missing)) $ do - putStrLn "The following constraints are missing:" - forM_ missing $ \(SomeDatabasePredicate p') -> - putStrLn (" - " ++ englishDescription p') - -displayScript :: MigrateCmdLine -> ModuleName -> PredicateDiff -> IO () -displayScript cmdLine modName (PredicateDiff dest from) = do - SomeBeamMigrationBackend BeamMigrationBackend - { backendActionProvider = actionProvider - , backendRenderSyntax = renderCmd } <- loadBackend' cmdLine modName - - let solver = heuristicSolver actionProvider (HS.toList from) (HS.toList dest) - - case finalSolution solver of - Candidates {} -> fail "Could not find appropriate migration between schemas." - Solved cmds -> - putStrLn (unlines (map (renderCmd . migrationCommand) cmds)) diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Init.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Init.hs deleted file mode 100644 index 358b42e2..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Init.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Database.Beam.Migrate.Tool.Init where - -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Registry - -import qualified Data.UUID.V4 as UUID -import qualified Data.Yaml as Yaml - -import System.Directory - -initBeamMigrate :: MigrateCmdLine -> InitCommand -> IO () -initBeamMigrate _ initCmd = do - alreadyInitialized <- doesPathExist ".beam-migrate" - - if alreadyInitialized then fail ".beam-migrate already exists. Run 'beam-migrate clean'" - else do - curDir <- getCurrentDirectory - headUuid <- UUID.nextRandom - - let registry' = MigrationRegistry - { migrationRegistryDatabases = mempty - , migrationRegistryHead = MigrationHeadBranch "master" - - , migrationRegistrySchemas = [] - , migrationRegistryMigrations = [] - - , migrationRegistryBranches = [ MigrationBranch "master" headUuid ] - - , migrationRegistrySrcDir = initModulePath initCmd - , migrationRegistrySchemaModule = initModule initCmd - - , migrationRegistryUserInfo = Nothing - - , migrationRegistryMode = BeamMigrateReady } - - Yaml.encodeFile ".beam-migrate" registry' - putStrLn ("Beam migrations initialized in " ++ curDir) - where diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Log.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Log.hs deleted file mode 100644 index 487fd4d4..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Log.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Database.Beam.Migrate.Tool.Log where - -import Database.Beam -import Database.Beam.Migrate.Log -import Database.Beam.Migrate.Backend -import Database.Beam.Migrate.Tool.Backend -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Diff -import Database.Beam.Migrate.Tool.Registry -import Database.Beam.Migrate.Tool.Status - -import Control.Exception -import Control.Monad - -import qualified Data.Text as T -import Text.Read (readMaybe) - -displayLog :: MigrateCmdLine -> IO () -displayLog MigrateCmdLine { migrateDatabase = Nothing } = - fail "No database specified" -displayLog cmdLine@MigrateCmdLine { migrateDatabase = Just dbName } = do - reg <- lookupRegistry cmdLine - - (db, _, SomeBeamMigrationBackend (be :: BeamMigrationBackend be m)) <- - loadBackend cmdLine reg dbName - - case be of - BeamMigrationBackend { backendTransact = transact } -> do - res <- transact (migrationDbConnString db) $ - runSelectReturningList $ select $ - orderBy_ (desc_ . _logEntryId) $ - all_ (_beamMigrateLogEntries (beamMigrateDb @be @m)) - case res of - Left err -> throwIO (CouldNotFetchLog err) - Right entries -> - forM_ entries $ \logEntry -> - let sch = do - commitId <- readMaybe (T.unpack (_logEntryCommitId logEntry)) - lookupSchema commitId [] reg - in case sch of - Nothing -> throwIO (InvalidCommitId (_logEntryCommitId logEntry)) - Just sch' -> do - showCommit (_logEntryDate logEntry) sch' diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Migrate.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Migrate.hs deleted file mode 100644 index 1418eff9..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Migrate.hs +++ /dev/null @@ -1,146 +0,0 @@ -module Database.Beam.Migrate.Tool.Migrate where - -import Database.Beam.Migrate.Backend -import Database.Beam.Migrate.Tool.Backend -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Diff -import Database.Beam.Migrate.Tool.Registry -import Database.Beam.Migrate.Tool.Status - -import Control.Applicative -import Control.Monad -import qualified Control.Monad.Fail as Fail - -import qualified Data.ByteString.Char8 as BS -import Data.Char as Char -import Data.Graph.Inductive.Graph -import qualified Data.Graph.Inductive.Query as Gr -import Data.List (find) -import Data.List.Split (splitWhen) -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Data.UUID (UUID) - -import System.IO -import System.Console.ANSI - -data MigrateDDLCommand cmd - = MigrateDDLCommandBeam BS.ByteString cmd - | MigrateDDLCommandRaw BS.ByteString - deriving Show - -data CLIMigration cmd = CLIMigration Text [MigrateDDLCommand cmd] - -showCommands :: [CLIMigration cmd] -> IO () -showCommands cmds = do - putStrLn "The following commands will be run, in order:" - - forM_ (zip [1..] cmds) $ \(i, CLIMigration stepDescr cmds) -> - do putStrLn (yellow ("Step " ++ show i ++ ": " ++ T.unpack stepDescr)) - forM_ (zip [1..] cmds) $ \(cmdIdx, cmd) -> - case cmd of - MigrateDDLCommandRaw rawCmd -> - putStrLn (green (" " ++ show cmdIdx) ++ ": " ++ BS.unpack rawCmd) - MigrateDDLCommandBeam rawCmd _ -> - putStrLn (green (" " ++ show cmdIdx) ++ ": " ++ BS.unpack rawCmd) - putStrLn "" - - where - yellow x = setSGRCode [ SetColor Foreground Dull Yellow ] ++ x ++ setSGRCode [ Reset ] - green x = setSGRCode [ SetColor Foreground Dull Green ] ++ x ++ setSGRCode [ Reset ] - -getSchemaCommandsForBackend :: Fail.MonadFail m - => MigrationRegistry -> Maybe (BeamMigrationBackend be m) - -> UUID -> IO [ MigrateDDLCommand cmd ] -getSchemaCommandsForBackend reg Nothing id = fail "Asked to get haskell schema" -getSchemaCommandsForBackend reg (Just be@(BeamMigrationBackend {})) commitId = - do let path = schemaFilePathForBackend (Just (SomeBeamMigrationBackend be)) reg commitId - cmdData <- BS.lines <$> BS.readFile path - - let cmds = fmap (fst . BS.spanEnd isSpace . BS.dropWhile isSpace . BS.unlines) $ - filter (any (not . BS.null)) $ -- Ensure every command contains something - splitWhen ("--" `BS.isPrefixOf`) cmdData - - pure (fmap MigrateDDLCommandRaw cmds) - -doMigrateDatabase :: MigrateCmdLine -> Bool -> IO () -doMigrateDatabase MigrateCmdLine { migrateDatabase = Nothing } _ = - fail "No database specified" -doMigrateDatabase cmdLine@MigrateCmdLine { migrateDatabase = Just dbName } script = do - registry <- lookupRegistry cmdLine - db <- lookupDb registry cmdLine - - let destCommit = registryHeadCommit registry - - sts <- getStatus cmdLine registry dbName - (_, _, SomeBeamMigrationBackend be@(BeamMigrationBackend {} :: BeamMigrationBackend be m)) <- - loadBackend cmdLine registry dbName - - cmds <- - case sts of - MigrateStatusNoCommits False -> fail "The beam-migrate schema does not exist in this database" - MigrateStatusNoCommits True -> do - putStrLn "This database has no history." - putStrLn ("Migrating database to " ++ show destCommit) - - let backendFmt = MigrationFormatBackend (unModuleName (migrationDbBackend db)) - - schema = lookupSchema destCommit [ backendFmt ] registry <|> - lookupSchema destCommit [ MigrationFormatHaskell ] registry - - case schema of - Nothing -> fail ("No schema for " ++ show destCommit ++ " in backend " ++ unModuleName (migrationDbBackend db)) - Just sch -> do - -- TODO user should be able to override this choice - backend <- if backendFmt `elem` registeredSchemaInfoFormats sch - then do - putStrLn "Using native backend" - pure (Just be) - else do - putStrLn "Using Haskell beam-migrate backend" - pure Nothing - - Just . pure . CLIMigration (fromString ("Initial import of schema " ++ show destCommit)) <$> - getSchemaCommandsForBackend registry backend destCommit - - MigrateStatusAtBranch srcCommit _ (PredicateDiff expected actual) - | expected /= actual -> fail "The database does not match its current schema (TODO add --fix option)" - | otherwise -> do - let migrations = registryMigrationGraph registry - - findMigration commit = fst <$> find (\(_, s) -> registeredSchemaInfoHash s == commit) (labNodes migrations) - - case (,) <$> findMigration srcCommit - <*> findMigration destCommit of - Nothing -> fail "Can't find schemas" - Just (sourceNode, destNode) - | sourceNode == destNode -> do - putStrLn "The database is already up-to-date with HEAD" - pure Nothing - | otherwise -> - case unLPath (Gr.lesp sourceNode destNode migrations) of - [] -> do - hPutStr stderr . unlines $ - [ "There is no migration between " ++ show srcCommit ++ - " and " ++ show destCommit - , "" - , "You can ask beam to generate one for you automatically, by running 'beam-migrate migration new --auto" - , "Alternatively, you can run 'beam-migrate migrate --manual', to write a custom migration script" - ] - fail "No possible migration" - path -> fail ("Migrating " ++ show path) - - -- Now run all the commands, which are given as bytestrings - case cmds of - Nothing -> putStrLn "No migration being performed" - Just cmds' -> do - showCommands cmds' - - putStrLn ("Should I run these commands?") - ack <- getLine - - if fmap Char.toLower ack /= "yes" - then fail "Exiting due to user request..." - else do - putStrLn "Would run commands" diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/MigrationCmd.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/MigrationCmd.hs deleted file mode 100644 index 3978b39f..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/MigrationCmd.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Database.Beam.Migrate.Tool.MigrationCmd where - -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Registry -import Database.Beam.Migrate.Tool.Diff - -import qualified Data.HashSet as S -import Data.Text (Text) -import Data.UUID (UUID) - -resolveFormats :: MigrationRegistry -> UUID -> UUID -> [MigrationFormat] - -> IO [MigrationFormat] -resolveFormats reg fromId toId [] = do - case (,) <$> lookupSchema fromId [] reg - <*> lookupSchema toId [] reg of - Nothing -> fail "Could not find schemas" - Just (fromSchema, toSchema) -> - let fromFormats = S.fromList $ registeredSchemaInfoFormats fromSchema - toFormats = S.fromList $ registeredSchemaInfoFormats toSchema - - commonFormats = S.intersection fromFormats toFormats - in if S.null commonFormats - then fail "The schemas have no formats in common" - else pure (S.toList commonFormats) - -resolveFormats _ _ _ fmts = pure fmts - - -newMigrationCmd :: MigrateCmdLine -> Text -> Text - -> Bool -> Bool -> [MigrationFormat] - -> IO () -newMigrationCmd cmdLine from to autoGen leaveOpen fmts' = - updatingRegistry cmdLine $ \reg -> do - fromSrc <- parsePredicateFetchSourceSpec cmdLine reg from - toSrc <- parsePredicateFetchSourceSpec cmdLine reg to - - -- TODO parallelize - (fromIdMaybe, fromPreds) <- getPredicatesFromSpec cmdLine reg fromSrc - (toIdMaybe, toPreds) <- getPredicatesFromSpec cmdLine reg toSrc - - case (,) <$> fromIdMaybe <*> toIdMaybe of - Nothing -> fail "Could not find schemas" - Just (fromId, toId) -> do - fmts <- resolveFormats reg fromId toId fmts' - - case (,) <$> lookupSchema fromId fmts reg - <*> lookupSchema toId fmts reg of - Nothing -> fail "Could not find schemas with the given formats" - Just (fromSchema, toSchema) -> - -- For each format, attempt to form a migration. - fail "Unimplemented" diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Registry.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Registry.hs deleted file mode 100644 index 256aff5f..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Registry.hs +++ /dev/null @@ -1,666 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Database.Beam.Migrate.Tool.Registry where - -import Database.Beam.Migrate -import Database.Beam.Migrate.Backend -import Database.Beam.Migrate.Serialization -import Database.Beam.Migrate.Tool.CmdLine - -import Control.Applicative -import Control.Exception - -import qualified Crypto.Hash as Crypto - -import Data.Aeson -import Data.Aeson.Types (Parser) -import qualified Data.ByteString.Char8 as BS -import Data.Graph.Inductive.Graph -import Data.Graph.Inductive.PatriciaTree -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.LargeWord (Word256) -import Data.List (find, intercalate, sort) -import Data.Maybe -#if !MIN_VERSION_base(4, 11, 0) -import Data.Monoid -#endif -import Data.String -import Data.Text (Text, unpack) -import qualified Data.Text as T -import Data.Time -import Data.UUID (UUID) -import qualified Data.UUID.V4 as UUID (nextRandom) -import qualified Data.Yaml as Yaml - -import Network.HostName - -import Numeric (showHex, readHex) - -import System.Directory -#if defined(mingw32_HOST_OS) -import System.Environment -#endif -import System.FilePath -import System.IO - -#if !defined(mingw32_HOST_OS) -import System.Posix.User -#endif - -import Text.Read hiding (String) - -data InvalidCommitId = InvalidCommitId T.Text - deriving Show -instance Exception InvalidCommitId - -newtype MigrateUUID = MigrateUUID { unMigrateUUID :: UUID } - -data BeamMigrateMode - = BeamMigrateReady - | BeamMigrateCreatingSchema !FilePath !(Maybe UUID) !Word256 -- ^ currently editing a schema, with SHA256 hash of file - | BeamMigrateEditingMigration !FilePath !UUID !UUID !Word256 -- ^ currently editing a migration, with SHA256 hash of file - deriving Show - -data PredicateFetchSource - = PredicateFetchSourceCommit !(Maybe ModuleName) !UUID - | PredicateFetchSourceDbHead !MigrationDatabase !(Maybe Int) - | PredicateFetchSourceEmpty - deriving Show - -data RegisteredSchemaInfo - = RegisteredSchemaInfo - { registeredSchemaInfoHash :: UUID - , registeredSchemaInfoCommitter :: UserInfo - , registeredSchemaInfoMessage :: Text - , registeredSchemaInfoFormats :: [ MigrationFormat ] - } deriving Show - -data RegisteredMigrationInfo - = RegisteredMigrationInfo - { registeredMigrationInfoResult :: UUID - , registeredMigrationInfoSource :: UUID - , registeredMigrationInfoFormats :: [ MigrationFormat ] - } deriving Show - -data MigrationBranch - = MigrationBranch - { migrationBranchName :: Text - , migrationBranchCommit :: UUID - } deriving Show - -data UserInfo - = UserInfo - { userInfoFullName :: Text - , userInfoEmail :: Text - } deriving Show - -data MigrationDatabase - = MigrationDatabase - { migrationDbBackend :: ModuleName - , migrationDbConnString :: String - } deriving Show - -data MigrationHead - = MigrationHeadDetached UUID - | MigrationHeadBranch Text - deriving (Show, Eq) - -data MigrationRegistry - = MigrationRegistry - { migrationRegistryDatabases :: HM.HashMap DatabaseName MigrationDatabase - , migrationRegistryHead :: MigrationHead - , migrationRegistrySchemas :: [ RegisteredSchemaInfo ] - , migrationRegistryMigrations :: [ RegisteredMigrationInfo ] - , migrationRegistryBranches :: [ MigrationBranch ] - - , migrationRegistrySrcDir :: FilePath - , migrationRegistrySchemaModule :: ModuleName - - , migrationRegistryUserInfo :: Maybe UserInfo - - , migrationRegistryMode :: BeamMigrateMode - } deriving Show - -data Schema - = Schema - { schemaPredicates :: [ (HS.HashSet PredicateSpecificity, SomeDatabasePredicate) ] - } deriving Show - -data SchemaMetaData - = SchemaMetaData - { schemaMetaDataCommit :: UUID - , schemaMetaDataFormats :: [ MigrationFormat ] - , schemaMetaDataCreatedOn :: UTCTime - , schemaMetaDataSchema :: Schema - } deriving Show - -instance ToJSON SchemaMetaData where - toJSON (SchemaMetaData commit formats timestamp' schema) = - object [ "commit" .= commit - , "formats" .= formats - , "createdOn" .= timestamp' - , "schema" .= schema ] --- instance FromJSON SchemaMetaData where --- parseJSON = withObject "SchemaMetaData" $ \o -> --- SchemaMetaData <$> o .: "commit" <*> o .: "formats" <*> o .: "createdOn" --- <*> o .: "schema" - -instance ToJSON Schema where - toJSON (Schema predicates) = - let grouped = HM.fromListWith mappend (map (fmap pure) predicates) - in toJSON (map (\(specificity, predicates') -> - object [ "specificity" .= specificity - , "predicates" .= map (\(SomeDatabasePredicate predicate) -> serializePredicate predicate) predicates' ]) - (HM.toList grouped)) --- instance FromJSON Schema where --- parseJSON = withArray "Schema" $ \a -> --- foldlM (\done -> withObject "Schema[]" $ \o -> --- do specificity <- o .: "specificity" --- predicates <- o .: "predicates" --- pure (map (specifity,) predicates ++ done)) --- [] a - -instance ToJSON MigrationDatabase where - toJSON (MigrationDatabase backend connString) = - object [ "backend" .= backend, "uri" .= connString ] -instance FromJSON MigrationDatabase where - parseJSON = withObject "MigrationDatabase" $ \o -> - MigrationDatabase <$> o .: "backend" <*> o .: "uri" - -instance ToJSON MigrateUUID where - toJSON = toJSON . show . unMigrateUUID -instance FromJSON MigrateUUID where - parseJSON v = fmap readMaybe (parseJSON v) >>= - \case - Nothing -> fail "Could not read UUID" - Just uuid -> pure (MigrateUUID uuid) - -instance ToJSON MigrationHead where - toJSON (MigrationHeadDetached headId) = toJSON (MigrateUUID headId) - toJSON (MigrationHeadBranch branch) = toJSON ("ref/branch/" <> branch) -instance FromJSON MigrationHead where - parseJSON x = (MigrationHeadDetached . unMigrateUUID <$> parseJSON x) <|> - readRef x - where - readRef = withText "MigrationHead" $ \ref -> - if "ref/branch/" `T.isPrefixOf` ref - then pure (MigrationHeadBranch (T.drop (T.length "ref/branch/") ref)) - else fail "Cannot read head" - -instance ToJSON BeamMigrateMode where - toJSON BeamMigrateReady = "ready" - toJSON (BeamMigrateCreatingSchema schemaFl src hash) = - object [ "tmpFile" .= schemaFl - , "src" .= src - , "hash" .= showHex hash "" ] - toJSON (BeamMigrateEditingMigration migrationFl from to hash) = - object [ "tmpFile" .= migrationFl - , "from" .= from, "to" .= to - , "hash" .= showHex hash "" ] -instance FromJSON BeamMigrateMode where - parseJSON "ready" = pure BeamMigrateReady - parseJSON o = withObject "BeamMigrateMode" - (\v -> BeamMigrateCreatingSchema <$> v .: "tmpFile" - <*> v .: "src" - <*> (rdHash =<< v .: "hash") <|> - BeamMigrateEditingMigration <$> v .: "tmpFile" - <*> v .: "from" <*> v .: "to" - <*> (rdHash =<< v .: "hash")) o - where - rdHash h = case filter (null . snd) (readHex h) of - [(x, _)] -> pure x - _ -> fail "Invalid hash" - -instance ToJSON MigrationRegistry where - toJSON MigrationRegistry {..} = - object ( (case migrationRegistryMode of - BeamMigrateReady -> [] - mode -> [ "mode" .= mode ]) ++ - [ "databases" .= migrationRegistryDatabases - , "head" .= migrationRegistryHead - , "schemas" .= migrationRegistrySchemas - , "migrations" .= migrationRegistryMigrations - , "branches" .= migrationRegistryBranches - , "module" .= object [ "src" .= migrationRegistrySrcDir, "name" .= migrationRegistrySchemaModule ] ] ++ - case migrationRegistryUserInfo of - Nothing -> [] - Just ui -> [ "user" .= ui ] ) - -instance FromJSON MigrationRegistry where - parseJSON = withObject "MigrationRegistry" $ \o -> do - (srcDir, name) <- (o .: "module") >>= withObject "MigrationRegistry.module" (\o' -> (,) <$> o' .: "src" <*> o' .: "name") - MigrationRegistry <$> o .: "databases" - <*> o .: "head" - <*> fmap (fromMaybe []) (o .:? "schemas") - <*> fmap (fromMaybe []) (o .:? "migrations") - <*> o .: "branches" - <*> pure srcDir <*> pure name - <*> o .:? "user" - <*> (fromMaybe BeamMigrateReady <$> o .:? "mode") - -instance ToJSON UserInfo where - toJSON UserInfo {..} = - object [ "full-name" .= userInfoFullName - , "email" .= userInfoEmail ] -instance FromJSON UserInfo where - parseJSON = withObject "UserInfo" $ \o -> - UserInfo <$> o .: "full-name" <*> o .: "email" - -instance ToJSON MigrationBranch where - toJSON MigrationBranch {..} = - object [ "name" .= migrationBranchName - , "commit" .= MigrateUUID migrationBranchCommit ] -instance FromJSON MigrationBranch where - parseJSON = withObject "MigrationBranch" $ \o -> - MigrationBranch <$> o .: "name" <*> (unMigrateUUID <$> o .: "commit") - -instance ToJSON RegisteredSchemaInfo where - toJSON RegisteredSchemaInfo {..} = - object [ "hash" .= MigrateUUID registeredSchemaInfoHash - , "message" .= registeredSchemaInfoMessage - , "formats" .= registeredSchemaInfoFormats - , "committer" .= registeredSchemaInfoCommitter ] -instance FromJSON RegisteredSchemaInfo where - parseJSON = withObject "RegisteredSchemaInfo" $ \o -> - RegisteredSchemaInfo <$> (unMigrateUUID <$> o .: "hash") - <*> o .: "committer" - <*> o .: "message" - <*> o .: "formats" - -instance ToJSON RegisteredMigrationInfo where - toJSON RegisteredMigrationInfo {..} = - object [ "result" .= registeredMigrationInfoResult - , "source" .= registeredMigrationInfoSource - , "formats" .= registeredMigrationInfoFormats ] -instance FromJSON RegisteredMigrationInfo where - parseJSON = withObject "RegisteredMigrationInfo" $ \o -> - RegisteredMigrationInfo <$> o .: "result" - <*> o .: "source" - <*> o .: "formats" - -instance ToJSON MigrationFormat where - toJSON MigrationFormatHaskell = "haskell" - toJSON (MigrationFormatBackend be) = fromString be -instance FromJSON MigrationFormat where - parseJSON "haskell" = pure MigrationFormatHaskell - parseJSON (String be) = pure (MigrationFormatBackend (unpack be)) - parseJSON _ = fail "Cannot parse MigrationFormat" - -reportDdlErrors :: IO (Either DdlError a) -> IO a -reportDdlErrors go = do - res <- go - case res of - Left err -> fail ("DDL error: " ++ show err) - Right x -> pure x - -registeredSchemaInfoShortMessage :: RegisteredSchemaInfo -> Text -registeredSchemaInfoShortMessage sch = - let fullMsg = registeredSchemaInfoMessage sch - in case T.lines fullMsg of - [] -> "(No message)" - x:_ -> x - --- | Attempt to read a registry from the common lookup paths --- --- 1. If a registry is given on the command line, don't attempt lookup --- 2. Otherwise, look for a @.beam-migrate@ file in this directory and each parent directory -lookupRegistry' :: MigrateCmdLine -> IO (FilePath, MigrationRegistry) -lookupRegistry' MigrateCmdLine { migrateRegistryPath = Just path } = - Yaml.decodeFileEither path >>= either (\e -> fail ("Could not read migration registry: " ++ show e)) (pure . (path,)) -lookupRegistry' cmdLine = getCurrentDirectory >>= lookupRegistry'' - where - lookupRegistry'' dir = - do let potentialRegistry = dir ".beam-migrate" - registryExists <- doesPathExist potentialRegistry - - if registryExists - then lookupRegistry' cmdLine { migrateRegistryPath = Just potentialRegistry } - else if isDrive dir - then fail "Could not find migration registry" - else lookupRegistry'' (takeDirectory dir) - -lookupRegistry :: MigrateCmdLine -> IO MigrationRegistry -lookupRegistry = fmap snd . lookupRegistry' - -lookupUserInfo :: MigrationRegistry -> IO UserInfo -lookupUserInfo MigrationRegistry { migrationRegistryUserInfo = Just ui } = pure ui -lookupUserInfo _ = do -#if defined(mingw32_HOST_OS) - username <- getEnv "USERNAME" - let fullName = username -#else - userId <- getEffectiveUserID - UserEntry { userName = username, userGecos = fullName } <- getUserEntryForID userId -#endif - hostname <- getHostName - - let email = username ++ "@" ++ hostname - userInfo = UserInfo { userInfoFullName = fromString fullName, userInfoEmail = fromString email } - - hPutStrLn stderr ("WARNING: defaulting user info to " ++ show userInfo) - pure userInfo - -showMigrationFormats :: [ MigrationFormat ] -> String -showMigrationFormats = intercalate ", ". map showFormat . sort - where - showFormat MigrationFormatHaskell = "Haskell" - showFormat (MigrationFormatBackend be) = be - -userInfoCommitter :: UserInfo -> Text -userInfoCommitter ui = "\"" <> userInfoEmail ui <> "\"<" <> userInfoEmail ui <> ">" - -assertRegistryReady :: MigrationRegistry -> IO () -assertRegistryReady MigrationRegistry { migrationRegistryMode = BeamMigrateReady } = pure () -assertRegistryReady _ = fail "There is an edit in progress. Use 'beam-migrate abort' to cancel" - -updatingRegistry :: MigrateCmdLine -> (MigrationRegistry -> IO (a, MigrationRegistry)) -> IO a -updatingRegistry cmdLine action = - do (registryPath, registry) <- lookupRegistry' cmdLine - (x, registry') <- action registry - Yaml.encodeFile registryPath registry' - pure x - -lookupDb :: MigrationRegistry -> MigrateCmdLine -> IO MigrationDatabase -lookupDb MigrationRegistry { migrationRegistryDatabases = dbs } MigrateCmdLine { migrateDatabase = Nothing } - | HM.null dbs = fail "No databases in registry" - | [(dbName, db)] <- HM.toList dbs = - do hPutStrLn stderr ("WARNING: No database specified, defaulting to '" ++ unDatabaseName dbName ++ "'") - pure db - | otherwise = fail ("Please specify database with the --database option") -lookupDb reg MigrateCmdLine { migrateDatabase = Just db } = - case HM.lookup db (migrationRegistryDatabases reg) of - Nothing -> fail ("No such database: " ++ unDatabaseName db) - Just db' -> pure db' - -lookupBranch :: MigrationRegistry -> Text -> Maybe MigrationBranch -lookupBranch reg branchNm = - find ((==branchNm) . migrationBranchName) (migrationRegistryBranches reg) - -lookupSchema :: UUID -> [MigrationFormat] -> MigrationRegistry -> Maybe RegisteredSchemaInfo -lookupSchema commitId fmts reg = - find (\sch -> registeredSchemaInfoHash sch == commitId && - all (`elem` registeredSchemaInfoFormats sch) fmts) - (migrationRegistrySchemas reg) - -lookupMigration :: UUID -> UUID -> [MigrationFormat] -> MigrationRegistry -> Maybe RegisteredMigrationInfo -lookupMigration from dest fmts reg = - find (\mig -> registeredMigrationInfoSource mig == from && - registeredMigrationInfoResult mig == dest && - all (`elem` registeredMigrationInfoFormats mig) fmts) - (migrationRegistryMigrations reg) - -newBaseBranch :: Text -> UUID -> MigrationRegistry -> IO MigrationRegistry -newBaseBranch branchName commit reg = - case find ((==branchName) . migrationBranchName) (migrationRegistryBranches reg) of - Just {} -> fail "Branch already exists" - Nothing -> do - putStrLn ("Created new branch " ++ unpack branchName) - let branch = MigrationBranch branchName commit - - pure reg { migrationRegistryBranches = branch:migrationRegistryBranches reg } - -updateBranch :: Text -> MigrationBranch -> MigrationRegistry -> IO MigrationRegistry -updateBranch branchNm newBranch reg = - case lookupBranch reg branchNm of - Nothing -> fail ("Cannot update branch " ++ T.unpack branchNm) - Just {} -> - pure reg { migrationRegistryBranches = - map (\br -> if migrationBranchName br == branchNm - then newBranch else br) - (migrationRegistryBranches reg) } - -newSchema :: UUID -> [MigrationFormat] -> Text -> MigrationRegistry -> IO MigrationRegistry -newSchema commitId fmts msg reg = - case lookupSchema commitId [] reg of - Just {} -> fail "Schema already exists" - Nothing -> do - userInfo <- lookupUserInfo reg - let schema = RegisteredSchemaInfo commitId userInfo msg fmts - pure reg { migrationRegistrySchemas = schema:migrationRegistrySchemas reg } - -newMigration :: UUID -> UUID -> [MigrationFormat] -> MigrationRegistry -> IO MigrationRegistry -newMigration from dest fmts reg = - case lookupMigration from dest [] reg of - Just {} -> fail "Migration alread exists" - Nothing -> - let mig = RegisteredMigrationInfo from dest fmts - in pure reg { migrationRegistryMigrations = mig:migrationRegistryMigrations reg} - -uuidToFileName :: UUID -> String -uuidToFileName = map (\c -> if c == '-' then '_' else c) . show - -schemaScriptName, schemaModuleName :: UUID -> String -schemaScriptName commitId = - "schema_" <> uuidToFileName commitId -schemaModuleName commitId = - "Schema_" <> uuidToFileName commitId - -migrationScriptName, migrationModuleName :: UUID -> UUID -> String -migrationScriptName fromId toId = - "migration_" <> uuidToFileName fromId <> "_to_" <> uuidToFileName toId -migrationModuleName fromId toId = - "Migration_" <> uuidToFileName fromId <> "_To_" <> uuidToFileName toId - -writeSchemaFile :: MigrateCmdLine -> MigrationRegistry -> String -> String -> String -> IO FilePath -writeSchemaFile _ reg extension fileNm content = do - let path = migrationRegistrySrcDir reg (fileNm <.> extension) - - putStrLn ("Writing schema to " ++ path ++ "...") - createDirectoryIfMissing True (migrationRegistrySrcDir reg) - writeFile path content - - pure path - -schemaFilePath :: MigrationRegistry -> UUID -> FilePath -schemaFilePath reg commitId = - migrationRegistrySrcDir reg schemaModuleName commitId <.> "hs" - -schemaFilePathForBackend :: Maybe SomeBeamMigrationBackend -> MigrationRegistry -> UUID -> FilePath -schemaFilePathForBackend Nothing reg commit = schemaFilePath reg commit -schemaFilePathForBackend (Just (SomeBeamMigrationBackend be)) reg commit = - migrationRegistrySrcDir reg schemaScriptName commit <.> backendFileExtension be - -registryNewCommitId :: MigrationRegistry -> IO UUID -registryNewCommitId reg = do - newCommitId <- UUID.nextRandom - case lookupSchema newCommitId [] reg of - Just {} -> registryNewCommitId reg - Nothing -> pure newCommitId - -registryHeadCommit :: MigrationRegistry -> UUID -registryHeadCommit reg = - case migrationRegistryHead reg of - MigrationHeadDetached commitId -> commitId - MigrationHeadBranch nm -> - case lookupBranch reg nm of - Nothing -> error "Cannot find branch" - Just branch -> migrationBranchCommit branch - --- hashToUUID :: Hashable a => a -> UUID --- hashToUUID a = --- let intSize = finiteBitSize (undefined :: Int) --- wordsNeeded = (128 + intSize - 1) `div` intSize - --- wordsData = take wordsNeeded (tail (iterate (\seed -> hashWithSalt seed a) 0)) - --- uuidData :: Integer --- uuidData = foldr (\w a' -> a' `shiftL` intSize .|. fromIntegral (fromIntegral w :: Word)) 0 wordsData - --- uuidWord1 = fromIntegral $ (uuidData `shiftR` 96) .&. 0xFFFFFFFF --- uuidWord2 = fromIntegral $ (uuidData `shiftR` 64) .&. 0xFFFFFFFF --- uuidWord3 = fromIntegral $ (uuidData `shiftR` 32) .&. 0xFFFFFFFF --- uuidWord4 = fromIntegral $ uuidData .&. 0xFFFFFFFF - --- in fromWords uuidWord1 uuidWord2 uuidWord3 uuidWord4 - -metadataComment :: String -> SchemaMetaData -> String -metadataComment commentMarker metadata = - let encoded = map BS.unpack (BS.lines (Yaml.encode metadata)) - in unlines ( [commentMarker <> " + BEAM-MIGRATE"] <> - map ((commentMarker <> " + ") <>) encoded <> - [commentMarker <> " + END-BEAM-MIGRATE"]) - -parseMetaData :: BeamDeserializers cmd -> Value -> Parser SchemaMetaData -parseMetaData d = - withObject "SchemaMetaData" $ \o -> - SchemaMetaData <$> o .: "commit" <*> o .: "formats" <*> o .: "createdOn" - <*> (Schema <$> (parseSchema =<< o .: "schema")) - where - parseSchema = - fmap mconcat . - mapM (withObject "SchemaMetaData.schema" $ \o -> - do specificity <- o .: "specificity" - predicates <- o .: "predicates" - -- TODO parse dummy if we can't parse - fmap (fmap (specificity,)) (mapM (beamDeserialize d) predicates)) - -predsForBackend :: BeamMigrationBackend be m -> [ (HS.HashSet PredicateSpecificity, SomeDatabasePredicate) ] - -> [ SomeDatabasePredicate ] -predsForBackend be = predsForBackendNamed (backendName be) - -predsForBackendNamed :: String -> [ (HS.HashSet PredicateSpecificity, SomeDatabasePredicate) ] - -> [SomeDatabasePredicate] -predsForBackendNamed be preds = - let ourSources = HS.fromList [ PredicateSpecificityAllBackends, PredicateSpecificityOnlyBackend be ] - applicablePreds = map snd (filter (not . HS.null . HS.intersection ourSources . fst) preds) - in applicablePreds - -withMetadata, withoutMetadata :: (Eq a, IsString a) => [a] -> [a] -withMetadata = - takeWhile (/="-- + END-BEAM-MIGRATE") . - dropWhile (/="-- + BEAM-MIGRATE") -withoutMetadata = - takeWhile (/="-- + BEAM-MIGRATE") - -readSchemaMetaData :: MigrationRegistry - -> BeamMigrationBackend be m - -> UUID - -> IO SchemaMetaData -readSchemaMetaData reg BeamMigrationBackend { backendPredicateParsers = parsers } commitId = do - d <- withMetadata . - BS.lines <$> - BS.readFile (schemaFilePath reg commitId) - case d of - [] -> fail "Invalid data in schema" - _:d' | Just realData <- BS.unlines <$> traverse (BS.stripPrefix "-- + ") d' - , Right metadataV <- Yaml.decodeEither' realData - -> case Yaml.parseEither (parseMetaData parsers) metadataV of - Left err -> fail ("Could not parse metadata: " ++ show err) - Right metadata -> pure metadata - | otherwise -> fail "Invalid data in schema" - -predicateFetchSourceBackend :: PredicateFetchSource -> Maybe ModuleName -predicateFetchSourceBackend (PredicateFetchSourceCommit be _) = be -predicateFetchSourceBackend (PredicateFetchSourceDbHead (MigrationDatabase be _) _) = Just be -predicateFetchSourceBackend PredicateFetchSourceEmpty = Nothing - -predicateSourceWithBackend :: ModuleName -> PredicateFetchSource -> PredicateFetchSource -predicateSourceWithBackend nm (PredicateFetchSourceCommit _ c) = PredicateFetchSourceCommit (Just nm) c -predicateSourceWithBackend nm (PredicateFetchSourceDbHead (MigrationDatabase _ conn) ref) = - PredicateFetchSourceDbHead (MigrationDatabase nm conn) ref -predicateSourceWithBackend _ PredicateFetchSourceEmpty = PredicateFetchSourceEmpty - -parsePredicateFetchSourceSpec :: MigrateCmdLine -> MigrationRegistry -> Text - -> IO PredicateFetchSource -parsePredicateFetchSourceSpec cmdLine reg t - | t == "0" = pure PredicateFetchSourceEmpty - | Just t' <- T.stripPrefix "HEAD" t = - let mod' = parsePredicateFetchSourceModulePart t' - in pure (PredicateFetchSourceCommit mod' (registryHeadCommit reg)) - | Just t' <- T.stripPrefix "DB" t = do - let (t'', db) = parsePredicateFetchSourceDbName t' - ref = parsePredicateFetchSourceDbRef t'' - db' <- - case db of - Nothing -> - case migrateDatabase cmdLine of - Nothing -> fail "Ambiguous database: DB given with no -d option or database specified" - Just cmdLineDb -> pure cmdLineDb - Just explicitDb -> pure explicitDb - - dbInfo <- lookupDb reg cmdLine { migrateDatabase = Just db' } - - pure (PredicateFetchSourceDbHead dbInfo ref) - | Just branchNm <- T.stripPrefix "branch/" t = do - let (branchNm', dbModNm) = T.breakOn "/" branchNm - case lookupBranch reg branchNm' of - Nothing -> fail ("No such branch: " ++ T.unpack branchNm') - Just branch -> do - let dbMod = if dbModNm == "" then Nothing else Just (ModuleName (T.unpack dbModNm)) - pure (PredicateFetchSourceCommit dbMod (migrationBranchCommit branch)) - | (commitIdTxt, dbModNm) <- T.breakOn "/" t - , Just commitId <- readMaybe (T.unpack commitIdTxt) = do - let dbMod = if T.null dbModNm then Nothing else Just (ModuleName (T.unpack (T.tail dbModNm))) - pure (PredicateFetchSourceCommit dbMod commitId) - | (t', rest) <- T.break (\c -> c == '/' || c == '!') t - , Just dbInfo <- HM.lookup (DatabaseName (T.unpack t')) (migrationRegistryDatabases reg) = - pure (PredicateFetchSourceDbHead dbInfo (parsePredicateFetchSourceDbRef rest)) - | otherwise = fail "Invalid predicate source spec" - - where - parsePredicateFetchSourceModulePart t' - | Just mod' <- T.stripPrefix "/" t' = Just (ModuleName (T.unpack mod')) - | otherwise = Nothing - parsePredicateFetchSourceDbName t' - | Just dbName <- T.stripPrefix "/" t' = - let (dbName', t'') = T.break (\c -> c == '/' || c == '!') dbName - in (t'', Just (DatabaseName (T.unpack dbName'))) - | otherwise = (t', Nothing) - parsePredicateFetchSourceDbRef "!" = Nothing - parsePredicateFetchSourceDbRef "" = Just 0 - parsePredicateFetchSourceDbRef dbRef - | (dbRef', "") <- T.span (=='^') dbRef = - Just (T.length dbRef') - | otherwise = error "Invalid dbref" - -registryMigrationGraph :: MigrationRegistry -> Gr RegisteredSchemaInfo RegisteredMigrationInfo -registryMigrationGraph reg = - let schemaIdxs = zip [0..] (migrationRegistrySchemas reg) - schemaIdToIdxMap = HM.fromList (map (\(i, schema) -> (registeredSchemaInfoHash schema, i)) schemaIdxs) - schemaIdToIdx = flip HM.lookup schemaIdToIdxMap - - migrations = mapMaybe (\mig -> (,,mig) <$> schemaIdToIdx (registeredMigrationInfoSource mig) - <*> schemaIdToIdx (registeredMigrationInfoResult mig)) - (migrationRegistryMigrations reg) - - in mkGraph schemaIdxs migrations - -sha256' :: BS.ByteString -> Word256 -sha256' d = let digest :: Crypto.Digest Crypto.SHA256 - digest = Crypto.hash d - in case filter (null . snd) (readHex (show digest)) of - [(x, _)] -> x - _ -> error "Can't parse digest" - -sha256 :: String -> Word256 -sha256 = sha256' . BS.pack - -abortEdits :: MigrateCmdLine -> Bool -> IO () -abortEdits cmdLine force = - updatingRegistry cmdLine (abortEdits' force) - -abortEdits' :: Bool -> MigrationRegistry -> IO ((), MigrationRegistry) -abortEdits' force reg = - let reg' = reg { migrationRegistryMode = BeamMigrateReady } - - tryAbort flNm flHash = do - flExists <- doesFileExist flNm - if flExists - then do - doDelete <- if force - then pure True - else do - flContents <- BS.readFile flNm - let actualHash = sha256' flContents - return (actualHash == flHash) - - if doDelete - then do - removeFile flNm - pure ((), reg') - else fail "WARNING: the editing files have been modified use '--force' to force abort" - else pure ((), reg') - in case migrationRegistryMode reg of - BeamMigrateReady -> pure ((), reg) - BeamMigrateEditingMigration tmpFile _ _ hash -> tryAbort tmpFile hash - BeamMigrateCreatingSchema tmpFile _ hash -> tryAbort tmpFile hash diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Schema.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Schema.hs deleted file mode 100644 index fcfdeadd..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Schema.hs +++ /dev/null @@ -1,480 +0,0 @@ -module Database.Beam.Migrate.Tool.Schema where - -import Prelude hiding (pred) - -import Database.Beam (Database) -import Database.Beam.Migrate.Tool.Backend -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Diff -import Database.Beam.Migrate.Tool.Registry -import Database.Beam.Migrate.Log - -import Database.Beam.Backend.SQL - -import Database.Beam.Migrate ( SomeDatabasePredicate(..) - , DatabasePredicate(..) - , PredicateSpecificity(..) - , MigrationCommand(..) - , CheckedDatabaseSettings - , collectChecks ) -import Database.Beam.Migrate.Actions -import Database.Beam.Migrate.Backend - -import Database.Beam.Haskell.Syntax - -import Control.Exception -import Control.Monad -import Control.Monad.Loops -import Control.Monad.State - -import qualified Data.ByteString.Char8 as BS -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as HS -import Data.Maybe -#if !MIN_VERSION_base(4, 11, 0) -import Data.List -import Data.Monoid -#endif -import Data.Proxy -import Data.String (fromString) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Time -import Data.Typeable -import Data.UUID (UUID) -import qualified Data.UUID as UUID (nil) -import qualified Data.Yaml as Yaml - -import Language.Haskell.Interpreter hiding (ModuleName, get, set) -import qualified Language.Haskell.Interpreter as GHCI -import qualified Language.Haskell.Exts as Hs - -import System.Directory -import System.FilePath -import System.IO - -import Text.Editor - -modifyM :: Functor m => (s -> m s) -> StateT s m () -modifyM f = StateT $ fmap ((),) . f - -withRegistry :: Monad m => (MigrationRegistry -> StateT MigrationRegistry m a) -> StateT MigrationRegistry m a -withRegistry f = get >>= f - -importDb :: MigrateCmdLine -> DatabaseName -> Maybe Text -> Bool -> Bool -> IO () -importDb cmdLine dbName@(DatabaseName dbNameStr) branchName doDbCommit autoCreateMigration = - updatingRegistry cmdLine . runStateT $ do - branchName' <- case branchName of - Nothing -> do - regHead <- gets migrationRegistryHead - case regHead of - MigrationHeadDetached {} -> fail "Cannot import into detached HEAD" - MigrationHeadBranch nm -> pure nm - Just nm -> pure nm - - (db, backendMigFmt, backend) <- withRegistry $ \registry -> lift $ loadBackend cmdLine registry dbName - - case backend of - SomeBeamMigrationBackend be@(BeamMigrationBackend { backendConvertToHaskell = HaskellPredicateConverter convDbPred - , backendTransact = transact - , backendActionProvider = actionProvider }) -> do - newCommit <- withRegistry $ \registry -> lift (registryNewCommitId registry) - let backendHash = newCommit - hsHash = newCommit - - (_, cs) <- withRegistry $ \registry -> liftIO (getPredicatesFromSpec cmdLine registry (PredicateFetchSourceDbHead db Nothing)) - - when autoCreateMigration $ do - registry <- get - oldPreds <- liftIO ((Just <$> getPredicatesFromSpec cmdLine registry - (PredicateFetchSourceDbHead db (Just 0))) - `catch` (\NoRecordedSchemas -> pure Nothing)) - - -- Generate haskell and backend migration - case oldPreds of - Nothing -> liftIO $ putStrLn "Skipping migration generation, since this is an initial import" - Just (Nothing, _) -> fail "No commit for DB^" - Just (Just oldCommitId, oldPreds') -> - let solver = heuristicSolver actionProvider oldPreds' cs - in case finalSolution solver of - Candidates {} -> fail "Could not find migration in backend" - Solved [] -> fail "Schemas are equivalent, not importing" - Solved cmds' -> do - let cmds = fmap migrationCommand cmds' - liftIO . void $ writeMigration cmdLine registry be oldCommitId newCommit cmds - modifyM (newMigration oldCommitId hsHash [MigrationFormatHaskell, backendMigFmt]) - - -- TODO factor out - let schema = Schema (map (\pred@(SomeDatabasePredicate (_ :: pred)) -> ( HS.singleton (predicateSpecificity (Proxy @pred)), pred)) cs) - - liftIO $ putStrLn "Exporting migration for backend..." - backendFileName <- withRegistry $ \registry -> liftIO (writeSchema cmdLine registry backendHash be cs) - liftIO (putStrLn ("Exported migration as " ++ backendFileName)) - - cs' <- lift . fmap catMaybes . - forM cs $ \c -> do - let c' = convDbPred c - case c' of - Nothing -> putStrLn ("Tossing constraint " ++ show c) - Just {} -> pure () - pure c' - - liftIO $ putStrLn "Exporting haskell schema..." - hsFileName <- withRegistry $ \registry -> liftIO $ writeHsSchema cmdLine registry hsHash cs' schema [ backendMigFmt ] - liftIO $ putStrLn ("Exported haskell migration as " ++ hsFileName) - - liftIO $ putStrLn "Import complete" - - let msg = "Initial import of " <> fromString dbNameStr - - when doDbCommit $ - liftIO $ reportDdlErrors $ transact (migrationDbConnString db) $ recordCommit newCommit - - modifyM (newSchema hsHash [MigrationFormatHaskell, backendMigFmt] msg) - - modifyM (\registry -> - case lookupBranch registry branchName' of - Nothing -> - newBaseBranch branchName' hsHash registry - Just branch -> - updateBranch branchName' (branch { migrationBranchCommit = hsHash }) registry) - -dumpSchema :: MigrateCmdLine - -> ModuleName - -> String - -> IO () -dumpSchema cmdLine backend connStr = do - backend' <- loadBackend' cmdLine backend - case backend' of - SomeBeamMigrationBackend (BeamMigrationBackend { backendGetDbConstraints = getConstraints - , backendTransact = transact }) -> do - cs <- transact connStr getConstraints - case cs of - Left err -> fail ("Error getting constraints: " ++ show err) - Right cs' -> - let sch = Schema (map (\c -> (HS.singleton predSrc, c)) cs') - predSrc = PredicateSpecificityOnlyBackend (unModuleName backend) - in BS.putStrLn (Yaml.encode sch) - -showSimpleSchema :: MigrateCmdLine - -> ModuleName - -> String - -> SchemaKind - -> IO () -showSimpleSchema cmdLine backend connStr schemaKind = do - backend' <- loadBackend' cmdLine backend - case backend' of - SomeBeamMigrationBackend (BeamMigrationBackend { backendGetDbConstraints = getConstraints - , backendConvertToHaskell = HaskellPredicateConverter convDbPred - , backendTransact = transact - , backendActionProvider = actionProvs - , backendRenderSyntax = renderSyntax }) -> do - cs <- transact connStr getConstraints - case cs of - Left err -> fail ("Error getting constraints: " ++ show err) - Right cs' -> - case schemaKind of - YamlSchema -> - let sch = Schema (map (\c -> (HS.singleton predSrc, c)) cs') - predSrc = PredicateSpecificityOnlyBackend (unModuleName backend) - in BS.putStrLn (Yaml.encode sch) - BackendSchema -> do - case finalSolution $ heuristicSolver actionProvs [] cs' of - Candidates {} -> fail "Could not form native schema" - Solved actions -> - putStrLn (unlines (map renderSyntax (fmap migrationCommand actions))) - HsSchema -> do - cs'' <- fmap catMaybes . - forM cs' $ \c -> do - let c' = convDbPred c - case c' of - Nothing -> putStrLn ("Tossing constraint " ++ show c) - Just {} -> pure () - pure c' - case finalSolution $ heuristicSolver (defaultActionProvider @HsMigrateBackend) [] cs'' of - Candidates {} -> fail "Could not form haskell schema" - Solved actions -> - case renderHsSchema (hsActionsToModule "Schema" (fmap migrationCommand actions)) of - Left err -> fail ("Could not render schema: " ++ err) - Right sch -> putStrLn sch - -writeSchema :: MigrateCmdLine -> MigrationRegistry - -> UUID -> BeamMigrationBackend be m - -> [SomeDatabasePredicate] - -> IO FilePath -writeSchema cmdLine registry commitId be cs = do - case finalSolution $ heuristicSolver (backendActionProvider be) [] cs of - Candidates {} -> fail "Could not form backend schema" - Solved actions -> - writeSchemaFile cmdLine registry (backendFileExtension be) (schemaScriptName commitId) $ - unlines (map (backendRenderSyntax be) (fmap migrationCommand actions)) - -writeHsSchema :: MigrateCmdLine -> MigrationRegistry - -> UUID - -> [SomeDatabasePredicate] - -> Schema - -> [MigrationFormat] -> IO FilePath -writeHsSchema cmdLine registry commitId cs dbSchema fmts = - case finalSolution $ heuristicSolver (defaultActionProvider @HsMigrateBackend) [] cs of - Candidates [] -> fail "Could not form haskell schema" - Candidates (x:_) -> - let allSolved = dbStateCurrentState x - allDesired = Map.fromList (map (,()) cs) - left = allDesired `Map.difference` allSolved - in putStrLn "Left" >> mapM_ (putStrLn . show . fst) (Map.toList left) >> fail ("Some predicates left ") - Solved actions -> do - metadata <- SchemaMetaData <$> pure commitId <*> pure fmts <*> getCurrentTime <*> pure dbSchema - writeHsSchemaFile cmdLine registry commitId metadata $ - let modName = unModuleName (migrationRegistrySchemaModule registry) <> "." <> schemaModuleName commitId - in case renderHsSchema (hsActionsToModule modName (fmap migrationCommand actions)) of - Left err -> error ("Could not render schema: " ++ err) - Right sch -> sch ++ "\n\n" ++ - metadataComment "--" metadata - -writeHsSchemaFile :: MigrateCmdLine -> MigrationRegistry -> UUID - -> SchemaMetaData -> String -> IO FilePath -writeHsSchemaFile cmdLine registry commitId metadata modStr = - writeSchemaFile cmdLine registry "hs" (schemaModuleName commitId) - (modStr ++ "\n\n" ++ metadataComment "--" metadata) - -writeMigration :: MigrateCmdLine -> MigrationRegistry - -> BeamMigrationBackend be m - -> UUID -> UUID - -> [ BeamSqlBackendSyntax be ] - -> IO FilePath -writeMigration cmdLine reg be fromId toId cmds = - case be of - BeamMigrationBackend { backendRenderSyntax = renderCmd - , backendFileExtension = fileExtension } -> - writeSchemaFile cmdLine reg fileExtension (migrationScriptName fromId toId) $ - unlines (map renderCmd cmds) - --- * Schema new command - -renamedSchemaModule :: FilePath -> String -> String -> IO String -renamedSchemaModule srcFile modName modSrc = do - let parseMode = Hs.defaultParseMode { Hs.parseFilename = srcFile - , Hs.extensions = map Hs.EnableExtension $ - [ Hs.ExplicitNamespaces, Hs.StandaloneDeriving - , Hs.TypeFamilies, Hs.ExplicitForAll - , Hs.MultiParamTypeClasses, Hs.TypeApplications ] } - case Hs.parseModuleWithComments parseMode modSrc of - Hs.ParseFailed loc err -> do - hPutStrLn stderr (show loc ++ ": " ++ err) - fail "Could not parse schema module" - Hs.ParseOk (srcMod, comments) -> - let srcMod' = renameModule modName srcMod - modStr = Hs.exactPrint srcMod' comments - in pure modStr - -renameModule :: String -> Hs.Module a -> Hs.Module a -renameModule modName (Hs.Module l (Just (Hs.ModuleHead l' (Hs.ModuleName l'' _) warning exports)) - pragmas imports decls) = - Hs.Module l (Just (Hs.ModuleHead l' (Hs.ModuleName l'' modName) warning exports)) - pragmas imports decls -renameModule _ _ = error "Could not rename module" - -beginNewSchema :: MigrateCmdLine -> Text -> FilePath -> IO () -beginNewSchema cmdLine tmplSrc tmpFile = do - updatingRegistry cmdLine $ \reg -> do - assertRegistryReady reg - - tmpFileExists <- doesFileExist tmpFile - when tmpFileExists (fail (tmpFile ++ ": already exists... aborting")) - - predSrc <- parsePredicateFetchSourceSpec cmdLine reg tmplSrc - src <- case predSrc of - PredicateFetchSourceDbHead {} -> fail "Cannot base schema off database. Import the database first" - PredicateFetchSourceCommit _ schema -> pure (Just schema) - PredicateFetchSourceEmpty -> pure Nothing - - let modName = unModuleName (migrationRegistrySchemaModule reg) <> "." <> - schemaModuleName UUID.nil - - hsModSrc <- - case src of - Nothing -> - case renderHsSchema (hsActionsToModule modName []) of - Left err -> fail ("Could not render empty schema: " ++ err) - Right sch -> pure (BS.pack sch) - Just srcSchema -> - case lookupSchema srcSchema [MigrationFormatHaskell] reg of - Nothing -> fail "Specified schema does not exist" - Just {} -> do - let srcSchemaFilePath = migrationRegistrySrcDir reg schemaModuleName srcSchema <.> "hs" - schemaExists <- doesFileExist srcSchemaFilePath - when (not schemaExists) (fail (show srcSchemaFilePath ++ ": could not find haskell source")) - - -- read schema module - BS.readFile srcSchemaFilePath - - let noMetadata = BS.unpack (BS.unlines (withoutMetadata (BS.lines hsModSrc))) - - modStr <- renamedSchemaModule tmpFile modName noMetadata - let hash = sha256 modStr - - putStrLn ("Writing temporary schema based off of commit " ++ show src ++ "...") - writeFile tmpFile modStr - - putStrLn ("You can now edit the schema at " ++ tmpFile) - putStrLn "When you are done, run 'beam-migrate schema commit' to commit the schema to the registry." - - pure ((), reg { migrationRegistryMode = BeamMigrateCreatingSchema tmpFile src hash }) - - -loadSchema :: forall be m a - . ModuleName -> BeamMigrationBackend be m - -> MigrateCmdLine -> MigrationRegistry -> FilePath - -> (forall be' db. Database be' db => CheckedDatabaseSettings be' db -> IO a) - -> IO a -loadSchema backendModule (BeamMigrationBackend {}) cmdLine reg modPath withDb = do - putStrLn ("Loading module " ++ unModuleName backendModule) - res <- runBeamInterpreter cmdLine $ do - loadModules [ modPath ] - setImportsQ [ ("Database.Beam.Migrate", Just "BeamMigrate") - , ("Database.Beam.Migrate.Backend", Nothing) - , (unModuleName backendModule, Just "BeamBackend") ] - - let beName = tyConName (typeRepTyCon (typeRep (Proxy @be))) - - setTopLevelModules [ unModuleName (migrationRegistrySchemaModule reg) <> "." <> schemaModuleName UUID.nil ] - GHCI.set [ languageExtensions := [ TypeApplications ] ] - interpret ("SomeCheckedDatabaseSettings (BeamMigrate.runMigrationSilenced (migration @BeamBackend." <> beName <> "))") (undefined :: SomeCheckedDatabaseSettings) - - case res of - Left e -> reportHintError e - Right (SomeCheckedDatabaseSettings db) -> - withDb db - -ensureCommitMsg :: Maybe Text -> IO Text -ensureCommitMsg Nothing = do - time <- getCurrentTime - T.strip . TE.decodeUtf8 <$> runUserEditorDWIM txtTemplate (fromString ("New schema created at " <> show time)) -ensureCommitMsg (Just msg) = pure msg - -normalizePredicates :: (SomeBeamMigrationBackend, ModuleName, HS.HashSet SomeDatabasePredicate) - -> Map.HashMap SomeDatabasePredicate PredicateSpecificity -normalizePredicates (SomeBeamMigrationBackend be, _, preds) = - let predList = HS.toList preds - bestPreds = - fmap (\pred@(SomeDatabasePredicate (p :: p)) -> - case predicateSpecificity (Proxy :: Proxy p) of - PredicateSpecificityAllBackends -> - case be of - BeamMigrationBackend { backendConvertToHaskell = HaskellPredicateConverter conv2Hs } -> - fromMaybe (pred, PredicateSpecificityAllBackends) $ - do pred'@(SomeDatabasePredicate p') <- conv2Hs pred - guard (serializePredicate p == serializePredicate p') - pure (pred', PredicateSpecificityAllBackends) - spec@(PredicateSpecificityOnlyBackend _) -> (pred, spec)) predList - in Map.fromList bestPreds - -commitSchema :: MigrateCmdLine -> Bool -> Bool -> Maybe Text -> IO () -commitSchema cmdLine force overwrite commitMsg = - updatingRegistry cmdLine $ \reg -> do - case migrationRegistryMode reg of - BeamMigrateCreatingSchema tmpFile src initialHash -> do - contents <- readFile tmpFile - let curHash = sha256 contents - - if curHash == initialHash - then do - putStrLn "No changes were made to schema, so no commit is being made" - putStrLn ("We are still at " ++ show (registryHeadCommit reg)) - - abortEdits' True reg - - else do - -- Validate the schema by attempting to load it in hint, and collecting the checks. - -- Then, diff the checks with the current schema. - -- If they are the same, output a warning message, but don't do anything - -- If they are different, then commit the schema to the current branch and make it the HEAD of the current branch - - - let allBackends = fmap ModuleName . HS.toList $ - foldMap (\MigrationDatabase { migrationDbBackend = ModuleName nm } -> - HS.singleton nm) $ - migrationRegistryDatabases reg - - predsInBackend backendModule = do - someBe@(SomeBeamMigrationBackend be) <- loadBackend' cmdLine backendModule - destinationPreds <- loadSchema backendModule be cmdLine reg tmpFile - (\schema -> pure (collectChecks schema)) - pure (someBe, backendModule, HS.fromList destinationPreds) - - predsInBackends <- mapM predsInBackend allBackends - - let predsDifferentForBackend src' (SomeBeamMigrationBackend be, backendModule, destinationPreds) = do - initialPreds <- predsForBackend be . schemaPredicates . schemaMetaDataSchema <$> - readSchemaMetaData reg be src' - - pure (HS.fromList initialPreds /= destinationPreds) - - finishSchemaCommit = - case migrationRegistryHead reg of - MigrationHeadDetached _ -> - fail "Cannot commit atop detached branch. Please check out a branch and then commit" - MigrationHeadBranch branchNm -> - case lookupBranch reg branchNm of - Nothing -> fail ("Cannot commit atop non-existent branch: " ++ T.unpack branchNm) - Just branch -> do - let schemaPreds = foldr (Map.unionWith mappend) mempty $ - fmap (fmap HS.singleton . normalizePredicates) $ - predsInBackends - - schemaDesc = Schema $ - fmap (\(pred, spec) -> (spec, pred)) $ - Map.toList $ schemaPreds - - commitMsg' <- ensureCommitMsg commitMsg - - -- Add the schema - newSchemaId <- registryNewCommitId reg - curTime <- getCurrentTime - let newModFullName = unModuleName (migrationRegistrySchemaModule reg) <> "." <> newModName - newModName = schemaModuleName newSchemaId - - schemaMetaData = SchemaMetaData newSchemaId [ MigrationFormatHaskell ] curTime schemaDesc - - newSchemaModStr <- renamedSchemaModule tmpFile newModFullName - (unlines (withoutMetadata (lines contents))) - - _ <- writeHsSchemaFile cmdLine reg newSchemaId schemaMetaData newSchemaModStr - - reg' <- newSchema newSchemaId [MigrationFormatHaskell] commitMsg' reg - reg'' <- updateBranch branchNm (branch { migrationBranchCommit = newSchemaId }) reg' - abortEdits' True reg'' - - schemaChangedSignificantly <- - maybe (pure True) - (\src' -> anyM (predsDifferentForBackend src') predsInBackends) - src - if not schemaChangedSignificantly && not force - then if overwrite - then finishSchemaCommit - else do - putStrLn (unlines [ "The schema was edited, but the new schema is identical to the last." - , "beam-migrate has decided to do nothing. Here is what you can do:" - , "" - , " 1. If you intend to update the schema, edit the schema file so that it " - , " is different than the original." - , "" - , " 2. If you no longer want to add a new schema, use 'beam-migrate abort'." - , "" - , " 3. If you want to commit this schema as a new schema anyway, add the " - , " '--force' option to the commit command." - , "" - , " 4. If you want to *overwrite* the schema in the given database, add the " - , " '--overwrite' option to the commit command. This can be dangerous." - , "" - , "For now, the registry is left in-tact, you can still edit the file at" - , " " ++ tmpFile - , "to make changes." - ]) - - pure ((), reg) - else finishSchemaCommit - - _ -> fail (mconcat [ "There is no schema to commit. " - , "Run 'beam-migrate schema new' to start working on a new schema" ]) diff --git a/beam-migrate-cli/Database/Beam/Migrate/Tool/Status.hs b/beam-migrate-cli/Database/Beam/Migrate/Tool/Status.hs deleted file mode 100644 index e73c37c7..00000000 --- a/beam-migrate-cli/Database/Beam/Migrate/Tool/Status.hs +++ /dev/null @@ -1,146 +0,0 @@ -module Database.Beam.Migrate.Tool.Status where - -import Database.Beam.Migrate.Backend -import Database.Beam.Migrate.Log -import Database.Beam.Migrate.Tool.Backend -import Database.Beam.Migrate.Tool.CmdLine -import Database.Beam.Migrate.Tool.Diff -import Database.Beam.Migrate.Tool.Registry - -import Data.Text (unpack) -import qualified Data.Text as T -import Data.Time (LocalTime) -import Data.UUID (UUID) - -import System.Console.ANSI - -import Text.Read - -data MigrateStatus - = MigrateStatusNoCommits Bool {- whether the schema has been created or not -} - | MigrateStatusAtBranch UUID LocalTime PredicateDiff - deriving Show - -displayMigrateStatus :: MigrateCmdLine -> MigrationRegistry - -> DatabaseName -> MigrateStatus - -> IO () -displayMigrateStatus _ reg dbName sts = do - putStrLn ("Status for '" ++ unDatabaseName dbName ++ "':\n") - let curHead = registryHeadCommit reg - case sts of - MigrateStatusNoCommits _ -> - putStr . unlines $ - [ "No commit history in this database." - , "" - , "You have some choices: " - , "" - , " 1. Run 'beam-migrate database match -d DBNAME' to attempt to determine" - , " which commit this database is at. If you have a good idea of which" - , " commit we're at, run " - , " 'beam-migrate database match -d DBNAME --hint COMMIT'" - , "" - , " 2. Run 'beam-migrate import -d DBNAME --commit' to import the current" - , " database state as a new migration from the empty state." - , "" - , " 3. Run 'beam-migrate migrate --auto -d DBNAME COMMIT' to generate a" - , " commit for the current database, and then an automatic migration" - , " from that commit to the commit specified." ] - MigrateStatusAtBranch branchId timestamp (PredicateDiff expected actual) -> - case lookupSchema branchId [] reg of - Nothing -> - putStrLn . unlines $ - [ "At commit " ++ show branchId ++ ", which is not registered in " - , "the registry." - , "" - , "This usually happens because this database is managed by another" - , "beam-migrate registry. Are you running 'beam-migrate' from the" - , "right directory?" ] - Just sch -> do - putStrLn ("At commit " ++ show branchId ++ "\n") - showCommit timestamp sch - - let green x = setSGRCode [ SetColor Foreground Dull Green ] ++ x ++ setSGRCode [ Reset ] - yellow x = setSGRCode [ SetColor Foreground Dull Yellow ] ++ x ++ setSGRCode [ Reset ] - red x = setSGRCode [ SetColor Foreground Dull Red ] ++ x ++ setSGRCode [ Reset ] - if expected == actual - then putStrLn (green "Database matches its latest schema\n") - else putStrLn (red "Database differs from registered schema.\nRun 'beam-migrate diff' for a full diff\n") - - if curHead /= branchId - then do - putStrLn (yellow "The database is at schema " ++ show branchId) - putStrLn (yellow " but beam-migrate HEAD is at " ++ show curHead) - putStrLn "\nRun 'beam-migrate migrate' to move this database to the current HEAD" - else putStrLn "Everything is up-to-date" - -showCommit :: LocalTime -> RegisteredSchemaInfo -> IO () -showCommit atTime sch = do - let green x = setSGRCode [ SetColor Foreground Dull Green ] ++ x ++ setSGRCode [ Reset ] - putStrLn . unlines $ - [ setSGRCode [ SetColor Foreground Dull Yellow ] ++ "schema " ++ show (registeredSchemaInfoHash sch) - , green "Date" ++ ": " ++ show atTime - , green "Commiter" ++ ": " ++ unpack (userInfoCommitter (registeredSchemaInfoCommitter sch)) - , green "Formats" ++ ": " ++ - showMigrationFormats (registeredSchemaInfoFormats sch) ] - putStrLn (T.unpack . T.unlines . map (" " <>) . - T.lines . registeredSchemaInfoMessage $ sch) - -hasBackendTables :: String -> BeamMigrationBackend be m -> IO Bool -hasBackendTables connStr be@BeamMigrationBackend { backendTransact = transact } = - do res <- transact connStr (checkForBackendTables be) - case res of - Left err -> fail ("hasBackendTables: " ++ show err) - Right x -> pure x - -getStatus :: MigrateCmdLine -> MigrationRegistry -> DatabaseName -> IO MigrateStatus -getStatus cmdLine reg dbName = do - (db, _, SomeBeamMigrationBackend be) <- loadBackend cmdLine reg dbName - hasSchema <- hasBackendTables (migrationDbConnString db) be - if not hasSchema - then do - putStrLn "WARNING: Beam migrate not installed in this database. Run" - putStrLn "WARNING:" - putStrLn ("WARNING: beam-migrate database upgrade " ++ unDatabaseName dbName) - putStrLn "WARNING:" - putStrLn "WARNING: to build the beam tables in the database" - pure (MigrateStatusNoCommits False) - else case be of - BeamMigrationBackend { backendTransact = transact } -> do - logEntry <- reportDdlErrors (transact (migrationDbConnString db) getLatestLogEntry) - case logEntry of - Nothing -> pure (MigrateStatusNoCommits True) - Just logEntry' -> - case readMaybe (unpack (_logEntryCommitId logEntry')) of - Nothing -> fail "Invalid commit id for last log entry" - Just commitId -> do - diff <- genDiffFromSources cmdLine reg - (PredicateFetchSourceDbHead db Nothing) - (PredicateFetchSourceCommit (Just (migrationDbBackend db)) commitId) - pure (MigrateStatusAtBranch commitId (_logEntryDate logEntry') diff) - -displayStatus :: MigrateCmdLine -> IO () -displayStatus MigrateCmdLine { migrateDatabase = Nothing } = - fail "No database specified" -displayStatus cmdLine@(MigrateCmdLine { migrateDatabase = Just dbName }) = do - reg <- lookupRegistry cmdLine - - case migrationRegistryMode reg of - BeamMigrateReady -> - putStrLn (setSGRCode [ SetColor Foreground Dull Green ] ++ - "(ready to perform migrations)") - BeamMigrateCreatingSchema {} -> - putStrLn (setSGRCode [ SetColor Foreground Dull Red ] ++ - "beam-migrate is currently in the process of creating a schema.\n" ++ - "Use 'beam-migrate abort' to abort the schema creation process.\n" ++ - "Some commands will not proceed with a pending schema edit.") - BeamMigrateEditingMigration {} -> - putStrLn (setSGRCode [ SetColor Foreground Dull Red ] ++ - "beam-migrate is currently in the process of editing a migration.\n" ++ - "Use 'beam-migrate abort' to abort the migration editing process.\n" ++ - "Some commands will not proceed with a pending migration edit.") - - putStrLn (setSGRCode [Reset]) - - migrateStatus <- getStatus cmdLine reg dbName - - displayMigrateStatus cmdLine reg dbName migrateStatus diff --git a/beam-migrate-cli/LICENSE b/beam-migrate-cli/LICENSE deleted file mode 100644 index 20e61c36..00000000 --- a/beam-migrate-cli/LICENSE +++ /dev/null @@ -1,8 +0,0 @@ -The MIT License (MIT) -Copyright (c) 2017-2018 Travis Athougies - -Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/beam-migrate-cli/beam-migrate-cli.cabal b/beam-migrate-cli/beam-migrate-cli.cabal deleted file mode 100644 index 82eb0d8e..00000000 --- a/beam-migrate-cli/beam-migrate-cli.cabal +++ /dev/null @@ -1,77 +0,0 @@ --- Initial beam-migrate-cli.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: beam-migrate-cli -version: 0.2.1.0 -synopsis: CLI tool for beam-migrate -homepage: https://travis.athougies.net/projects/beam.html -license: MIT -license-file: LICENSE -author: Travis Athougies -maintainer: travis@athougies.net -category: Database -build-type: Simple -cabal-version: >=1.10 - -executable beam-migrate - main-is: BeamMigrate.hs - other-modules: Database.Beam.Migrate.Tool.CmdLine - Database.Beam.Migrate.Tool.Registry - Database.Beam.Migrate.Tool.Backend - Database.Beam.Migrate.Tool.Schema - Database.Beam.Migrate.Tool.MigrationCmd - Database.Beam.Migrate.Tool.Branch - Database.Beam.Migrate.Tool.Database - Database.Beam.Migrate.Tool.Init - Database.Beam.Migrate.Tool.Status - Database.Beam.Migrate.Tool.Diff - Database.Beam.Migrate.Tool.Log - Database.Beam.Migrate.Tool.Migrate - build-depends: base >=4.9 && <5.0, - beam-core >=0.10 && <0.11, - beam-migrate >=0.4 && <0.6, - text >=1.2 && <2.1, - bytestring >=0.10 && <0.12, - time >=1.6 && <1.13, - optparse-applicative >=0.13 && <0.18, - directory >=1.2 && <1.4, - filepath >=1.4 && <1.5, - largeword >=1.2 && <1.3, - mtl >=2.2 && <2.3, - fgl >=5.5 && <5.8, - containers >=0.5 && <0.7, - unordered-containers >=0.2 && <0.3, - hashable >=1.2 && <1.5, - aeson >=0.11 && <2.2, - unix >=2.7 && <2.8, - network >=2.6 && <3.2, - hostname >=1.0 && <=2.0, - yaml >=0.8 && <0.12, - uuid >=1.3 && <1.4, - hint >=0.6 && <0.10, - random >=1.1 && <1.3, - ansi-terminal >=0.6 && <0.12, - haskell-src-exts >=1.18 && <1.24, - cryptonite >=0.23 && <0.31, - monad-loops >=0.4 && <0.5, - exceptions >=0.8 && <0.11, - editor-open >=0.6 && <0.7, - split >=0.2 && <0.3 - default-language: Haskell2010 - default-extensions: KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts, - StandaloneDeriving, GADTs, DeriveFunctor, RankNTypes, ScopedTypeVariables, - FlexibleInstances, TypeOperators, TypeApplications, MultiParamTypeClasses, - DataKinds, DeriveGeneric, CPP, LambdaCase, RecordWildCards, TupleSections - ghc-options: -Wall -dynamic -threaded - if flag(werror) - ghc-options: -Werror - -flag werror - description: Enable -Werror during development - default: False - manual: True - -source-repository head - type: git - location: https://github.com/haskell-beam/beam.git - subdir: beam-migrate-cli diff --git a/beam-migrate/Database/Beam/Migrate/Backend.hs b/beam-migrate/Database/Beam/Migrate/Backend.hs index 0a00709a..64696a73 100644 --- a/beam-migrate/Database/Beam/Migrate/Backend.hs +++ b/beam-migrate/Database/Beam/Migrate/Backend.hs @@ -7,8 +7,6 @@ -- -- 1. Ensure the command syntax for your backend satisfies 'Sql92SaneDdlCommandSyntax'. -- 2. Create a value of type 'BeamMigrationBackend' --- 3. For compatibility with @beam-migrate-cli@, export this value in an --- exposed module with the name 'migrationBackend'. -- -- This may sound trivial, but it's a bit more involved. In particular, in order -- to complete step 2, you will have to define several instances for some of @@ -24,8 +22,7 @@ -- -- Tools may be interested in the 'SomeBeamMigrationBackend' data type which -- provides a monomorphic type to wrap the polymorphic 'BeamMigrationBackend' --- type. Currently, @beam-migrate-cli@ uses this type to get the underlying --- 'BeamMigrationBackend' via the @hint@ package. +-- type. -- -- For an example migrate backend, see "Database.Beam.Sqlite.Migrate" module Database.Beam.Migrate.Backend diff --git a/beam-migrate/Database/Beam/Migrate/Log.hs b/beam-migrate/Database/Beam/Migrate/Log.hs index 2c324493..ba02d1d9 100644 --- a/beam-migrate/Database/Beam/Migrate/Log.hs +++ b/beam-migrate/Database/Beam/Migrate/Log.hs @@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- | Contains a schema for beam migration tools. Used by the CLI and +-- | Contains a schema for beam migration tools. Used by -- the managed migrations support here. module Database.Beam.Migrate.Log where diff --git a/beam-migrate/README.md b/beam-migrate/README.md index 79c6b5ec..a5085765 100644 --- a/beam-migrate/README.md +++ b/beam-migrate/README.md @@ -10,8 +10,3 @@ automatic generation of migrations in SQL and Haskell formats. This is mostly a low-level support library. Most often, this library is used to write tooling to support DDL manipulation in your project, or to enable migrations support in beam backends. - -For a more turnkey solution for database migrations, consider -the [beam-migrate](../beam-migrate-cli) command line tool. This provides -out-of-the-box support for migrations, schema change management, and version -control, based on the features provided in this library. diff --git a/beam-migrate/beam-migrate.cabal b/beam-migrate/beam-migrate.cabal index c37b5029..f9812fa3 100644 --- a/beam-migrate/beam-migrate.cabal +++ b/beam-migrate/beam-migrate.cabal @@ -13,12 +13,6 @@ description: This package provides type classes to allow backends to imp library is used to write tooling to support DDL manipulation in your project, or to enable migrations support in beam backends. - For a more turnkey solution for database migrations, consider - the - command line tool. This provides out-of-the-box support for migrations, - schema change management, and version control, based on the features - provided in this library. - homepage: https://travis.athougies.net/projects/beam.html license: MIT license-file: LICENSE diff --git a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs index d4fd748a..de623465 100644 --- a/beam-sqlite/Database/Beam/Sqlite/Migrate.hs +++ b/beam-sqlite/Database/Beam/Sqlite/Migrate.hs @@ -3,8 +3,7 @@ -- | Migrations support for SQLite databases module Database.Beam.Sqlite.Migrate - ( -- * @beam-migrate@ CLI support - migrationBackend, SqliteCommandSyntax + ( migrationBackend, SqliteCommandSyntax -- * @beam-migrate@ utility functions , migrateScript, writeMigrationScript @@ -48,8 +47,7 @@ import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Encoding as TE --- | Top-level 'Tool.BeamMigrationBackend' loaded dynamically by the --- @beam-migrate@ CLI tool. +-- | Top-level 'Tool.BeamMigrationBackend' migrationBackend :: Tool.BeamMigrationBackend Sqlite SqliteM migrationBackend = Tool.BeamMigrationBackend "sqlite" diff --git a/cabal.project b/cabal.project index 43f47cd7..ee19d1d6 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,5 @@ packages: beam-core beam-migrate - beam-migrate-cli beam-postgres beam-sqlite diff --git a/docs/about/faq.md b/docs/about/faq.md index 0e8864e3..2d97b85b 100644 --- a/docs/about/faq.md +++ b/docs/about/faq.md @@ -38,10 +38,7 @@ function, you can make that query polymorphic over a choice in backend by using the `IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax` class. You can freely mix and match backends at any time (well, within -the realms of possibility in terms of Haskell polymorphism). For -example, the `beam-migrate` CLI tool loads backends at run-time and -issues queries against them, without knowing the specifics of any -particular backend. +the realms of possibility in terms of Haskell polymorphism). Finally, beam produces readable queries. Here is what opaleye produces on a left join: diff --git a/docs/schema-guide/library.md b/docs/schema-guide/library.md deleted file mode 100644 index a23e5fb9..00000000 --- a/docs/schema-guide/library.md +++ /dev/null @@ -1 +0,0 @@ -supported diff --git a/docs/schema-guide/migrations.md b/docs/schema-guide/migrations.md index 178d5b1d..9e3e52d2 100644 --- a/docs/schema-guide/migrations.md +++ b/docs/schema-guide/migrations.md @@ -41,41 +41,11 @@ checked type becomes `[TableExistsPredicate "table", TableHasColumn "table" !!! note "Note" The types are a bit more complicated than what they appear. In particular, a predicate can be of any type that satisfies the `DatabasePredicate` type - class. The predicates can be stored in a + class. The predicates can be stored in a ([heterogenous](https://wiki.haskell.org/Heterogenous_collections#Existential_types)) list because they are wrapped in the `SomeDatabasePredicate` GADT that holds the type class instance as well. - -## Usage modes - -`beam-migrate` can be used as a library or a command-line tool in *managed* or -*unmanaged* mode. - -### The `beam-migrate` library - -The `beam-migrate` library provides syntax definitions for common SQL DDL tasks. -It also provides types for expressing migrations as transformations of one or -more schemas to another. `beam-migrate` offers a built-in way to apply these -migrations to a production database, running only those migrations that are -necessary. You can also directly interpret the `beam-migrate` DSL to hook your -Haskell migrations into your own system. - -`beam-migrate` is described in more detail in the [`beam-migrate` migrations -guide](library.md) - -### The `beam-migrate` tool - -There is an optional `beam-migrate` command line tool, available in the -`beam-migrate-cli` package. - -The `beam-migrate` tool can generate a beam schema from a pre-existing database, -manage migrations for several production databases, automatically generate -migrations between two schemas, and much more. It is rather opinionated, and is -described in more detail in the [`beam-migrate` CLI guide](tool.md) - - - ### Automatic migration generation Given two `CheckedDatabaseSettings` values, `beam-migrate` can generate a set of diff --git a/docs/schema-guide/tool.md b/docs/schema-guide/tool.md deleted file mode 100644 index a475bbc4..00000000 --- a/docs/schema-guide/tool.md +++ /dev/null @@ -1 +0,0 @@ -Tool diff --git a/mkdocs.yml b/mkdocs.yml index 40e4a152..68996ba5 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -34,9 +34,6 @@ nav: - 'DELETE': 'user-guide/manipulation/delete.md' - Schema management: - 'The Migrations Framework': 'schema-guide/migrations.md' - - 'The beam-migrate tool': 'schema-guide/tool.md' - - 'The beam-migrate library': 'schema-guide/library.md' -# - 'Supported migrations': 'schema-guide/supported.md' - Backends: - 'beam-postgres': 'user-guide/backends/beam-postgres.md' - 'beam-sqlite': 'user-guide/backends/beam-sqlite.md' diff --git a/nix/lib.nix b/nix/lib.nix index e3a47e91..b2f9488c 100644 --- a/nix/lib.nix +++ b/nix/lib.nix @@ -5,9 +5,6 @@ rec { "beam-core" "beam-migrate" "beam-sqlite" - ] ++ lib.optionals (builtins.compareVersions ghc.ghc.version "9.4" < 0) [ - # hint doesn't yet support 9.4+ - "beam-migrate-cli" ] ++ lib.optionals (builtins.compareVersions ghc.ghc.version "9.6" < 0) [ # postgres-options doesn't yet support 9.6+ "beam-postgres" diff --git a/stack-8.10.yaml b/stack-8.10.yaml index 534d2608..43df86f3 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -6,7 +6,6 @@ packages: - beam-postgres - beam-core - beam-migrate - - beam-migrate-cli nix: shell-file: shell.nix diff --git a/stack.yaml b/stack.yaml index ac60fc53..c5ff30b3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,7 +9,6 @@ packages: - beam-postgres - beam-core - beam-migrate - - beam-migrate-cli nix: shell-file: shell.nix