{-|
Module      :  Database.Persist.Migration.Operation
Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
Stability   :  experimental
Portability :  portable

Defines the Operation data types.
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Database.Persist.Migration.Operation
  ( Operation(..)
  , validateOperation
  ) where

import Control.Monad (when)
import Data.List (nub)
import Data.Maybe (isNothing, mapMaybe)
import Data.Text (Text)
import Database.Persist.Migration.Operation.Types
import Database.Persist.Migration.Utils.Sql (MigrateSql)
import Database.Persist.Sql (PersistValue, SqlPersistT)

-- | An operation that can be migrated.
data Operation
  = CreateTable
      { Operation -> Text
name        :: Text
      , Operation -> [Column]
schema      :: [Column]
      , Operation -> [TableConstraint]
constraints :: [TableConstraint]
      }
  | DropTable
      { Operation -> Text
table :: Text
      }
  | RenameTable
      { Operation -> Text
from :: Text
      , Operation -> Text
to   :: Text
      }
  | AddConstraint
      { table      :: Text
      , Operation -> TableConstraint
constraint :: TableConstraint
      }
  | DropConstraint
      { table          :: Text
      , Operation -> Text
constraintName :: Text
      }
  | AddColumn
      { table      :: Text
      , Operation -> Column
column     :: Column
      , Operation -> Maybe PersistValue
colDefault :: Maybe PersistValue
        -- ^ The default for existing rows; required if the column is non-nullable
      }
  | RenameColumn
      { table :: Text
      , from  :: Text
      , to    :: Text
      }
  | DropColumn
      { Operation -> ColumnIdentifier
columnId :: ColumnIdentifier
      }
  | RawOperation
      { Operation -> Text
message :: Text
      , Operation -> SqlPersistT IO [MigrateSql]
rawOp   :: SqlPersistT IO [MigrateSql]
      }
    -- ^ A custom operation that can be defined manually.
    --
    -- RawOperations should primarily use 'rawSql' and 'rawExecute' from the persistent library. If the
    -- operation depends on the backend being run, query 'connRDBMS' from the 'SqlBackend':
    --
    -- @
    -- asks connRDBMS >>= \case
    --   "sqlite" -> ...
    --   _ -> return ()
    -- @
  deriving (Int -> Operation -> ShowS
[Operation] -> ShowS
Operation -> String
(Int -> Operation -> ShowS)
-> (Operation -> String)
-> ([Operation] -> ShowS)
-> Show Operation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Operation] -> ShowS
$cshowList :: [Operation] -> ShowS
show :: Operation -> String
$cshow :: Operation -> String
showsPrec :: Int -> Operation -> ShowS
$cshowsPrec :: Int -> Operation -> ShowS
Show)

instance Show (SqlPersistT m a) where
  show :: SqlPersistT m a -> String
show SqlPersistT m a
_ = String
"<SqlPersistT>"

-- | Validate that the given Operation is valid.
validateOperation :: Operation -> Either String ()
validateOperation :: Operation -> Either String ()
validateOperation ct :: Operation
ct@CreateTable{[TableConstraint]
[Column]
Text
constraints :: [TableConstraint]
schema :: [Column]
name :: Text
constraints :: Operation -> [TableConstraint]
schema :: Operation -> [Column]
name :: Operation -> Text
..} = do
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Column] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Column]
schema) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall b. String -> Either String b
fail' String
"No columns specified in the schema"

  (Column -> Either String ()) -> [Column] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Column -> Either String ()
validateColumn [Column]
schema

  case [TableConstraint] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TableConstraint] -> Int)
-> ([TableConstraint] -> [TableConstraint])
-> [TableConstraint]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TableConstraint -> Bool) -> [TableConstraint] -> [TableConstraint]
forall a. (a -> Bool) -> [a] -> [a]
filter TableConstraint -> Bool
isPrimaryKey ([TableConstraint] -> Int) -> [TableConstraint] -> Int
forall a b. (a -> b) -> a -> b
$ [TableConstraint]
constraints of
    Int
0 -> String -> Either String ()
forall b. String -> Either String b
fail' String
"No primary key specified"
    Int
1 -> () -> Either String ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Int
_ -> String -> Either String ()
forall b. String -> Either String b
fail' String
"Multiple primary keys specified"

  let getUniqueName :: TableConstraint -> Maybe Text
getUniqueName (Unique Text
n [Text]
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
n
      getUniqueName TableConstraint
_ = Maybe Text
forall a. Maybe a
Nothing
      uniqueNames :: [Text]
uniqueNames = (TableConstraint -> Maybe Text) -> [TableConstraint] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TableConstraint -> Maybe Text
getUniqueName [TableConstraint]
constraints
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub [Text]
uniqueNames) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
uniqueNames) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall b. String -> Either String b
fail' String
"Multiple unique constraints with the same name detected"

  let constraintCols :: [Text]
constraintCols = (TableConstraint -> [Text]) -> [TableConstraint] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TableConstraint -> [Text]
getConstraintColumns [TableConstraint]
constraints
      schemaCols :: [Text]
schemaCols = (Column -> Text) -> [Column] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Column -> Text
colName [Column]
schema
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
schemaCols) [Text]
constraintCols) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall b. String -> Either String b
fail' String
"Table constraint references non-existent column"
  where
    fail' :: String -> Either String b
fail' = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> ShowS -> String -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Operation -> String
forall a. Show a => a -> String
show Operation
ct)

validateOperation ac :: Operation
ac@AddColumn{Maybe PersistValue
Text
Column
colDefault :: Maybe PersistValue
column :: Column
table :: Text
colDefault :: Operation -> Maybe PersistValue
column :: Operation -> Column
table :: Operation -> Text
..} = do
  Column -> Either String ()
validateColumn Column
column
  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ColumnProp
NotNull ColumnProp -> [ColumnProp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Column -> [ColumnProp]
colProps Column
column Bool -> Bool -> Bool
&& Maybe PersistValue -> Bool
forall a. Maybe a -> Bool
isNothing Maybe PersistValue
colDefault) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
    String -> Either String ()
forall b. String -> Either String b
fail' String
"Adding a non-nullable column requires a default"
  where
    fail' :: String -> Either String b
fail' = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> ShowS -> String -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Operation -> String
forall a. Show a => a -> String
show Operation
ac)

validateOperation Operation
_ = () -> Either String ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()