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