{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-- |Module containing externally useful types for Refurb, most notably the 'Migration' type.
module Refurb.Types
  ( ConnInfo(..)
  , connInfoAsConnString, connInfoAsLogString
  , MigrationType(..)
  , MonadMigration
  , Migration(..), migrationSchema, migrationKey, migrationType, migrationCheck, migrationExecute, migrationQualifiedKey
  , schemaMigration, seedDataMigration, withCheck
  ) where

import ClassyPrelude
import Control.Lens.TH (makeLenses)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString.Char8 as BSC8
import Data.Word (Word16)
import qualified Database.PostgreSQL.Simple as PG

-- |Structure with connection information for connecting to the database.
data ConnInfo = ConnInfo
  { ConnInfo -> Text
connHost     :: Text
  -- ^Hostname or IP address of the PostgreSQL server.
  , ConnInfo -> Word16
connPort     :: Word16
  -- ^Port number the PostgreSQL server is running on (usually @5432@).
  , ConnInfo -> Text
connUser     :: Text
  -- ^What user to connect to the database as.
  , ConnInfo -> Text
connPassword :: Text
  -- ^What password to connect to the database with.
  , ConnInfo -> Text
connDbName   :: Text
  -- ^What database in the PostgreSQL server to attach to.
  }

-- |Given a 'ConnInfo' generate the connection string pairs that are shared between the loggable and real version, that is all of them except password.
commonParams :: ConnInfo -> [(ByteString, ByteString)]
commonParams :: ConnInfo -> [(ByteString, ByteString)]
commonParams (ConnInfo {Word16
Text
connDbName :: Text
connPassword :: Text
connUser :: Text
connPort :: Word16
connHost :: Text
connDbName :: ConnInfo -> Text
connPassword :: ConnInfo -> Text
connUser :: ConnInfo -> Text
connPort :: ConnInfo -> Word16
connHost :: ConnInfo -> Text
..}) =
  [ (ByteString
"host",   Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
connHost)
  , (ByteString
"port",   Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> ByteString) -> (Word16 -> Text) -> Word16 -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word16 -> Text
forall a. Show a => a -> Text
tshow (Word16 -> ByteString) -> Word16 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word16
connPort)
  , (ByteString
"user",   Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
connUser)
  , (ByteString
"dbname", Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
connDbName)
  ]

-- |Given a list of key/value pairs, make up a @key1=value1 key2=value2@ string that PostgreSQL expects.
asConnString :: [(ByteString, ByteString)] -> ByteString
asConnString :: [(ByteString, ByteString)] -> ByteString
asConnString = ByteString -> [ByteString] -> ByteString
BSC8.intercalate ByteString
" " ([ByteString] -> ByteString)
-> ([(ByteString, ByteString)] -> [ByteString])
-> [(ByteString, ByteString)]
-> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\ (ByteString
key, ByteString
val) -> ByteString
key ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
val)

-- |Given a 'ConnInfo' make up the real connection string to pass when connecting to the database. Includes password, so never log this.
connInfoAsConnString :: ConnInfo -> ByteString
connInfoAsConnString :: ConnInfo -> ByteString
connInfoAsConnString connInfo :: ConnInfo
connInfo@(ConnInfo { Text
connPassword :: Text
connPassword :: ConnInfo -> Text
connPassword }) =
  [(ByteString, ByteString)] -> ByteString
asConnString ((ByteString
"password", Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
connPassword) (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ConnInfo -> [(ByteString, ByteString)]
commonParams ConnInfo
connInfo)

-- |Given a 'ConnInfo' make up the log-safe connection string to show to humans, which omits the password.
connInfoAsLogString :: ConnInfo -> Text
connInfoAsLogString :: ConnInfo -> Text
connInfoAsLogString =
  ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 (ByteString -> Text)
-> (ConnInfo -> ByteString) -> ConnInfo -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [(ByteString, ByteString)] -> ByteString
asConnString ([(ByteString, ByteString)] -> ByteString)
-> (ConnInfo -> [(ByteString, ByteString)])
-> ConnInfo
-> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ConnInfo -> [(ByteString, ByteString)]
commonParams

-- |Enumeration of the types of migration that are known about.
data MigrationType
  = MigrationSchema
  -- ^Migration that updates the schema of the database and should be run everywhere.
  | MigrationSeedData
  -- ^Migration that installs or replaces data for testing purposes and should never be run in production.
  deriving (MigrationType -> MigrationType -> Bool
(MigrationType -> MigrationType -> Bool)
-> (MigrationType -> MigrationType -> Bool) -> Eq MigrationType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationType -> MigrationType -> Bool
$c/= :: MigrationType -> MigrationType -> Bool
== :: MigrationType -> MigrationType -> Bool
$c== :: MigrationType -> MigrationType -> Bool
Eq, Int -> MigrationType -> ShowS
[MigrationType] -> ShowS
MigrationType -> String
(Int -> MigrationType -> ShowS)
-> (MigrationType -> String)
-> ([MigrationType] -> ShowS)
-> Show MigrationType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrationType] -> ShowS
$cshowList :: [MigrationType] -> ShowS
show :: MigrationType -> String
$cshow :: MigrationType -> String
showsPrec :: Int -> MigrationType -> ShowS
$cshowsPrec :: Int -> MigrationType -> ShowS
Show)

