packages feed

migrant-core (empty) → 0.1.0.0

raw patch · 11 files changed

+496/−0 lines, 11 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, migrant-core, tasty, tasty-hunit, tasty-quickcheck, text

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Tobias Dammers++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 Tobias Dammers 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ migrant-core.cabal view
@@ -0,0 +1,45 @@+cabal-version: 2.4+-- Initial package description 'migrant.cabal' generated by 'cabal init'.+-- For further documentation, see http://haskell.org/cabal/users-guide/++name: migrant-core+version: 0.1.0.0+synopsis: Semi-automatic database schema migrations+-- description:+homepage: https://github.com/tdammers/migrant+-- bug-reports:+license: BSD-3-Clause+license-file: LICENSE+author: Tobias Dammers+maintainer: tdammers@gmail.com+-- copyright:+category: Database+extra-source-files: ++library+  exposed-modules: Database.Migrant+                 , Database.Migrant.Run+                 , Database.Migrant.Driver.Class+                 , Database.Migrant.MigrationName+  -- other-extensions:+  build-depends: base ^>=4.12.0.0+               , text >=1.2.4.0 && <1.3+  hs-source-dirs: src+  default-language: Haskell2010++test-suite migrant-core-test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  other-modules: Database.Migrant.Run_Orphans+               , Database.Migrant.MigrationName_Orphans+               , Database.Migrant.Run_Tests+  build-depends: base ^>=4.12.0.0+               , migrant-core+               , HUnit >=1.6.1.0 && <1.7+               , QuickCheck >=2.14.2 && <2.15+               , tasty >=1.4 && <1.5+               , tasty-hunit >=0.10.0.2 && <0.11+               , tasty-quickcheck >=0.10.1.1 && <0.11+               , text >=1.2.4.0 && <1.3
+ src/Database/Migrant.hs view
@@ -0,0 +1,12 @@+module Database.Migrant+( Driver (..)+, MigrationName+, MigrationDirection+, migrate+, plan+)+where++import Database.Migrant.Driver.Class+import Database.Migrant.MigrationName+import Database.Migrant.Run
+ src/Database/Migrant/Driver/Class.hs view
@@ -0,0 +1,50 @@+{-#LANGUAGE TypeFamilies #-}+module Database.Migrant.Driver.Class+where++import Database.Migrant.MigrationName (MigrationName)+import Data.Text (Text)+import Text.Printf (printf)+import Control.Monad++-- | A migrations driver abstracts over the database to run over and the+-- associated migration mechanism.+class Driver d where+  --  | Migrations should be done transactionally, so we need to provide a+  --  way of wrapping things in a transaction. Implementations should make+  --  sure that whatever runs inside a transaction is actually transactional+  --  (i.e., atomic), including host exceptions.+  withTransaction :: (d -> IO a) -> d -> IO a++  -- | Initialize the migrations system on the backend. This should generally+  -- involve creating a table of ordered migration names, e.g.:+  -- @@@+  -- CREATE TABLE IF NOT EXISTS _migrations (id SERIAL PRIMARY KEY, name TEXT);+  -- @@@+  --+  -- **Note** that 'initMigrations' should be idempotent, that is, executing it+  -- when the migrations system has already been initialized should be a no-op.+  initMigrations :: d -> IO ()++  -- | Mark a migration as \"executed\". Typically, this will @INSERT@ a row+  -- into the migrations table.+  markUp :: MigrationName -> d -> IO ()++  -- | Mark a migration as \"not executed\" / \"rolled back\". Typically, this+  -- will @DELETE@ a row from the migrations table.+  markDown :: MigrationName -> d -> IO ()++  -- | Get the list of migrations applied to the backend, in the order they+  -- were applied.+  getMigrations :: d -> IO [MigrationName]++data DummyDriver = DummyDriver++instance Driver DummyDriver where+  withTransaction = id+  initMigrations = const mzero+  markUp migration _ =+    printf "UP: %s" migration+  markDown migration _ =+    printf "DOWN: %s" migration+  getMigrations _ = return []
+ src/Database/Migrant/MigrationName.hs view
@@ -0,0 +1,15 @@+{-#LANGUAGE GeneralizedNewtypeDeriving #-}+{-#LANGUAGE DerivingVia #-}+module Database.Migrant.MigrationName+where++import Data.Text+import Text.Printf+import Data.String (IsString)++newtype MigrationName =+  MigrationName { unpackMigrationName :: Text }+  deriving Eq via Text+  deriving Show via Text+  deriving PrintfArg via Text+  deriving IsString via Text
+ src/Database/Migrant/Run.hs view
@@ -0,0 +1,108 @@+module Database.Migrant.Run+( migrate+, unsafeMigrate+, executePlan+, plan+, makePlan+, MigrationDirection (..)+)+where++import Database.Migrant.Driver.Class+import Database.Migrant.MigrationName++import Control.Monad (forM_)++data MigrationDirection+  = MigrateUp+  | MigrateDown+  deriving (Show, Eq, Ord, Enum, Bounded)++-- | Create a migration plan based on the current situation on the database,+-- and the specified target.+plan :: Driver d+     => [MigrationName]+     -> d+     -> IO [(MigrationDirection, MigrationName)]+plan target driver = do+  current <- getMigrations driver+  return $ makePlan target current++-- | Make a plan from a previously loaded current situation and the specified+-- target.+makePlan :: [MigrationName]+            -- ^ target+         -> [MigrationName]+            -- ^ current+         -> [(MigrationDirection, MigrationName)]+makePlan [] []+  -- Situation 0: nothing left to do+  = []+makePlan [] xs+  -- Situation 1: no more "up" targets left, but more migrations exist, so+  -- we need to roll those back.+  = [(MigrateDown, n) | n <- xs]+makePlan xs []+  -- Situation 2: only "up" targets left, run them.+  = [(MigrateUp, n) | n <- xs]+makePlan (t:ts) (c:cs)+  -- Situation 3: "up" targets exist, and we also have existing migrations+  -- left. The same migration exists on both ends, so we can just skip+  -- forward.+  | t == c+  = makePlan ts cs+  -- Situation 4: both "up" targets and existing migrations are present but the+  -- do not match, so we need to roll back existing migrations until a+  -- consistent situation is restored.+  | otherwise+  = (MigrateDown, c):makePlan (t:ts) cs++-- | Apply a migration plan to a database.+-- This should generally be done within the same transaction as loading the+-- current situation from the database and creating a migration plan. Running+-- this action outside of a transaction may leave the database and migration+-- tracking in an inconsistent state.+executePlan :: Driver d+            => [(MigrationDirection, MigrationName)]+            -> (MigrationName -> d -> IO ())+            -> (MigrationName -> d -> IO ())+            -> d+            -> IO ()+executePlan migrationPlan up down driver = do+  forM_ migrationPlan $ \(direction, name) -> do+    let (run, mark) = case direction of+          MigrateUp -> (up, markUp)+          MigrateDown -> (down, markDown)+    run name driver+    mark name driver++-- | Safely (transactionally) infer and execute a migration.+migrate :: Driver d+        => [MigrationName]+           -- ^ Target situation+        -> (MigrationName -> d -> IO ())+           -- ^ Factory for \'up\' migration actions+        -> (MigrationName -> d -> IO ())+           -- ^ Factory for \'down\' migration actions+        -> d+        -> IO ()+migrate target up down driver =+  withTransaction (unsafeMigrate target up down) driver++-- | Infer and execute a migration in a non-transactional fashion. This means+-- that migration failures may leave the database and migration tracking in+-- an inconsistent state, so you should never call this outside of a+-- transaction.+unsafeMigrate :: Driver d+              => [MigrationName]+                 -- ^ Target situation+              -> (MigrationName -> d -> IO ())+                 -- ^ Factory for \'up\' migration actions+              -> (MigrationName -> d -> IO ())+                 -- ^ Factory for \'down\' migration actions+              -> d+              -> IO ()+unsafeMigrate target up down driver = do+  initMigrations driver+  migrationPlan <- plan target driver+  executePlan migrationPlan up down driver
+ test/Database/Migrant/MigrationName_Orphans.hs view
@@ -0,0 +1,9 @@+module Database.Migrant.MigrationName_Orphans+where++import Test.Tasty.QuickCheck+import Database.Migrant.MigrationName+import qualified Data.Text as Text++instance Arbitrary MigrationName where+  arbitrary = MigrationName . Text.pack <$> arbitrary
+ test/Database/Migrant/Run_Orphans.hs view
@@ -0,0 +1,12 @@+{-#LANGUAGE LambdaCase #-}+module Database.Migrant.Run_Orphans+where++import Test.Tasty.QuickCheck+import Database.Migrant.Run+import qualified Data.Text as Text++instance Arbitrary MigrationDirection where+  arbitrary = arbitrary >>= \case+    True -> return MigrateUp+    False -> return MigrateDown
+ test/Database/Migrant/Run_Tests.hs view
@@ -0,0 +1,197 @@+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE OverloadedStrings #-}++module Database.Migrant.Run_Tests+where++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit++import Data.Text (Text)+import qualified Data.Text as Text+import Data.List (isSuffixOf, isPrefixOf)+import Data.IORef+import Control.Exception+import System.IO.Unsafe (unsafePerformIO)++import Database.Migrant.Run+import Database.Migrant.Driver.Class+import Database.Migrant.MigrationName+import Database.Migrant.MigrationName_Orphans+import Database.Migrant.Run_Orphans++tests = testGroup "Database.Migrant.Run"+    [ testGroup "makePlan"+        makePlanTests+    , testGroup "executePlan"+        executePlanTests+    , testGroup "migrateTests"+        migrateTests+    ]++makePlanTests :: [TestTree]+makePlanTests =+  [ testProperty "same inputs, empty diff" propSameInputEmptyDiff+  , testProperty "appended becomes diff" propAppendIsDiff+  , testProperty "removed becomes diff" propRemoveIsDiff+  , testProperty "diff length never longer than inputs combined" propDiffNotLargerThanInputs+  , testProperty "removeBeforeAdd" propRemoveBeforeAdd+  ]++propSameInputEmptyDiff migs =+  makePlan migs migs == []++propAppendIsDiff base ext =+  makePlan (base ++ ext) base == [(MigrateUp, m) | m <- ext]++propRemoveIsDiff base ext =+  makePlan base (base ++ ext) == [(MigrateDown, m) | m <- ext]++propDiffNotLargerThanInputs target current =+  length (makePlan target current) <= length target + length current++propRemoveBeforeAdd ext1 ext2 =+  all not ((==) <$> ext1 <*> ext2) ==>+  makePlan ext1 ext2 ==+  [(MigrateDown, e) | e <- ext2] +++  [(MigrateUp, e) | e <- ext1]++executePlanTests :: [TestTree]+executePlanTests =+  [ testProperty "updates only" propExecuteUpdatesOnly+  , testProperty "rollbacks only" propExecuteRollbacksOnly+  , testProperty "mixed updates/rollbacks" propExecuteMixed+  ]++propExecuteUpdatesOnly target =+  let expected = [("MARK MigrateUp " <> unpackMigrationName n) | n <- target]+      plan = [(MigrateUp, n) | n <- target]+      getMigration _ _ = return ()+      logged = runChat (executePlan plan getMigration getMigration) []+  in logged == expected++propExecuteRollbacksOnly target =+  let expected = [("MARK MigrateDown " <> unpackMigrationName n) | n <- target]+      plan = [(MigrateDown, n) | n <- target]+      getMigration _ _ = return ()+      logged = runChat (executePlan plan getMigration getMigration) []+  in logged == expected++propExecuteMixed plan =+  let expected = [("MARK " <> Text.pack (show d) <> " " <> unpackMigrationName n) | (d, n) <- plan]+      getMigration _ _ = return ()+      logged = runChat (executePlan plan getMigration getMigration) []+  in logged == expected++migrateTests :: [TestTree]+migrateTests =+  [ testCase "transactionally do nothing" testMigrateNothing+  , testCase "transactionally do something" testMigrateSomething+  , testCase "roll back on host failure" testMigrateError+  ]++testMigrateNothing :: Assertion+testMigrateNothing = do+  let target = []+      up name = logChatQuery ("MigrateUp " <> unpackMigrationName name)+      down name = logChatQuery ("MigrateDown " <> unpackMigrationName name)+  actual <- runChatIO (migrate target up down) [[]]+  let expected =+        [ "BEGIN TRANSACTION"+        , "INIT"+        , "COMMIT TRANSACTION"+        ]+  assertEqual "migration log" expected actual++testMigrateSomething :: Assertion+testMigrateSomething = do+  let target = ["foo", "bar"]+      situation = ["bar", "quux"]+      up name = logChatQuery ("MigrateUp " <> unpackMigrationName name)+      down name = logChatQuery ("MigrateDown " <> unpackMigrationName name)+  actual <- runChatIO (migrate target up down) (repeat situation)+  let expected =+        [ "BEGIN TRANSACTION"+        , "INIT"+        , "MigrateDown bar"+        , "MARK MigrateDown bar"+        , "MigrateDown quux"+        , "MARK MigrateDown quux"+        , "MigrateUp foo"+        , "MARK MigrateUp foo"+        , "MigrateUp bar"+        , "MARK MigrateUp bar"+        , "COMMIT TRANSACTION"+        ]+  assertEqual "migration log" expected actual++testMigrateError :: Assertion+testMigrateError = do+  let target = ["foo"]+      situation = ["bar"]+      up name driver = throwIO DummyError+      down name = logChatQuery ("MigrateDown " <> unpackMigrationName name)+  actual <- runChatIO (migrate target up down) (repeat situation)+  let expected =+        [ "BEGIN TRANSACTION"+        , "INIT"+        , "MigrateDown bar"+        , "MARK MigrateDown bar"+        , "ROLLBACK TRANSACTION"+        ]+  assertEqual "migration log" expected actual++-- | A mockup driver we can use to test the migration planner/executor+data ChatDriver =+  ChatDriver+    { queries :: IORef [Text]+    , responses :: IORef [[MigrationName]]+    }++logChatQuery :: Text -> ChatDriver -> IO ()+logChatQuery msg ChatDriver { queries = queries } = +  modifyIORef queries (++ [msg])++runChatIO :: (ChatDriver -> IO ()) -> [[MigrationName]] -> IO [Text]+runChatIO action responses = do+  queriesRef <- newIORef []+  responsesRef <- newIORef responses+  action (ChatDriver queriesRef responsesRef)+  readIORef queriesRef++runChat :: (ChatDriver -> IO ()) -> [[MigrationName]] -> [Text]+runChat action responses = unsafePerformIO (runChatIO action responses)++instance Driver ChatDriver where+  withTransaction action driver = do+    logChatQuery "BEGIN TRANSACTION" driver+    catch+        (do+          result <- action driver+          logChatQuery "COMMIT TRANSACTION" driver+          return result+        )+        (\(e :: SomeException) -> do+          logChatQuery "ROLLBACK TRANSACTION" driver+          return undefined+        )++  initMigrations driver = do+    logChatQuery "INIT" driver++  markUp name driver = do+    logChatQuery ("MARK MigrateUp " <> unpackMigrationName name) driver++  markDown name driver = do+    logChatQuery ("MARK MigrateDown " <> unpackMigrationName name) driver++  getMigrations driver = do+    (r:rs) <- readIORef (responses driver)+    writeIORef (responses driver) rs+    return r++data DummyError = DummyError+  deriving (Show)++instance Exception DummyError where
+ test/Spec.hs view
@@ -0,0 +1,16 @@+module Main (main) where++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit++import Data.Text (Text)+import qualified Data.Text as Text++import qualified Database.Migrant.Run_Tests++main :: IO ()+main = defaultMain $+  testGroup "Migrant"+    [ Database.Migrant.Run_Tests.tests+    ]