{-# LANGUAGE ApplicativeDo #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Hasql.Mover (
  Migration (..),
  SomeMigration (..),

  -- * Declaration
  declareMigration,

  -- * Checking and running migrations

  -- ** Main functions
  hasqlMover,
  performMigrations,

  -- *** Options
  MigrationCli (..),
  MigrationCmd (..),

  -- *** Results
  MigrationError (..),

  -- *** Checked migrations
  UpMigration (..),
  PendingMigration (..),
  DivergentMigration (..),

  -- ** Settings
  MigrationDB (..),
  migrationDBFromSettings,

  -- ** Integrating into an existing "main"
  hasqlMoverOpts,
) where

import Control.Exception qualified as E
import Control.Monad (forM_, void, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, withExceptT)
import Control.Monad.Trans.Resource (allocate, runResourceT)
import Control.Monad.Trans.State.Strict (State, StateT (..), execState, execStateT, gets, modify', put)
import Data.Char (isSpace)
import Data.Proxy (Proxy (..))
import Data.SOP.Constraint (All)
import Data.SOP.NP (NP (..), cpure_NP, ctraverse__NP, traverse__NP)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Time (UTCTime)
import Data.Typeable (Typeable, cast)
import Data.Void (Void)
import Hasql.Connection qualified as Sql
import Hasql.Session qualified as Sql
import Hasql.TH qualified as Sql
import Hasql.Transaction qualified as Tx
import Hasql.Transaction.Sessions qualified as Tx
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Options.Applicative qualified as O
import Prettyprinter ((<+>))
import Prettyprinter qualified as R
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color, colorDull, putDoc)
import Text.Megaparsec qualified as M
import Text.Megaparsec.Char qualified as M
import Text.Megaparsec.Char.Lexer qualified as L

--------------------------------------------------------------------------------
-- Checked migrations -- these have been checked against the current database
-- status

data PendingMigration = forall m. (Migration m) => PendingMigration {()
migration :: m}
data UpMigration = forall m. (Migration m) => UpMigration {()
migration :: m, UpMigration -> UTCTime
executedAt :: UTCTime}
data DivergentMigration = forall m. (Migration m) => DivergentMigration {()
migration :: m, DivergentMigration -> Text
oldUp, DivergentMigration -> Text
oldDown :: Text, DivergentMigration -> UTCTime
executedAt :: UTCTime}
data UnknownMigration m = (Migration m) => UnknownMigration m
data SomeMigration where SomeMigration :: (Migration m) => m -> SomeMigration

type Doc = R.Doc AnsiStyle

prettyPending :: PendingMigration -> Doc
prettyPending :: PendingMigration -> Doc AnsiStyle
prettyPending PendingMigration {m
$sel:migration:PendingMigration :: ()
migration :: m
migration} =
  [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.vsep
    [ Doc AnsiStyle
"Pending " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
migration Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
colorDull Color
Green) Doc AnsiStyle
"[up]" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (m -> Text
forall a. Migration a => a -> Text
up m
migration) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    ]

prettyUp :: UpMigration -> Doc
prettyUp :: UpMigration -> Doc AnsiStyle
prettyUp UpMigration {m
$sel:migration:UpMigration :: ()
migration :: m
migration, UTCTime
$sel:executedAt:UpMigration :: UpMigration -> UTCTime
executedAt :: UTCTime
executedAt} =
  [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.vsep
    [ Doc AnsiStyle
"Up " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
migration Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"executed at" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UTCTime -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow UTCTime
executedAt Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
colorDull Color
Green) Doc AnsiStyle
"[up]" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (m -> Text
forall a. Migration a => a -> Text
up m
migration) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    ]

prettyDivergent :: DivergentMigration -> Doc
prettyDivergent :: DivergentMigration -> Doc AnsiStyle
prettyDivergent DivergentMigration {m
$sel:migration:DivergentMigration :: ()
migration :: m
migration, Text
$sel:oldUp:DivergentMigration :: DivergentMigration -> Text
oldUp :: Text
oldUp, UTCTime
$sel:executedAt:DivergentMigration :: DivergentMigration -> UTCTime
executedAt :: UTCTime
executedAt} =
  [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.vsep
    [ Doc AnsiStyle
"Divergent " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
migration Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"executed at" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UTCTime -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow UTCTime
executedAt Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
colorDull Color
Green) Doc AnsiStyle
"[up/new]" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (m -> Text
forall a. Migration a => a -> Text
up m
migration) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
colorDull Color
Green) Doc AnsiStyle
"[up/old]" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty Text
oldUp Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    ]

prettyRollback :: (Migration m) => Rollback m -> Doc
prettyRollback :: forall m. Migration m => Rollback m -> Doc AnsiStyle
prettyRollback (Rollback m
m) =
  [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.vsep
    [ Doc AnsiStyle
"Rollback of " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
m Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
colorDull Color
Green) Doc AnsiStyle
"[down]" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    , Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (m -> Text
forall a. Migration a => a -> Text
down m
m) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.line
    ]

instance Show PendingMigration where
  showsPrec :: Int -> PendingMigration -> ShowS
showsPrec Int
p (PendingMigration m
m) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"PendingMigration " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 m
m)

instance Show UpMigration where
  showsPrec :: Int -> UpMigration -> ShowS
showsPrec Int
p (UpMigration m
m UTCTime
e) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (String -> ShowS
showString String
"UpMigration " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> UTCTime -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 UTCTime
e ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 m
m)

data CheckedMigrations names = CheckedMigrations
  { forall {k} (names :: k). CheckedMigrations names -> [UpMigration]
ups :: [UpMigration]
  , forall {k} (names :: k).
CheckedMigrations names -> [DivergentMigration]
divergents :: [DivergentMigration]
  , forall {k} (names :: k).
CheckedMigrations names -> [PendingMigration]
pendings :: [PendingMigration]
  }

-- | A mapping from a singleton migration name to its up and down SQL
class (Typeable a, Show a) => Migration a where
  -- | The name for this migration
  migration :: a

  -- | How to run this migration
  up :: a -> Text

  -- | How to rollback this migration
  down :: a -> Text

migrationName :: (Migration a) => a -> Text
migrationName :: forall a. Migration a => a -> Text
migrationName = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

--------------------------------------------------------------------------------
-- The base migration

-- | Sets up necessary tables for hasql-mover
data BaseMigration = BaseMigration
  deriving stock (Int -> BaseMigration -> ShowS
[BaseMigration] -> ShowS
BaseMigration -> String
(Int -> BaseMigration -> ShowS)
-> (BaseMigration -> String)
-> ([BaseMigration] -> ShowS)
-> Show BaseMigration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BaseMigration -> ShowS
showsPrec :: Int -> BaseMigration -> ShowS
$cshow :: BaseMigration -> String
show :: BaseMigration -> String
$cshowList :: [BaseMigration] -> ShowS
showList :: [BaseMigration] -> ShowS
Show, ReadPrec [BaseMigration]
ReadPrec BaseMigration
Int -> ReadS BaseMigration
ReadS [BaseMigration]
(Int -> ReadS BaseMigration)
-> ReadS [BaseMigration]
-> ReadPrec BaseMigration
-> ReadPrec [BaseMigration]
-> Read BaseMigration
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS BaseMigration
readsPrec :: Int -> ReadS BaseMigration
$creadList :: ReadS [BaseMigration]
readList :: ReadS [BaseMigration]
$creadPrec :: ReadPrec BaseMigration
readPrec :: ReadPrec BaseMigration
$creadListPrec :: ReadPrec [BaseMigration]
readListPrec :: ReadPrec [BaseMigration]
Read, BaseMigration -> BaseMigration -> Bool
(BaseMigration -> BaseMigration -> Bool)
-> (BaseMigration -> BaseMigration -> Bool) -> Eq BaseMigration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BaseMigration -> BaseMigration -> Bool
== :: BaseMigration -> BaseMigration -> Bool
$c/= :: BaseMigration -> BaseMigration -> Bool
/= :: BaseMigration -> BaseMigration -> Bool
Eq, Eq BaseMigration
Eq BaseMigration =>
(BaseMigration -> BaseMigration -> Ordering)
-> (BaseMigration -> BaseMigration -> Bool)
-> (BaseMigration -> BaseMigration -> Bool)
-> (BaseMigration -> BaseMigration -> Bool)
-> (BaseMigration -> BaseMigration -> Bool)
-> (BaseMigration -> BaseMigration -> BaseMigration)
-> (BaseMigration -> BaseMigration -> BaseMigration)
-> Ord BaseMigration
BaseMigration -> BaseMigration -> Bool
BaseMigration -> BaseMigration -> Ordering
BaseMigration -> BaseMigration -> BaseMigration
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BaseMigration -> BaseMigration -> Ordering
compare :: BaseMigration -> BaseMigration -> Ordering
$c< :: BaseMigration -> BaseMigration -> Bool
< :: BaseMigration -> BaseMigration -> Bool
$c<= :: BaseMigration -> BaseMigration -> Bool
<= :: BaseMigration -> BaseMigration -> Bool
$c> :: BaseMigration -> BaseMigration -> Bool
> :: BaseMigration -> BaseMigration -> Bool
$c>= :: BaseMigration -> BaseMigration -> Bool
>= :: BaseMigration -> BaseMigration -> Bool
$cmax :: BaseMigration -> BaseMigration -> BaseMigration
max :: BaseMigration -> BaseMigration -> BaseMigration
$cmin :: BaseMigration -> BaseMigration -> BaseMigration
min :: BaseMigration -> BaseMigration -> BaseMigration
Ord)

