{-# LANGUAGE TemplateHaskell #-}
module Database.Relational.Schema.SQLServer (
module Database.Relational.Schema.SQLServer.Config,
getType, normalizeColumn, notNull,
columnTypeQuerySQL, primaryKeyQuerySQL
) where
import qualified Data.Map as Map
import qualified Database.Relational.Schema.SQLServer.Columns as Columns
import qualified Database.Relational.Schema.SQLServer.Indexes as Indexes
import qualified Database.Relational.Schema.SQLServer.IndexColumns as IndexColumns
import qualified Database.Relational.Schema.SQLServer.Types as Types
import Control.Applicative ((<|>))
import Data.ByteString (ByteString)
import Data.Char (toLower)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Map (Map)
import Data.Time (LocalTime, Day, TimeOfDay)
import Database.Relational (Query, Relation, PlaceHolders, Record, Flat,
(!), (.=.), (><), asc, relationalQuery, just, placeholder',
query, relation', unsafeShowSql,
unsafeProjectSql, wheres)
import Database.Relational.Schema.SQLServer.Config
import Database.Relational.Schema.SQLServer.Columns
import Database.Relational.Schema.SQLServer.Indexes
import Database.Relational.Schema.SQLServer.IndexColumns
import Database.Relational.Schema.SQLServer.Types
import Language.Haskell.TH (TypeQ)
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault =
[(String, TypeQ)] -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ("text", [t|ByteString|])
, ("date", [t|Day|])
, ("time", [t|TimeOfDay|])
, ("tinyint", [t|Int8|])
, ("smallint", [t|Int16|])
, ("int", [t|Int32|])
, ("real", [t|Double|])
, ("datetime", [t|LocalTime|])
, ("float", [t|Double|])
, ("ntext", [t|String|])
, ("bit", [t|Char|])
, ("bigint", [t|Int64|])
, ("varchar", [t|String|])
, ("binary", [t|ByteString|])
, ("char", [t|String|])
, ("timestamp", [t|LocalTime|])
, ("nvarchar", [t|String|])
, ("nchar", [t|String|])
]
normalizeColumn :: String -> String
normalizeColumn :: String -> String
normalizeColumn = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
notNull :: ((Columns,Types),String) -> Bool
notNull :: ((Columns, Types), String) -> Bool
notNull ((cols :: Columns
cols,_),_) = Maybe Bool -> Bool
isTrue (Maybe Bool -> Bool) -> (Columns -> Maybe Bool) -> Columns -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Columns -> Maybe Bool
Columns.isNullable (Columns -> Bool) -> Columns -> Bool
forall a b. (a -> b) -> a -> b
$ Columns
cols
where
isTrue :: Maybe Bool -> Bool
isTrue (Just b :: Bool
b) = Bool -> Bool
not Bool
b
isTrue _ = Bool
True
getType :: Map String TypeQ -> ((Columns,Types),String) -> Maybe (String, TypeQ)
getType :: Map String TypeQ
-> ((Columns, Types), String) -> Maybe (String, TypeQ)
getType mapFromSql :: Map String TypeQ
mapFromSql rec :: ((Columns, Types), String)
rec@((cols :: Columns
cols,typs :: Types
typs),typScms :: String
typScms) = do
String
colName <- Columns -> Maybe String
Columns.name Columns
cols
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
colName, TypeQ -> TypeQ
mayNull TypeQ
typ)
where
key :: String
key = if String
typScms String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "sys"
then Types -> String
Types.name Types
typs
else String
typScms String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Types -> String
Types.name Types
typs
mayNull :: TypeQ -> TypeQ
mayNull typ :: TypeQ
typ = if ((Columns, Types), String) -> Bool
notNull ((Columns, Types), String)
rec
then TypeQ
typ
else [t|Maybe $(typ)|]
sqlsrvTrue :: Record Flat Bool
sqlsrvTrue :: Record Flat Bool
sqlsrvTrue = String -> Record Flat Bool
forall c t. SqlContext c => String -> Record c t
unsafeProjectSql "1"
sqlsrvObjectId :: Record Flat String -> Record Flat String -> Record Flat Int32
sqlsrvObjectId :: Record Flat String -> Record Flat String -> Record Flat Int32
sqlsrvObjectId s :: Record Flat String
s t :: Record Flat String
t = String -> Record Flat Int32
forall c t. SqlContext c => String -> Record c t
unsafeProjectSql (String -> Record Flat Int32) -> String -> Record Flat Int32
forall a b. (a -> b) -> a -> b
$
"OBJECT_ID(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Record Flat String -> String
forall c a. Record c a -> String
unsafeShowSql Record Flat String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ " + '.' + " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Record Flat String -> String
forall c a. Record c a -> String
unsafeShowSql Record Flat String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder = (PlaceHolders String
nsParam PlaceHolders String
-> PlaceHolders String -> PlaceHolders (String, String)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders String
relParam, Record Flat Int32
oid)
where
(nsParam :: PlaceHolders String
nsParam, (relParam :: PlaceHolders String
relParam, oid :: Record Flat Int32
oid)) =
(Record Flat String -> (PlaceHolders String, Record Flat Int32))
-> (PlaceHolders String, (PlaceHolders String, Record Flat Int32))
forall t c a.
(PersistableWidth t, SqlContext c) =>
(Record c t -> a) -> (PlaceHolders t, a)
placeholder' (\nsPh :: Record Flat String
nsPh ->
(Record Flat String -> Record Flat Int32)
-> (PlaceHolders String, Record Flat Int32)
forall t c a.
(PersistableWidth t, SqlContext c) =>
(Record c t -> a) -> (PlaceHolders t, a)
placeholder' (\relPh :: Record Flat String
relPh ->
Record Flat String -> Record Flat String -> Record Flat Int32
sqlsrvObjectId Record Flat String
nsPh Record Flat String
relPh))
columnTypeRelation :: Relation (String,String) ((Columns,Types),String)
columnTypeRelation :: Relation (String, String) ((Columns, Types), String)
columnTypeRelation = SimpleQuery (String, String) ((Columns, Types), String)
-> Relation (String, String) ((Columns, Types), String)
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) ((Columns, Types), String)
-> Relation (String, String) ((Columns, Types), String))
-> SimpleQuery (String, String) ((Columns, Types), String)
-> Relation (String, String) ((Columns, Types), String)
forall a b. (a -> b) -> a -> b
$ do
Record Flat Columns
cols <- 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
Record Flat Types
typs <- Relation () Types -> Orderings Flat QueryCore (Record Flat Types)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Types
types
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
cols Record Flat Columns -> Pi Columns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.userTypeId' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Types
typs Record Flat Types -> Pi Types Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Types Int32
Types.userTypeId'
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
cols Record Flat Columns -> Pi Columns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.objectId' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
oid
Record Flat Int32 -> Orderings Flat QueryCore ()
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc (Record Flat Int32 -> Orderings Flat QueryCore ())
-> Record Flat Int32 -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat Columns
cols Record Flat Columns -> Pi Columns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.columnId'
(PlaceHolders (String, String),
Record Flat ((Columns, Types), String))
-> SimpleQuery (String, String) ((Columns, Types), String)
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
params, Record Flat Columns
cols Record Flat Columns
-> Record Flat Types -> Record Flat (Columns, Types)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< Record Flat Types
typs Record Flat (Columns, Types)
-> Record Flat String -> Record Flat ((Columns, Types), String)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< Record Flat Int32 -> Record Flat String
forall c c a t. SqlContext c => Record c a -> Record c t
sqlsrvSchemaName (Record Flat Types
typs Record Flat Types -> Pi Types Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Types Int32
Types.schemaId' :: Record Flat Int32))
where
(params :: PlaceHolders (String, String)
params, oid :: Record Flat Int32
oid) = (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder
sqlsrvSchemaName :: Record c a -> Record c t
sqlsrvSchemaName i :: Record c a
i = String -> Record c t
forall c t. SqlContext c => String -> Record c t
unsafeProjectSql (String -> Record c t) -> String -> Record c t
forall a b. (a -> b) -> a -> b
$
"SCHEMA_NAME(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Record c a -> String
forall c a. Record c a -> String
unsafeShowSql Record c a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
columnTypeQuerySQL :: Query (String, String) ((Columns, Types), String)
columnTypeQuerySQL :: Query (String, String) ((Columns, Types), String)
columnTypeQuerySQL = Relation (String, String) ((Columns, Types), String)
-> Query (String, String) ((Columns, Types), String)
forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) ((Columns, Types), String)
columnTypeRelation
primaryKeyRelation :: Relation (String,String) (Maybe String)
primaryKeyRelation :: Relation (String, String) (Maybe String)
primaryKeyRelation = SimpleQuery (String, String) (Maybe String)
-> Relation (String, String) (Maybe String)
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) (Maybe String)
-> Relation (String, String) (Maybe String))
-> SimpleQuery (String, String) (Maybe String)
-> Relation (String, String) (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
Record Flat Indexes
idxes <- Relation () Indexes
-> Orderings Flat QueryCore (Record Flat Indexes)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Indexes
indexes
Record Flat IndexColumns
idxcol <- Relation () IndexColumns
-> Orderings Flat QueryCore (Record Flat IndexColumns)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () IndexColumns
indexColumns
Record Flat Columns
cols <- 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
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 Indexes
idxes Record Flat Indexes -> Pi Indexes Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes Int32
Indexes.objectId' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat IndexColumns
idxcol Record Flat IndexColumns
-> Pi IndexColumns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.objectId'
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 Indexes
idxes Record Flat Indexes -> Pi Indexes Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes Int32
Indexes.indexId' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat IndexColumns
idxcol Record Flat IndexColumns
-> Pi IndexColumns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.indexId'
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 IndexColumns
idxcol Record Flat IndexColumns
-> Pi IndexColumns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.objectId' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Columns
cols Record Flat Columns -> Pi Columns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.objectId'
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 IndexColumns
idxcol Record Flat IndexColumns
-> Pi IndexColumns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.columnId' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Columns
cols Record Flat Columns -> Pi Columns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.columnId'
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 Indexes
idxes Record Flat Indexes -> Pi Indexes (Maybe Bool) -> Predicate Flat
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes (Maybe Bool)
Indexes.isPrimaryKey' Predicate Flat -> Predicate Flat -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Bool -> Predicate Flat
forall (p :: * -> *) a. ProjectableMaybe p => p a -> p (Maybe a)
just Record Flat Bool
sqlsrvTrue
let (params :: PlaceHolders (String, String)
params, oid :: Record Flat Int32
oid) = (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder
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 Indexes
idxes Record Flat Indexes -> Pi Indexes Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes Int32
Indexes.objectId' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
oid
Record Flat Int32 -> Orderings Flat QueryCore ()
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc (Record Flat Int32 -> Orderings Flat QueryCore ())
-> Record Flat Int32 -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat IndexColumns
idxcol Record Flat IndexColumns
-> Pi IndexColumns Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.keyOrdinal'
(PlaceHolders (String, String), Record Flat (Maybe String))
-> SimpleQuery (String, String) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
params, Record Flat Columns
cols Record Flat Columns
-> Pi Columns (Maybe String) -> Record Flat (Maybe String)
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns (Maybe String)
Columns.name')
primaryKeyQuerySQL :: Query (String,String) (Maybe String)
primaryKeyQuerySQL :: Query (String, String) (Maybe String)
primaryKeyQuerySQL = Relation (String, String) (Maybe String)
-> Query (String, String) (Maybe String)
forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) (Maybe String)
primaryKeyRelation