diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# Drifter +[![Build Status](https://travis-ci.org/AndrewRademacher/drifter.svg)](https://travis-ci.org/AndrewRademacher/drifter) + + +Simple schema management for arbitrary databases. diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,6 @@ +# 0.2 +* Drop direct support for postgresql. That can be found in the drifter-postgresql package. +* Just export a single module, Drifter +* Change Drifter typeclass method from migrate to migrateSingle +* Add changeSequence helper function +* Make migrate automatically resolve dependency order diff --git a/drifter.cabal b/drifter.cabal --- a/drifter.cabal +++ b/drifter.cabal @@ -1,31 +1,63 @@ - name: drifter -version: 0.1.0.1 +version: 0.2 synopsis: Simple schema management for arbitrary databases. description: Simple support for migrating database schemas, which allows haskell functions to be run as a part of the migration. license: MIT license-file: LICENSE author: AndrewRademacher -maintainer: andrewrademacher@gmail.com +maintainer: Michael Xavier category: Database build-type: Simple cabal-version: >=1.10 homepage: https://github.com/AndrewRademacher/drifter +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 +extra-source-files: + README.md + LICENSE + changelog + test/Main.hs source-repository head type: git location: git@github.com:AndrewRademacher/drifter.git +flag lib-Werror + default: False + manual: True + library hs-source-dirs: src default-language: Haskell2010 - build-depends: base >=4.7 && <4.8 - , postgresql-simple >=0.4 && <0.5 - , bytestring >=0.10 && <0.11 - , time >=1.4 && <1.5 - , text >=1.2 && <1.3 + build-depends: base >=4.5 && <4.9 + , fgl >=5.5 && <5.6 + , containers >=0.5 && <0.6 + , text >=0.11 && <1.3 - exposed-modules: Drifter.PostgreSQL + other-modules: Drifter.Graph , Drifter.Types + exposed-modules: Drifter + + 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 + , text + , tasty + , tasty-quickcheck + , tasty-hunit + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall diff --git a/src/Drifter.hs b/src/Drifter.hs new file mode 100644 --- /dev/null +++ b/src/Drifter.hs @@ -0,0 +1,33 @@ +module Drifter + ( + -- * Managing Migrations + resolveDependencyOrder + , changeSequence + , migrate + -- * Types + , Drifter(..) + , ChangeName(..) + , Change(..) + , Description + , Method + , DBConnection + ) where + + +import Data.List + +import Drifter.Graph +import Drifter.Types + + +-- | This is a helper for the common case of where you just want +-- dependencies to run in list order. This will take the input list +-- and set their dependencies to run in the given sequence. +changeSequence :: [Change a] -> [Change a] +changeSequence [] = [] +changeSequence (x:xs) = reverse $ snd $ foldl' go (x, []) xs + where + go :: (Change a, [Change a]) -> Change a -> (Change a, [Change a]) + go (lastChange, xs') c = + let c' = c { changeDependencies = [changeName lastChange] } + in (c', c':xs') diff --git a/src/Drifter/Graph.hs b/src/Drifter/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Drifter/Graph.hs @@ -0,0 +1,76 @@ +module Drifter.Graph + ( resolveDependencyOrder + , Drifter(..) + , migrate + ) where + +import Control.Applicative +import Control.Monad +import Data.Graph.Inductive (Edge, Gr, UEdge, mkGraph, topsort') +import qualified Data.Map.Strict as Map +import Data.Maybe + +import Drifter.Types + +labUEdges :: [Edge] -> [UEdge] +labUEdges = map (\(a, b) -> (a, b, ())) + +-- | Take an unordered list of changes and put them in dependency +-- order. 'migrate' will do this automatically. +resolveDependencyOrder :: [Change a] -> [Change a] +resolveDependencyOrder cs = topsort' $ graphDependencies cs + +graphDependencies :: [Change a] -> Gr (Change a) () +graphDependencies cs = mkGraph nodes (labUEdges edges) + where nodes = zip [1..] cs + nMap = Map.fromList $ map (\(i, c) -> (changeName c, i)) nodes + edges = catMaybes + $ map (\(a, b) -> (,) <$> a <*> b) + $ concat + $ map (\c -> map (\dn -> ( Map.lookup dn nMap + , Map.lookup (changeName c) nMap)) + (changeDependencies c)) + cs + + +class Drifter a where + -- | How to run a single, isolated migration. + migrateSingle :: DBConnection a -> Change a -> IO (Either String ()) + + +-- | Runs a list of changes. They will automatically be sorted and run +-- in dependency order. Will terminate early on error. +migrate :: Drifter a => DBConnection a -> [Change a] -> IO (Either String ()) +migrate conn csUnsorted = runEitherT (mapM_ go cs) + where cs = resolveDependencyOrder csUnsorted + go = EitherT . migrateSingle conn + + +newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) } + + +instance Monad m => Functor (EitherT e m) where + fmap f = EitherT . liftM (fmap f) . runEitherT + {-# INLINE fmap #-} + +instance Monad m => Applicative (EitherT e m) where + pure a = EitherT $ return (Right a) + {-# INLINE pure #-} + EitherT f <*> EitherT v = EitherT $ f >>= \mf -> case mf of + Left e -> return (Left e) + Right k -> v >>= \mv -> case mv of + Left e -> return (Left e) + Right x -> return (Right (k x)) + {-# INLINE (<*>) #-} + +instance Monad m => Monad (EitherT e m) where + return a = EitherT $ return (Right a) + {-# INLINE return #-} + m >>= k = EitherT $ do + a <- runEitherT m + case a of + Left l -> return (Left l) + Right r -> runEitherT (k r) + {-# INLINE (>>=) #-} + fail = EitherT . fail + {-# INLINE fail #-} diff --git a/src/Drifter/PostgreSQL.hs b/src/Drifter/PostgreSQL.hs deleted file mode 100644 --- a/src/Drifter/PostgreSQL.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Drifter.PostgreSQL - ( Postgres - , Method (..) - , DBConnection (..) - ) where - -import Control.Applicative -import Control.Exception -import Data.ByteString (ByteString) -import Data.Int -import Data.Time -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.FromRow -import Database.PostgreSQL.Simple.SqlQQ -import Database.PostgreSQL.Simple.Types - -import Drifter.Types - -data Postgres - -data instance Method Postgres = Script ByteString - | Function (Connection -> IO (Either String ())) - -data instance DBConnection Postgres = DBConnection Connection - -newtype ChangeId = ChangeId { unChangeId :: Int } deriving (Eq, Ord, Show, FromField) - -data ChangeHistory = ChangeHistory - { histId :: ChangeId - , histName :: Name - , 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 <*> field <*> field <*> field - -instance Drifter Postgres where - migrate (DBConnection conn) changes = do - _ <- bootstrap conn - hist :: [(ChangeHistory)] <- query_ conn "SELECT id, name, description, time FROM drifter.changelog ORDER BY id" - start <- findNext hist changes - migratePostgres conn start - -findNext :: [ChangeHistory] -> [Change Postgres] -> IO [Change Postgres] -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 [] - -bootstrap :: Connection -> IO Int64 -bootstrap conn = execute_ conn [sql| -BEGIN; - -CREATE SCHEMA IF NOT EXISTS drifter; - -CREATE TABLE IF NOT EXISTS drifter.changelog ( - id serial NOT NULL, - name text NOT NULL, - description text, - time timestamp NOT NULL, - - PRIMARY KEY (id), - UNIQUE (name) -); - -COMMIT; -|] - -migratePostgres :: Connection -> [Change Postgres] -> IO (Either String ()) -migratePostgres _ [] = return $ Right () -migratePostgres conn (Change n d m:cs) = do - res <- handleChange conn m - now <- getCurrentTime - - case res of - Left er -> return $ Left er - Right _ -> do _ <- logChange conn n d now - putStrLn $ "Committed: " ++ show n - migratePostgres conn cs - -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) - ] - -handleChange :: Connection -> Method Postgres -> IO (Either String ()) -handleChange conn (Script q) = (execute_ conn (Query q) >>= \_ -> return $ Right ()) - `catches` errorHandlers -handleChange conn (Function f) = (f conn >>= \_ -> return $ Right ()) - `catches` errorHandlers - -logChange :: Connection -> Name -> Maybe Description -> UTCTime -> IO (Either String ()) -logChange conn n d now = (execute conn insLog (n, d, now) >>= \_ -> return $ Right ()) - `catches` errorHandlers - where insLog = [sql| -BEGIN; - -INSERT INTO drifter.changelog (name, description, time) - VALUES (?, ?, ?); - -COMMIT; -|] diff --git a/src/Drifter/Types.hs b/src/Drifter/Types.hs --- a/src/Drifter/Types.hs +++ b/src/Drifter/Types.hs @@ -4,18 +4,17 @@ import Data.Text -type Name = Text +newtype ChangeName = ChangeName + { changeNameText :: Text } deriving (Show, Eq, Ord) type Description = Text data Change a = Change - { changeName :: Name - , changeDescription :: Maybe Description - , changeMethod :: Method a + { changeName :: ChangeName + , changeDescription :: Maybe Description + , changeDependencies :: [ChangeName] + , changeMethod :: Method a } data family Method a data family DBConnection a - -class Drifter a where - migrate :: DBConnection a -> [Change a] -> IO (Either String ()) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main + ( main + ) where + +import Control.Applicative +import Data.IORef +import Data.List +import Data.Text (Text) +import qualified Data.Text as T +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Drifter + + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "drifter" + [ + graphTests + , typesTests + ] + +graphTests :: TestTree +graphTests = testGroup "Drifter.Graph" + [ + resolveDependencyOrderTests + ] + +typesTests :: TestTree +typesTests = testGroup "Drifter.Types" + [ + migrateTests + ] + +resolveDependencyOrderTests :: TestTree +resolveDependencyOrderTests = testGroup "resolveDependencyOrder" + [ + testProperty "orders by dependency" $ \(UniqueChanges cs) -> + let presorted = changeSequence cs + in resolveDependencyOrder presorted === presorted + ] + +migrateTests :: TestTree +migrateTests = testGroup "migrate" + [ + testCase "runs the given migrations" $ do + runs <- newIORef [] + _ <- migrate (DBConnection $ TestDBConn runs) exampleChanges + res <- readIORef runs + res @?= [1,2,3] + ] + +exampleChanges :: [Change TestDB] +exampleChanges = [c2, c3, c1] + where + c1 = Change c1n Nothing [] (RunMigrationNumber 1) + c1n = ChangeName "c1" + c2n = ChangeName "c2" + c3n = ChangeName "c3" + c2 = c1 { changeName = c2n, changeDependencies = [c1n], changeMethod = RunMigrationNumber 2} + c3 = c1 { changeName = c3n, changeDependencies = [c2n], changeMethod = RunMigrationNumber 3} + +data TestDB + +newtype TestDBConn = TestDBConn (IORef [Int]) + +data instance Method TestDB = RunMigrationNumber Int deriving (Show, Eq) + +data instance DBConnection TestDB = DBConnection TestDBConn + +instance Drifter TestDB where + migrateSingle (DBConnection (TestDBConn runs)) Change { changeMethod = RunMigrationNumber mn} = do + modifyIORef runs (++ [mn]) + return $ Right () + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +deriving instance Arbitrary ChangeName + +instance Arbitrary (Method TestDB) where + arbitrary = RunMigrationNumber <$> arbitrary + +instance Arbitrary (Change TestDB) where + arbitrary = Change <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +deriving instance Eq (Change TestDB) +deriving instance Show (Change TestDB) + +newtype UniqueChanges = UniqueChanges [Change TestDB] deriving (Show) + +instance Arbitrary UniqueChanges where + arbitrary = UniqueChanges <$> arbitrary `suchThat` uniqueNames + where + uniqueNames cs = let names = map changeName cs + in nub names == names