module Database.Trek.Db
(
apply
, 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 :: NonEmpty InputMigration -> DB InputGroup
inputGroup inputGroupMigrations = do
inputGroupCreateAd <- liftIO $
fmap ( posixSecondsToUTCTime
. (1e-4 *)
. (fromIntegral :: Integer -> NominalDiffTime)
. floor
. (1e4 *)
) $ getPOSIXTime
pure InputGroup {..}
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 :: 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);
|]
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)