diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Ricky Elrod + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ricky Elrod nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dbm.cabal b/dbm.cabal new file mode 100644 --- /dev/null +++ b/dbm.cabal @@ -0,0 +1,26 @@ +name: dbm +version: 0.1.0.0 +synopsis: A *simple* database migration tool. +homepage: https://github.com/relrod/dbm +license: BSD3 +license-file: LICENSE +author: Ricky Elrod +maintainer: ricky@elrod.me +copyright: (c) 2016 Ricky Elrod +category: Database +build-type: Simple +cabal-version: >= 1.10 + +executable dbm + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >= 4 && < 5 + , directory + , ini + , optparse-applicative + , sqlite-simple + , text + , time + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Ini +import Data.List (elem, isSuffixOf) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Directory +import System.Exit +import Options.Applicative + +import Utility + +-------------------------------------------------------------------------------- +-- These are the things you need to extend if you wish to add another backend. - +-------------------------------------------------------------------------------- +import qualified SQLite + +data Config = + SQLiteConfig { sqliteConfigPath :: T.Text } + +getConfigForEnv :: String -> Ini -> IO Config +getConfigForEnv env ini = do + backend <- getConfigValue ini (T.pack env) "backend" + case backend of + "sqlite" -> SQLiteConfig <$> getConfigValue ini (T.pack env) "path" + _ -> error "No valid backend configured." + +initializeEnv :: Config -> IO () +initializeEnv (SQLiteConfig path) = SQLite.initialize (T.unpack path) + +getLastMigration :: Config -> IO (Maybe Integer) +getLastMigration (SQLiteConfig path) = SQLite.getLastMigration (T.unpack path) + +doMigration :: Config -> FilePath -> Integer -> IO () +doMigration (SQLiteConfig path) sql mid = + SQLite.performMigration (T.unpack path) sql mid +-------------------------------------------------------------------------------- + +data Command = + Configs + | Initialize String + | Last String + | Status String + | Migrate String + +envParser :: Parser String +envParser = argument str (metavar "ENVIRONMENT" + <> help "The configuration environment to initialize") + +initializeParser, lastParser, statusParser, migrateParser :: Parser Command +initializeParser = Initialize <$> envParser +lastParser = Last <$> envParser +statusParser = Status <$> envParser +migrateParser = Migrate <$> envParser + +parser :: Parser Command +parser = subparser $ + (command "configs" + (info (pure Configs) + (progDesc "Print available configurations."))) + <> (command "initialize" + (info initializeParser + (progDesc "Set up a database for use with dbm and apply all migrations."))) + <> (command "last" + (info lastParser + (progDesc "Get the id of the last migration performed."))) + <> (command "status" + (info statusParser + (progDesc "Get the current migration status."))) + <> (command "migrate" + (info migrateParser + (progDesc "Migrate the database completely."))) + +run :: Command -> Ini -> IO () +run Configs ini = showConfigs ini +run (Initialize env) ini = getConfigForEnv env ini >>= initializeEnv +run (Last env) ini = getConfigForEnv env ini >>= showLastMigration +run (Status env) ini = getConfigForEnv env ini >>= showMigrationStatus +run (Migrate env) ini = getConfigForEnv env ini >>= performMigrations + +opts :: ParserInfo Command +opts = info (parser <**> helper) idm + +main :: IO () +main = do + current <- listDirectory "." + if not ("sql" `elem` current) + then do + putStrLn "`dbm` must be run in a directory with an 'sql' subdirectory." + exitFailure + else do + ini <- getConfigFile + opts <- execParser opts + run opts ini + +getConfigFile :: IO Ini +getConfigFile = do + config <- readIniFile "sql/.dbm" + case config of + Right x -> return x + Left err -> putStrLn err >> exitFailure + +getConfigValue :: Ini -> T.Text -> T.Text -> IO T.Text +getConfigValue c s l = do + case lookupValue s l c of + Right x -> return x + Left err -> putStrLn err >> exitFailure + +showConfigs :: Ini -> IO () +showConfigs config = do + mapM_ T.putStrLn (sections config) + +showLastMigration :: Config -> IO () +showLastMigration cfg = do + mid <- getLastMigration cfg + case mid of + Just mid -> putStrLn $ "Last migration id: " ++ show mid + Nothing -> putStrLn "No migrations have been performed. :-(" + +getNecessaryMigrations :: Config -> IO [(Maybe Integer, FilePath)] +getNecessaryMigrations cfg = do + mid <- fromMaybe 0 <$> getLastMigration cfg + migrations <- filter (\x -> ".sql" `isSuffixOf` x) <$> listDirectory "sql" + let migrationList = fmap (\x -> (parseMigrationId x, "sql/" ++ x)) migrations + migrationFiltered = filter (getNecessaryMigrations mid) migrationList + return migrationFiltered + where + getNecessaryMigrations _ (Nothing, fn) = + error $ "Invalid migration filename: " ++ fn + getNecessaryMigrations current (Just mid, fn) = + if mid > current + then True + else False + +showMigrationStatus :: Config -> IO () +showMigrationStatus cfg = do + migrations <- getNecessaryMigrations cfg + if null migrations + then putStrLn "Database schema is up to date." + else do + putStrLn "Need to migrate:" + mapM_ (\(_, x) -> putStrLn ("* " ++ x)) migrations + +performMigrations :: Config -> IO () +performMigrations cfg = do + showMigrationStatus cfg + migrations <- getNecessaryMigrations cfg + -- This pattern match is "safe" because we `error` in getNecessaryMigrations + -- if it were never a `Nothing`. + mapM_ (\(Just mid, x) -> doMigration' x mid) migrations + where + doMigration' sql mid = do + putStr $ "Migrating " ++ sql ++ "... " + doMigration cfg sql mid + putStrLn "Done."