drifter-postgresql (empty) → 0.0.1
raw patch · 7 files changed
+340/−0 lines, 7 filesdep +basedep +drifterdep +drifter-postgresqlsetup-changed
Dependencies added: base, drifter, drifter-postgresql, either, mtl, postgresql-simple, tasty, tasty-hunit, text, time
Files
- LICENSE +20/−0
- README.md +3/−0
- Setup.hs +2/−0
- changelog.md +0/−0
- drifter-postgresql.cabal +56/−0
- src/Drifter/PostgreSQL.hs +175/−0
- test/Main.hs +84/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,3 @@+# drifter-postgresql++PostgreSQL support for the drifter schema migration tool
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
+ drifter-postgresql.cabal view
@@ -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
+ src/Drifter/PostgreSQL.hs view
@@ -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
+ test/Main.hs view
@@ -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