{-# 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

-- TODO: Need to check unsigned int types to avoid wrong mapping

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')