-- |Constraint for actions run in the context of a migration, with access to underlying IO, PostgreSQL connection, and logging.
type MonadMigration m = (MonadBaseControl IO m, MonadMask m, MonadReader PG.Connection m, MonadLogger m)

-- |Data type of a migration, with its key, type, and actions.
data Migration = Migration
  { Migration -> Text
_migrationSchema  :: Text
  -- ^Schema for the migration to run in, which also qualifies the migration key."
  , Migration -> Text
_migrationKey     :: Text
  -- ^Unique key to identify this migration among all known migrations. Never reuse keys, as they're the only link between the stored migration log and known
  -- migrations.
  , Migration -> MigrationType
_migrationType    :: MigrationType
  -- ^What type of migration this is.
  , Migration -> forall (m :: * -> *). MonadMigration m => Maybe (m ())
_migrationCheck   :: forall m. MonadMigration m => Maybe (m ())
  -- ^Optional action to execute before the primary execution to verify preconditions.
  , Migration -> forall (m :: * -> *). MonadMigration m => m ()
_migrationExecute :: forall m. MonadMigration m =>        m ()
  -- ^Main migration action, such as creating tables or updating data.
  }

-- |The fully qualified key of the migration, schema.key
migrationQualifiedKey :: Migration -> Text
migrationQualifiedKey :: Migration -> Text
migrationQualifiedKey (Migration { Text
_migrationSchema :: Text
_migrationSchema :: Migration -> Text
_migrationSchema, Text
_migrationKey :: Text
_migrationKey :: Migration -> Text
_migrationKey }) =
  Text
_migrationSchema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
_migrationKey

makeLenses ''Migration

-- |Helper to construct a 'MigrationSchema' type 'Migration' with the given execution action and no check action.
schemaMigration :: Text -> Text -> (forall m. MonadMigration m => m ()) -> Migration
schemaMigration :: Text
-> Text
-> (forall (m :: * -> *). MonadMigration m => m ())
-> Migration
schemaMigration Text
schema Text
key forall (m :: * -> *). MonadMigration m => m ()
execute = Migration :: Text
-> Text
-> MigrationType
-> (forall (m :: * -> *). MonadMigration m => Maybe (m ()))
-> (forall (m :: * -> *). MonadMigration m => m ())
-> Migration
Migration
  { _migrationSchema :: Text
_migrationSchema  = Text
schema
  , _migrationKey :: Text
_migrationKey     = Text
key
  , _migrationType :: MigrationType
_migrationType    = MigrationType
MigrationSchema
  , _migrationCheck :: forall (m :: * -> *). MonadMigration m => Maybe (m ())
_migrationCheck   = forall a. Maybe a
forall (m :: * -> *). MonadMigration m => Maybe (m ())
Nothing
  , _migrationExecute :: forall (m :: * -> *). MonadMigration m => m ()
_migrationExecute = forall (m :: * -> *). MonadMigration m => m ()
execute
  }

-- |Helper to construct a 'MigrationSeedData' type 'Migration' with the given execution action and no check action.
seedDataMigration :: Text -> Text -> (forall m. MonadMigration m => m ()) -> Migration
seedDataMigration :: Text
-> Text
-> (forall (m :: * -> *). MonadMigration m => m ())
-> Migration
seedDataMigration Text
schema Text
key forall (m :: * -> *). MonadMigration m => m ()
execute = Migration :: Text
-> Text
-> MigrationType
-> (forall (m :: * -> *). MonadMigration m => Maybe (m ()))
-> (forall (m :: * -> *). MonadMigration m => m ())
-> Migration
Migration
  { _migrationSchema :: Text
_migrationSchema  = Text
schema
  , _migrationKey :: Text
_migrationKey     = Text
key
  , _migrationType :: MigrationType
_migrationType    = MigrationType
MigrationSeedData
  , _migrationCheck :: forall (m :: * -> *). MonadMigration m => Maybe (m ())
_migrationCheck   = forall a. Maybe a
forall (m :: * -> *). MonadMigration m => Maybe (m ())
Nothing
  , _migrationExecute :: forall (m :: * -> *). MonadMigration m => m ()
_migrationExecute = forall (m :: * -> *). MonadMigration m => m ()
execute
  }

-- |Attach a check function to a 'Migration'.
withCheck :: Migration -> (forall m. MonadMigration m => m ()) -> Migration
withCheck :: Migration
-> (forall (m :: * -> *). MonadMigration m => m ()) -> Migration
withCheck Migration
m forall (m :: * -> *). MonadMigration m => m ()
c = Migration
m { _migrationCheck :: forall (m :: * -> *). MonadMigration m => Maybe (m ())
_migrationCheck = m () -> Maybe (m ())
forall a. a -> Maybe a
Just m ()
forall (m :: * -> *). MonadMigration m => m ()
c }