drifter 0.1.0.1 → 0.2

raw patch · 8 files changed

+274/−136 lines, 8 filesdep +containersdep +drifterdep +fgldep −bytestringdep −postgresql-simpledep −timedep ~basedep ~textnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, drifter, fgl, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: bytestring, postgresql-simple, time

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• README.md +5/−0
• changelog +6/−0
• drifter.cabal +41/−9
• src/Drifter.hs +33/−0
• src/Drifter/Graph.hs +76/−0
• src/Drifter/PostgreSQL.hs +0/−120
• src/Drifter/Types.hs +6/−7
• test/Main.hs +107/−0

@@ -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.

@@ -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

@@ -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 <michael@michaelxavier.net> 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

@@ -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')

@@ -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 #-}

@@ -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;-|]

@@ -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 ())

@@ -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