instance Migration BaseMigration where
  migration :: BaseMigration
migration = BaseMigration
BaseMigration
  up :: BaseMigration -> Text
up BaseMigration
_ =
    Text
"CREATE TABLE hasql_mover_migration (\n\
    \  id serial NOT NULL,\n\
    \  name text NOT NULL,\n\
    \  up text NOT NULL,\n\
    \  down text NOT NULL,\n\
    \  executed_at timestamptz NOT NULL DEFAULT now()\n\
    \)"
  down :: BaseMigration -> Text
down BaseMigration
_ =
    Text
"DROP TABLE hasql_mover_migration CASCADE"

newtype Rollback m = Rollback m
  deriving stock (Int -> Rollback m -> ShowS
[Rollback m] -> ShowS
Rollback m -> String
(Int -> Rollback m -> ShowS)
-> (Rollback m -> String)
-> ([Rollback m] -> ShowS)
-> Show (Rollback m)
forall m. Show m => Int -> Rollback m -> ShowS
forall m. Show m => [Rollback m] -> ShowS
forall m. Show m => Rollback m -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall m. Show m => Int -> Rollback m -> ShowS
showsPrec :: Int -> Rollback m -> ShowS
$cshow :: forall m. Show m => Rollback m -> String
show :: Rollback m -> String
$cshowList :: forall m. Show m => [Rollback m] -> ShowS
showList :: [Rollback m] -> ShowS
Show, ReadPrec [Rollback m]
ReadPrec (Rollback m)
Int -> ReadS (Rollback m)
ReadS [Rollback m]
(Int -> ReadS (Rollback m))
-> ReadS [Rollback m]
-> ReadPrec (Rollback m)
-> ReadPrec [Rollback m]
-> Read (Rollback m)
forall m. Read m => ReadPrec [Rollback m]
forall m. Read m => ReadPrec (Rollback m)
forall m. Read m => Int -> ReadS (Rollback m)
forall m. Read m => ReadS [Rollback m]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall m. Read m => Int -> ReadS (Rollback m)
readsPrec :: Int -> ReadS (Rollback m)
$creadList :: forall m. Read m => ReadS [Rollback m]
readList :: ReadS [Rollback m]
$creadPrec :: forall m. Read m => ReadPrec (Rollback m)
readPrec :: ReadPrec (Rollback m)
$creadListPrec :: forall m. Read m => ReadPrec [Rollback m]
readListPrec :: ReadPrec [Rollback m]
Read)

instance (Migration m) => Migration (Rollback m) where
  migration :: Rollback m
migration = m -> Rollback m
forall m. m -> Rollback m
Rollback m
forall a. Migration a => a
migration
  up :: Rollback m -> Text
up (Rollback m
m) = m -> Text
forall a. Migration a => a -> Text
down m
m
  down :: Rollback m -> Text
down (Rollback m
m) = m -> Text
forall a. Migration a => a -> Text
up m
m

--------------------------------------------------------------------------------

type CheckM = StateT CheckState Tx.Transaction

data CheckState = CheckState
  { CheckState -> [UpMigration]
ups :: [UpMigration]
  , CheckState -> [DivergentMigration]
divergents :: [DivergentMigration]
  , CheckState -> [PendingMigration]
pendings :: [PendingMigration]
  , CheckState -> Bool
haveBaseTable :: Bool
  }

checkMigrations :: forall migrations. (All Migration migrations) => Sql.Session (CheckedMigrations (BaseMigration : migrations))
checkMigrations :: forall (migrations :: [Type]).
All Migration migrations =>
Session (CheckedMigrations (BaseMigration : migrations))
checkMigrations =
  CheckM ()
-> Session (CheckedMigrations (BaseMigration : migrations))
runCheckState do
    CheckM ()
checkBaseMigration
    CheckM ()
checkOthers
  where
    runCheckState :: CheckM () -> Sql.Session (CheckedMigrations (BaseMigration : migrations))
    runCheckState :: CheckM ()
-> Session (CheckedMigrations (BaseMigration : migrations))
runCheckState CheckM ()
s = IsolationLevel
-> Mode
-> Transaction (CheckedMigrations (BaseMigration : migrations))
-> Session (CheckedMigrations (BaseMigration : migrations))
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
Tx.transaction IsolationLevel
Tx.Serializable Mode
Tx.Read do
      CheckState {[UpMigration]
$sel:ups:CheckState :: CheckState -> [UpMigration]
ups :: [UpMigration]
ups, [DivergentMigration]
$sel:divergents:CheckState :: CheckState -> [DivergentMigration]
divergents :: [DivergentMigration]
divergents, [PendingMigration]
$sel:pendings:CheckState :: CheckState -> [PendingMigration]
pendings :: [PendingMigration]
pendings} <- CheckM () -> CheckState -> Transaction CheckState
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
execStateT CheckM ()
s ([UpMigration]
-> [DivergentMigration] -> [PendingMigration] -> Bool -> CheckState
CheckState [] [] [] Bool
True)
      CheckedMigrations (BaseMigration : migrations)
-> Transaction (CheckedMigrations (BaseMigration : migrations))
forall a. a -> Transaction a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
        CheckedMigrations
          { $sel:ups:CheckedMigrations :: [UpMigration]
ups = [UpMigration] -> [UpMigration]
forall a. [a] -> [a]
reverse [UpMigration]
ups
          , $sel:divergents:CheckedMigrations :: [DivergentMigration]
divergents = [DivergentMigration] -> [DivergentMigration]
forall a. [a] -> [a]
reverse [DivergentMigration]
divergents
          , $sel:pendings:CheckedMigrations :: [PendingMigration]
pendings = [PendingMigration] -> [PendingMigration]
forall a. [a] -> [a]
reverse [PendingMigration]
pendings
          }

    checkBaseMigration :: CheckM ()
    checkBaseMigration :: CheckM ()
checkBaseMigration = do
      Bool
haveBaseTable <- Transaction Bool -> StateT CheckState Transaction Bool
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT CheckState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction Bool -> StateT CheckState Transaction Bool)
-> Transaction Bool -> StateT CheckState Transaction Bool
forall a b. (a -> b) -> a -> b
$ () -> Statement () Bool -> Transaction Bool
forall a b. a -> Statement a b -> Transaction b
Tx.statement () [Sql.singletonStatement|SELECT (to_regclass('hasql_mover_migration') IS NOT NULL)::boolean|]
      if Bool
haveBaseTable
        then BaseMigration -> CheckM ()
forall m. Migration m => m -> CheckM ()
checkMigration BaseMigration
BaseMigration
        else do
          (CheckState -> CheckState) -> CheckM ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify' \CheckState
s -> CheckState
s {haveBaseTable = False}
          BaseMigration -> CheckM ()
forall m. Migration m => m -> CheckM ()
addPending BaseMigration
BaseMigration

    checkOthers :: CheckM ()
    checkOthers :: CheckM ()
checkOthers =
      (forall a. UnknownMigration a -> CheckM ())
-> NP UnknownMigration migrations -> CheckM ()
forall {k} (xs :: [k]) (f :: k -> Type) (g :: Type -> Type).
(SListI xs, Applicative g) =>
(forall (a :: k). f a -> g ()) -> NP f xs -> g ()
traverse__NP
        (\(UnknownMigration a
m) -> a -> CheckM ()
forall m. Migration m => m -> CheckM ()
checkMigration a
m)
        (Proxy Migration
-> (forall a. Migration a => UnknownMigration a)
-> NP UnknownMigration migrations
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> Type) (f :: k -> Type).
All c xs =>
proxy c -> (forall (a :: k). c a => f a) -> NP f xs
cpure_NP (forall {k} (t :: k). Proxy t
forall (t :: Type -> Constraint). Proxy t
Proxy @Migration) (a -> UnknownMigration a
forall m. Migration m => m -> UnknownMigration m
UnknownMigration a
forall a. Migration a => a
migration) :: NP UnknownMigration migrations)

    checkMigration :: (Migration m) => m -> CheckM ()
    checkMigration :: forall m. Migration m => m -> CheckM ()
checkMigration m
m = do
      Bool
