diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for drifter-sqlite + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Michael Xavier (c) 2018 + +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 Author name here 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# drifter-sqlite + +SQLite bindings to the drifter migration tool. 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/drifter-sqlite.cabal b/drifter-sqlite.cabal new file mode 100644 --- /dev/null +++ b/drifter-sqlite.cabal @@ -0,0 +1,82 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 1c812093b91becb632c3972bb1823dedd068a8d7435c734b27fb9aaf1095e484 + +name: drifter-sqlite +version: 0.1.0.0 +synopsis: SQLite support for the drifter schema migraiton tool +description: Please see the README on GitHub at +category: Database +homepage: https://github.com/MichaelXavier/drifter-sqlite#readme +bug-reports: https://github.com/MichaelXavier/drifter-sqlite/issues +author: Michael Xavier +maintainer: michael@michaelxavier.net +copyright: 2018 Michael Xavier +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/MichaelXavier/drifter-sqlite + +flag lib-Werror + description: Treat warnings as errors + manual: True + default: False + +library + exposed-modules: + Drifter.SQLite + other-modules: + Paths_drifter_sqlite + hs-source-dirs: + src + default-extensions: ScopedTypeVariables TypeFamilies GeneralizedNewtypeDeriving OverloadedStrings + build-depends: + base >=4.7 && <5 + , containers + , drifter >=0.2.1 + , mtl + , sqlite-simple + , time + , transformers + if flag(lib-Werror) + ghc-options: -Werror -Wall + else + ghc-options: -Wall + default-language: Haskell2010 + +test-suite drifter-sqlite-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_drifter_sqlite + hs-source-dirs: + test + default-extensions: ScopedTypeVariables TypeFamilies GeneralizedNewtypeDeriving OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , containers + , directory + , drifter >=0.2.1 + , drifter-sqlite + , mtl + , sqlite-simple + , tasty + , tasty-hunit + , text + , time + , transformers + if flag(lib-Werror) + ghc-options: -Werror -Wall + else + ghc-options: -Wall + default-language: Haskell2010 diff --git a/src/Drifter/SQLite.hs b/src/Drifter/SQLite.hs new file mode 100644 --- /dev/null +++ b/src/Drifter/SQLite.hs @@ -0,0 +1,192 @@ +module Drifter.SQLite + ( SQLiteMigration + , Method(..) + , DBConnection(..) + , ChangeHistory(..) + , runMigrations + , getChangeHistory + , getChangeNameHistory + ) where + + +------------------------------------------------------------------------------- +import Control.Applicative as A +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Except +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Time +import Database.SQLite.Simple +import Database.SQLite.Simple.FromField +import Drifter +------------------------------------------------------------------------------- + + + +data SQLiteMigration + + +data instance Method SQLiteMigration = + MigrationQuery Query + -- ^ Run a query against the database + | MigrationCode (Connection -> IO (Either String ())) + -- ^ Run any arbitrary IO code + + +data instance DBConnection SQLiteMigration = DBConnection SQLiteMigrationConnection + + +data SQLiteMigrationConnection = SQLiteMigrationConnection (Set ChangeName) Connection + + +instance Drifter SQLiteMigration where + migrateSingle (DBConnection migrationConn) change = do + runExceptT (migrateChange migrationConn change) + + +------------------------------------------------------------------------------- +-- Change History Tracking +------------------------------------------------------------------------------- +newtype ChangeId = ChangeId Int deriving (Eq, Ord, Show, FromField) + + +data ChangeHistory = ChangeHistory { + histId :: ChangeId + , histName :: ChangeName + , histDescription :: Maybe Description + , histTime :: UTCTime + } deriving (Show) + + +instance Eq ChangeHistory where + a == b = (histName a) == (histName b) + + +instance Ord ChangeHistory where + compare a b = compare (histId a) (histId b) + + +instance FromRow ChangeHistory where + fromRow = ChangeHistory + <$> field + <*> (ChangeName <$> field) + <*> field + <*> field + + +------------------------------------------------------------------------------- +-- Queries +------------------------------------------------------------------------------- +bootstrapQ :: Query +bootstrapQ = "\ +\ CREATE TABLE IF NOT EXISTS schema_migrations ( \ +\ id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,\ +\ name TEXT NOT NULL UNIQUE ON CONFLICT ROLLBACK,\ +\ description TEXT,\ +\ time DATETIME NOT NULL DEFAULT CURRENT_TIMESTAMP\ +\ );" + + +------------------------------------------------------------------------------- +changeHistoryQ :: Query +changeHistoryQ = + "SELECT id, name, description, time FROM schema_migrations ORDER BY id;" + + +------------------------------------------------------------------------------- +changeNameHistoryQ :: Query +changeNameHistoryQ = + "SELECT name FROM schema_migrations ORDER BY id;" + + +------------------------------------------------------------------------------- +insertLogQ :: Query +insertLogQ = + "INSERT INTO schema_migrations (name, description, time) VALUES (?, ?, ?);" + + +------------------------------------------------------------------------------- +migrateChange :: SQLiteMigrationConnection -> Change SQLiteMigration -> ExceptT String IO () +migrateChange (SQLiteMigrationConnection hist c) change = do + if Set.member cn hist + then lift (putStrLn ("Skipping: " ++ show (changeNameText cn))) + else do + runMethod c (changeMethod change) + logChange c change + lift (putStrLn ("Committed: " ++ show cn)) + where + cn = changeName change + + +------------------------------------------------------------------------------- +runMethod :: Connection -> Method SQLiteMigration -> ExceptT String IO () +runMethod c (MigrationQuery q) = + void (ExceptT ((Right <$> execute_ c q) `catches` errorHandlers)) +runMethod c (MigrationCode f) = + ExceptT (f c `catches` errorHandlers) + + + ------------------------------------------------------------------------------- +logChange :: Connection -> Change SQLiteMigration -> ExceptT String IO () +logChange c change = do + now <- lift getCurrentTime + void (ExceptT ((Right <$> go now) `catches` errorHandlers)) + where + go now = execute c insertLogQ (changeNameText (changeName change), changeDescription change, now) + + +------------------------------------------------------------------------------- +errorHandlers :: [Handler (Either String b)] +errorHandlers = + [ Handler (\(ex::SQLError) -> return (Left (show ex))) + , Handler (\(ex::FormatError) -> return (Left (show ex))) + , Handler (\(ex::ResultError) -> return (Left (show ex))) + ] + + +------------------------------------------------------------------------------- +-- | Takes a connection and builds the state to thread throughout the migration. +-- This includes bootstrapping the migration tables and collecting all the +-- migrations that have already been committed. +makePGMigrationConnection :: Connection -> IO SQLiteMigrationConnection +makePGMigrationConnection conn = do + void (execute_ conn bootstrapQ) + hist <- getChangeNameHistory conn + return (SQLiteMigrationConnection (Set.fromList hist) conn) + + +------------------------------------------------------------------------------- +-- | Takes the list of all migrations, removes the ones that have +-- already run and runs them. Use this instead of 'migrate'. +runMigrations :: Connection -> [Change SQLiteMigration] -> IO (Either String ()) +runMigrations conn changesList = handle (\(RolledBack e) -> pure (Left e)) $ fmap Right $ do + withTransaction conn $ do + migrationConn <- makePGMigrationConnection conn + res <- migrate (DBConnection migrationConn) changesList + case res of + Right _ -> pure () + Left e -> throw (RolledBack e) + + +------------------------------------------------------------------------------- +data RolledBack = RolledBack String + deriving (Show) + +instance Exception RolledBack + + +------------------------------------------------------------------------------- +-- | Get all changes from schema_migrations table for all the migrations that +-- have previously run. +getChangeHistory :: Connection -> IO [ChangeHistory] +getChangeHistory conn = query_ conn changeHistoryQ + + +------------------------------------------------------------------------------- +-- | Get just the names of all changes from schema_migrations for migrations +-- that have previously run. +getChangeNameHistory :: Connection -> IO [ChangeName] +getChangeNameHistory conn = fmap (\(Only nm) -> ChangeName nm) + A.<$> query_ conn changeNameHistoryQ diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,85 @@ +module Main + ( main + ) where + + +------------------------------------------------------------------------------- +import Control.Applicative as A +import Control.Exception +import Data.IORef +import Data.Text (Text) +import Database.SQLite.Simple +import Drifter +import System.Directory +import System.IO.Error +import Test.Tasty +import Test.Tasty.HUnit +------------------------------------------------------------------------------- +import Drifter.SQLite +------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain $ testGroup "drifter-postgresql" + [ + withResource setup teardown $ \getConn -> testCase "migrations" $ do + c <- getConn + c3Calls <- newIORef 0 + let migrate' = runMigrations c . changeSequence + res <- migrate' [c1, c2] + res @?= Right () + + rows <- query_ c "SELECT x FROM c1;" + rows @?= ([Only "val"] :: [Only Text]) + + res' <- migrate' [c1, c2, c3 c3Calls] + res' @?= Right () + calls <- readIORef c3Calls + calls @?= 1 + + res'' <- migrate' [c1, c2, c3 c3Calls] + res'' @?= Right () + + calls' <- readIORef c3Calls + calls' @?= 1 + ] + + +------------------------------------------------------------------------------- +c1 :: Change SQLiteMigration +c1 = Change (ChangeName "c1") (Just "create table") [] meth + where + meth = MigrationQuery q + q = "CREATE TABLE c1 (id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL, x text NOT NULL);" + + +c2 :: Change SQLiteMigration +c2 = Change (ChangeName "c2") (Just "insert value") [] meth + where + meth = MigrationQuery q + q = "INSERT INTO c1 (x) VALUES ('val');" + +------------------------------------------------------------------------------- +c3 :: IORef Int -> Change SQLiteMigration +c3 ref = Change (ChangeName "c3") (Just "bump an IORef") [changeName c1] meth + where + meth = MigrationCode (\_ -> Right A.<$> modifyIORef' ref succ) + + +------------------------------------------------------------------------------- +setup :: IO Connection +setup = open testFile + + +------------------------------------------------------------------------------- +teardown :: Connection -> IO () +teardown conn = close conn `finally` dropFile + where + dropFile = catchJust + (\e -> if isDoesNotExistError e then Just () else Nothing) + (removeFile testFile) + pure + + +------------------------------------------------------------------------------- +testFile :: FilePath +testFile = "test.db"