diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jonathan Fischoff (c) 2019, 2020 + +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 Author name here 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. 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/src/Database/Trek/Db.hs b/src/Database/Trek/Db.hs new file mode 100644 --- /dev/null +++ b/src/Database/Trek/Db.hs @@ -0,0 +1,248 @@ +module Database.Trek.Db + ( -- * Life cycle management + apply + -- * Types + , InputMigration (..) + , OutputMigration (..) + , GroupId (..) + , Version + , Hash + , DB + , OutputGroup (..) + , InputGroup (..) + , inputGroup + , Time + , makeGroupHash + ) + where +import Database.PostgreSQL.Transact +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.ByteString (ByteString) +import qualified Database.PostgreSQL.Simple as Psql +import qualified Database.PostgreSQL.Simple.FromField as Psql +import qualified Database.PostgreSQL.Simple.ToField as Psql +import qualified Database.PostgreSQL.Simple.ToRow as Psql +import qualified Database.PostgreSQL.Simple.FromRow as Psql +import Database.PostgreSQL.Simple.SqlQQ +import Control.Monad (void) +import GHC.Generics +import qualified Data.Set as Set +import Data.Traversable +import Data.Foldable +import Control.Monad.IO.Class +import Data.Time +import Crypto.Hash.SHA1 +import Database.PostgreSQL.Simple.Types +import Data.Time.Clock.POSIX +import qualified Data.ByteString.Char8 as BSC +import Data.Function + +type Version = UTCTime + +type Hash = ByteString + +type Time = UTCTime + +data InputMigration = InputMigration + { inputAction :: DB () + , inputVersion :: Version + , inputHash :: Binary Hash + } + +instance Psql.ToRow InputMigration where + toRow InputMigration {..} = [Psql.toField inputVersion, Psql.toField inputHash] + +newtype GroupId = GroupId (Binary ByteString) + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Psql.FromField, Psql.ToField) + deriving (Psql.ToRow) via (Psql.Only GroupId) + +instance Psql.FromRow GroupId where + fromRow = GroupId <$> Psql.field + +data OutputMigration = OutputMigration + { omVersion :: Version + , omHash :: Binary Hash + } deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (Psql.FromRow) + + +data OutputGroup = OutputGroup + { ogId :: GroupId + , ogCreatedAt :: UTCTime + , ogMigrations :: NonEmpty OutputMigration + } + deriving (Show, Eq) + +data InputGroup = InputGroup + { inputGroupMigrations :: NonEmpty InputMigration + , inputGroupCreateAd :: UTCTime + } + +data GroupRow = GroupRow + { arId :: GroupId + , arCreatedAt :: UTCTime + } deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Psql.ToRow, Psql.FromRow) + +-- InputGroup constructor +inputGroup :: NonEmpty InputMigration -> DB InputGroup +inputGroup inputGroupMigrations = do + inputGroupCreateAd <- liftIO $ + fmap ( posixSecondsToUTCTime + . (1e-4 *) + . (fromIntegral :: Integer -> NominalDiffTime) + . floor + . (1e4 *) + ) $ getPOSIXTime + pure InputGroup {..} + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- +onSetup :: (Bool -> Bool) -> DB a -> DB (Maybe a) +onSetup onF action = do + setupExists <- Psql.fromOnly . head <$> query_ [sql| + SELECT EXISTS ( + SELECT 1 + FROM information_schema.tables + WHERE table_schema = 'meta' + AND table_name = 'applications' + ) + |] + if onF setupExists + then Just <$> action + else pure Nothing + +withoutSetup :: DB a -> DB (Maybe a) +withoutSetup = onSetup not + +------------------------------------------------------------------------------- +-- setup/teardown +------------------------------------------------------------------------------- + +setup :: DB (Maybe ()) +setup = withoutSetup $ void $ execute_ [sql| + CREATE SCHEMA meta; + + CREATE TABLE meta.applications + ( id bytea PRIMARY KEY + , rowOrder SERIAL NOT NULL + , created_at TIMESTAMP WITH TIME ZONE NOT NULL + ); + + CREATE INDEX ON meta.applications (rowOrder); + CREATE INDEX ON meta.applications (created_at); + + CREATE TABLE meta.actions + ( version TIMESTAMP WITH TIME ZONE PRIMARY KEY + , hash bytea NOT NULL + , application_id bytea NOT NULL REFERENCES meta.applications ON DELETE CASCADE + , rowOrder SERIAL NOT NULL + ); + + CREATE INDEX ON meta.actions (hash); + CREATE INDEX ON meta.actions (application_id); + CREATE INDEX ON meta.actions (rowOrder); + + |] + +-------------------------- +-- apply +------------------------- +createApplication :: GroupRow -> DB () +createApplication groupRow = void $ execute [sql| + INSERT INTO meta.applications + (id, created_at) + VALUES + (?, ?) + |] groupRow + +dup :: (t -> a) -> (t -> b) -> t -> (a, b) +dup f g x = (f x, g x) + +outputGroupsToVersions :: [OutputGroup] -> [(Version, Hash)] +outputGroupsToVersions = concatMap (toList . outputGroupToVersions) + +outputGroupToVersions :: OutputGroup -> NonEmpty (Version, Hash) +outputGroupToVersions = fmap (dup omVersion (fromBinary . omHash)) . ogMigrations + +diffToUnappliedMigrations :: [Version] -> [Version] -> [Version] +diffToUnappliedMigrations allMigrations appliedMigrations + = Set.toList + $ Set.fromList allMigrations `Set.difference` Set.fromList appliedMigrations + +differenceMigrationsByVersion :: [InputMigration] -> [Version] -> [InputMigration] +differenceMigrationsByVersion migrations appliedVersions = + let versionsToApply = diffToUnappliedMigrations (map inputVersion migrations) appliedVersions + in filter (\m -> inputVersion m `elem` versionsToApply) migrations + +getOutputGroup :: GroupId -> DB OutputGroup +getOutputGroup groupId = do + outputMigrations <- NonEmpty.fromList <$> query [sql| + SELECT version, hash + FROM meta.actions + WHERE application_id = ? + ORDER BY rowOrder ASC + |] groupId + + arCreatedAt <- fmap (Psql.fromOnly . head) $ query [sql| + SELECT created_at + FROM meta.applications + WHERE id = ? + |] groupId + + pure $ OutputGroup groupId arCreatedAt outputMigrations + +listApplications :: DB [OutputGroup] +listApplications = do + _ <- setup + mapM getOutputGroup =<< + query_ [sql| + SELECT id + FROM meta.applications + ORDER BY rowOrder ASC |] + +makeGroupHash :: UTCTime -> [InputMigration] -> Hash +makeGroupHash createdAt migrations = hash $ + mconcat ((BSC.pack $ show createdAt) : map (fromBinary . inputHash) migrations) + +inputGroupToGroupRow :: InputGroup -> GroupRow +inputGroupToGroupRow InputGroup {..} = + let arId = GroupId $ Binary $ makeGroupHash inputGroupCreateAd $ NonEmpty.toList inputGroupMigrations + arCreatedAt = inputGroupCreateAd + + in GroupRow {..} + +apply :: InputGroup -> DB (Maybe OutputGroup) +apply migrations = do + _ <- setup + appliedMigrations <- listApplications + + let unappliedMigrations = differenceMigrationsByVersion + (toList $ inputGroupMigrations migrations) $ map fst $ + outputGroupsToVersions appliedMigrations + + forM (nonEmpty unappliedMigrations) $ \ms -> do + let groupRow = inputGroupToGroupRow $ + migrations { inputGroupMigrations = ms } + applyMigrations groupRow ms + + getOutputGroup $ arId groupRow + +applyMigrations :: GroupRow -> NonEmpty (InputMigration) -> DB () +applyMigrations groupRow migrations = do + createApplication groupRow + forM_ (NonEmpty.sortBy (compare `on` inputVersion) migrations) $ \migration -> do + inputAction migration + insertMigration (arId groupRow) migration + +insertMigration :: GroupId -> InputMigration -> DB () +insertMigration groupId migration = void $ execute + [sql| + INSERT INTO meta.actions + (version, hash, application_id) + VALUES + (?, ?, ?) + |] (migration Psql.:. groupId) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Tests/Database/Trek/DbSpec.hs b/test/Tests/Database/Trek/DbSpec.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Database/Trek/DbSpec.hs @@ -0,0 +1,164 @@ +module Tests.Database.Trek.DbSpec (spec) where +import Database.Trek.Db +import Data.Time.QQ +import qualified Database.Postgres.Temp as Temp +import qualified Database.PostgreSQL.Transact as T +import qualified Database.PostgreSQL.Simple as Psql +import Database.PostgreSQL.Simple.SqlQQ +import Control.Exception +import Control.Monad (void) +import Data.Pool +import qualified Data.List.NonEmpty as NonEmpty +import Test.Hspec hiding (shouldReturn, shouldBe) +import Data.Foldable +import Control.Monad ((<=<)) +import Test.Hspec.Expectations.Lifted (shouldReturn, shouldBe) +import Data.List.NonEmpty (NonEmpty(..), fromList) +import Control.Concurrent +import Control.Concurrent.Async +import Data.IORef +import Data.Function + +type WorldState = String + +------------------------------------------------------------------------------- +-- Functions that should live somewhere else +------------------------------------------------------------------------------- +-- This is sequential subsets! + +nonEmptyPartitionsOf :: NonEmpty a -> NonEmpty (NonEmpty (NonEmpty a)) +nonEmptyPartitionsOf = fromList . fmap fromList . fmap (fmap fromList) . partitions . toList + +partitions :: [a] -> [[[a]]] +partitions [] = [[]] +partitions (x:xs) = [[x]:p | p <- partitions xs] + ++ [(x:ys):yss | (ys:yss) <- partitions xs] +------------------------------------------------------------------------------- +-- Hspec helper +------------------------------------------------------------------------------- +aroundAll :: forall a. ((a -> IO ()) -> IO ()) -> SpecWith a -> Spec +aroundAll withFunc specWith = do + (var, stopper, asyncer) <- runIO $ + (,,) <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Nothing + let theStart :: IO a + theStart = do + + thread <- async $ do + withFunc $ \x -> do + putMVar var x + takeMVar stopper + pure $ error "Don't evaluate this" + + writeIORef asyncer $ Just thread + + either pure pure =<< (wait thread `race` takeMVar var) + + theStop :: a -> IO () + theStop _ = do + putMVar stopper () + traverse_ cancel =<< readIORef asyncer + + beforeAll theStart $ afterAll theStop $ specWith + +clear :: DB () +clear = void $ T.execute_ [sql| + DROP SCHEMA IF EXISTS meta CASCADE; + DROP SCHEMA IF EXISTS test CASCADE; + |] + +worldState :: DB WorldState +worldState = do + xs :: [String] <- fmap Psql.fromOnly <$> T.query_ + "SELECT CAST(table_name AS varchar) FROM information_schema.tables where table_schema = 'test' ORDER BY table_name" + pure $ concat xs + +createFoo :: DB () +createFoo = void $ T.execute_ [sql| CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.foo (id SERIAL PRIMARY KEY)|] + +createBar :: DB () +createBar = void $ T.execute_ [sql| CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.bar (id SERIAL PRIMARY KEY)|] + +createQuux :: DB () +createQuux = void $ T.execute_ [sql| CREATE SCHEMA IF NOT EXISTS test; CREATE TABLE test.quux (id SERIAL PRIMARY KEY)|] + +foo :: InputMigration +foo = InputMigration createFoo [utcIso8601| 2022-12-01 |] (Psql.Binary "extra") + +bar :: InputMigration +bar = InputMigration createBar [utcIso8601| 2025-12-01 |] (Psql.Binary "migration-2025-12-01") + +quux :: InputMigration +quux = InputMigration createQuux [utcIso8601| 2025-12-02 |] (Psql.Binary "migration-2025-12-02") + +toOutputMigration :: InputMigration -> OutputMigration +toOutputMigration InputMigration {..} = OutputMigration + { omVersion = inputVersion + , omHash = inputHash + } + +toOutput :: InputGroup -> DB OutputGroup +toOutput InputGroup {..} = pure OutputGroup + { ogId = GroupId $ Psql.Binary $ makeGroupHash inputGroupCreateAd $ NonEmpty.toList inputGroupMigrations + , ogCreatedAt = inputGroupCreateAd + , ogMigrations = fmap toOutputMigration $ NonEmpty.sortBy (compare `on` inputHash) inputGroupMigrations + } + +rollback :: DB a -> DB a +rollback = T.rollback +-- +withSetup :: (Pool Psql.Connection -> IO a) -> IO a +withSetup f = do + -- Helper to throw exceptions + let throwE x = either throwIO pure =<< x + + throwE $ Temp.withDbCache $ \dbCache -> do + let combinedConfig = Temp.defaultConfig <> Temp.cacheConfig dbCache + Temp.withConfig combinedConfig $ \db -> + f =<< createPool (Psql.connectPostgreSQL $ Temp.toConnectionString db) Psql.close 2 60 10 + +withPool :: DB a -> Pool Psql.Connection -> IO a +withPool action pool = withResource pool $ \conn -> T.runDBTSerializable action conn + +spec :: Spec +spec = do + let rollbackIt msg action = it msg $ \pool -> flip withPool pool $ rollback action + + aroundAll withSetup $ describe "Tests.Database.Trek.Db.Interface" $ do + rollbackIt "input migration on clean setup give output group" $ do + initial <- inputGroup $ pure foo + expected <- toOutput initial + apply initial `shouldReturn` Just expected + + it "for s ⊆ x. apply x >> apply s = Nothing" $ withPool $ rollback $ do + twoMigrations <- inputGroup (foo NonEmpty.:| [bar]) + expectedTwoOutput <- toOutput twoMigrations + apply twoMigrations `shouldReturn` Just expectedTwoOutput + + rollback $ (apply =<< inputGroup (pure foo)) `shouldReturn` Nothing + rollback $ (apply =<< inputGroup (pure bar)) `shouldReturn` Nothing + + rollbackIt "for s ⊆ x and y st. z = y / x and z ≠ ∅. apply s >> apply y = Just z" $ do + twoMigrations <- inputGroup (foo NonEmpty.:| [bar]) + expectedTwoOutput <- toOutput twoMigrations + apply twoMigrations `shouldReturn` Just expectedTwoOutput + + someAlreadyApplied <- inputGroup (foo NonEmpty.:| [quux]) + onlyQuux <- toOutput =<< inputGroup (quux NonEmpty.:| []) + + apply someAlreadyApplied `shouldReturn` Just onlyQuux + + -- TODO make exception safe + it "actions are preserved during migration : all partitions apply the same effects" $ \pool -> do + let migrations = quux NonEmpty.:| [foo, bar] + forM_ (nonEmptyPartitionsOf migrations) $ \parts -> do + _ <- flip withPool pool clear + + expectedWorldState <- mapM_ (flip withPool pool . sequenceA_ . fmap inputAction) parts + >> flip withPool pool worldState + + _ <- flip withPool pool clear + + actual <- flip withPool pool + (mapM_ (apply <=< inputGroup) parts >> worldState) + + actual `shouldBe` expectedWorldState diff --git a/trek-db.cabal b/trek-db.cabal new file mode 100644 --- /dev/null +++ b/trek-db.cabal @@ -0,0 +1,93 @@ +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: ab7f58e2ba372fd8cc72dcb41598085a170ea1109e6522551fd9f2b2d1fd5bde + +name: trek-db +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/jfischoff/trek#readme +bug-reports: https://github.com/jfischoff/trek/issues +author: Jonathan Fischoff +maintainer: jonathangfischoff at gmail.com +copyright: 2019 Jonathan Fischoff +license: BSD3 +license-file: LICENSE +build-type: Simple +tested-with: GHC==8.8.1 +category: Database +synopsis: A PostgreSQL Database Migrator + +source-repository head + type: git + location: https://github.com/jfischoff/trek + +library + exposed-modules: + Database.Trek.Db + -- , Database.Trek.Db.Metadata + -- , Database.Trek.Db.Metadata.Impl + -- , Database.PostgreSQL.Simple.Statement + -- This could have a plugin interface + -- , Database.Trek.Db.BackupHooks.Impl + -- this are different version of migrate filePath + -- , Database.Trek.Db.FromDirectory + -- , Database.Trek.Db.FromManifest + -- , Database.Trek.Db.FromSql + -- , Database.Trek.Db.FromSh + -- This exposes a new interface + -- that is something like setup, teardown, migrate filePath, listMigrations + + -- add the simpler teardown, migrate filePath, listMigrations + hs-source-dirs: + src + default-extensions: DataKinds GADTs KindSignatures QuasiQuotes RecordWildCards LambdaCase RankNTypes ScopedTypeVariables OverloadedStrings GeneralizedNewtypeDeriving DerivingVia DeriveGeneric DeriveAnyClass TupleSections + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , pg-transact >= 0.2.1.0 + , postgresql-simple + , semigroups + , text + , time + , cryptohash-sha1 + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: Tests.Database.Trek.DbSpec + hs-source-dirs: test + default-extensions: QuasiQuotes + , RecordWildCards + , LambdaCase + , RankNTypes + , ScopedTypeVariables + , OverloadedStrings + , GeneralizedNewtypeDeriving + , DerivingVia + , DeriveGeneric + , DeriveAnyClass + , TupleSections + , NamedFieldPuns + , FlexibleContexts + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , hspec + , hspec-discover + , trek-db + , time-qq + , tmp-postgres + , resource-pool + , hspec-expectations-lifted + , async + , postgresql-simple + , pg-transact + default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover