diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Michael Xavier + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# drifter-postgresql + +PostgreSQL support for the drifter schema 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/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md diff --git a/drifter-postgresql.cabal b/drifter-postgresql.cabal new file mode 100644 --- /dev/null +++ b/drifter-postgresql.cabal @@ -0,0 +1,56 @@ +name: drifter-postgresql +version: 0.0.1 +synopsis: PostgreSQL support for the drifter schema migration tool +description: Support for postgresql-simple Query migrations as well as arbitrary Haskell IO functions. +license: MIT +license-file: LICENSE +author: Michael Xavier +maintainer: michael@michaelxavier.net +category: Database +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 +extra-source-files: + README.md + changelog.md + +flag lib-Werror + default: False + manual: True + +library + exposed-modules: Drifter.PostgreSQL + build-depends: base >=4.5 && <4.9 + , postgresql-simple >= 0.2 && < 0.5 + , drifter >= 0.2 && < 0.3 + , time + , either + , mtl + hs-source-dirs: src + default-language: Haskell2010 + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall + + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + + build-depends: base + , drifter + , postgresql-simple + , drifter-postgresql + , tasty + , tasty-hunit + , either + , text + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall diff --git a/src/Drifter/PostgreSQL.hs b/src/Drifter/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/src/Drifter/PostgreSQL.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Drifter.PostgreSQL + ( PGMigration + , Method(..) + , DBConnection(..) + , ChangeHistory(..) + , runMigrations + , getChangeHistory + ) where + +------------------------------------------------------------------------------- +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Either +import Data.Time +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.SqlQQ +import Drifter +------------------------------------------------------------------------------- + + +data PGMigration + + +data instance Method PGMigration = MigrationQuery Query + -- ^ Run a query against the database + | MigrationCode (Connection -> IO (Either String ())) + -- ^ Run any arbitrary IO code + + +data instance DBConnection PGMigration = DBConnection Connection + + +instance Drifter PGMigration where + migrateSingle (DBConnection conn) change = do + runEitherT $ migrateChange conn 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 = [sql| +CREATE TABLE IF NOT EXISTS schema_migrations ( + id serial NOT NULL, + name text NOT NULL, + description text, + time timestamptz NOT NULL DEFAULT now(), + + PRIMARY KEY (id), + UNIQUE (name) +); +|] + + +------------------------------------------------------------------------------- +changeHistoryQ :: Query +changeHistoryQ = + "SELECT id, name, description, time FROM schema_migrations ORDER BY id;" + + +------------------------------------------------------------------------------- +insertLogQ :: Query +insertLogQ = + "INSERT INTO schema_migrations (name, description, time) VALUES (?, ?, ?);" + + +------------------------------------------------------------------------------- +findNext :: [ChangeHistory] -> [Change PGMigration] -> IO [Change PGMigration] +findNext [] cs = return cs +findNext (h:hs) (c:cs) + | (histName h) == (changeName c) = do + putStrLn $ "Skipping: " ++ show (changeName c) + findNext hs cs + | otherwise = return (c:cs) +findNext _ _ = do + putStrLn "Change Set Exhausted" + return [] + + +------------------------------------------------------------------------------- +migrateChange :: Connection -> Change PGMigration -> EitherT String IO () +migrateChange c ch@Change{..} = do + runMethod c changeMethod + + logChange c ch + lift $ putStrLn $ "Committed: " ++ show changeName + + +------------------------------------------------------------------------------- +runMethod :: Connection -> Method PGMigration -> EitherT String IO () +runMethod c (MigrationQuery q) = + void $ EitherT $ (Right <$> execute_ c q) `catches` errorHandlers +runMethod c (MigrationCode f) = + EitherT $ f c `catches` errorHandlers + + + ------------------------------------------------------------------------------- +logChange :: Connection -> Change PGMigration -> EitherT String IO () +logChange c Change{..} = do + now <- lift getCurrentTime + void $ EitherT $ (Right <$> go now) `catches` errorHandlers + where + go now = execute c insertLogQ (changeNameText changeName, changeDescription, 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) + , Handler (\(ex::QueryError) -> return $ Left $ show ex) + ] + + +------------------------------------------------------------------------------- +-- | Takes the list of all migrations, removes the ones that have +-- already run and runs them. Use this instead of 'migrate'. +runMigrations :: Connection -> [Change PGMigration] -> IO (Either String ()) +runMigrations conn changes = do + void $ execute_ conn bootstrapQ + hist <- getChangeHistory conn + remainingChanges <- findNext hist changes + begin conn + res <- migrate (DBConnection conn) remainingChanges `onException` rollback conn + case res of + Right _ -> commit conn + Left _ -> rollback conn + return res + + +------------------------------------------------------------------------------- +-- | Check the schema_migrations table for all the migrations that +-- have previously run. +getChangeHistory :: Connection -> IO [ChangeHistory] +getChangeHistory conn = query_ conn changeHistoryQ diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Main + ( main + ) where + + +------------------------------------------------------------------------------- +import Control.Applicative +import Control.Monad +import Data.IORef +import Data.Text (Text) +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.SqlQQ +import Drifter +import Test.Tasty +import Test.Tasty.HUnit +------------------------------------------------------------------------------- +import Drifter.PostgreSQL +------------------------------------------------------------------------------- + + +main :: IO () +main = defaultMain $ testGroup "drifter-postgresql" + [ + withResource setup teardown $ \getConn -> testCase "migrations" $ do + c <- getConn + c2Calls <- newIORef 0 + let migrate' = runMigrations c + res <- migrate' [c1] + res @?= Right () + rows <- query_ c "SELECT x FROM c1;" + rows @?= ([Only "c1"] :: [Only Text]) + + res' <- migrate' [c1, c2 c2Calls] + res' @?= Right () + calls <- readIORef c2Calls + calls @?= 1 + + res'' <- migrate' [c1, c2 c2Calls] + res'' @?= Right () + + calls' <- readIORef c2Calls + calls' @?= 1 + ] + +------------------------------------------------------------------------------- +c1 :: Change PGMigration +c1 = Change (ChangeName "c1") (Just "c1 migration") [] meth + where + meth = MigrationQuery q + q = [sql| + CREATE TABLE c1 ( + id serial NOT NULL, + x text NOT NULL, + + PRIMARY KEY (id) + ); + + INSERT INTO c1 (x) VALUES ('c1'); + |] + + +------------------------------------------------------------------------------- +c2 :: IORef Int -> Change PGMigration +c2 ref = Change (ChangeName "c2") (Just "c2 migration") [changeName c1] meth + where + meth = MigrationCode (\_ -> Right <$> modifyIORef' ref succ) + + +------------------------------------------------------------------------------- +setup :: IO Connection +setup = do + c <- connect defaultConnectInfo + void $ execute_ c "DROP DATABASE IF EXISTS drifter_test;" + void $ execute_ c "CREATE DATABASE drifter_test;" + close c + c' <- connect defaultConnectInfo { connectDatabase = "drifter_test" } + return c' + + +------------------------------------------------------------------------------- +teardown :: Connection -> IO () +teardown = close