vervis/src/Database/Persist/Schema/Sql.hs

{- 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 (Sql, SqlBackend, rawExecute)
import Database.Persist.Types (SqlType)

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 []

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
        , 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
        }
    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 (Field name typ mnull) mdef = 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)