{-# LANGUAGE TemplateHaskell #-}
module Database.Relational.Schema.MySQL
( module Database.Relational.Schema.MySQL.Config
, normalizeColumn
, notNull
, getType
, columnsQuerySQL
, primaryKeyQuerySQL
)
where
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Char (toLower, toUpper)
import Data.Map (Map, fromList)
import qualified Data.Map as Map
import Data.Time (Day, LocalTime, TimeOfDay)
import Data.Time.Clock.POSIX (POSIXTime)
import Data.ByteString (ByteString)
import Control.Applicative ((<|>))
import Language.Haskell.TH (TypeQ)
import Database.Relational ( Query
, relationalQuery
, query
, relation'
, wheres
, (.=.)
, (!)
, (><)
, placeholder
, asc
, value
)
import Database.Relational.Schema.MySQL.Config
import Database.Relational.Schema.MySQL.Columns (Columns, columns)
import qualified Database.Relational.Schema.MySQL.Columns as Columns
import Database.Relational.Schema.MySQL.TableConstraints (tableConstraints)
import qualified Database.Relational.Schema.MySQL.TableConstraints as Tabconst
import Database.Relational.Schema.MySQL.KeyColumnUsage (keyColumnUsage)
import qualified Database.Relational.Schema.MySQL.KeyColumnUsage as Keycoluse
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault = [(String, TypeQ)] -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
fromList
[ ("CHAR", [t| String |])
, ("VARCHAR", [t| String |])
, ("TINYTEXT", [t| String |])
, ("TEXT", [t| String |])
, ("MEDIUMTEXT", [t| String |])
, ("LONGTEXT", [t| String |])
, ("TINYBLOB", [t| ByteString |])
, ("BLOB", [t| ByteString |])
, ("MEDIUMBLOB", [t| ByteString |])
, ("LONGBLOB", [t| ByteString |])
, ("DATE", [t| Day |])
, ("DATETIME", [t| LocalTime |])
, ("TIME", [t| TimeOfDay |])
, ("TIMESTAMP", [t| POSIXTime |])
, ("TINYINT", [t| Int8 |])
, ("SMALLINT", [t| Int16 |])
, ("MEDIUMINT", [t| Int32 |])
, ("INT", [t| Int32 |])
, ("INTEGER", [t| Int32 |])
, ("BIGINT", [t| Int64 |])
]
normalizeColumn :: String -> String
normalizeColumn :: String -> String
normalizeColumn = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
notNull :: Columns -> Bool
notNull :: Columns -> Bool
notNull = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "NO") (String -> Bool) -> (Columns -> String) -> Columns -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Columns -> String
Columns.isNullable
getType :: Map String TypeQ
-> Columns
-> Maybe (String, TypeQ)
getType :: Map String TypeQ -> Columns -> Maybe (String, TypeQ)
getType mapFromSql :: Map String TypeQ
mapFromSql rec :: Columns
rec = do
TypeQ
typ <- String -> Map String TypeQ -> Maybe TypeQ
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSql
Maybe TypeQ -> Maybe TypeQ -> Maybe TypeQ
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
String -> Map String TypeQ -> Maybe TypeQ
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSqlDefault
(String, TypeQ) -> Maybe (String, TypeQ)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
normalizeColumn (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Columns -> String
Columns.columnName Columns
rec, TypeQ -> TypeQ
mayNull TypeQ
typ)
where
key :: String
key = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Columns -> String
Columns.dataType Columns
rec
mayNull :: TypeQ -> TypeQ
mayNull typ :: TypeQ
typ = if Columns -> Bool
notNull Columns
rec
then TypeQ
typ
else [t|Maybe $(typ)|]
columnsQuerySQL :: Query (String, String) Columns
columnsQuerySQL :: Query (String, String) Columns
columnsQuerySQL = Relation (String, String) Columns -> Query (String, String) Columns
forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) Columns
columnsRelationFromTable
where
columnsRelationFromTable :: Relation (String, String) Columns
columnsRelationFromTable = SimpleQuery (String, String) Columns
-> Relation (String, String) Columns
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) Columns
-> Relation (String, String) Columns)
-> SimpleQuery (String, String) Columns
-> Relation (String, String) Columns
forall a b. (a -> b) -> a -> b
$ do
Record Flat Columns
c <- Relation () Columns
-> Orderings Flat QueryCore (Record Flat Columns)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Columns
columns
(schemaP :: PlaceHolders String
schemaP, ()) <- (Record Flat String -> Orderings Flat QueryCore ())
-> Orderings Flat QueryCore (PlaceHolders String, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\ph :: Record Flat String
ph -> Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat Columns
c Record Flat Columns -> Pi Columns String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns String
Columns.tableSchema' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)
(nameP :: PlaceHolders String
nameP , ()) <- (Record Flat String -> Orderings Flat QueryCore ())
-> Orderings Flat QueryCore (PlaceHolders String, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\ph :: Record Flat String
ph -> Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat Columns
c Record Flat Columns -> Pi Columns String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns String
Columns.tableName' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)
Record Flat Int16 -> Orderings Flat QueryCore ()
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc (Record Flat Int16 -> Orderings Flat QueryCore ())
-> Record Flat Int16 -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat Columns
c Record Flat Columns -> Pi Columns Int16 -> Record Flat Int16
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int16
Columns.ordinalPosition'
(PlaceHolders (String, String), Record Flat Columns)
-> SimpleQuery (String, String) Columns
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders String
schemaP PlaceHolders String
-> PlaceHolders String -> PlaceHolders (String, String)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders String
nameP, Record Flat Columns
c)
primaryKeyQuerySQL :: Query (String, String) String
primaryKeyQuerySQL :: Query (String, String) String
primaryKeyQuerySQL = Relation (String, String) String -> Query (String, String) String
forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) String
primaryKeyRelation
where
primaryKeyRelation :: Relation (String, String) String
primaryKeyRelation = SimpleQuery (String, String) String
-> Relation (String, String) String
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) String
-> Relation (String, String) String)
-> SimpleQuery (String, String) String
-> Relation (String, String) String
forall a b. (a -> b) -> a -> b
$ do
Record Flat TableConstraints
cons <- Relation () TableConstraints
-> Orderings Flat QueryCore (Record Flat TableConstraints)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () TableConstraints
tableConstraints
Record Flat KeyColumnUsage
key <- Relation () KeyColumnUsage
-> Orderings Flat QueryCore (Record Flat KeyColumnUsage)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () KeyColumnUsage
keyColumnUsage
Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat TableConstraints
cons Record Flat TableConstraints
-> Pi TableConstraints String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi TableConstraints String
Tabconst.tableSchema' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat KeyColumnUsage
key Record Flat KeyColumnUsage
-> Pi KeyColumnUsage String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi KeyColumnUsage String
Keycoluse.tableSchema'
Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat TableConstraints
cons Record Flat TableConstraints
-> Pi TableConstraints String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi TableConstraints String
Tabconst.tableName' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat KeyColumnUsage
key Record Flat KeyColumnUsage
-> Pi KeyColumnUsage String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi KeyColumnUsage String
Keycoluse.tableName'
Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat TableConstraints
cons Record Flat TableConstraints
-> Pi TableConstraints String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi TableConstraints String
Tabconst.constraintName' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat KeyColumnUsage
key Record Flat KeyColumnUsage
-> Pi KeyColumnUsage String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi KeyColumnUsage String
Keycoluse.constraintName'
(schemaP :: PlaceHolders String
schemaP, ()) <- (Record Flat String -> Orderings Flat QueryCore ())
-> Orderings Flat QueryCore (PlaceHolders String, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\ph :: Record Flat String
ph -> Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat TableConstraints
cons Record Flat TableConstraints
-> Pi TableConstraints String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi TableConstraints String
Tabconst.tableSchema' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)
(nameP :: PlaceHolders String
nameP , ()) <- (Record Flat String -> Orderings Flat QueryCore ())
-> Orderings Flat QueryCore (PlaceHolders String, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\ph :: Record Flat String
ph -> Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat TableConstraints
cons Record Flat TableConstraints
-> Pi TableConstraints String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi TableConstraints String
Tabconst.tableName' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)
Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat TableConstraints
cons Record Flat TableConstraints
-> Pi TableConstraints String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi TableConstraints String
Tabconst.constraintType' Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. String -> Record Flat String
forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value "PRIMARY KEY"
Record Flat Int16 -> Orderings Flat QueryCore ()
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc (Record Flat Int16 -> Orderings Flat QueryCore ())
-> Record Flat Int16 -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat KeyColumnUsage
key Record Flat KeyColumnUsage
-> Pi KeyColumnUsage Int16 -> Record Flat Int16
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi KeyColumnUsage Int16
Keycoluse.ordinalPosition'
(PlaceHolders (String, String), Record Flat String)
-> SimpleQuery (String, String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders String
schemaP PlaceHolders String
-> PlaceHolders String -> PlaceHolders (String, String)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders String
nameP, Record Flat KeyColumnUsage
key Record Flat KeyColumnUsage
-> Pi KeyColumnUsage String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi KeyColumnUsage String
Keycoluse.columnName')