{-# 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
(MigrationResult -> MigrationResult -> Bool)
-> (MigrationResult -> MigrationResult -> Bool)
-> Eq MigrationResult
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
(Int -> MigrationResult -> ShowS)
-> (MigrationResult -> String)
-> ([MigrationResult] -> ShowS)
-> Show MigrationResult
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 = String
-> String
-> TableFields
(Record MigrationLogColsW) (Record MigrationLogColsR)
-> Table (Record MigrationLogColsW) (Record MigrationLogColsR)
forall writeFields viewFields.
String
-> String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
tableWithSchema String
"refurb" String
"migration_log" TableFields (Record MigrationLogColsW) (Record MigrationLogColsR)
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 = String
-> String
-> TableFields (Record RefurbConfigCols) (Record RefurbConfigCols)
-> Table (Record RefurbConfigCols) (Record RefurbConfigCols)
forall writeFields viewFields.
String
-> String
-> TableFields writeFields viewFields
-> Table writeFields viewFields
tableWithSchema String
"refurb" String
"config" TableFields (Record RefurbConfigCols) (Record RefurbConfigCols)
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 :: Connection -> m Bool
isSchemaPresent Connection
conn = do
Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
Text -> Text
(Text -> m ()) -> (Text -> Text) -> 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 ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
$logDebug Text
"Checking if schema present"
ReaderT Connection m Bool -> Connection -> m Bool
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Text -> Text -> ReaderT Connection m Bool
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 :: Connection -> m Bool
isProdSystem Connection
conn = do
Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
Text -> Text
(Text -> m ()) -> (Text -> Text) -> 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 ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
$logDebug Text
"Checking if this is a prod system"
([Bool] -> Bool) -> m [Bool] -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> ([Bool] -> Maybe Bool) -> [Bool] -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Bool] -> Maybe Bool
forall mono. MonoFoldable mono => mono -> Maybe (Element mono)
headMay) (m [Bool] -> m Bool)
-> (Select (Field SqlBool) -> m [Bool])
-> Select (Field SqlBool)
-> m Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO [Bool] -> m [Bool]
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO [Bool] -> m [Bool])
-> (Select (Field SqlBool) -> IO [Bool])
-> Select (Field SqlBool)
-> m [Bool]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Connection -> Select (Field SqlBool) -> IO [Bool]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn (Select (Field SqlBool) -> m Bool)
-> Select (Field SqlBool) -> m Bool
forall a b. (a -> b) -> a -> b
$ proc () -> do
Record RefurbConfigCols
config <- Table (Record RefurbConfigCols) (Record RefurbConfigCols)
-> Select (Record RefurbConfigCols)
forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table (Record RefurbConfigCols) (Record RefurbConfigCols)
refurbConfig -< ()
SelectArr (Field SqlBool) (Field SqlBool)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Getting (Field SqlBool) (Record RefurbConfigCols) (Field SqlBool)
-> Record RefurbConfigCols -> Field SqlBool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Field SqlBool) (Record RefurbConfigCols) (Field SqlBool)
forall (f :: * -> *) (rs :: [*]).
(Functor f, CProdSystem ∈ rs) =>
(Field SqlBool -> f (Field SqlBool)) -> Record rs -> f (Record rs)
cProdSystem Record RefurbConfigCols
config
initializeSchema :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m ()
initializeSchema :: Connection -> m ()
initializeSchema Connection
conn = do
Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> m ()
Text -> Text
(Text -> m ()) -> (Text -> Text) -> 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 ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
$logDebug Text
"Initializing refurb schema"
IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Element [Query] -> IO ()) -> [Query] -> IO ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
(Element mono -> f b) -> mono -> f ()
traverse_ (IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> (Query -> IO Int64) -> Query -> IO ()
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 :: 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
Loc -> Text -> LogLevel -> Text -> m ()
Text -> Text
(Text -> m ()) -> (Text -> Text) -> 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 ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
$logDebug Text
"Reading migration status"
[Record MigrationLog]
migrationStatus <- IO [Record MigrationLog] -> m [Record MigrationLog]
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO [Record MigrationLog] -> m [Record MigrationLog])
-> IO [Record MigrationLog] -> m [Record MigrationLog]
forall a b. (a -> b) -> a -> b
$ Connection
-> Select (Record MigrationLogColsR) -> IO [Record MigrationLog]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
conn (Select (Record MigrationLogColsR) -> IO [Record MigrationLog])
-> (Select (Record MigrationLogColsR)
-> Select (Record MigrationLogColsR))
-> Select (Record MigrationLogColsR)
-> IO [Record MigrationLog]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Order (Record MigrationLogColsR)
-> Select (Record MigrationLogColsR)
-> Select (Record MigrationLogColsR)
forall a. Order a -> Select a -> Select a
orderBy ((Record MigrationLogColsR -> Field SqlText)
-> Order (Record MigrationLogColsR)
forall b a. SqlOrd b => (a -> Field b) -> Order a
asc ((Record MigrationLogColsR -> Field SqlText)
-> Order (Record MigrationLogColsR))
-> (Record MigrationLogColsR -> Field SqlText)
-> Order (Record MigrationLogColsR)
forall a b. (a -> b) -> a -> b
$ Getting (Field SqlText) (Record MigrationLogColsR) (Field SqlText)
-> Record MigrationLogColsR -> Field SqlText
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Field SqlText) (Record MigrationLogColsR) (Field SqlText)
forall (f :: * -> *) (rs :: [*]).
(Functor f, CQualifiedKey ∈ rs) =>
(Field SqlText -> f (Field SqlText)) -> Record rs -> f (Record rs)
cQualifiedKey) (Select (Record MigrationLogColsR) -> IO [Record MigrationLog])
-> Select (Record MigrationLogColsR) -> IO [Record MigrationLog]
forall a b. (a -> b) -> a -> b
$ proc () -> do
Record MigrationLogColsR
mlog <- Table (Record MigrationLogColsW) (Record MigrationLogColsR)
-> Select (Record MigrationLogColsR)
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
SelectArr (Record MigrationLogColsR) (Record MigrationLogColsR)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Record MigrationLogColsR
mlog
let migrationLogByKey :: Map Text (Record MigrationLog)
migrationLogByKey = [(ContainerKey (Map Text (Record MigrationLog)),
MapValue (Map Text (Record MigrationLog)))]
-> Map Text (Record MigrationLog)
forall map. IsMap map => [(ContainerKey map, MapValue map)] -> map
mapFromList ([(ContainerKey (Map Text (Record MigrationLog)),
MapValue (Map Text (Record MigrationLog)))]
-> Map Text (Record MigrationLog))
-> ([Record MigrationLog]
-> [(ContainerKey (Map Text (Record MigrationLog)),
MapValue (Map Text (Record MigrationLog)))])
-> [Record MigrationLog]
-> Map Text (Record MigrationLog)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Record MigrationLog -> (Text, Record MigrationLog))
-> [Record MigrationLog] -> [(Text, Record MigrationLog)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Getting Text (Record MigrationLog) Text
-> Record MigrationLog -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text (Record MigrationLog) Text
forall (f :: * -> *) (rs :: [*]).
(Functor f, FQualifiedKey ∈ rs) =>
(Text -> f Text) -> Record rs -> f (Record rs)
fQualifiedKey (Record MigrationLog -> Text)
-> (Record MigrationLog -> Record MigrationLog)
-> Record MigrationLog
-> (Text, Record MigrationLog)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Record MigrationLog -> Record MigrationLog
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) ([Record MigrationLog] -> Map Text (Record MigrationLog))
-> [Record MigrationLog] -> Map Text (Record MigrationLog)
forall a b. (a -> b) -> a -> b
$ [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) =
(Maybe (Record MigrationLog)
-> [These Migration (Record MigrationLog)])
-> (Maybe (Record MigrationLog), Map Text (Record MigrationLog))
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((These Migration (Record MigrationLog)
-> [These Migration (Record MigrationLog)]
-> [These Migration (Record MigrationLog)]
forall a. a -> [a] -> [a]
:[These Migration (Record MigrationLog)]
t) (These Migration (Record MigrationLog)
-> [These Migration (Record MigrationLog)])
-> (Maybe (Record MigrationLog)
-> These Migration (Record MigrationLog))
-> Maybe (Record MigrationLog)
-> [These Migration (Record MigrationLog)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. These Migration (Record MigrationLog)
-> (Record MigrationLog -> These Migration (Record MigrationLog))
-> Maybe (Record MigrationLog)
-> These Migration (Record MigrationLog)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Migration -> These Migration (Record MigrationLog)
forall a b. a -> These a b
This Migration
m) (Migration
-> Record MigrationLog -> These Migration (Record MigrationLog)
forall a b. a -> b -> These a b
These Migration
m)) ((ContainerKey (Map Text (Record MigrationLog))
-> MapValue (Map Text (Record MigrationLog))
-> Maybe (MapValue (Map Text (Record MigrationLog))))
-> ContainerKey (Map Text (Record MigrationLog))
-> Map Text (Record MigrationLog)
-> (Maybe (MapValue (Map Text (Record MigrationLog))),
Map Text (Record MigrationLog))
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))
_ -> Maybe (MapValue (Map Text (Record MigrationLog)))
forall a. Maybe a
Nothing) Text
ContainerKey (Map Text (Record MigrationLog))
k Map Text (Record MigrationLog)
l)
([These Migration (Record MigrationLog)]
aligned, Map Text (Record MigrationLog)
extra) = (Element [Migration]
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog)))
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
-> [Migration]
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
forall mono b.
MonoFoldable mono =>
(Element mono -> b -> b) -> b -> mono -> b
foldr Element [Migration]
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
-> ([These Migration (Record MigrationLog)],
Map Text (Record MigrationLog))
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
[These Migration (Record MigrationLog)]
-> m [These Migration (Record MigrationLog)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([These Migration (Record MigrationLog)]
-> m [These Migration (Record MigrationLog)])
-> [These Migration (Record MigrationLog)]
-> m [These Migration (Record MigrationLog)]
forall a b. (a -> b) -> a -> b
$ (Record MigrationLog -> These Migration (Record MigrationLog))
-> [Record MigrationLog] -> [These Migration (Record MigrationLog)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Record MigrationLog -> These Migration (Record MigrationLog)
forall a b. b -> These a b
That (Map Text (Record MigrationLog)
-> [Element (Map Text (Record MigrationLog))]
forall mono. MonoFoldable mono => mono -> [Element mono]
toList Map Text (Record MigrationLog)
extra) [These Migration (Record MigrationLog)]
-> [These Migration (Record MigrationLog)]
-> [These Migration (Record MigrationLog)]
forall m. Monoid m => m -> m -> m
++ [These Migration (Record MigrationLog)]
aligned