Migration.hs

{-|
Module: Squeal.PostgreSQL.Session.Migration
Description: migrations
Copyright: (c) Eitan Chatav, 2019
Maintainer: eitan@morphism.tech
Stability: experimental

This module defines a `Migration` type to safely
change the schema of your database over time. Let's see an example!

First turn on some extensions.

>>> :set -XDataKinds -XOverloadedLabels
>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators

Next, let's define our `TableType`s.

>>> :{
type UsersTable =
  '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
  '[ "id" ::: 'Def :=> 'NotNull 'PGint4
   , "name" ::: 'NoDef :=> 'NotNull 'PGtext
   ]
:}

>>> :{
type EmailsTable =
  '[ "pk_emails" ::: 'PrimaryKey '["id"]
   , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"]
   ] :=>
  '[ "id" ::: 'Def :=> 'NotNull 'PGint4
   , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
   , "email" ::: 'NoDef :=> 'Null 'PGtext
   ]
:}

Now we can define some `Migration`s to make our tables.

`Migration`s are parameterized giving the option of a

* pure one-way `Migration` `Definition`
* impure one-way `Migration` @(@`Indexed` `PQ` `IO`@)@
* pure reversible `Migration` @(@`IsoQ` `Definition`@)@
* impure reversible `Migration` @(@`IsoQ` @(@`Indexed` `PQ` `IO`@)@@)@

For this example, we'll use pure reversible `Migration`s.