canContinue <- (CheckState -> Bool) -> StateT CheckState Transaction Bool
forall (m :: Type -> Type) s a. Monad m => (s -> a) -> StateT s m a
gets \CheckState {Bool
$sel:haveBaseTable:CheckState :: CheckState -> Bool
haveBaseTable :: Bool
haveBaseTable, [DivergentMigration]
$sel:divergents:CheckState :: CheckState -> [DivergentMigration]
divergents :: [DivergentMigration]
divergents} -> Bool
haveBaseTable Bool -> Bool -> Bool
&& [DivergentMigration] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [DivergentMigration]
divergents
      if Bool
canContinue
        then do
          Maybe (Text, Text, UTCTime)
r <-
            Transaction (Maybe (Text, Text, UTCTime))
-> StateT CheckState Transaction (Maybe (Text, Text, UTCTime))
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT CheckState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (Maybe (Text, Text, UTCTime))
 -> StateT CheckState Transaction (Maybe (Text, Text, UTCTime)))
-> Transaction (Maybe (Text, Text, UTCTime))
-> StateT CheckState Transaction (Maybe (Text, Text, UTCTime))
forall a b. (a -> b) -> a -> b
$
              Text
-> Statement Text (Maybe (Text, Text, UTCTime))
-> Transaction (Maybe (Text, Text, UTCTime))
forall a b. a -> Statement a b -> Transaction b
Tx.statement
                (m -> Text
forall a. Migration a => a -> Text
migrationName m
m)
                [Sql.maybeStatement|
                  SELECT up::text, down::text, executed_at::timestamptz
                  FROM hasql_mover_migration
                  WHERE name = $1::text
                |]
          case Maybe (Text, Text, UTCTime)
r of
            Just (Text
oldUp, Text
oldDown, UTCTime
executedAt)
              | Text
oldUp Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== m -> Text
forall a. Migration a => a -> Text
up m
m -> m -> UTCTime -> CheckM ()
forall m. Migration m => m -> UTCTime -> CheckM ()
addUp m
m UTCTime
executedAt
              | Bool
otherwise -> m -> UTCTime -> Text -> Text -> CheckM ()
forall m. Migration m => m -> UTCTime -> Text -> Text -> CheckM ()
addDivergent m
m UTCTime
executedAt Text
oldUp Text
oldDown
            Maybe (Text, Text, UTCTime)
Nothing -> m -> CheckM ()
forall m. Migration m => m -> CheckM ()
addPending m
m
        else m -> CheckM ()
forall m. Migration m => m -> CheckM ()
addPending m
m

    addDivergent :: (Migration m) => m -> UTCTime -> Text -> Text -> CheckM ()
    addDivergent :: forall m. Migration m => m -> UTCTime -> Text -> Text -> CheckM ()
addDivergent m
migration UTCTime
executedAt Text
oldUp Text
oldDown =
      (CheckState -> CheckState) -> CheckM ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify' \CheckState {Bool
[DivergentMigration]
[UpMigration]
[PendingMigration]
$sel:ups:CheckState :: CheckState -> [UpMigration]
$sel:divergents:CheckState :: CheckState -> [DivergentMigration]
$sel:pendings:CheckState :: CheckState -> [PendingMigration]
$sel:haveBaseTable:CheckState :: CheckState -> Bool
ups :: [UpMigration]
divergents :: [DivergentMigration]
pendings :: [PendingMigration]
haveBaseTable :: Bool
..} -> CheckState {$sel:divergents:CheckState :: [DivergentMigration]
divergents = DivergentMigration {m
$sel:migration:DivergentMigration :: m
migration :: m
migration, Text
UTCTime
$sel:oldUp:DivergentMigration :: Text
$sel:oldDown:DivergentMigration :: Text
$sel:executedAt:DivergentMigration :: UTCTime
executedAt :: UTCTime
oldUp :: Text
oldDown :: Text
..} DivergentMigration -> [DivergentMigration] -> [DivergentMigration]
forall a. a -> [a] -> [a]
: [DivergentMigration]
divergents, Bool
[UpMigration]
[PendingMigration]
$sel:ups:CheckState :: [UpMigration]
$sel:pendings:CheckState :: [PendingMigration]
$sel:haveBaseTable:CheckState :: Bool
ups :: [UpMigration]
pendings :: [PendingMigration]
haveBaseTable :: Bool
..}

    addPending :: (Migration m) => m -> CheckM ()
    addPending :: forall m. Migration m => m -> CheckM ()
addPending m
migration =
      (CheckState -> CheckState) -> CheckM ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify' \CheckState {Bool
[DivergentMigration]
[UpMigration]
[PendingMigration]
$sel:ups:CheckState :: CheckState -> [UpMigration]
$sel:divergents:CheckState :: CheckState -> [DivergentMigration]
$sel:pendings:CheckState :: CheckState -> [PendingMigration]
$sel:haveBaseTable:CheckState :: CheckState -> Bool
ups :: [UpMigration]
divergents :: [DivergentMigration]
pendings :: [PendingMigration]
haveBaseTable :: Bool
..} -> CheckState {$sel:pendings:CheckState :: [PendingMigration]
pendings = PendingMigration {m
$sel:migration:PendingMigration :: m
migration :: m
migration, ..} PendingMigration -> [PendingMigration] -> [PendingMigration]
forall a. a -> [a] -> [a]
: [PendingMigration]
pendings, Bool
[DivergentMigration]
[UpMigration]
$sel:ups:CheckState :: [UpMigration]
$sel:divergents:CheckState :: [DivergentMigration]
$sel:haveBaseTable:CheckState :: Bool
ups :: [UpMigration]
divergents :: [DivergentMigration]
haveBaseTable :: Bool
..}

    addUp :: (Migration m) => m -> UTCTime -> CheckM ()
    addUp :: forall m. Migration m => m -> UTCTime -> CheckM ()
addUp m
migration UTCTime
executedAt =
      (CheckState -> CheckState) -> CheckM ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify' \CheckState {Bool
[DivergentMigration]
[UpMigration]
[PendingMigration]
$sel:ups:CheckState :: CheckState -> [UpMigration]
$sel:divergents:CheckState :: CheckState -> [DivergentMigration]
$sel:pendings:CheckState :: CheckState -> [PendingMigration]
$sel:haveBaseTable:CheckState :: CheckState -> Bool
ups :: [UpMigration]
divergents :: [DivergentMigration]
pendings :: [PendingMigration]
haveBaseTable :: Bool
..} -> CheckState {$sel:ups:CheckState :: [UpMigration]
ups = UpMigration {m
$sel:migration:UpMigration :: m
migration :: m
migration, UTCTime
$sel:executedAt:UpMigration :: UTCTime
executedAt :: UTCTime
..} UpMigration -> [UpMigration] -> [UpMigration]
forall a. a -> [a] -> [a]
: [UpMigration]
ups, Bool
[DivergentMigration]
[PendingMigration]
$sel:divergents:CheckState :: [DivergentMigration]
$sel:pendings:CheckState :: [PendingMigration]
$sel:haveBaseTable:CheckState :: Bool
divergents :: [DivergentMigration]
pendings :: [PendingMigration]
haveBaseTable :: Bool
..}

--------------------------------------------------------------------------------
-- Performing migrations

-- | Encapsulates a way to run a hasql session; it could be through a pool, or
-- through a connection directly.
data MigrationDB = forall db.
  MigrationDB
  { ()
acquire :: IO (Either Sql.ConnectionError db)
  , ()
release :: db -> IO ()
  , ()
run :: forall a. Sql.Session a -> db -> IO (Either Sql.QueryError a)
  }

-- | Create a 'MigrationDB' from a hasql settings - a PostgreSQL connection
-- string as of writing
migrationDBFromSettings :: Sql.Settings -> MigrationDB
migrationDBFromSettings :: ByteString -> MigrationDB
migrationDBFromSettings ByteString
connstr =
  MigrationDB
    { $sel:acquire:MigrationDB :: IO (Either ConnectionError Connection)
acquire = ByteString -> IO (Either ConnectionError Connection)
Sql.acquire ByteString
connstr
    , $sel:release:MigrationDB :: Connection -> IO ()
release = Connection -> IO ()
Sql.release
    , $sel:run:MigrationDB :: forall a. Session a -> Connection -> IO (Either QueryError a)
run = Session a -> Connection -> IO (Either QueryError a)
forall a. Session a -> Connection -> IO (Either QueryError a)
Sql.run
    }

-- | Options to supply to 'hasqlMover': a database connection and what migration
-- command to run
data MigrationCli = MigrationCli
  { MigrationCli -> MigrationDB
db :: MigrationDB
  , MigrationCli -> MigrationCmd
cmd :: MigrationCmd
  }

-- | A command for 'hasqlMover'
data MigrationCmd
  = -- | Run pending migrations
    MigrateUp
  | -- | Rollback a migration
    MigrateDown
      { MigrationCmd -> Bool
undoDivergents :: Bool
      -- ^ Are we allowed to undo a divergent migration? Default: No
      , MigrationCmd -> Bool
divergentUseOldDown :: Bool
      -- ^ For a divergent migration, use the previous "down" SQL text, or the new one? Default: New down
      }
  | -- | Print the current status
    MigrateStatus
  | -- | Force the 'up' of a migration to run, regardless of its status or position in the migrations list
    MigrateForceUp Text
  | -- | Force the 'down' of a migration to run, regardless of its status or position in the migrations list
    MigrateForceDown Text

