{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
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.Base (liftBase)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Logger (MonadLogger, logDebug)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.These (These(This, These, That))
import qualified Database.PostgreSQL.Simple as PG
import Opaleye (Field, SelectArr, SqlBool, SqlInt4, SqlFloat8, SqlText, SqlTimestamptz, Table, asc, orderBy, runSelect, selectTable, tableWithSchema)
import Refurb.MigrationUtils (doesTableExist, qqSqls)
import Refurb.Types (Migration, migrationQualifiedKey)
data MigrationResult
= MigrationSuccess
| MigrationFailure
deriving (MigrationResult -> MigrationResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationResult -> MigrationResult -> Bool
$c/= :: MigrationResult -> MigrationResult -> Bool
== :: MigrationResult -> MigrationResult -> Bool
$c== :: MigrationResult -> MigrationResult -> Bool
Eq, Int -> MigrationResult -> ShowS
[MigrationResult] -> ShowS
MigrationResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrationResult] -> ShowS
$cshowList :: [MigrationResult] -> ShowS
show :: MigrationResult -> String
$cshow :: MigrationResult -> String
showsPrec :: Int -> MigrationResult -> ShowS
$cshowsPrec :: Int -> MigrationResult -> ShowS
Show)
deriveOpaleyeEnum ''MigrationResult "refurb.migration_result_enum" (stripPrefix "migration" . toLower)
withLensesAndProxies [d|
type FId = "id" :-> Int32
type FIdMay = "id" :-> Maybe Int32
type CId = "id" :-> Field SqlInt4
type CIdMay = "id" :-> Maybe (Field SqlInt4)
type FQualifiedKey = "qualified_key" :-> Text
type CQualifiedKey = "qualified_key" :-> Field SqlText
type FApplied = "applied" :-> UTCTime
type CApplied = "applied" :-> Field SqlTimestamptz
type FOutput = "output" :-> Text
type COutput = "output" :-> Field SqlText
type FResult = "result" :-> MigrationResult
type CResult = "result" :-> Field PGMigrationResult
type FDuration = "duration" :-> Double
type CDuration = "duration" :-> Field SqlFloat8
type FProdSystem = "prod_system" :-> Bool
type CProdSystem = "prod_system" :-> Field SqlBool
|]
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 :: Table (Record MigrationLogColsW) (Record MigrationLogColsR)
migrationLog = forall writeFields viewFields.
String
-> String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
tableWithSchema String
"refurb" String
"migration_log" forall (write :: [*]) (read :: [*]).
DefaultRecTable write read =>
TableFields (Rec Identity write) (Rec Identity read)
defaultRecTable
refurbConfig :: Table (Record RefurbConfigCols) (Record RefurbConfigCols)
refurbConfig :: Table (Record RefurbConfigCols) (Record RefurbConfigCols)
refurbConfig = forall writeFields viewFields.
String
-> String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
tableWithSchema String
"refurb" String
"config" forall (write :: [*]) (read :: [*]).
DefaultRecTable write read =>
TableFields (Rec Identity write) (Rec Identity read)
defaultRecTable
isSchemaPresent :: (MonadBaseControl IO m, MonadMask m, MonadLogger m) => PG.Connection -> m Bool
isSchemaPresent :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadMask m, MonadLogger m) =>
Connection -> m Bool
isSchemaPresent Connection
conn = do
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug Text
"Checking if schema present"
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *). MonadMigration m => Text -> Text -> m Bool
doesTableExist Text
"refurb" Text
"config") Connection
conn
isProdSystem :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m Bool
isProdSystem :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadLogger m) =>
Connection -> m Bool
isProdSystem Connection
conn = do
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug Text
"Checking if this is a prod system"
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a. a -> Maybe a -> a
fromMaybe Bool
False forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall mono. MonoFoldable mono => mono -> Maybe (Element mono)
headMay) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn forall a b. (a -> b) -> a -> b
$ proc () -> do
Record RefurbConfigCols
config <- forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table (Record RefurbConfigCols) (Record RefurbConfigCols)
refurbConfig -< ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *) (rs :: [*]).
(Functor f, CProdSystem ∈ rs) =>
(Field_ 'NonNullable SqlBool -> f (Field_ 'NonNullable SqlBool))
-> Record rs -> f (Record rs)
cProdSystem Record RefurbConfigCols
config
initializeSchema :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m ()
initializeSchema :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadLogger m) =>
Connection -> m ()
initializeSchema Connection
conn = do
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug Text
"Initializing refurb schema"
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
(Element mono -> f b) -> mono -> f ()
traverse_ (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Connection -> Query -> IO Int64
PG.execute_ Connection
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]
-> SelectArr (Record MigrationLogColsR) ()
-> m [These Migration (Record MigrationLog)]
readMigrationStatus :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadLogger m) =>
Connection
-> [Migration]
-> SelectArr (Record MigrationLogColsR) ()
-> m [These Migration (Record MigrationLog)]
readMigrationStatus Connection
conn [Migration]
migrations SelectArr (Record MigrationLogColsR) ()
restriction = do
$Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logDebug Text
"Reading migration status"
[MapValue (Map Text (Record MigrationLog))]
migrationStatus <- forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Order a -> Select a -> Select a
orderBy (forall b a. SqlOrd b => (a -> Field b) -> Order a
asc forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *) (rs :: [*]).
(Functor f, CQualifiedKey ∈ rs) =>
(Field_ 'NonNullable SqlText -> f (Field_ 'NonNullable SqlText))
-> Record rs -> f (Record rs)
cQualifiedKey) forall a b. (a -> b) -> a -> b
$ proc () -> do
Record MigrationLogColsR
mlog <- forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table (Record MigrationLogColsW) (Record MigrationLogColsR)
migrationLog -< ()
SelectArr (Record MigrationLogColsR) ()
restriction -< Record MigrationLogColsR
mlog
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Record MigrationLogColsR
mlog
let migrationLogByKey :: Map Text (Record MigrationLog)
migrationLogByKey = forall map. IsMap map => [(ContainerKey map, MapValue map)] -> map
mapFromList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *) (rs :: [*]).
(Functor f, FQualifiedKey ∈ rs) =>
(Text -> f Text) -> Record rs -> f (Record rs)
fQualifiedKey forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) forall a b. (a -> b) -> a -> b
$ [MapValue (Map Text (Record MigrationLog))]
migrationStatus
alignMigration
:: Migration
-> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog))
-> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog))
alignMigration :: Migration
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
alignMigration m :: Migration
m@(Migration -> Text
migrationQualifiedKey -> Text
k) ([These Migration (Record MigrationLog)]
t, Map Text (Record MigrationLog)
l) =
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((forall a. a -> [a] -> [a]
:[These Migration (Record MigrationLog)]
t) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> These a b
This Migration
m) (forall a b. a -> b -> These a b
These Migration
m)) (forall map.
IsMap map =>
(ContainerKey map -> MapValue map -> Maybe (MapValue map))
-> ContainerKey map -> map -> (Maybe (MapValue map), map)
updateLookupWithKey (\ ContainerKey (Map Text (Record MigrationLog))
_ MapValue (Map Text (Record MigrationLog))
_ -> forall a. Maybe a
Nothing) Text
k Map Text (Record MigrationLog)
l)
([These Migration (Record MigrationLog)]
aligned, Map Text (Record MigrationLog)
extra) = forall mono b.
MonoFoldable mono =>
(Element mono -> b -> b) -> b -> mono -> b
foldr Migration
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
alignMigration ([], Map Text (Record MigrationLog)
migrationLogByKey) [Migration]
migrations
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. b -> These a b
That (forall mono. MonoFoldable mono => mono -> [Element mono]
toList Map Text (Record MigrationLog)
extra) forall m. Monoid m => m -> m -> m
++ [These Migration (Record MigrationLog)]
aligned