Use my new persistent-migration library, to which I moved the related modules
This commit is contained in:
fr33domlover
parent
3b4bd2a5e8
commit
829fd72fef
6 changed files with 3 additions and 528 deletions
|
|
@ -1,6 +1,6 @@
|
||||||
-- This file is part of Vervis.
|
-- This file is part of Vervis.
|
||||||
--
|
--
|
||||||
-- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
-- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
|
||||||
--
|
--
|
||||||
-- ♡ Copying is an act of love. Please copy, reuse and share.
|
-- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
--
|
--
|
||||||
|
|
@ -12,13 +12,6 @@
|
||||||
-- with this software. If not, see
|
-- with this software. If not, see
|
||||||
-- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
-- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
-- Meta
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
SchemaVersion
|
|
||||||
number Int
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- People
|
-- People
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
|
||||||
|
|
@ -1,160 +0,0 @@
|
||||||
{- This file is part of Vervis.
|
|
||||||
-
|
|
||||||
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
|
||||||
-
|
|
||||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
||||||
-
|
|
||||||
- The author(s) have dedicated all copyright and related and neighboring
|
|
||||||
- rights to this software to the public domain worldwide. This software is
|
|
||||||
- distributed without any warranty.
|
|
||||||
-
|
|
||||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
||||||
- with this software. If not, see
|
|
||||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
||||||
-}
|
|
||||||
|
|
||||||
module Database.Persist.Schema
|
|
||||||
( FieldName (..)
|
|
||||||
, EntityName (..)
|
|
||||||
, UniqueName (..)
|
|
||||||
, FieldType (..)
|
|
||||||
, MaybeNull (..)
|
|
||||||
, Field (..)
|
|
||||||
, Entity (..)
|
|
||||||
, Unique (..)
|
|
||||||
, SchemaT
|
|
||||||
, PersistSchema (..)
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
|
||||||
import Control.Monad.Trans.Reader (ReaderT)
|
|
||||||
import Data.Char (isAsciiLower, isAsciiUpper)
|
|
||||||
import Data.String (IsString (..))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Database.Persist.Types (SqlType)
|
|
||||||
|
|
||||||
import qualified Data.Text as T (uncons, all, stripPrefix)
|
|
||||||
|
|
||||||
import Data.Char.Local (isAsciiLetter)
|
|
||||||
|
|
||||||
newtype FieldName = FieldName { unFieldName :: Text }
|
|
||||||
|
|
||||||
instance IsString FieldName where
|
|
||||||
fromString s =
|
|
||||||
let t = fromString s
|
|
||||||
in case T.uncons t of
|
|
||||||
Nothing -> error "empty field name"
|
|
||||||
Just (c, r) ->
|
|
||||||
if isAsciiLower c
|
|
||||||
then
|
|
||||||
if T.all isAsciiLetter r
|
|
||||||
then FieldName t
|
|
||||||
else
|
|
||||||
error "non ascii-letter char in field name"
|
|
||||||
else
|
|
||||||
error
|
|
||||||
"field name doesn't start with lowercase \
|
|
||||||
\ascii letter"
|
|
||||||
|
|
||||||
newtype EntityName = EntityName { unEntityName :: Text }
|
|
||||||
|
|
||||||
instance IsString EntityName where
|
|
||||||
fromString s =
|
|
||||||
let t = fromString s
|
|
||||||
in case T.uncons t of
|
|
||||||
Nothing -> error "empty entity name"
|
|
||||||
Just (c, r) ->
|
|
||||||
if isAsciiUpper c
|
|
||||||
then
|
|
||||||
if T.all isAsciiLetter r
|
|
||||||
then EntityName t
|
|
||||||
else
|
|
||||||
error
|
|
||||||
"non ascii-letter char in entity name"
|
|
||||||
else
|
|
||||||
error
|
|
||||||
"entity name doesn't start with uppercase \
|
|
||||||
\ascii letter"
|
|
||||||
|
|
||||||
newtype UniqueName = UniqueName { unUniqueName :: Text }
|
|
||||||
|
|
||||||
instance IsString UniqueName where
|
|
||||||
fromString s =
|
|
||||||
let t = fromString s
|
|
||||||
in case T.stripPrefix "Unique" t of
|
|
||||||
Nothing -> error "unique name doesn't start with \"Unique\""
|
|
||||||
Just u ->
|
|
||||||
case T.uncons u of
|
|
||||||
Nothing -> error "unique name is just \"Unique\""
|
|
||||||
Just (c, r) ->
|
|
||||||
if isAsciiUpper c
|
|
||||||
then
|
|
||||||
if T.all isAsciiLetter r
|
|
||||||
then UniqueName t
|
|
||||||
else
|
|
||||||
error
|
|
||||||
"non ascii-letter char in \
|
|
||||||
\unique name"
|
|
||||||
else
|
|
||||||
error
|
|
||||||
"unique name doesn't follow with \
|
|
||||||
\uppercase ascii letter after Unique"
|
|
||||||
|
|
||||||
data FieldType = FTPrim SqlType | FTRef
|
|
||||||
|
|
||||||
data MaybeNull = MaybeNull | NotNull
|
|
||||||
|
|
||||||
data Field = Field
|
|
||||||
{ fieldName :: FieldName
|
|
||||||
, fieldType :: FieldType
|
|
||||||
, fieldNull :: MaybeNull
|
|
||||||
}
|
|
||||||
|
|
||||||
data Entity = Entity
|
|
||||||
{ entityName :: EntityName
|
|
||||||
, entityFields :: [Field]
|
|
||||||
, entityUniques :: [Unique]
|
|
||||||
}
|
|
||||||
|
|
||||||
data Unique = Unique
|
|
||||||
{ uniqueName :: UniqueName
|
|
||||||
, uniqueFields :: [FieldName]
|
|
||||||
}
|
|
||||||
|
|
||||||
type SchemaT b m = ReaderT (SchemaBackend b) (ReaderT b m)
|
|
||||||
|
|
||||||
-- | Ideally we'd make the @backend@ provide schema related specifics. The
|
|
||||||
-- problem is that e.g. @SqlBackend@ is already defined in @persistent@ and
|
|
||||||
-- I'll need a patch to get it updated. A patch that will take time to get
|
|
||||||
-- accpted, if the maintainer likes it at all. So instead, I'm letting these
|
|
||||||
-- specifics be specified in a separate, associated data type.
|
|
||||||
--
|
|
||||||
-- The only benefit I see for this approach is schema changes are separate from
|
|
||||||
-- data manipulations. You can't mix them in a single transaction without
|
|
||||||
-- explicitly specifying the schema backend and using 'lift' for data manip.
|
|
||||||
class PersistSchema backend where
|
|
||||||
data SchemaBackend backend -- :: *
|
|
||||||
hasSchemaEntity
|
|
||||||
:: MonadIO m => SchemaT backend m Bool
|
|
||||||
addEntity
|
|
||||||
:: MonadIO m => Entity -> SchemaT backend m ()
|
|
||||||
removeEntity
|
|
||||||
:: MonadIO m => EntityName -> SchemaT backend m ()
|
|
||||||
addField
|
|
||||||
:: MonadIO m
|
|
||||||
=> EntityName -> Maybe Text -> Field -> SchemaT backend m ()
|
|
||||||
renameField
|
|
||||||
:: MonadIO m
|
|
||||||
=> EntityName -> FieldName -> FieldName -> SchemaT backend m ()
|
|
||||||
removeField
|
|
||||||
:: MonadIO m => EntityName -> FieldName -> SchemaT backend m ()
|
|
||||||
addUnique
|
|
||||||
:: MonadIO m => EntityName -> Unique -> SchemaT backend m ()
|
|
||||||
renameUnique
|
|
||||||
:: MonadIO m
|
|
||||||
=> EntityName -> UniqueName -> UniqueName -> SchemaT backend m ()
|
|
||||||
removeUnique
|
|
||||||
:: MonadIO m => EntityName -> UniqueName -> SchemaT backend m ()
|
|
||||||
|
|
@ -1,165 +0,0 @@
|
||||||
{- This file is part of Vervis.
|
|
||||||
-
|
|
||||||
- Written in 2016, 2017 by fr33domlover <fr33domlover@riseup.net>.
|
|
||||||
-
|
|
||||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
||||||
-
|
|
||||||
- The author(s) have dedicated all copyright and related and neighboring
|
|
||||||
- rights to this software to the public domain worldwide. This software is
|
|
||||||
- distributed without any warranty.
|
|
||||||
-
|
|
||||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
||||||
- with this software. If not, see
|
|
||||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
||||||
-}
|
|
||||||
|
|
||||||
module Database.Persist.Schema.PostgreSQL
|
|
||||||
( schemaBackend
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Data.Monoid ((<>))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Database.Persist.Sql (SqlBackend)
|
|
||||||
import Database.Persist.Types (SqlType (..))
|
|
||||||
import Formatting
|
|
||||||
|
|
||||||
import qualified Data.Text as T (empty, pack, intercalate, foldr)
|
|
||||||
|
|
||||||
import Database.Persist.Schema
|
|
||||||
import Database.Persist.Schema.Sql
|
|
||||||
|
|
||||||
quoteName :: Text -> Text
|
|
||||||
quoteName =
|
|
||||||
let f '\0' _ = error "quoteName found \\0 character, invalid in names"
|
|
||||||
f '"' cs = '"' : '"' : cs
|
|
||||||
f c cs = c : cs
|
|
||||||
in T.pack . ('"' :) . T.foldr f "\""
|
|
||||||
|
|
||||||
table2sql :: TableName -> Text
|
|
||||||
table2sql = quoteName . unTableName
|
|
||||||
|
|
||||||
column2sql :: ColumnName -> Text
|
|
||||||
column2sql = quoteName . unColumnName
|
|
||||||
|
|
||||||
constraint2sql :: ConstraintName -> Text
|
|
||||||
constraint2sql = quoteName . unConstraintName
|
|
||||||
|
|
||||||
typeSql :: SqlType -> Text
|
|
||||||
typeSql SqlString = "VARCHAR"
|
|
||||||
typeSql SqlInt32 = "INT4"
|
|
||||||
typeSql SqlInt64 = "INT8"
|
|
||||||
typeSql SqlReal = "DOUBLE PRECISION"
|
|
||||||
typeSql (SqlNumeric prec scale) =
|
|
||||||
sformat ("NUMERIC(" % int % "," % int % ")") prec scale
|
|
||||||
typeSql SqlDay = "DATE"
|
|
||||||
typeSql SqlTime = "TIME"
|
|
||||||
typeSql SqlDayTime = "TIMESTAMP WITH TIME ZONE"
|
|
||||||
typeSql SqlBlob = "BYTEA"
|
|
||||||
typeSql SqlBool = "BOOLEAN"
|
|
||||||
typeSql (SqlOther t) = t
|
|
||||||
|
|
||||||
columnSql :: Column -> Text
|
|
||||||
columnSql (Column name typ mnull) = mconcat
|
|
||||||
[ column2sql name, " "
|
|
||||||
, typeSql typ
|
|
||||||
, case mnull of
|
|
||||||
MaybeNull -> " NULL"
|
|
||||||
NotNull -> " NOT NULL"
|
|
||||||
]
|
|
||||||
|
|
||||||
idCol :: ColumnName
|
|
||||||
idCol = ColumnName "id"
|
|
||||||
|
|
||||||
idSql :: Text
|
|
||||||
idSql = "id SERIAL8 PRIMARY KEY UNIQUE"
|
|
||||||
|
|
||||||
schemaBackend :: SchemaBackend SqlBackend
|
|
||||||
schemaBackend = SqlSchemaBackend
|
|
||||||
{ ssbRefType = SqlInt64
|
|
||||||
, ssbDoesTableExist =
|
|
||||||
"SELECT COUNT(*) FROM pg_catalog.pg_tables \
|
|
||||||
\ WHERE schemaname != 'pg_catalog' AND \
|
|
||||||
\ schemaname != 'information_schema' AND \
|
|
||||||
\ tablename = ?"
|
|
||||||
, ssbCreateTable = \ table columns -> mconcat
|
|
||||||
[ "CREATE TABLE ", table2sql table, " ("
|
|
||||||
, idSql
|
|
||||||
, if null columns then T.empty else ", "
|
|
||||||
, T.intercalate ", " $ map columnSql columns
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
, ssbRenameTable = \ old new -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql old
|
|
||||||
, " RENAME TO ", table2sql new
|
|
||||||
]
|
|
||||||
, ssbDropTable = \ table -> mconcat
|
|
||||||
[ "DROP TABLE ", table2sql table
|
|
||||||
]
|
|
||||||
, ssbAddColumn = \ table column mdef -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " ADD COLUMN ", columnSql column
|
|
||||||
, case mdef of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just t -> " DEFAULT " <> t
|
|
||||||
]
|
|
||||||
, ssbRenameColumn = \ table old new -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " RENAME COLUMN ", column2sql old, " TO ", column2sql new
|
|
||||||
]
|
|
||||||
, ssbRetypeColumn = \ table column typ -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " ALTER COLUMN ", column2sql column
|
|
||||||
, " TYPE ", typeSql typ
|
|
||||||
]
|
|
||||||
, ssbRenullColumn = \ table column mnull -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " ALTER COLUMN ", column2sql column
|
|
||||||
, case mnull of
|
|
||||||
MaybeNull -> " DROP"
|
|
||||||
NotNull -> " SET"
|
|
||||||
, " NOT NULL"
|
|
||||||
]
|
|
||||||
, ssbUnnullColumn = \ table column val -> mconcat
|
|
||||||
[ "UPDATE ", table2sql table
|
|
||||||
, " SET ", column2sql column, " = ", val
|
|
||||||
, " WHERE ", column2sql column, " IS NULL"
|
|
||||||
]
|
|
||||||
, ssbDefColumn = \ table column val -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " ALTER COLUMN ", column2sql column
|
|
||||||
, " SET DEFAULT ", val
|
|
||||||
]
|
|
||||||
, ssbUndefColumn = \ table column -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " ALTER COLUMN ", column2sql column
|
|
||||||
, " DROP DEFAULT"
|
|
||||||
]
|
|
||||||
, ssbDropColumn = \ table column -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " DROP COLUMN ", column2sql column
|
|
||||||
]
|
|
||||||
, ssbAddUnique = \ table constraint columns -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " ADD CONSTRAINT ", constraint2sql constraint
|
|
||||||
, " UNIQUE("
|
|
||||||
, T.intercalate ", " $ map column2sql columns
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
, ssbAddForeignKey = \ table constraint column target -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " ADD CONSTRAINT ", constraint2sql constraint
|
|
||||||
, " FOREIGN KEY(", column2sql column
|
|
||||||
, ") REFERENCES ", table2sql target, "(", column2sql idCol, ")"
|
|
||||||
]
|
|
||||||
, ssbRenameConstraint = \ _table old new -> mconcat
|
|
||||||
[ "ALTER INDEX ", constraint2sql old
|
|
||||||
, " RENAME TO ", constraint2sql new
|
|
||||||
]
|
|
||||||
, ssbDropConstraint = \ table constraint -> mconcat
|
|
||||||
[ "ALTER TABLE ", table2sql table
|
|
||||||
, " DROP CONSTRAINT ", constraint2sql constraint
|
|
||||||
]
|
|
||||||
}
|
|
||||||
|
|
@ -1,191 +0,0 @@
|
||||||
{- This file is part of Vervis.
|
|
||||||
-
|
|
||||||
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
|
||||||
-
|
|
||||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
||||||
-
|
|
||||||
- The author(s) have dedicated all copyright and related and neighboring
|
|
||||||
- rights to this software to the public domain worldwide. This software is
|
|
||||||
- distributed without any warranty.
|
|
||||||
-
|
|
||||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
||||||
- with this software. If not, see
|
|
||||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
||||||
-}
|
|
||||||
|
|
||||||
-- | SQL schema backend specifying SQL statements for manipulating a SQL
|
|
||||||
-- database's table schema.
|
|
||||||
module Database.Persist.Schema.Sql
|
|
||||||
( TableName (..)
|
|
||||||
, ColumnName (..)
|
|
||||||
, ConstraintName (..)
|
|
||||||
, Column (..)
|
|
||||||
, SchemaBackend (..)
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Control.Monad (when)
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
|
||||||
import Control.Monad.Trans.Reader (ask)
|
|
||||||
import Data.Char (isUpper, toLower)
|
|
||||||
import Data.Foldable (traverse_)
|
|
||||||
import Data.Maybe (isJust)
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Database.Persist.Sql hiding (FieldType, Entity, Column)
|
|
||||||
import Database.Persist.Types (SqlType)
|
|
||||||
|
|
||||||
import qualified Data.Conduit.List as CL (head)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import Database.Persist.Schema
|
|
||||||
|
|
||||||
newtype TableName = TableName { unTableName :: Text }
|
|
||||||
|
|
||||||
newtype ColumnName = ColumnName { unColumnName :: Text }
|
|
||||||
|
|
||||||
newtype ConstraintName = ConstraintName { unConstraintName :: Text }
|
|
||||||
|
|
||||||
data Column = Column
|
|
||||||
{ colName :: ColumnName
|
|
||||||
, colType :: SqlType
|
|
||||||
, colNull :: MaybeNull
|
|
||||||
}
|
|
||||||
|
|
||||||
exec :: MonadIO m => Sql -> SchemaT SqlBackend m ()
|
|
||||||
exec t = lift $ rawExecute t []
|
|
||||||
|
|
||||||
inquire
|
|
||||||
:: MonadIO m => Sql -> [PersistValue] -> SchemaT SqlBackend m PersistValue
|
|
||||||
inquire t vs = lift $ withRawQuery t vs $ do
|
|
||||||
l <- CL.head
|
|
||||||
case l of
|
|
||||||
Just [x] -> return x
|
|
||||||
Just [] -> error $ "inquire: got empty list " ++ show t
|
|
||||||
Just xs -> error $ "inquire: got multiple values " ++ show xs ++ show t
|
|
||||||
Nothing -> error $ "inquire: got nothing " ++ show t
|
|
||||||
|
|
||||||
camelWords :: Text -> [Text]
|
|
||||||
camelWords ident =
|
|
||||||
let low = toLower
|
|
||||||
slow = T.singleton . toLower
|
|
||||||
go c t l =
|
|
||||||
let (x, y) = T.break isUpper t
|
|
||||||
in case (T.null x, T.uncons y) of
|
|
||||||
(True, Nothing) -> slow c : l
|
|
||||||
(True, Just (d, r)) -> go d r $ slow c : l
|
|
||||||
(False, Nothing) -> (low c `T.cons` x) : l
|
|
||||||
(False, Just (d, r)) -> go d r $ (low c `T.cons` x) : l
|
|
||||||
(a, b) = T.break isUpper ident
|
|
||||||
in reverse $ case (T.null a, T.uncons b) of
|
|
||||||
(True, Nothing) -> []
|
|
||||||
(True, Just (c, r)) -> go c r []
|
|
||||||
(False, Nothing) -> [a]
|
|
||||||
(False, Just (c, r)) -> go c r [a]
|
|
||||||
|
|
||||||
dbname :: Text -> Text
|
|
||||||
dbname = T.intercalate (T.singleton '_') . camelWords
|
|
||||||
|
|
||||||
entity2table :: EntityName -> TableName
|
|
||||||
entity2table (EntityName t) = TableName $ dbname t
|
|
||||||
|
|
||||||
field2column :: FieldName -> ColumnName
|
|
||||||
field2column (FieldName t) = ColumnName $ dbname t
|
|
||||||
|
|
||||||
unique2constraint :: UniqueName -> ConstraintName
|
|
||||||
unique2constraint (UniqueName t) = ConstraintName $ dbname t
|
|
||||||
|
|
||||||
type2sql :: SchemaBackend SqlBackend -> FieldType -> SqlType
|
|
||||||
type2sql _ (FTPrim t) = t
|
|
||||||
type2sql ssb FTRef = ssbRefType ssb
|
|
||||||
|
|
||||||
mkcolumn :: SchemaBackend SqlBackend -> Field -> Column
|
|
||||||
mkcolumn ssb (Field name typ mnull) = Column
|
|
||||||
{ colName = field2column name
|
|
||||||
, colType = type2sql ssb typ
|
|
||||||
, colNull = mnull
|
|
||||||
}
|
|
||||||
|
|
||||||
instance PersistSchema SqlBackend where
|
|
||||||
data SchemaBackend SqlBackend = SqlSchemaBackend
|
|
||||||
{ ssbRefType :: SqlType
|
|
||||||
, ssbDoesTableExist :: Sql
|
|
||||||
, ssbCreateTable :: TableName -> [Column] -> Sql
|
|
||||||
, ssbRenameTable :: TableName -> TableName -> Sql
|
|
||||||
, ssbDropTable :: TableName -> Sql
|
|
||||||
, ssbAddColumn :: TableName -> Column -> Maybe Text -> Sql
|
|
||||||
, ssbRenameColumn :: TableName -> ColumnName -> ColumnName -> Sql
|
|
||||||
, ssbRetypeColumn :: TableName -> ColumnName -> SqlType -> Sql
|
|
||||||
, ssbRenullColumn :: TableName -> ColumnName -> MaybeNull -> Sql
|
|
||||||
, ssbUnnullColumn :: TableName -> ColumnName -> Text -> Sql
|
|
||||||
, ssbDefColumn :: TableName -> ColumnName -> Text -> Sql
|
|
||||||
, ssbUndefColumn :: TableName -> ColumnName -> Sql
|
|
||||||
, ssbDropColumn :: TableName -> ColumnName -> Sql
|
|
||||||
, ssbAddUnique
|
|
||||||
:: TableName -> ConstraintName -> [ColumnName] -> Sql
|
|
||||||
, ssbAddForeignKey
|
|
||||||
:: TableName -> ConstraintName -> ColumnName -> TableName -> Sql
|
|
||||||
, ssbRenameConstraint
|
|
||||||
:: TableName -> ConstraintName -> ConstraintName -> Sql
|
|
||||||
, ssbDropConstraint :: TableName -> ConstraintName -> Sql
|
|
||||||
}
|
|
||||||
hasSchemaEntity = do
|
|
||||||
ssb <- ask
|
|
||||||
let table =
|
|
||||||
toPersistValue $ unTableName $ entity2table $ EntityName $
|
|
||||||
T.pack "SchemaVersion"
|
|
||||||
v <- inquire (ssbDoesTableExist ssb) [table]
|
|
||||||
case v of
|
|
||||||
PersistInt64 1 -> return True
|
|
||||||
PersistInt64 0 -> return False
|
|
||||||
_ -> error "hasSchemaEntity: count inquiry didn't return a number"
|
|
||||||
addEntity (Entity name fields uniques) = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $
|
|
||||||
ssbCreateTable ssb (entity2table name) (map (mkcolumn ssb) fields)
|
|
||||||
traverse_ (addUnique name) uniques
|
|
||||||
removeEntity name = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $ ssbDropTable ssb $ entity2table name
|
|
||||||
addField ent mdef (Field name typ mnull) = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $
|
|
||||||
ssbAddColumn ssb
|
|
||||||
(entity2table ent)
|
|
||||||
(Column (field2column name) (type2sql ssb typ) mnull)
|
|
||||||
mdef
|
|
||||||
when (isJust mdef) $
|
|
||||||
exec $
|
|
||||||
ssbUndefColumn ssb (entity2table ent) (field2column name)
|
|
||||||
renameField entity old new = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $
|
|
||||||
ssbRenameColumn ssb
|
|
||||||
(entity2table entity)
|
|
||||||
(field2column old)
|
|
||||||
(field2column new)
|
|
||||||
removeField entity field = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $ ssbDropColumn ssb (entity2table entity) (field2column field)
|
|
||||||
addUnique entity (Unique name fields) = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $
|
|
||||||
ssbAddUnique ssb
|
|
||||||
(entity2table entity)
|
|
||||||
(unique2constraint name)
|
|
||||||
(map field2column fields)
|
|
||||||
renameUnique entity old new = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $
|
|
||||||
ssbRenameConstraint ssb
|
|
||||||
(entity2table entity)
|
|
||||||
(unique2constraint old)
|
|
||||||
(unique2constraint new)
|
|
||||||
removeUnique entity name = do
|
|
||||||
ssb <- ask
|
|
||||||
exec $
|
|
||||||
ssbDropConstraint ssb
|
|
||||||
(entity2table entity)
|
|
||||||
(unique2constraint name)
|
|
||||||
|
|
@ -12,6 +12,7 @@ packages:
|
||||||
- '../hit-graph'
|
- '../hit-graph'
|
||||||
- '../hit-harder'
|
- '../hit-harder'
|
||||||
- '../hit-network'
|
- '../hit-network'
|
||||||
|
- '../persistent-migration'
|
||||||
|
|
||||||
# Packages to be pulled from upstream that are not in the resolver (e.g.,
|
# Packages to be pulled from upstream that are not in the resolver (e.g.,
|
||||||
# acme-missiles-0.3)
|
# acme-missiles-0.3)
|
||||||
|
|
|
||||||
|
|
@ -83,10 +83,6 @@ library
|
||||||
Database.Persist.Local.Sql
|
Database.Persist.Local.Sql
|
||||||
Database.Persist.Local.Sql.Orphan.Common
|
Database.Persist.Local.Sql.Orphan.Common
|
||||||
Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
||||||
Database.Persist.Migration
|
|
||||||
Database.Persist.Schema
|
|
||||||
Database.Persist.Schema.PostgreSQL
|
|
||||||
Database.Persist.Schema.Sql
|
|
||||||
Development.DarcsRev
|
Development.DarcsRev
|
||||||
Diagrams.IntransitiveDAG
|
Diagrams.IntransitiveDAG
|
||||||
Formatting.CaseInsensitive
|
Formatting.CaseInsensitive
|
||||||
|
|
@ -276,6 +272,7 @@ library
|
||||||
-- for PathPiece instance for CI, Web.PathPieces.Local
|
-- for PathPiece instance for CI, Web.PathPieces.Local
|
||||||
, path-pieces
|
, path-pieces
|
||||||
, persistent
|
, persistent
|
||||||
|
, persistent-migration
|
||||||
, persistent-postgresql
|
, persistent-postgresql
|
||||||
, persistent-template
|
, persistent-template
|
||||||
, process
|
, process
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue