trek-db (empty) → 0.1.0.0
raw patch · 6 files changed
+538/−0 lines, 6 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, containers, cryptohash-sha1, hspec, hspec-discover, hspec-expectations-lifted, pg-transact, postgresql-simple, resource-pool, semigroups, text, time, time-qq, tmp-postgres, trek-db
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Database/Trek/Db.hs +248/−0
- test/Spec.hs +1/−0
- test/Tests/Database/Trek/DbSpec.hs +164/−0
- trek-db.cabal +93/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Database/Trek/Db.hs view
@@ -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)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Tests/Database/Trek/DbSpec.hs view
@@ -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
+ trek-db.cabal view
@@ -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 <https://github.com/jfischoff/trek#readme>+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