-- | optparse-applicative options for hasql-mover; use 'hasqlMover' to then run the parsed options
hasqlMoverOpts :: O.Parser MigrationCli
hasqlMoverOpts :: Parser MigrationCli
hasqlMoverOpts =
  MigrationDB -> MigrationCmd -> MigrationCli
MigrationCli
    (MigrationDB -> MigrationCmd -> MigrationCli)
-> Parser MigrationDB -> Parser (MigrationCmd -> MigrationCli)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> MigrationDB
migrationDBFromSettings (ByteString -> MigrationDB)
-> (String -> ByteString) -> String -> MigrationDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> MigrationDB) -> Parser String -> Parser MigrationDB
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
O.strOption (String -> Mod OptionFields String
forall (f :: Type -> Type) a. HasName f => String -> Mod f a
O.long String
"db" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: Type -> Type) a. HasMetavar f => String -> Mod f a
O.metavar String
"DB"))
    Parser (MigrationCmd -> MigrationCli)
-> Parser MigrationCmd -> Parser MigrationCli
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Mod CommandFields MigrationCmd -> Parser MigrationCmd
forall a. Mod CommandFields a -> Parser a
O.subparser
      ( [Mod CommandFields MigrationCmd] -> Mod CommandFields MigrationCmd
forall a. Monoid a => [a] -> a
mconcat
          [ String -> ParserInfo MigrationCmd -> Mod CommandFields MigrationCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
O.command String
"up" (Parser MigrationCmd
-> InfoMod MigrationCmd -> ParserInfo MigrationCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
O.info (MigrationCmd -> Parser MigrationCmd
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MigrationCmd
MigrateUp) (String -> InfoMod MigrationCmd
forall a. String -> InfoMod a
O.progDesc String
"Perform any pending migrations"))
          , String -> ParserInfo MigrationCmd -> Mod CommandFields MigrationCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
O.command String
"down" (Parser MigrationCmd
-> InfoMod MigrationCmd -> ParserInfo MigrationCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
O.info Parser MigrationCmd
migrateDown (String -> InfoMod MigrationCmd
forall a. String -> InfoMod a
O.progDesc String
"Rollback the last migration"))
          , String -> ParserInfo MigrationCmd -> Mod CommandFields MigrationCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
O.command String
"force-up" (Parser MigrationCmd
-> InfoMod MigrationCmd -> ParserInfo MigrationCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
O.info Parser MigrationCmd
migrateForceUp (String -> InfoMod MigrationCmd
forall a. String -> InfoMod a
O.progDesc String
"Run a given up migration"))
          , String -> ParserInfo MigrationCmd -> Mod CommandFields MigrationCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
O.command String
"force-down" (Parser MigrationCmd
-> InfoMod MigrationCmd -> ParserInfo MigrationCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
O.info Parser MigrationCmd
migrateForceDown (String -> InfoMod MigrationCmd
forall a. String -> InfoMod a
O.progDesc String
"Run a given down migration"))
          , String -> ParserInfo MigrationCmd -> Mod CommandFields MigrationCmd
forall a. String -> ParserInfo a -> Mod CommandFields a
O.command String
"status" (Parser MigrationCmd
-> InfoMod MigrationCmd -> ParserInfo MigrationCmd
forall a. Parser a -> InfoMod a -> ParserInfo a
O.info (MigrationCmd -> Parser MigrationCmd
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure MigrationCmd
MigrateStatus) (String -> InfoMod MigrationCmd
forall a. String -> InfoMod a
O.progDesc String
"Check current status"))
          ]
      )
  where
    migrateForceUp :: Parser MigrationCmd
migrateForceUp = Text -> MigrationCmd
MigrateForceUp (Text -> MigrationCmd) -> Parser Text -> Parser MigrationCmd
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod ArgumentFields Text -> Parser Text
forall s. IsString s => Mod ArgumentFields s -> Parser s
O.strArgument Mod ArgumentFields Text
forall a. Monoid a => a
mempty
    migrateForceDown :: Parser MigrationCmd
migrateForceDown = Text -> MigrationCmd
MigrateForceDown (Text -> MigrationCmd) -> Parser Text -> Parser MigrationCmd
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod ArgumentFields Text -> Parser Text
forall s. IsString s => Mod ArgumentFields s -> Parser s
O.strArgument Mod ArgumentFields Text
forall a. Monoid a => a
mempty
    migrateDown :: Parser MigrationCmd
migrateDown =
      Bool -> Bool -> MigrationCmd
MigrateDown
        (Bool -> Bool -> MigrationCmd)
-> Parser Bool -> Parser (Bool -> MigrationCmd)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
O.switch (String -> Mod FlagFields Bool
forall (f :: Type -> Type) a. HasName f => String -> Mod f a
O.long String
"undo-diverging" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: Type -> Type) a. HasName f => Char -> Mod f a
O.short Char
'u' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: Type -> Type) a. String -> Mod f a
O.help String
"Can we undo a diverging migration?")
        Parser (Bool -> MigrationCmd) -> Parser Bool -> Parser MigrationCmd
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
O.switch (String -> Mod FlagFields Bool
forall (f :: Type -> Type) a. HasName f => String -> Mod f a
O.long String
"divergent-down-from-old" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: Type -> Type) a. HasName f => Char -> Mod f a
O.short Char
'o' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: Type -> Type) a. String -> Mod f a
O.help String
"Use the 'down' definition for a divergent migration from its original definition, when it was initially ran")

-- | Main function for running hasql-mover migrations
--
-- Example usage:
--
-- @
-- [declareMigration|
-- name = V0
--
-- [up]
-- CREATE TABLE foo ();
--
-- [down]
-- DROP TABLE foo CASCADE;
-- |]
--
-- type Migrations = '[V0]
--
-- main :: IO ()
-- main = hasqlMoverMain @Migrations
-- @
hasqlMover :: forall ms. (All Migration ms) => IO ()
hasqlMover :: forall (ms :: [Type]). All Migration ms => IO ()
hasqlMover = do
  MigrationCli
cli <-
    ParserInfo MigrationCli -> IO MigrationCli
forall a. ParserInfo a -> IO a
O.execParser
      ( Parser MigrationCli
-> InfoMod MigrationCli -> ParserInfo MigrationCli
forall a. Parser a -> InfoMod a -> ParserInfo a
O.info
          (Parser MigrationCli
hasqlMoverOpts Parser MigrationCli
-> Parser (MigrationCli -> MigrationCli) -> Parser MigrationCli
forall (f :: Type -> Type) a b.
Applicative f =>
f a -> f (a -> b) -> f b
O.<**> Parser (MigrationCli -> MigrationCli)
forall a. Parser (a -> a)
O.helper)
          (InfoMod MigrationCli
forall a. InfoMod a
O.fullDesc InfoMod MigrationCli
-> InfoMod MigrationCli -> InfoMod MigrationCli
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod MigrationCli
forall a. String -> InfoMod a
O.progDesc String
"Perform or check hasql-mover migrations")
      )
  Either MigrationError ()
result <- forall (migrations :: [Type]).
All Migration migrations =>
MigrationCli -> IO (Either MigrationError ())
performMigrations @ms MigrationCli
cli
  case Either MigrationError ()
result of
    Right () -> String -> IO ()
putStrLn String
"Done"
    Left MigrationError
err -> Doc AnsiStyle -> IO ()
putDoc (MigrationError -> Doc AnsiStyle
prettyMigrationError MigrationError
err Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
forall ann. Doc ann
R.softline)

data MigrationError
  = MigrationCheckError !Sql.QueryError
  | MigrationUpError !PendingMigration !Sql.QueryError
  | MigrationDownError !UpMigration !Sql.QueryError
  | MigrationForceUpError !SomeMigration !Sql.QueryError
  | MigrationForceDownError !SomeMigration !Sql.QueryError
  | MigrationDivergentDownError !DivergentMigration !Sql.QueryError
  | MigrationConnectError !Sql.ConnectionError
  | MigrationNothingToRollback
  | MigrationGotDivergents
  | MigrationException !E.SomeException
  | MigrationNotFound !Text

prettyMigrationError :: MigrationError -> Doc
prettyMigrationError :: MigrationError -> Doc AnsiStyle
prettyMigrationError = \case
  MigrationCheckError QueryError
qe -> Doc AnsiStyle
"Check error" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> QueryError -> Doc AnsiStyle
forall {ann}. QueryError -> Doc ann
prettyQueryError QueryError
qe
  MigrationUpError PendingMigration
pending QueryError
qe -> Doc AnsiStyle
"Up error" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PendingMigration -> Doc AnsiStyle
prettyPending PendingMigration
pending Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> QueryError -> Doc AnsiStyle
forall {ann}. QueryError -> Doc ann
prettyQueryError QueryError
qe
  MigrationDownError UpMigration
