module Refurb.Store where
import ClassyPrelude
import Composite.Opaleye (defaultRecTable)
import Composite.Opaleye.TH (deriveOpaleyeEnum)
import Composite.Record ((:->), Record)
import Composite.TH (withLensesAndProxies)
import Control.Arrow (returnA)
import Control.Lens (view)
import Control.Monad.Logger (MonadLogger, logDebug)
import Data.These (These(This, These, That))
import qualified Database.PostgreSQL.Simple as PG
import Opaleye (Column, PGBool, PGInt4, PGFloat8, PGText, PGTimestamptz, QueryArr, Table(TableWithSchema), asc, orderBy, queryTable, runQuery)
import Refurb.MigrationUtils (doesTableExist, qqSqls)
import Refurb.Types (Migration, migrationQualifiedKey)
data MigrationResult
= MigrationSuccess
| MigrationFailure
deriving (Eq, Show)
deriveOpaleyeEnum ''MigrationResult "migration_result_enum" (stripPrefix "migration" . toLower)
withLensesAndProxies [d|
type FId = "id" :-> Int32
type FIdMay = "id" :-> Maybe Int32
type CId = "id" :-> Column PGInt4
type CIdMay = "id" :-> Maybe (Column PGInt4)
type FQualifiedKey = "qualified_key" :-> Text
type CQualifiedKey = "qualified_key" :-> Column PGText
type FApplied = "applied" :-> UTCTime
type CApplied = "applied" :-> Column PGTimestamptz
type FOutput = "output" :-> Text
type COutput = "output" :-> Column PGText
type FResult = "result" :-> MigrationResult
type CResult = "result" :-> Column PGMigrationResult
type FDuration = "duration" :-> Double
type CDuration = "duration" :-> Column PGFloat8
type FProdSystem = "prod_system" :-> Bool
type CProdSystem = "prod_system" :-> Column PGBool
|]
type MigrationLog = '[FId , FQualifiedKey, FApplied, FOutput, FResult, FDuration]
type MigrationLogW = '[FIdMay, FQualifiedKey, FApplied, FOutput, FResult, FDuration]
type MigrationLogColsR = '[CId , CQualifiedKey, CApplied, COutput, CResult, CDuration]
type MigrationLogColsW = '[CIdMay, CQualifiedKey, CApplied, COutput, CResult, CDuration]
type RefurbConfig = '[FProdSystem]
type RefurbConfigCols = '[CProdSystem]
migrationLog :: Table (Record MigrationLogColsW) (Record MigrationLogColsR)
migrationLog = TableWithSchema "refurb" "migration_log" defaultRecTable
refurbConfig :: Table (Record RefurbConfigCols) (Record RefurbConfigCols)
refurbConfig = TableWithSchema "refurb" "config" defaultRecTable
isSchemaPresent :: (MonadBaseControl IO m, MonadMask m, MonadLogger m) => PG.Connection -> m Bool
isSchemaPresent conn = do
$logDebug "Checking if schema present"
runReaderT (doesTableExist "refurb" "config") conn
isProdSystem :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m Bool
isProdSystem conn = do
$logDebug "Checking if this is a prod system"
map (fromMaybe False . headMay) . liftBase . runQuery conn $ proc () -> do
config <- queryTable refurbConfig -< ()
returnA -< view cProdSystem config
initializeSchema :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m ()
initializeSchema conn = do
$logDebug "Initializing refurb schema"
liftBase $ traverse_ (void . PG.execute_ conn) [qqSqls|
create schema refurb;
set search_path = 'refurb';
create type migration_result_enum as enum('success', 'failure');
create table config (prod_system boolean not null);
insert into config (prod_system) values (false);
create sequence migration_log_serial;
create table migration_log
( id int not null
primary key
default nextval('migration_log_serial')
, qualified_key text not null
unique
, applied timestamptz not null
, output text not null
, result migration_result_enum not null
, duration double precision not null
);
|]
readMigrationStatus
:: (MonadBaseControl IO m, MonadLogger m)
=> PG.Connection
-> [Migration]
-> QueryArr (Record MigrationLogColsR) ()
-> m [These Migration (Record MigrationLog)]
readMigrationStatus conn migrations restriction = do
$logDebug "Reading migration status"
migrationStatus <- liftBase $ runQuery conn . orderBy (asc $ view cQualifiedKey) $ proc () -> do
mlog <- queryTable migrationLog -< ()
restriction -< mlog
returnA -< mlog
let migrationLogByKey = mapFromList . map (view fQualifiedKey &&& id) $ migrationStatus
alignMigration
:: Migration
-> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog))
-> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog))
alignMigration m@(migrationQualifiedKey -> k) (t, l) =
first ((:t) . maybe (This m) (These m)) (updateLookupWithKey (\ _ _ -> Nothing) k l)
(aligned, extra) = foldr alignMigration ([], migrationLogByKey) migrations
pure $ map That (toList extra) ++ aligned