>>> :{
let
  makeUsers :: Migration (IsoQ Definition)
    '["public" ::: '[]]
    '["public" ::: '["users" ::: 'Table UsersTable]]
  makeUsers = Migration "make users table" IsoQ
    { up = createTable #users
        ( serial `as` #id :*
          notNullable text `as` #name )
        ( primaryKey #id `as` #pk_users )
    , down = dropTable #users
    }
:}

>>> :{
let
  makeEmails :: Migration (IsoQ Definition)
    '["public" ::: '["users" ::: 'Table UsersTable]]
    '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
  makeEmails = Migration "make emails table" IsoQ
    { up = createTable #emails
          ( serial `as` #id :*
            notNullable int `as` #user_id :*
            nullable text `as` #email )
          ( primaryKey #id `as` #pk_emails :*
            foreignKey #user_id #users #id
              (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id )
    , down = dropTable #emails
    }
:}

Now that we have a couple migrations we can chain them together into a `Path`.

>>> let migrations = makeUsers :>> makeEmails :>> Done

Now run the migrations.

>>> import Control.Monad.IO.Class
>>> :{
withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $
  manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;")
    -- suppress notices
  & pqThen (liftIO (putStrLn "Migrate"))
  & pqThen (migrateUp migrations)
  & pqThen (liftIO (putStrLn "Rollback"))
  & pqThen (migrateDown migrations)
:}
Migrate
Rollback

We can also create a simple executable using `mainMigrateIso`.

>>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" migrations

>>> withArgs [] main
Invalid command: "". Use:
migrate    to run all available migrations
rollback   to rollback all available migrations
status     to display migrations run and migrations left to run

>>> withArgs ["status"] main
Migrations already run:
  None
Migrations left to run:
  - make users table
  - make emails table

>>> withArgs ["migrate"] main
Migrations already run:
  - make users table
  - make emails table
Migrations left to run:
  None

>>> withArgs ["rollback"] main
Migrations already run:
  None
Migrations left to run:
  - make users table
  - make emails table

In addition to enabling `Migration`s using pure SQL `Definition`s for
the `up` and `down` migrations, you can also perform impure `IO` actions
by using a `Migration`s over the `Indexed` `PQ` `IO` category.
-}

{-# LANGUAGE
    DataKinds
  , DeriveGeneric
  , FlexibleContexts
  , FlexibleInstances
  , FunctionalDependencies
  , GADTs
  , LambdaCase
  , MultiParamTypeClasses
  , OverloadedLabels
  , OverloadedStrings
  , PolyKinds
  , QuantifiedConstraints
  , RankNTypes
  , TypeApplications
  , TypeOperators
#-}

module Squeal.PostgreSQL.Session.Migration
  ( -- * Migration
    Migration (..)
  , Migratory (..)
  , migrate
  , migrateUp
  , migrateDown
  , MigrationsTable
    -- * Executable
  , mainMigrate
  , mainMigrateIso
    -- * Re-export
  , IsoQ (..)
  ) where

import Control.Category
import Control.Category.Free
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.Foldable (traverse_)
import Data.Function ((&))
import Data.List ((\\))
import Data.Quiver
import Data.Quiver.Functor
import Data.Text (Text)
import Data.Time (UTCTime)
import Prelude hiding ((.), id)
import System.Environment

import qualified Data.Text.IO as Text (putStrLn)
import qualified Generics.SOP as SOP
import qualified GHC.Generics as GHC

import Squeal.PostgreSQL.Definition
import Squeal.PostgreSQL.Definition.Constraint
import Squeal.PostgreSQL.Definition.Table
import Squeal.PostgreSQL.Expression.Comparison
import Squeal.PostgreSQL.Expression.Default
import Squeal.PostgreSQL.Expression.Parameter
import Squeal.PostgreSQL.Expression.Time
import Squeal.PostgreSQL.Expression.Type
import Squeal.PostgreSQL.Manipulation
import Squeal.PostgreSQL.Manipulation.Delete
import Squeal.PostgreSQL.Manipulation.Insert
import Squeal.PostgreSQL.Session
import Squeal.PostgreSQL.Session.Decode
import Squeal.PostgreSQL.Session.Encode
import Squeal.PostgreSQL.Session.Indexed
import Squeal.PostgreSQL.Session.Monad
import Squeal.PostgreSQL.Session.Result
import Squeal.PostgreSQL.Session.Statement
import Squeal.PostgreSQL.Session.Transaction.Unsafe
import Squeal.PostgreSQL.Query.From
import Squeal.PostgreSQL.Query.Select
import Squeal.PostgreSQL.Query.Table
import Squeal.PostgreSQL.Type.Alias
import Squeal.PostgreSQL.Type.List
import Squeal.PostgreSQL.Type.Schema

-- | A `Migration` consists of a name and a migration definition.
data Migration def db0 db1 = Migration
  { migrationName :: Text -- ^ The name of a `Migration`.
    -- Each `migrationName` should be unique.
  , migrationDef :: def db0 db1 -- ^ The migration of a `Migration`.
  } deriving (GHC.Generic)
instance QFunctor Migration where
  qmap f (Migration n i) = Migration n (f i)

{- |
A `Migratory` `Category` can run or
possibly rewind a `Path` of `Migration`s.
-}
class (Category def, Category run) => Migratory def run | def -> run where
  {- | Run a `Path` of `Migration`s.-}
  runMigrations :: Path (Migration def) db0 db1 -> run db0 db1
-- | impure migrations
instance Migratory (Indexed PQ IO ()) (Indexed PQ IO ()) where
  runMigrations path = Indexed . unsafePQ . transactionally_ $ do
    define createMigrations
    qtoMonoid upMigration path
    where
      upMigration step = do
        executed <- do
          result <- executeParams selectMigration (migrationName step)
          ntuples (result :: Result UTCTime)
        unless (executed == 1) $ do
          _ <- unsafePQ . runIndexed $ migrationDef step
          executeParams_ insertMigration (migrationName step)
-- | pure migrations
instance Migratory Definition (Indexed PQ IO ()) where
  runMigrations = runMigrations . qmap (qmap ixDefine)
-- | impure rewinds
instance Migratory (OpQ (Indexed PQ IO ())) (OpQ (Indexed PQ IO ())) where
  runMigrations path = OpQ . Indexed . unsafePQ . transactionally_ $ do
    define createMigrations
    qtoMonoid @FoldPath downMigration (reversePath path)
    where
      downMigration (OpQ step) = do
        executed <- do
          result <- executeParams selectMigration (migrationName step)
          ntuples (result :: Result UTCTime)
        unless (executed == 0) $ do
          _ <- unsafePQ . runIndexed . getOpQ $ migrationDef step
          executeParams_ deleteMigration (migrationName step)
-- | pure rewinds
instance Migratory (OpQ Definition) (OpQ (Indexed PQ IO ())) where
  runMigrations = runMigrations . qmap (qmap (qmap ixDefine))
-- | impure rewindable migrations
instance Migratory
  (IsoQ (Indexed PQ IO ()))
  (IsoQ (Indexed PQ IO ())) where
    runMigrations path = IsoQ
      (runMigrations (qmap (qmap up) path))
      (getOpQ (runMigrations (qmap (qmap (OpQ . down)) path)))
-- | pure rewindable migrations
instance Migratory (IsoQ Definition) (IsoQ (Indexed PQ IO ())) where
  runMigrations = runMigrations . qmap (qmap (qmap ixDefine))

unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK

-- | Run migrations.
migrate
  :: Migratory def (Indexed PQ IO ())
  => Path (Migration def) db0 db1
  -> PQ db0 db1 IO ()
migrate = runIndexed . runMigrations

-- | Run rewindable migrations.
migrateUp
  :: Migratory def (IsoQ (Indexed PQ IO ()))
  => Path (Migration def) db0 db1
  -> PQ db0 db1 IO ()
migrateUp = runIndexed . up . runMigrations

-- | Rewind migrations.
migrateDown
  :: Migratory def (IsoQ (Indexed PQ IO ()))
  => Path (Migration def) db0 db1
  -> PQ db1 db0 IO ()
migrateDown = runIndexed . down . runMigrations

ixDefine :: Definition db0 db1 -> Indexed PQ IO () db0 db1
ixDefine = indexedDefine

-- | The `TableType` for a Squeal migration.
type MigrationsTable =
  '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
  '[ "name"        ::: 'NoDef :=> 'NotNull 'PGtext
   , "executed_at" :::   'Def :=> 'NotNull 'PGtimestamptz
   ]

data MigrationRow =
  MigrationRow { name :: Text
               , executed_at :: UTCTime }
  deriving (GHC.Generic, Show)

instance SOP.Generic MigrationRow
instance SOP.HasDatatypeInfo MigrationRow

type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
type MigrationsSchemas = Public MigrationsSchema

-- | Creates a `MigrationsTable` if it does not already exist.
createMigrations :: Definition MigrationsSchemas MigrationsSchemas
createMigrations =
  createTableIfNotExists #schema_migrations
    ( (text & notNullable) `as` #name :*
      (timestampWithTimeZone & notNullable & default_ currentTimestamp)
        `as` #executed_at )
    ( unique #name `as` #migrations_unique_name )

-- | Inserts a `Migration` into the `MigrationsTable`, returning
-- the time at which it was inserted.
insertMigration :: Statement MigrationsSchemas Text ()
insertMigration = Manipulation aParam genericRow $
  insertInto_ #schema_migrations $
    Values_ (Set (param @1) `as` #name :* Default `as` #executed_at)

-- | Deletes a `Migration` from the `MigrationsTable`, returning
-- the time at which it was inserted.
deleteMigration :: Statement MigrationsSchemas Text ()
deleteMigration = Manipulation aParam genericRow $
  deleteFrom_ #schema_migrations (#name .== param @1)

-- | Selects a `Migration` from the `MigrationsTable`, returning
-- the time at which it was inserted.
selectMigration :: Statement MigrationsSchemas Text UTCTime
selectMigration = Query aParam #executed_at $
  select_ #executed_at
    $ from (table (#schema_migrations))
    & where_ (#name .== param @1)

selectMigrations :: Statement MigrationsSchemas () MigrationRow
selectMigrations = query $ select Star (from (table #schema_migrations))

{- | `mainMigrate` creates a simple executable
from a connection string and a `Path` of `Migration`s. -}
mainMigrate
  :: Migratory p (Indexed PQ IO ())
  => ByteString
  -- ^ connection string
  -> Path (Migration p) db0 db1
  -- ^ migrations
  -> IO ()
mainMigrate connectTo migrations = do
  command <- getArgs
  performCommand command

  where

    performCommand :: [String] -> IO ()
    performCommand = \case
      ["status"] -> withConnection connectTo $
        suppressNotices >> migrateStatus
      ["migrate"] -> withConnection connectTo $
        suppressNotices
        & pqThen (runIndexed (runMigrations migrations))
        & pqThen migrateStatus
      args -> displayUsage args

    migrateStatus :: PQ schema schema IO ()
    migrateStatus = unsafePQ $ do
      runNames <- getRunMigrationNames
      let names = qtoList migrationName migrations
          unrunNames = names \\ runNames
      liftIO $ displayRunned runNames >> displayUnrunned unrunNames

    suppressNotices :: PQ schema schema IO ()
    suppressNotices = manipulate_ $
      UnsafeManipulation "SET client_min_messages TO WARNING;"

    displayUsage :: [String] -> IO ()
    displayUsage args = do
      putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
      putStrLn "migrate    to run all available migrations"
      putStrLn "rollback   to rollback all available migrations"

{- | `mainMigrateIso` creates a simple executable
from a connection string and a `Path` of `Migration` `IsoQ`s. -}
mainMigrateIso
  :: Migratory (IsoQ def) (IsoQ (Indexed PQ IO ()))
  => ByteString
  -- ^ connection string
  -> Path (Migration (IsoQ def)) db0 db1
  -- ^ migrations
  -> IO ()
mainMigrateIso connectTo migrations = performCommand =<< getArgs

  where

    performCommand :: [String] -> IO ()
    performCommand = \case
      ["status"] -> withConnection connectTo $
        suppressNotices >> migrateStatus
      ["migrate"] -> withConnection connectTo $
        suppressNotices
        & pqThen (migrateUp migrations)
        & pqThen migrateStatus
      ["rollback"] -> withConnection connectTo $
        suppressNotices
        & pqThen (migrateDown migrations)
        & pqThen migrateStatus
      args -> displayUsage args

    migrateStatus :: PQ schema schema IO ()
    migrateStatus = unsafePQ $ do
      runNames <- getRunMigrationNames
      let names = qtoList migrationName migrations
          unrunNames = names \\ runNames
      liftIO $ displayRunned runNames >> displayUnrunned unrunNames

    suppressNotices :: PQ schema schema IO ()
    suppressNotices = manipulate_ $
      UnsafeManipulation "SET client_min_messages TO WARNING;"

    displayUsage :: [String] -> IO ()
    displayUsage args = do
      putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
      putStrLn "migrate    to run all available migrations"
      putStrLn "rollback   to rollback all available migrations"
      putStrLn "status     to display migrations run and migrations left to run"

getRunMigrationNames :: PQ db0 db0 IO [Text]
getRunMigrationNames =
  fmap name <$>
    (unsafePQ (define createMigrations
    & pqThen (execute selectMigrations)) >>= getRows)

displayListOfNames :: [Text] -> IO ()
displayListOfNames [] = Text.putStrLn "  None"
displayListOfNames xs =
  let singleName n = Text.putStrLn $ "  - " <> n
  in traverse_ singleName xs

displayUnrunned :: [Text] -> IO ()
displayUnrunned unrunned =
  Text.putStrLn "Migrations left to run:"
  >> displayListOfNames unrunned

displayRunned :: [Text] -> IO ()
displayRunned runned =
  Text.putStrLn "Migrations already run:"
  >> displayListOfNames runned