up QueryError
qe -> Doc AnsiStyle
"Down error" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UpMigration -> Doc AnsiStyle
prettyUp UpMigration
up Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> QueryError -> Doc AnsiStyle
forall {ann}. QueryError -> Doc ann
prettyQueryError QueryError
qe
  MigrationForceUpError (SomeMigration m
m) QueryError
qe -> Doc AnsiStyle
"Forced up error" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
m Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> QueryError -> Doc AnsiStyle
forall {ann}. QueryError -> Doc ann
prettyQueryError QueryError
qe
  MigrationForceDownError (SomeMigration m
m) QueryError
qe -> Doc AnsiStyle
"Forced down error" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
m Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> QueryError -> Doc AnsiStyle
forall {ann}. QueryError -> Doc ann
prettyQueryError QueryError
qe
  MigrationDivergentDownError DivergentMigration
up QueryError
qe -> Doc AnsiStyle
"Divergent down error" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> DivergentMigration -> Doc AnsiStyle
prettyDivergent DivergentMigration
up Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> QueryError -> Doc AnsiStyle
forall {ann}. QueryError -> Doc ann
prettyQueryError QueryError
qe
  MigrationConnectError ConnectionError
connerr -> Doc AnsiStyle
"Connection error" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ConnectionError -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow ConnectionError
connerr
  MigrationError
MigrationNothingToRollback -> Doc AnsiStyle
"Nothing to roll back"
  MigrationError
MigrationGotDivergents -> Doc AnsiStyle
"Divergent migrations"
  MigrationException SomeException
se -> SomeException -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow SomeException
se
  MigrationNotFound Text
name -> Doc AnsiStyle
"Migration not found:" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow Text
name
  where
    prettyQueryError :: QueryError -> Doc ann
prettyQueryError (Sql.QueryError ByteString
bs [Text]
params CommandError
cmderr) =
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
R.vsep
        [ Doc ann
"QueryError for  " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
R.align ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
R.vsep ((Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (Text -> [Text]
Text.lines (ByteString -> Text
Text.decodeUtf8 ByteString
bs))))
        , Doc ann
" - Params: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
R.align ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
R.list ((Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty [Text]
params))
        , Doc ann
" - Command Error: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
R.align case CommandError
cmderr of
            Sql.ClientError ConnectionError
mc -> Doc ann
"ClientError " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (ByteString -> Doc ann) -> ConnectionError -> Doc ann
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (Text -> Doc ann) -> (ByteString -> Text) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8) ConnectionError
mc
            Sql.ResultError ResultError
re -> Doc ann
"ResultError " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ResultError -> Doc ann
forall {ann}. ResultError -> Doc ann
prettyResultError ResultError
re
        ]
    prettyResultError :: ResultError -> Doc ann
prettyResultError = \case
      Sql.ServerError ByteString
code ByteString
message ConnectionError
details ConnectionError
hint Maybe Int
pos ->
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
R.vsep
          [ Doc ann
"ServerError " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ByteString -> Doc ann
forall a ann. Show a => a -> Doc ann
R.viaShow ByteString
code Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
": " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (ByteString -> Text
Text.decodeUtf8 ByteString
message)
          , (ByteString -> Doc ann) -> ConnectionError -> Doc ann
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) Doc ann
"Details: " (Doc ann -> Doc ann)
-> (ByteString -> Doc ann) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
R.align (Doc ann -> Doc ann)
-> (ByteString -> Doc ann) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (Text -> Doc ann) -> (ByteString -> Text) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8) ConnectionError
details
          , (ByteString -> Doc ann) -> ConnectionError -> Doc ann
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) Doc ann
"Hint: " (Doc ann -> Doc ann)
-> (ByteString -> Doc ann) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
R.align (Doc ann -> Doc ann)
-> (ByteString -> Doc ann) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty (Text -> Doc ann) -> (ByteString -> Text) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8) ConnectionError
hint
          , (Int -> Doc ann) -> Maybe Int -> Doc ann
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) Doc ann
"Position: " (Doc ann -> Doc ann) -> (Int -> Doc ann) -> Int -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
R.align (Doc ann -> Doc ann) -> (Int -> Doc ann) -> Int -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty) Maybe Int
pos
          ]
      Sql.UnexpectedResult Text
err -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty Text
err
      ResultError
err -> ResultError -> Doc ann
forall a ann. Show a => a -> Doc ann
R.viaShow ResultError
err

-- | Perform the migrations according to some 'MigrationCli'
performMigrations
  :: forall migrations
   . (All Migration migrations)
  => MigrationCli
  -> IO (Either MigrationError ())
performMigrations :: forall (migrations :: [Type]).
All Migration migrations =>
MigrationCli -> IO (Either MigrationError ())
performMigrations MigrationCli {$sel:db:MigrationCli :: MigrationCli -> MigrationDB
db = MigrationDB {IO (Either ConnectionError db)
$sel:acquire:MigrationDB :: ()
acquire :: IO (Either ConnectionError db)
acquire, db -> IO ()
$sel:release:MigrationDB :: ()
release :: db -> IO ()
release, forall a. Session a -> db -> IO (Either QueryError a)
$sel:run:MigrationDB :: ()
run :: forall a. Session a -> db -> IO (Either QueryError a)
run}, MigrationCmd
$sel:cmd:MigrationCli :: MigrationCli -> MigrationCmd
cmd :: MigrationCmd
cmd} = ResourceT IO (Either MigrationError ())
-> IO (Either MigrationError ())
forall (m :: Type -> Type) a.
MonadUnliftIO m =>
ResourceT m a -> m a
runResourceT (ResourceT IO (Either MigrationError ())
 -> IO (Either MigrationError ()))
-> ResourceT IO (Either MigrationError ())
-> IO (Either MigrationError ())
forall a b. (a -> b) -> a -> b
$ ExceptT MigrationError (ResourceT IO) ()
-> ResourceT IO (Either MigrationError ())
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT do
  (ReleaseKey
_releaseKey, Either ConnectionError db
mdb) <- IO (Either ConnectionError db)
-> (Either ConnectionError db -> IO ())
-> ExceptT
     MigrationError
     (ResourceT IO)
     (ReleaseKey, Either ConnectionError db)
forall (m :: Type -> Type) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO (Either ConnectionError db)
acquire \case
    Left ConnectionError
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    Right db
db -> db -> IO ()
release db
db
  db
