{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
-- |Module containing definition of and functions for maintaining the in-database state storage for Refurb.
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)

-- |Result of running a migration, either success or failure.
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
  |]

-- |Fields of a migration log entry in memory fetched from the database (with ID)
type MigrationLog      = '[FId   , FQualifiedKey, FApplied, FOutput, FResult, FDuration]
-- |Fields of a migration log entry to insert in the database (with the ID column optional)
type MigrationLogW     = '[FIdMay, FQualifiedKey, FApplied, FOutput, FResult, FDuration]
-- |Columns of a migration log when reading from the database (with ID)
type MigrationLogColsR = '[CId   , CQualifiedKey, CApplied, COutput, CResult, CDuration]
-- |Columns of a migration log when inserting into the database (with ID column optional)
type MigrationLogColsW = '[CIdMay, CQualifiedKey, CApplied, COutput, CResult, CDuration]

-- |Fields of the Refurb config in memory
type RefurbConfig     = '[FProdSystem]
-- |Columns of the Refurb config in the database
type RefurbConfigCols = '[CProdSystem]

-- |The migration log table which records all executed migrations and their results
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

-- |The refurb config table which controls whether this database is considered a production one or not
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

-- |Test to see if the schema seems to be installed by looking for an existing refurb_config table
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

-- |Check if this database is configured as a production database by reading the refurb config table
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

-- |Create the refurb schema elements. Will fail if they already exist.
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
      );
    |]

-- |Read the migration log and stitch it together with the expected migration list, forming a list in the same order as the known migrations but with
-- 'These' representing whether the migration log for the known migration is present or not.
--
-- * @'This' migration@ represents a known migration that has no log entry.
-- * @'That' migrationLog@ represents an unknown migration that was applied in the past.
-- * @'These' migration migrationLog@ represents a migration that has an attempted application in the log.
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