db <- (ConnectionError -> MigrationError)
-> ResourceT IO (Either ConnectionError db)
-> ExceptT MigrationError (ResourceT IO) db
forall {m :: Type -> Type} {e} {e'} {a}.
Functor m =>
(e -> e') -> m (Either e a) -> ExceptT e' m a
errBy ConnectionError -> MigrationError
MigrationConnectError (Either ConnectionError db
-> ResourceT IO (Either ConnectionError db)
forall a. a -> ResourceT IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Either ConnectionError db
mdb)
  let
    check :: ExceptT
  MigrationError
  (ResourceT IO)
  (CheckedMigrations (BaseMigration : migrations))
check = (QueryError -> MigrationError)
-> ResourceT
     IO
     (Either
        QueryError (CheckedMigrations (BaseMigration : migrations)))
-> ExceptT
     MigrationError
     (ResourceT IO)
     (CheckedMigrations (BaseMigration : migrations))
forall {m :: Type -> Type} {e} {e'} {a}.
Functor m =>
(e -> e') -> m (Either e a) -> ExceptT e' m a
errBy QueryError -> MigrationError
MigrationCheckError (Session (CheckedMigrations (BaseMigration : migrations))
-> ResourceT
     IO
     (Either
        QueryError (CheckedMigrations (BaseMigration : migrations)))
forall (m :: Type -> Type) a.
MonadIO m =>
Session a -> m (Either QueryError a)
runSession (forall (migrations :: [Type]).
All Migration migrations =>
Session (CheckedMigrations (BaseMigration : migrations))
checkMigrations @migrations))

    runSession :: (MonadIO m) => Sql.Session a -> m (Either Sql.QueryError a)
    runSession :: forall (m :: Type -> Type) a.
MonadIO m =>
Session a -> m (Either QueryError a)
runSession Session a
s = IO (Either QueryError a) -> m (Either QueryError a)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Session a -> db -> IO (Either QueryError a)
forall a. Session a -> db -> IO (Either QueryError a)
run Session a
s db
db)

    runPending :: (Migration m) => m -> IO (Either Sql.QueryError UTCTime)
    runPending :: forall m. Migration m => m -> IO (Either QueryError UTCTime)
runPending m
m = do
      Doc AnsiStyle -> IO ()
putDoc (PendingMigration -> Doc AnsiStyle
prettyPending (m -> PendingMigration
forall m. Migration m => m -> PendingMigration
PendingMigration m
m))
      Session UTCTime -> IO (Either QueryError UTCTime)
forall (m :: Type -> Type) a.
MonadIO m =>
Session a -> m (Either QueryError a)
runSession (Session UTCTime -> IO (Either QueryError UTCTime))
-> Session UTCTime -> IO (Either QueryError UTCTime)
forall a b. (a -> b) -> a -> b
$ IsolationLevel -> Mode -> Transaction UTCTime -> Session UTCTime
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
Tx.transaction IsolationLevel
Tx.Serializable Mode
Tx.Write do
        ByteString -> Transaction ()
Tx.sql (ByteString -> Transaction ()) -> ByteString -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ m -> Text
forall a. Migration a => a -> Text
up m
m
        (Text, Text, Text)
-> Statement (Text, Text, Text) UTCTime -> Transaction UTCTime
forall a b. a -> Statement a b -> Transaction b
Tx.statement
          (m -> Text
forall a. Migration a => a -> Text
migrationName m
m, m -> Text
forall a. Migration a => a -> Text
up m
m, m -> Text
forall a. Migration a => a -> Text
down m
m)
          [Sql.singletonStatement|
              INSERT INTO hasql_mover_migration (name, up, down) VALUES($1::text, $2::text, $3::text)
              RETURNING executed_at::timestamptz
            |]

    runRollback :: (Migration m) => m -> Text -> IO (Either Sql.QueryError ())
    runRollback :: forall m. Migration m => m -> Text -> IO (Either QueryError ())
runRollback m
m Text
downSql = do
      Doc AnsiStyle -> IO ()
putDoc (Rollback m -> Doc AnsiStyle
forall m. Migration m => Rollback m -> Doc AnsiStyle
prettyRollback (m -> Rollback m
forall m. m -> Rollback m
Rollback m
m))
      Session () -> IO (Either QueryError ())
forall (m :: Type -> Type) a.
MonadIO m =>
Session a -> m (Either QueryError a)
runSession (Session () -> IO (Either QueryError ()))
-> Session () -> IO (Either QueryError ())
forall a b. (a -> b) -> a -> b
$ IsolationLevel -> Mode -> Transaction () -> Session ()
forall a. IsolationLevel -> Mode -> Transaction a -> Session a
Tx.transaction IsolationLevel
Tx.Serializable Mode
Tx.Write do
        ByteString -> Transaction ()
Tx.sql (ByteString -> Transaction ()) -> ByteString -> Transaction ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 Text
downSql
        case m -> Maybe BaseMigration
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast m
m of
          Just BaseMigration
BaseMigration -> () -> Transaction ()
forall a. a -> Transaction a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
          Maybe BaseMigration
Nothing -> Text -> Statement Text () -> Transaction ()
forall a b. a -> Statement a b -> Transaction b
Tx.statement (m -> Text
forall a. Migration a => a -> Text
migrationName m
m) [Sql.resultlessStatement|DELETE FROM hasql_mover_migration WHERE name = ($1::text)|]

  checked :: CheckedMigrations (BaseMigration : migrations)
checked@CheckedMigrations {[UpMigration]
$sel:ups:CheckedMigrations :: forall {k} (names :: k). CheckedMigrations names -> [UpMigration]
ups :: [UpMigration]
ups, [DivergentMigration]
$sel:divergents:CheckedMigrations :: forall {k} (names :: k).
CheckedMigrations names -> [DivergentMigration]
divergents :: [DivergentMigration]
divergents, [PendingMigration]
$sel:pendings:CheckedMigrations :: forall {k} (names :: k).
CheckedMigrations names -> [PendingMigration]
pendings :: [PendingMigration]
pendings} <- ExceptT
  MigrationError
  (ResourceT IO)
  (CheckedMigrations (BaseMigration : migrations))
check

  let
    findMigrationByName :: Text -> Maybe SomeMigration
    findMigrationByName :: Text -> Maybe SomeMigration
findMigrationByName Text
name =
      (State (Maybe SomeMigration) ()
-> Maybe SomeMigration -> Maybe SomeMigration
forall s a. State s a -> s -> s
`execState` Maybe SomeMigration
forall a. Maybe a
Nothing) do
        Proxy Migration
-> (forall a.
    Migration a =>
    UnknownMigration a -> State (Maybe SomeMigration) ())
-> NP UnknownMigration migrations
-> State (Maybe SomeMigration) ()
forall {k} (c :: k -> Constraint)
       (proxy :: (k -> Constraint) -> Type) (xs :: [k]) (f :: k -> Type)
       (g :: Type -> Type).
(All c xs, Applicative g) =>
proxy c -> (forall (a :: k). c a => f a -> g ()) -> NP f xs -> g ()
ctraverse__NP (forall {k} (t :: k). Proxy t
forall (t :: Type -> Constraint). Proxy t
Proxy @Migration) UnknownMigration a -> State (Maybe SomeMigration) ()
forall a.
Migration a =>
UnknownMigration a -> State (Maybe SomeMigration) ()
findIt NP UnknownMigration migrations
allMigrations
      where
        findIt :: (Migration m) => UnknownMigration m -> State (Maybe SomeMigration) ()
        findIt :: forall a.
Migration a =>
UnknownMigration a -> State (Maybe SomeMigration) ()
findIt (UnknownMigration m
m) =
          Bool
-> State (Maybe SomeMigration) () -> State (Maybe SomeMigration) ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when
            (String -> Text
Text.pack (m -> String
forall a. Show a => a -> String
show m
m) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name)
            (Maybe SomeMigration -> State (Maybe SomeMigration) ()
forall (m :: Type -> Type) s. Monad m => s -> StateT s m ()
put (SomeMigration -> Maybe SomeMigration
forall a. a -> Maybe a
Just (m -> SomeMigration
forall m. Migration m => m -> SomeMigration
SomeMigration m
m)))

        allMigrations :: NP UnknownMigration migrations
allMigrations = Proxy Migration
-> (forall a. Migration a => UnknownMigration a)
-> NP UnknownMigration migrations
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> Type) (f :: k -> Type).
All c xs =>
proxy c -> (forall (a :: k). c a => f a) -> NP f xs
cpure_NP (forall {k} (t :: k). Proxy t
forall (t :: Type -> Constraint). Proxy t
Proxy @Migration) (a -> UnknownMigration a
forall m. Migration m => m -> UnknownMigration m
UnknownMigration a
forall a. Migration a => a
migration) :: NP UnknownMigration migrations

  case MigrationCmd
cmd of
    -- Status
    MigrationCmd
MigrateStatus -> IO () -> ExceptT MigrationError (ResourceT IO) ()
forall a. IO a -> ExceptT MigrationError (ResourceT IO) a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Doc AnsiStyle -> IO ()
putDoc (Text
-> CheckedMigrations (BaseMigration : migrations) -> Doc AnsiStyle
forall {k} (m :: k). Text -> CheckedMigrations m -> Doc AnsiStyle
ppStatus Text
"Current migrations status" CheckedMigrations (BaseMigration : migrations)
checked))
    -- Up
    MigrationCmd
MigrateUp
      | [DivergentMigration] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [DivergentMigration]
divergents -> do
          [PendingMigration]
-> (PendingMigration -> ExceptT MigrationError (ResourceT IO) ())
-> ExceptT MigrationError (ResourceT IO) ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [PendingMigration]
pendings \p :: PendingMigration
p@PendingMigration {m
$sel:migration:PendingMigration :: ()
migration :: m
migration} -> do
            UTCTime
_ <- (QueryError -> MigrationError)
-> IO (Either QueryError UTCTime)
-> ExceptT MigrationError (ResourceT IO) UTCTime
forall {m :: Type -> Type} {t} {b}.
MonadIO m =>
(t -> MigrationError)
-> IO (Either t b) -> ExceptT MigrationError m b
wrapQuery (PendingMigration -> QueryError -> MigrationError
MigrationUpError PendingMigration
p) (m -> IO (Either QueryError UTCTime)
forall m. Migration m => m -> IO (Either QueryError UTCTime)
runPending m
migration)
            IO () -> ExceptT MigrationError (ResourceT IO) ()
forall a. IO a -> ExceptT MigrationError (ResourceT IO) a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT MigrationError (ResourceT IO) ())
-> (CheckedMigrations (BaseMigration : migrations) -> IO ())
-> CheckedMigrations (BaseMigration : migrations)
-> ExceptT MigrationError (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ())
-> (CheckedMigrations (BaseMigration : migrations)
    -> Doc AnsiStyle)
-> CheckedMigrations (BaseMigration : migrations)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> CheckedMigrations (BaseMigration : migrations) -> Doc AnsiStyle
forall {k} (m :: k). Text -> CheckedMigrations m -> Doc AnsiStyle
ppStatus Text
"New migrations status" (CheckedMigrations (BaseMigration : migrations)
 -> ExceptT MigrationError (ResourceT IO) ())
-> ExceptT
     MigrationError
     (ResourceT IO)
     (CheckedMigrations (BaseMigration : migrations))
-> ExceptT MigrationError (ResourceT IO) ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT
  MigrationError
  (ResourceT IO)
  (CheckedMigrations (BaseMigration : migrations))
check
      | Bool
otherwise -> MigrationError -> ExceptT MigrationError (ResourceT IO) ()
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE MigrationError
MigrationGotDivergents
    -- Down
    MigrateDown {Bool
$sel:undoDivergents:MigrateUp :: MigrationCmd -> Bool
undoDivergents :: Bool
undoDivergents, Bool
$sel:divergentUseOldDown:MigrateUp :: MigrationCmd -> Bool
divergentUseOldDown :: Bool
divergentUseOldDown}
      | [UpMigration] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [UpMigration]
ups Bool -> Bool -> Bool
&& ([DivergentMigration] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [DivergentMigration]
divergents Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
undoDivergents) -> MigrationError -> ExceptT MigrationError (ResourceT IO) ()
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE MigrationError
MigrationNothingToRollback
      | Bool
undoDivergents Bool -> Bool -> Bool
&& Bool -> Bool
not ([DivergentMigration] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [DivergentMigration]
divergents)
      , u :: DivergentMigration
u@DivergentMigration {m
$sel:migration:DivergentMigration :: ()
migration :: m
migration, Text
$sel:oldDown:DivergentMigration :: DivergentMigration -> Text
oldDown :: Text
oldDown} <- [DivergentMigration] -> DivergentMigration
forall a. HasCallStack => [a] -> a
last [DivergentMigration]
divergents ->
          (QueryError -> MigrationError)
-> IO (Either QueryError ())
-> ExceptT MigrationError (ResourceT IO) ()
forall {m :: Type -> Type} {t} {b}.
MonadIO m =>
(t -> MigrationError)
-> IO (Either t b) -> ExceptT MigrationError m b
wrapQuery
            (DivergentMigration -> QueryError -> MigrationError
MigrationDivergentDownError DivergentMigration
u)
            (m -> Text -> IO (Either QueryError ())
forall m. Migration m => m -> Text -> IO (Either QueryError ())
runRollback m
migration (if Bool
divergentUseOldDown then Text
oldDown else m -> Text
forall a. Migration a => a -> Text
down m
migration))
      | Bool -> Bool
not ([DivergentMigration] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [DivergentMigration]
divergents) ->
          MigrationError -> ExceptT MigrationError (ResourceT IO) ()
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE MigrationError
MigrationGotDivergents
      | u :: UpMigration
u@UpMigration {m
$sel:migration:UpMigration :: ()
migration :: m
migration} <- [UpMigration] -> UpMigration
forall a. HasCallStack => [a] -> a
last [UpMigration]
ups -> do
          (QueryError -> MigrationError)
-> IO (Either QueryError ())
-> ExceptT MigrationError (ResourceT IO) ()
forall {m :: Type -> Type} {t} {b}.
MonadIO m =>
(t -> MigrationError)
-> IO (Either t b) -> ExceptT MigrationError m b
wrapQuery (UpMigration -> QueryError -> MigrationError
MigrationDownError UpMigration
u) (m -> Text -> IO (Either QueryError ())
forall m. Migration m => m -> Text -> IO (Either QueryError ())
runRollback m
migration (m -> Text
forall a. Migration a => a -> Text
down m
migration))
          IO () -> ExceptT MigrationError (ResourceT IO) ()
forall a. IO a -> ExceptT MigrationError (ResourceT IO) a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT MigrationError (ResourceT IO) ())
-> (CheckedMigrations (BaseMigration : migrations) -> IO ())
-> CheckedMigrations (BaseMigration : migrations)
-> ExceptT MigrationError (ResourceT IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ())
-> (CheckedMigrations (BaseMigration : migrations)
    -> Doc AnsiStyle)
-> CheckedMigrations (BaseMigration : migrations)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> CheckedMigrations (BaseMigration : migrations) -> Doc AnsiStyle
forall {k} (m :: k). Text -> CheckedMigrations m -> Doc AnsiStyle
ppStatus Text
"New migrations status" (CheckedMigrations (BaseMigration : migrations)
 -> ExceptT MigrationError (ResourceT IO) ())
-> ExceptT
     MigrationError
     (ResourceT IO)
     (CheckedMigrations (BaseMigration : migrations))
-> ExceptT MigrationError (ResourceT IO) ()
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT
  MigrationError
  (ResourceT IO)
  (CheckedMigrations (BaseMigration : migrations))
check
    -- Forcing down
    MigrateForceDown Text
nameText | Just (SomeMigration m
m) <- Text -> Maybe SomeMigration
findMigrationByName Text
nameText -> do
      (QueryError -> MigrationError)
-> IO (Either QueryError ())
-> ExceptT MigrationError (ResourceT IO) ()
forall {m :: Type -> Type} {t} {b}.
MonadIO m =>
(t -> MigrationError)
-> IO (Either t b) -> ExceptT MigrationError m b
wrapQuery (SomeMigration -> QueryError -> MigrationError
MigrationForceDownError (m -> SomeMigration
forall m. Migration m => m -> SomeMigration
SomeMigration m
m)) (m -> Text -> IO (Either QueryError ())
forall m. Migration m => m -> Text -> IO (Either QueryError ())
runRollback m
m (m -> Text
forall a. Migration a => a -> Text
down m
m))
    MigrateForceDown Text
nameText -> MigrationError -> ExceptT MigrationError (ResourceT IO) ()
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (Text -> MigrationError
MigrationNotFound Text
nameText)
    -- Forcing up
    MigrateForceUp Text
nameText | Just (SomeMigration m
m) <- Text -> Maybe SomeMigration
findMigrationByName Text
nameText -> ExceptT MigrationError (ResourceT IO) UTCTime
-> ExceptT MigrationError (ResourceT IO) ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void do
      (QueryError -> MigrationError)
-> IO (Either QueryError UTCTime)
-> ExceptT MigrationError (ResourceT IO) UTCTime
forall {m :: Type -> Type} {t} {b}.
MonadIO m =>
(t -> MigrationError)
-> IO (Either t b) -> ExceptT MigrationError m b
wrapQuery (SomeMigration -> QueryError -> MigrationError
MigrationForceUpError (m -> SomeMigration
forall m. Migration m => m -> SomeMigration
SomeMigration m
m)) (m -> IO (Either QueryError UTCTime)
forall m. Migration m => m -> IO (Either QueryError UTCTime)
runPending m
m)
    MigrateForceUp Text
nameText -> MigrationError -> ExceptT MigrationError (ResourceT IO) ()
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (Text -> MigrationError
MigrationNotFound Text
nameText)
  where
    ppStatus :: Text -> CheckedMigrations m -> Doc
    ppStatus :: forall {k} (m :: k). Text -> CheckedMigrations m -> Doc AnsiStyle
ppStatus Text
title CheckedMigrations {[UpMigration]
$sel:ups:CheckedMigrations :: forall {k} (names :: k). CheckedMigrations names -> [UpMigration]
ups :: [UpMigration]
ups, [DivergentMigration]
$sel:divergents:CheckedMigrations :: forall {k} (names :: k).
CheckedMigrations names -> [DivergentMigration]
divergents :: [DivergentMigration]
divergents, [PendingMigration]
$sel:pendings:CheckedMigrations :: forall {k} (names :: k).
CheckedMigrations names -> [PendingMigration]
pendings :: [PendingMigration]
pendings} =
      [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.vsep
        [ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
R.pretty Text
title
        , [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
            forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat @[]
              [ (UpMigration -> Doc AnsiStyle) -> [UpMigration] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map UpMigration -> Doc AnsiStyle
ppUp [UpMigration]
ups
              , (DivergentMigration -> Doc AnsiStyle)
-> [DivergentMigration] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map DivergentMigration -> Doc AnsiStyle
ppDivergent [DivergentMigration]
divergents
              , (PendingMigration -> Doc AnsiStyle)
-> [PendingMigration] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map PendingMigration -> Doc AnsiStyle
ppPending [PendingMigration]
pendings
              ]
        , Item [Doc AnsiStyle]
Doc AnsiStyle
forall ann. Doc ann
R.softline
        ]

    ppUp :: UpMigration -> Doc AnsiStyle
ppUp UpMigration {m
$sel:migration:UpMigration :: ()
migration :: m
migration, UTCTime
$sel:executedAt:UpMigration :: UpMigration -> UTCTime
executedAt :: UTCTime
executedAt} =
      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
color Color
Green) (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.hsep [Item [Doc AnsiStyle]
Doc AnsiStyle
"[ UP ", UTCTime -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow UTCTime
executedAt, Item [Doc AnsiStyle]
Doc AnsiStyle
" ]", Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
R.align (m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
migration)]
    ppDivergent :: DivergentMigration -> Doc AnsiStyle
ppDivergent DivergentMigration {m
$sel:migration:DivergentMigration :: ()
migration :: m
migration, UTCTime
$sel:executedAt:DivergentMigration :: DivergentMigration -> UTCTime
executedAt :: UTCTime
executedAt} =
      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
color Color
Red) (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.hsep [Item [Doc AnsiStyle]
Doc AnsiStyle
"[ DIVERGENT ", UTCTime -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow UTCTime
executedAt, Item [Doc AnsiStyle]
Doc AnsiStyle
" ]", Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
R.align (m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
migration)]
    ppPending :: PendingMigration -> Doc AnsiStyle
ppPending PendingMigration {m
$sel:migration:PendingMigration :: ()
migration :: m
migration} =
      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
R.annotate (Color -> AnsiStyle
colorDull Color
White) (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
R.hsep [Item [Doc AnsiStyle]
Doc AnsiStyle
"[ PENDING ]", Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
R.align (m -> Doc AnsiStyle
forall a ann. Show a => a -> Doc ann
R.viaShow m
migration)]

    errBy :: (e -> e') -> m (Either e a) -> ExceptT e' m a
errBy e -> e'
f m (Either e a)
a = (e -> e') -> ExceptT e m a -> ExceptT e' m a
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT e -> e'
f (m (Either e a) -> ExceptT e m a
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT m (Either e a)
a)
    wrapQuery :: (t -> MigrationError)
-> IO (Either t b) -> ExceptT MigrationError m b
wrapQuery t -> MigrationError
f IO (Either t b)
p = do
      Either SomeException (Either t b)
r <- IO (Either SomeException (Either t b))
-> ExceptT MigrationError m (Either SomeException (Either t b))
forall a. IO a -> ExceptT MigrationError m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
E.try @E.SomeException IO (Either t b)
p)
      case Either SomeException (Either t b)
r of
        Left SomeException
se -> MigrationError -> ExceptT MigrationError m b
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (SomeException -> MigrationError
MigrationException SomeException
se)
        Right (Left t
e) -> MigrationError -> ExceptT MigrationError m b
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (t -> MigrationError
f t
e)
        Right (Right b
a) -> b -> ExceptT MigrationError m b
forall a. a -> ExceptT MigrationError m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
a

--------------------------------------------------------------------------------
-- Declaring migrations

-- | Declare a migration with a nice syntax.
--
-- @
-- [declareMigration|
-- name = AddFoo
--
-- [up]
-- CREATE TABLE foo();
--
-- [down]
-- DROP TABLE foo();
-- |]
--
-- type Migrations = '[BaseMigration, AddFoo]
--
-- @
declareMigration :: TH.QuasiQuoter
declareMigration :: QuasiQuoter
declareMigration =
  TH.QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
forall a. HasCallStack => a
undefined
    , quoteType :: String -> Q Pred
quoteType = String -> Q Pred
forall a. HasCallStack => a
undefined
    , quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined
    , quoteDec :: String -> Q [Dec]
quoteDec = \String
s ->
        case Parsec Void Text MigrationDesc
-> String
-> Text
-> Either (ParseErrorBundle Text Void) MigrationDesc
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
M.parse Parsec Void Text MigrationDesc
parseMigrationDesc String
"hasql-mover" (String -> Text
Text.pack String
s) of
          Left ParseErrorBundle Text Void
err -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
M.errorBundlePretty ParseErrorBundle Text Void
err)
          Right MigrationDesc {Text
name :: Text
$sel:name:MigrationDesc :: MigrationDesc -> Text
name, Text
up :: Text
$sel:up:MigrationDesc :: MigrationDesc -> Text
up, Text
down :: Text
$sel:down:MigrationDesc :: MigrationDesc -> Text
down} -> do
            Name
qtype <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
TH.newName (Text -> String
Text.unpack Text
name)
            Name
qconstr <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
TH.newName (Text -> String
Text.unpack Text
name)
            Dec
dec <- Q Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Pred
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: Type -> Type).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Pred
-> [m Con]
-> [m DerivClause]
-> m Dec
TH.dataD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []) Name
qtype [] Maybe Pred
forall a. Maybe a
Nothing [Name -> [Q BangType] -> Q Con
forall (m :: Type -> Type).
Quote m =>
Name -> [m BangType] -> m Con
TH.normalC Name
qconstr []] [Maybe DerivStrategy -> [Q Pred] -> Q DerivClause
forall (m :: Type -> Type).
Quote m =>
Maybe DerivStrategy -> [m Pred] -> m DerivClause
TH.derivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
TH.StockStrategy) [[t|Show|]]]
            [Dec]
inst <-
              [d|
                instance Migration $(Name -> Q Pred
forall (m :: Type -> Type). Quote m => Name -> m Pred
TH.conT Name
qtype) where
                  migration = $(Name -> Q Exp
forall (m :: Type -> Type). Quote m => Name -> m Exp
TH.conE Name
qconstr)
                  up _ = $(String -> Q Exp
forall t (m :: Type -> Type). (Lift t, Quote m) => t -> m Exp
forall (m :: Type -> Type). Quote m => String -> m Exp
TH.lift (Text -> String
Text.unpack Text
up))
                  down _ = $(String -> Q Exp
forall t (m :: Type -> Type). (Lift t, Quote m) => t -> m Exp
forall (m :: Type -> Type). Quote m => String -> m Exp
TH.lift (Text -> String
Text.unpack Text
down))
                |]
            pure (Dec
dec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
inst)
    }

-- Parsing for declareMigration
----------------------------------------

data MigrationDesc = MigrationDesc {MigrationDesc -> Text
name, MigrationDesc -> Text
up, MigrationDesc -> Text
down :: Text}
  deriving stock (Int -> MigrationDesc -> ShowS
[MigrationDesc] -> ShowS
MigrationDesc -> String
(Int -> MigrationDesc -> ShowS)
-> (MigrationDesc -> String)
-> ([MigrationDesc] -> ShowS)
-> Show MigrationDesc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MigrationDesc -> ShowS
showsPrec :: Int -> MigrationDesc -> ShowS
$cshow :: MigrationDesc -> String
show :: MigrationDesc -> String
$cshowList :: [MigrationDesc] -> ShowS
showList :: [MigrationDesc] -> ShowS
Show)

type P = M.Parsec Void Text

parseMigrationDesc :: P MigrationDesc
parseMigrationDesc :: Parsec Void Text MigrationDesc
parseMigrationDesc = do
  Tokens Text
_ <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
M.takeWhileP Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
isSpace
  Text
name <- Text -> P ()
symbol Text
"name" P () -> P () -> P ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Text -> P ()
symbol Text
"=" P ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity Text
parseName ParsecT Void Text Identity Text
-> P () -> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* P ()
vspace
  Text -> P ()
header Text
"up"
  String
up <- String
"up sql" String
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
`M.label` ParsecT Void Text Identity Char
-> P () -> ParsecT Void Text Identity String
forall (m :: Type -> Type) a end.
MonadPlus m =>
m a -> m end -> m [a]
M.manyTill ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type). MonadParsec e s m => m (Token s)
M.anySingle (P () -> P ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a. MonadParsec e s m => m a -> m a
M.try (ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
M.newline ParsecT Void Text Identity Char -> P () -> P ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Text -> P ()
header Text
"down"))
  Text
down <- String
"down sql" String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
`M.label` ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type). MonadParsec e s m => m (Tokens s)
M.takeRest
  pure
    MigrationDesc
      { Text
$sel:name:MigrationDesc :: Text
name :: Text
name
      , $sel:up:MigrationDesc :: Text
up = Text -> Text
Text.strip (String -> Text
Text.pack String
up)
      , $sel:down:MigrationDesc :: Text
down = Text -> Text
Text.strip Text
down
      }

vspace :: P ()
vspace :: P ()
vspace = ParsecT Void Text Identity (Tokens Text) -> P ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
M.takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'))

header :: Text -> P ()
header :: Text -> P ()
header Text
t = ParsecT Void Text Identity (Tokens Text) -> P ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (String
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
M.label (String
"section header " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
h) (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.chunk Text
Tokens Text
h))
  where
    h :: Text
h = [Text] -> Text
Text.concat [Text
Item [Text]
"[", Text
Item [Text]
t, Text
Item [Text]
"]\n"]

symbol :: Text -> P ()
symbol :: Text -> P ()
symbol = ParsecT Void Text Identity Text -> P ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> P ())
-> (Text -> ParsecT Void Text Identity Text) -> Text -> P ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. P () -> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol P ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
M.hspace

lexeme :: P a -> P a
lexeme :: forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme = P ()
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
m () -> m a -> m a
L.lexeme P ()
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m ()
M.hspace

parseName :: P Text
parseName :: ParsecT Void Text Identity Text
parseName =
  String
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
String
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
M.label String
"name of the migration" (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$
    ParsecT Void Text Identity Text -> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
lexeme
      ( String -> Text
Text.pack (String -> Text)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          Char
c1 <- ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
M.upperChar
          String
cs <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: Type -> Type) a. MonadPlus m => m a -> m [a]
M.many ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: Type -> Type).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
M.alphaNumChar
          pure (Char
c1 Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs)
      )