Merge MS SQLServer driver.

relational-query-HDBC/src/Database/HDBC/Schema/SQLServer.hs

@@ -0,0 +1,88 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.HDBC.Schema.SQLServer
+-- Copyright   : 2013 Shohei Murayama
+-- License     : BSD3
+--
+-- Maintainer  : shohei.murayama@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+module Database.HDBC.Schema.SQLServer (
+  driverSQLServer,
+  ) where
+
+import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns
+import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types
+import qualified Language.Haskell.TH.Lib.Extra as TH
+
+import Data.Map (fromList)
+import Data.Maybe (catMaybes)
+import Database.HDBC (IConnection, SqlValue)
+import Database.HDBC.Record.Query (runQuery')
+import Database.HDBC.Record.Persistable ()
+import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)
+import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)
+import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn,
+                                            notNull, primaryKeyQuerySQL)
+import Database.Relational.Schema.SQLServerSyscat.Columns (Columns)
+import Database.Relational.Schema.SQLServerSyscat.Types (Types)
+import Language.Haskell.TH (TypeQ)
+
+$(makeRecordPersistableWithSqlTypeDefaultFromDefined
+  [t| SqlValue |] ''Columns)
+
+$(makeRecordPersistableWithSqlTypeDefaultFromDefined
+  [t| SqlValue |] ''Types)
+
+logPrefix :: String -> String
+logPrefix = ("SQLServer: " ++)
+
+putLog :: String -> IO ()
+putLog = putStrLn . logPrefix
+
+compileErrorIO :: String -> IO a
+compileErrorIO = TH.compileErrorIO . logPrefix
+
+getPrimaryKey' :: IConnection conn
+               => conn
+               -> String
+               -> String
+               -> IO [String]
+getPrimaryKey' conn scm tbl = do
+    prims <- catMaybes `fmap` runQuery' conn primaryKeyQuerySQL (scm,tbl)
+    let primColumns = map normalizeColumn prims
+    putLog $ "getPrimaryKey: keys=" ++ show primColumns
+    return primColumns
+
+getFields' :: IConnection conn
+           => TypeMap
+           -> conn
+           -> String
+           -> String
+           -> IO ([(String, TypeQ)], [Int])
+getFields' tmap conn scm tbl = do
+    rows <- runQuery' conn columnTypeQuerySQL (scm, tbl)
+    case rows of
+      [] -> compileErrorIO
+            $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl
+      _  -> return ()
+    let columnId ((cols,_),_) = Columns.columnId cols - 1
+    let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows
+    putLog
+        $ "getFields: num of columns = " ++ show (length rows)
+        ++ ", not null columns = " ++ show notNullIdxs
+    let getType' rec@((_,typs),typScms) = case getType (fromList tmap) rec of
+          Nothing -> compileErrorIO
+                     $ "Type mapping is not defined against SQLServer type: "
+                     ++ typScms ++ "." ++ Types.name typs
+          Just p  -> return p
+    types <- mapM getType' rows
+    return (types, notNullIdxs)
+
+driverSQLServer :: IConnection conn => Driver conn
+driverSQLServer =
+    emptyDriver { getFieldsWithMap = getFields' }
+                { getPrimaryKey    = getPrimaryKey' }

relational-query-HDBC/test/SQLServer/SQLServerTest.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module SQLServerTest where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Distribution.TestSuite (Test)
+import SQLServerTestDataSource (defineTable)
+
+tests :: IO [Test]
+tests = return []
+
+$(defineTable
+  [("varchar", [t| ByteString |]),
+   ("text", [t| Text |])
+  ]
+  "TEST" "test_table0" [])

relational-query-HDBC/test/SQLServer/SQLServerTestDataSource.hs

@@ -0,0 +1,23 @@
+module SQLServerTestDataSource (
+    connect,
+    defineTable
+    ) where
+
+import Database.HDBC.ODBC (Connection, connectODBC)
+import Database.HDBC.Query.TH (defineTableFromDB)
+import Database.HDBC.Schema.Driver (typeMap)
+import Database.HDBC.Schema.SQLServer (driverSQLServer)
+import Language.Haskell.TH (Q, Dec, TypeQ)
+import Language.Haskell.TH.Name.CamelCase (ConName)
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
+
+connect :: IO Connection
+connect = connectODBC "DSN=testdb;UID=test;PWD=test"
+
+defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
+defineTable tmap scm tbl derives =
+    defineTableFromDB
+      connect
+      (driverSQLServer { typeMap = tmap })
+      scm tbl derives

relational-query-HDBC/test/SQLServer/TypeCheck.hs

@@ -0,0 +1,16 @@
+module Main where
+
+import Database.HDBC
+import Database.HDBC.ODBC
+import System.Environment
+import System.IO
+
+main :: IO ()
+main = do
+    args <- getArgs
+    if length args > 1 then do
+        conn <- connectODBC $ args !! 0
+        rows <- quickQuery conn $ args !! 1
+        mapM_ putStrLn $ map show rows
+     else
+        hPutStrLn stderr "query <DB file path> <SQL>"

relational-query-HDBC/test/SQLServer/runCreate.sh

@@ -0,0 +1,190 @@
+#! /bin/sh
+
+PATH='/usr/local/bin:/usr/bin:/bin'
+
+usage() {
+    echo "Usage: ./runCreate.sh [-D] -S <server> -U <user> -P <pass>"
+    echo "  -S <server>  Server or DSN if -D is provided"
+    echo "               examples:"
+    echo "                 -S 127.0.0.1"
+    echo "                 -S 127.0.0.1¥instanceA"
+    echo "                 -S 127.0.0.1,1433"
+    echo "                 -D -S testdb"
+    echo "  -U <user>    Login ID"
+    echo "  -P <pass>    Password"
+    exit 1
+}
+
+DSN=0
+SERVER=
+PORT=1433
+USER=
+PASS=
+
+eval set -- "`getopt DS:P:U:P: $*`"
+for opt; do
+    case $opt in
+        -D )
+            DSN=1;;
+        -S )
+            SERVER=$2;;
+        -U )
+            USER=$2;;
+        -P )
+            PASS=$2;;
+    esac
+    shift
+done
+
+if [ -z "$SERVER" -o -z "$USER" -o -z "$PASS" ]; then
+    usage
+fi
+
+STDOUT=
+ERROR_STDERR=
+GO=
+QUIT=
+
+if [ "$DSN" -eq 0 ]; then
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        usage
+    fi
+else
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -D -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        SQLCMD="isql -n $SERVER $USER $PASS"
+        STDOUT="/dev/null" # "/dev/fd/1"
+        GO=";"
+        QUIT="\quit"
+    fi
+fi
+
+#set -x
+
+create0="
+CREATE TABLE [TEST].[test_table0] (
+  [foo]      [smallint] NOT NULL ,
+  [foo_bar]  [integer]  NOT NULL ,
+  [par_ent]  [integer]  NOT NULL ,
+  [bar]      [date] ,
+  [bar_baz]  [text] ,
+  [baz]      [VARCHAR] (10) ,
+  CONSTRAINT [pk_test_table0] PRIMARY KEY([foo_bar])
+)
+"
+
+create1="
+CREATE TABLE [TEST].[test_table1] (
+  [foo]      [integer]  NOT NULL ,
+  CONSTRAINT [pk_test_table1] PRIMARY KEY ([foo])
+)
+"
+
+create2="
+CREATE TABLE [TEST].[test_table2] (
+  [x] [ntext] ,
+  [y] [nvarchar] (16) NOT NULL ,
+  [z] [nchar]    (16) NOT NULL
+)
+"
+
+create3="
+CREATE TABLE [TEST].[test_table3] (
+  [name] [nvarchar] (50) NOT NULL,
+  [birth] [date] NOT NULL,
+  [sex]  [integer] NOT NULL,
+  [height] [integer] NOT NULL,
+
+  CONSTRAINT [pk_test_table3] PRIMARY KEY ([name], [sex], [birth])
+)
+"
+
+$SQLCMD > $STDOUT <<EOS
+$ERROR_STDERR
+USE [testdb]
+$GO
+
+IF not exists (select * from sys.schemas where name = N'TEST')
+BEGIN
+    EXEC ('CREATE SCHEMA [TEST]')
+END
+$GO
+
+$QUIT
+EOS
+
+$SQLCMD > $STDOUT <<EOS
+$ERROR_STDERR
+USE [testdb]
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table0]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table0]
+END
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table1]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table1]
+END
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table2]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table2]
+END
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table3]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table3]
+END
+$GO
+
+$create0
+$GO
+
+$create1
+$GO
+
+$create2
+$GO
+
+$create3
+$GO
+
+$QUIT
+EOS
+
+$SQLCMD > $STDOUT <<EOS
+$ERROR_STDERR
+USE [testdb]
+$GO
+
+INSERT INTO [TEST].[test_table1] ([foo]) VALUES (1)
+INSERT INTO [TEST].[test_table1] ([foo]) VALUES (2)
+$GO
+
+INSERT INTO [TEST].[test_table2] ([x], [y], [z]) VALUES (N'実験', N'実験', N'実験')
+INSERT INTO [TEST].[test_table2] ([x], [y], [z]) VALUES (N'鷗鄧', N'鷗鄧', N'鷗鄧')
+INSERT INTO [TEST].[test_table2] ([x], [y], [z]) VALUES (N'𦿶丈', N'𦿶丈', N'𦿶丈')
+$GO
+
+INSERT INTO [TEST].[test_table3] ([name], [sex], [birth], [height]) VALUES ('Ichiro Yamada', 1, '1955-03-01', 178)
+INSERT INTO [TEST].[test_table3] ([name], [sex], [birth], [height]) VALUES ('Hanako Sato', 2, '1973-04-01', 165)
+$GO
+
+$QUIT
+EOS

relational-query-HDBC/test/SQLServer/runCreateDB.sh

@@ -0,0 +1,114 @@
+#! /bin/sh
+
+PATH='/usr/local/bin:/usr/bin:/bin'
+
+usage() {
+	echo "Usage: ./runCreateDB.sh [-D] -S <server> -U <user> -P <pass>"
+	echo "  -S <server>  Server or DSN if -D is provided"
+	echo "               examples:"
+	echo "                 -S 127.0.0.1"
+	echo "                 -S 127.0.0.1¥instanceA"
+	echo "                 -S 127.0.0.1,1433"
+	echo "                 -D -S testdb"
+	echo "  -U <user>    Login ID"
+	echo "  -P <pass>    Password"
+	exit 1
+}
+
+DSN=0
+SERVER=
+PORT=1433
+USER=
+PASS=
+
+eval set -- "`getopt DS:P:U:P: $*`"
+for opt; do
+    case $opt in
+    	-D )
+            DSN=1;;
+    	-S )
+            SERVER=$2;;
+        -U )
+            USER=$2;;
+        -P )
+            PASS=$2;;
+    esac
+    shift
+done
+
+if [ -z "$SERVER" -o -z "$USER" -o -z "$PASS" ]; then
+    usage
+fi
+
+STDOUT=
+ERROR_STDERR=
+GO=
+QUIT=
+
+if [ "$DSN" -eq 0 ]; then
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        usage
+    fi
+else
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -D -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        SQLCMD="isql -n $SERVER $USER $PASS"
+        STDOUT="/dev/null" # "/dev/fd/1"
+        GO=";"
+        QUIT="\quit"
+    fi
+fi
+
+#set -x
+
+$SQLCMD > $STDOUT <<EOS
+$ERROR_STDERR
+-- Create a database
+IF DB_ID(N'testdb') IS NULL
+BEGIN
+    CREATE DATABASE [testdb]
+END
+$GO
+
+-- Create a login with name 'test' and password 'test'
+USE [master]
+$GO
+
+IF not exists (select * from sys.server_principals where name = N'test')
+BEGIN
+    CREATE LOGIN [test] WITH PASSWORD=N'test', DEFAULT_DATABASE=[testdb], CHECK_EXPIRATION=OFF, CHECK_POLICY=OFF
+END
+$GO
+
+-- Create a user with name 'test' and map it to a login
+USE [testdb]
+$GO
+
+IF not exists (select * from sys.database_principals where name = N'test')
+BEGIN
+    CREATE USER [test] FOR LOGIN [test]
+END
+$GO
+
+EXEC sp_addrolemember N'db_datareader', N'test'
+EXEC sp_addrolemember N'db_datawriter', N'test'
+EXEC sp_addrolemember N'db_ddladmin', N'test'
+$GO
+
+-- Grant permission to user "test"
+GRANT EXECUTE TO [test]
+$GO
+
+$QUIT
+EOS

relational-query-HDBC/test/SQLServer/runDrop.sh

@@ -0,0 +1,119 @@
+#! /bin/sh
+
+PATH='/usr/local/bin:/usr/bin:/bin'
+
+usage() {
+    echo "Usage: ./runDrop.sh [-D] -S <server> -U <user> -P <pass>"
+    echo "  -S <server>  Server or DSN if -D is provided"
+    echo "               examples:"
+    echo "                 -S 127.0.0.1"
+    echo "                 -S 127.0.0.1¥instanceA"
+    echo "                 -S 127.0.0.1,1433"
+    echo "                 -D -S testdb"
+    echo "  -U <user>    Login ID"
+    echo "  -P <pass>    Password"
+    exit 1
+}
+
+DSN=0
+SERVER=
+PORT=1433
+USER=
+PASS=
+
+eval set -- "`getopt DS:P:U:P: $*`"
+for opt; do
+    case $opt in
+        -D )
+            DSN=1;;
+        -S )
+            SERVER=$2;;
+        -U )
+            USER=$2;;
+        -P )
+            PASS=$2;;
+    esac
+    shift
+done
+
+if [ -z "$SERVER" -o -z "$USER" -o -z "$PASS" ]; then
+    usage
+fi
+
+#set -x
+
+STDOUT=
+ERROR_STDERR=
+GO=
+QUIT=
+
+if [ "$DSN" -eq 0 ]; then
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        usage
+    fi
+else
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -D -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        SQLCMD="isql -n $SERVER $USER $PASS"
+        STDOUT="/dev/null" # "/dev/fd/1"
+        GO=";"
+        QUIT="\quit"
+    fi
+fi
+
+$SQLCMD > $STDOUT <<EOS
+$ERROR_STDERR
+USE [testdb]
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table3]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table3]
+END
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table2]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table2]
+END
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table1]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table1]
+END
+$GO
+
+IF exists (select * from dbo.sysobjects where id = object_id(N'[TEST].[test_table0]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
+BEGIN
+    drop table [TEST].[test_table0]
+END
+$GO
+
+$QUIT
+EOS
+
+$SQLCMD > $STDOUT <<EOS
+$ERROR_STDERR
+USE [testdb]
+$GO
+
+IF exists (select * from sys.schemas where name = N'TEST')
+BEGIN
+    EXEC ('DROP SCHEMA [TEST]')
+END
+$GO
+
+$QUIT
+EOS

relational-query-HDBC/test/SQLServer/runDropDB.sh

@@ -0,0 +1,93 @@
+#! /bin/sh
+
+PATH='/usr/local/bin:/usr/bin:/bin'
+
+usage() {
+    echo "Usage: ./runDropDB.sh [-D] -S <server> -U <user> -P <pass>"
+    echo "  -S <server>  Server or DSN if -D is provided"
+    echo "               examples:"
+    echo "                 -S 127.0.0.1"
+    echo "                 -S 127.0.0.1¥instanceA"
+    echo "                 -S 127.0.0.1,1433"
+    echo "                 -D -S testdb"
+    echo "  -U <user>    Login ID"
+    echo "  -P <pass>    Password"
+    exit 1
+}
+
+DSN=0
+SERVER=
+PORT=1433
+USER=
+PASS=
+
+eval set -- "`getopt DS:P:U:P: $*`"
+for opt; do
+    case $opt in
+        -D )
+            DSN=1;;
+        -S )
+            SERVER=$2;;
+        -U )
+            USER=$2;;
+        -P )
+            PASS=$2;;
+    esac
+    shift
+done
+
+if [ -z "$SERVER" -o -z "$USER" -o -z "$PASS" ]; then
+    usage
+fi
+
+#set -x
+
+STDOUT=
+ERROR_STDERR=
+GO=
+QUIT=
+
+if [ "$DSN" -eq 0 ]; then
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        usage
+    fi
+else
+    which sqlcmd > /dev/null 2>&1
+    if [ "$?" -eq 0 ]; then
+        SQLCMD="sqlcmd -D -S $SERVER -U $USER -P $PASS"
+        STDOUT="/dev/null"
+        ERROR_STDERR=":error STDERR"
+        GO="GO"
+    else
+        SQLCMD="isql -n $SERVER $USER $PASS"
+        STDOUT="/dev/null" # "/dev/fd/1"
+        GO=";"
+        QUIT="\quit"
+    fi
+fi
+
+$SQLCMD > $STDOUT <<EOS
+$ERROR_STDERR
+USE [master]
+$GO
+
+IF DB_ID(N'testdb') IS NOT NULL
+BEGIN
+    DROP DATABASE [testdb]
+END
+$GO
+
+IF exists (select * from sys.server_principals where name = N'test')
+BEGIN
+    DROP LOGIN test
+END
+$GO
+
+$QUIT
+EOS

relational-schemas/src/Database/Relational/Schema/SQLServer.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Database.Relational.Schema.SQLServer (
+  getType, normalizeColumn, notNull,
+  columnTypeQuerySQL, primaryKeyQuerySQL
+  ) where
+
+import qualified Data.Map as Map
+import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns
+import qualified Database.Relational.Schema.SQLServerSyscat.Indexes as Indexes
+import qualified Database.Relational.Schema.SQLServerSyscat.IndexColumns as IndexColumns
+import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types
+
+import Control.Applicative ((<|>))
+import Data.ByteString (ByteString)
+import Data.Char (toLower)
+import Data.Int (Int32, Int64)
+import Data.Map (Map)
+import Data.Time (LocalTime, Day, TimeOfDay)
+import Database.Record.Instances ()
+import Database.Relational.Query (Query, Relation, PlaceHolders, Projection, Flat,
+                                  (!), (.=.), (><), asc, relationalQuery, just, placeholder',
+                                  query, relation', unsafeShowSql, unsafeShowSqlProjection,
+                                  unsafeProjectSql, wheres)
+import Database.Relational.Schema.SQLServerSyscat.Columns
+import Database.Relational.Schema.SQLServerSyscat.Indexes
+import Database.Relational.Schema.SQLServerSyscat.IndexColumns
+import Database.Relational.Schema.SQLServerSyscat.Types
+import Language.Haskell.TH (TypeQ)
+
+--{-# ANN module "HLint: ignore Redundant $" #-}
+
+mapFromSqlDefault :: Map String TypeQ
+mapFromSqlDefault =
+    Map.fromList [ ("image",         [t|ByteString|])
+                 , ("text",          [t|ByteString|])
+                 , ("date",          [t|Day|])
+                 , ("time",          [t|TimeOfDay|])
+                 , ("tinyint",       [t|Int32|])
+                 , ("smallint",      [t|Int32|])
+                 , ("int",           [t|Int32|])
+                 , ("smalldatetime", [t|LocalTime|])
+                 , ("real",          [t|Double|])
+                 , ("datetime",      [t|LocalTime|])
+                 , ("float",         [t|Double|])
+                 , ("ntext",         [t|String|])
+                 , ("bit",           [t|Char|])
+                 , ("bigint",        [t|Int64|])
+                 , ("varbinary",     [t|String|])
+                 , ("varchar",       [t|String|])
+                 , ("binary",        [t|ByteString|])
+                 , ("char",          [t|String|])
+                 , ("timestamp",     [t|LocalTime|])
+                 , ("nvarchar",      [t|String|])
+                 , ("nchar",         [t|String|])
+                 ]
+
+normalizeColumn :: String -> String
+normalizeColumn = map toLower
+
+notNull :: ((Columns,Types),String) -> Bool
+notNull ((cols,_),_) = isTrue . Columns.isNullable $ cols
+  where
+    isTrue (Just b) = not b
+    isTrue _        = True
+
+getType :: Map String TypeQ -> ((Columns,Types),String) -> Maybe (String, TypeQ)
+getType mapFromSql rec@((cols,typs),typScms) = do
+    colName <- Columns.name cols
+    typ <- Map.lookup key mapFromSql
+           <|>
+           Map.lookup key mapFromSqlDefault
+    return (normalizeColumn colName, mayNull typ)
+  where
+    key = if typScms == "sys"
+            then Types.name typs
+            else typScms ++ "." ++ Types.name typs
+    mayNull typ = if notNull rec
+                    then typ
+                    else [t|Maybe $(typ)|]
+
+sqlsrvTrue :: Projection Flat Bool
+sqlsrvTrue =  unsafeProjectSql "1"
+
+sqlsrvObjectId :: Projection Flat String -> Projection Flat String -> Projection Flat Int32
+sqlsrvObjectId s t = unsafeProjectSql $
+    "OBJECT_ID(" ++ unsafeShowSql s ++ " + '.' + " ++ unsafeShowSql t ++ ")"
+
+sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Projection Flat Int32)
+sqlsrvOidPlaceHolder =  (nsParam >< relParam, oid)
+  where
+    (nsParam, (relParam, oid)) =
+      placeholder' (\nsPh ->
+                     placeholder' (\relPh ->
+                                    sqlsrvObjectId nsPh relPh))
+
+columnTypeRelation :: Relation (String,String) ((Columns,Types),String)
+columnTypeRelation = relation' $ do
+    cols <- query columns
+    typs <- query types
+
+    wheres $ cols ! Columns.userTypeId' .=. typs ! Types.userTypeId'
+    wheres $ cols ! Columns.objectId'   .=. oid
+    asc $ cols ! Columns.columnId'
+    return   (params, cols >< typs >< sqlsrvSchemaName (typs ! Types.schemaId'))
+  where
+    (params, oid) = sqlsrvOidPlaceHolder
+    sqlsrvSchemaName i = unsafeProjectSql $
+        "SCHEMA_NAME(" ++ unsafeShowSqlProjection i ++ ")"
+
+columnTypeQuerySQL :: Query (String, String) ((Columns, Types), String)
+columnTypeQuerySQL =  relationalQuery columnTypeRelation
+
+primaryKeyRelation :: Relation (String,String) (Maybe String)
+primaryKeyRelation = relation' $ do
+    idxes  <- query indexes
+    idxcol <- query indexColumns
+    cols   <- query columns
+    wheres $ idxes  ! Indexes.objectId'      .=. idxcol ! IndexColumns.objectId'
+    wheres $ idxes  ! Indexes.indexId'       .=. idxcol ! IndexColumns.indexId'
+    wheres $ idxcol ! IndexColumns.objectId' .=. cols   ! Columns.objectId'
+    wheres $ idxcol ! IndexColumns.columnId' .=. cols   ! Columns.columnId'
+    wheres $ idxes  ! Indexes.isPrimaryKey'  .=. just sqlsrvTrue
+    let (params, oid) = sqlsrvOidPlaceHolder
+    wheres $ idxes  ! Indexes.objectId'      .=. oid
+    asc    $ idxcol ! IndexColumns.keyOrdinal'
+    return   (params, cols   ! Columns.name')
+
+primaryKeyQuerySQL :: Query (String,String) (Maybe String)
+primaryKeyQuerySQL =  relationalQuery primaryKeyRelation

relational-schemas/src/Database/Relational/Schema/SQLServerSyscat/Columns.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Database.Relational.Schema.SQLServerSyscat.Columns where
+
+import Data.Int (Int32)
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+  "sys" "columns"
+  [
+  -- column                schema  type                length   NULL
+  -- --------------------- ------- ------------------- -------- ------
+  -- object_id             sys     int                        4 No
+    ("object_id", [t|Int32|]),
+  -- name                  sys     sysname(nvarchar)        128 Yes
+    ("name", [t|Maybe String|]),
+  -- column_id             sys     int                        4 No
+    ("column_id", [t|Int32|]),
+  -- system_type_id        sys     tinyint                    1 No
+    --("system_type_id", [t|Int32|]),
+  -- user_type_id          sys     int                        4 No
+    ("user_type_id", [t|Int32|]),
+  -- max_length            sys     smallint                   2 No
+    --("max_length", [t|Int32|]),
+  -- precision             sys     tinyint                    1 No
+    --("precision", [t|Int32|]),
+  -- scale                 sys     tinyint                    1 No
+    --("scale", [t|Int32|]),
+  -- collation_name        sys     sysname(nvarchar)        128 Yes
+    --("collation_name", [t|Maybe String|]),
+  -- is_nullable           sys     bit                        1 Yes
+    ("is_nullable", [t|Maybe Bool|])--,
+  -- is_ansi_padded        sys     bit                        1 No
+    --("is_ansi_padded", [t|Bool|]),
+  -- is_rowguidcol         sys     bit                        1 No
+    --("is_rowguidcol", [t|Bool|]),
+  -- is_identity           sys     bit                        1 No
+    --("is_identity", [t|Bool|]),
+  -- is_computed           sys     bit                        1 No
+    --("is_computed", [t|Bool|]),
+  -- is_filestream         sys     bit                        1 No
+    --("is_filestream", [t|Bool|]),
+  -- is_replicated         sys     bit                        1 Yes
+    --("is_replicated", [t|Maybe Bool|]),
+  -- is_non_sql_subscribed sys     bit                        1 Yes
+    --("is_non_sql_subscribed", [t|Maybe Bool|]),
+  -- is_merge_published    sys     bit                        1 Yes
+    --("is_merge_published", [t|Maybe Bool|]),
+  -- is_dts_repllicated    sys     bit                        1 Yes
+    --("is_dts_replicated", [t|Maybe Bool|]),
+  -- is_xml_document       sys     bit                        1 No
+    --("is_xml_document", [t|Bool|]),
+  -- xml_collection_id     sys     int                        4 No
+    --("xml_collection_id", [t|Int32|]),
+  -- default_object_id     sys     int                        4 No
+    --("default_object_id", [t|Int32|]),
+  -- rule_object_id        sys     int                        4 No
+    --("rule_object_id", [t|Int32|]),
+  -- is_sparse             sys     bit                        1 Yes
+    --("is_sparse", [t|Maybe Bool|]),
+  -- is_column_set         sys     bit                        1 Yes
+    --("is_column_set", [t|Maybe Bool|])
+  ]
+  [derivingShow])

relational-schemas/src/Database/Relational/Schema/SQLServerSyscat/IndexColumns.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Database.Relational.Schema.SQLServerSyscat.IndexColumns where
+
+import Data.Int (Int32)
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+  "sys" "index_columns"
+  [
+  -- column                schema  type                length   NULL
+  -- --------------------- ------- ------------------- -------- ------
+  -- object_id             sys     int                        4 No
+    ("object_id", [t|Int32|]),
+  -- index_id              sys     int                        4 No
+    ("index_id", [t|Int32|]),
+  -- index_column_id       sys     int                        4 No
+    ("column_id", [t|Int32|]),
+  -- key_ordinal           sys     tinyint                    1 No
+    ("key_ordinal", [t|Int32|]),
+  -- partition_ordinal     sys     tinyint                    1 No
+    --("partition_ordinal", [t|Int32|]),
+  -- is_descending_key     sys     bit                        1 No
+    --("is_descending_key", [t|Bool|]),
+  -- is_included_column    sys     bit                        1 No
+    ("is_included_column", [t|Bool|])
+  ]
+  [derivingShow])

relational-schemas/src/Database/Relational/Schema/SQLServerSyscat/Indexes.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Database.Relational.Schema.SQLServerSyscat.Indexes where
+
+--import Data.ByteString (ByteString)
+import Data.Int (Int32)
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+  "sys" "indexes"
+  [
+-- View "sys.indexes"
+-- column                schema  type                length   NULL
+-- --------------------- ------- ------------------- -------- ------
+-- object_id             sys     int                        4 No
+    ("object_id", [t|Int32|]),
+-- name                  sys     sysname(nvarchar)        128 Yes
+    --("name", [t|Maybe String|]),
+-- index_id              sys     int                        4 No
+    ("index_id", [t|Int32|]),
+-- type                  sys     tinyint                    1 No
+    --("type", [t|Char|]),
+-- type_desc             sys     nvarchar                  60 Yes
+    --("type_desc", [t|Maybe String|]),
+-- is_unique             sys     bit                        1 Yes
+    --("is_unique", [t|Maybe Bool|]),
+-- data_space_id         sys     int                        4 No
+    --("data_space_id", [t|Int32|]),
+-- ignore_dup_key        sys     bit                        1 Yes
+    --("ignore_dup_key", [t|Maybe Bool|]),
+-- is_primary_key        sys     bit                        1 Yes
+    ("is_primary_key", [t|Maybe Bool|])--,
+-- is_unique_constraint  sys     bit                        1 Yes
+    --("is_unique_constraint", [t|Maybe Bool|]),
+-- fill_factor           sys     tinyint                    1 No
+    --("fill_factor", [t|Int32|]),
+-- is_padded             sys     bit                        1 Yes
+    --("is_padded", [t|Maybe Bool|]),
+-- is_disabled           sys     bit                        1 Yes
+    --("is_disabled", [t|Maybe Bool|]),
+-- is_hypothetical       sys     bit                        1 Yes
+    --("is_hypothetical", [t|Maybe Bool|]),
+-- allow_row_locks       sys     bit                        1 Yes
+    --("allow_row_locks", [t|Maybe Bool|]),
+-- allow_page_locks      sys     bit                        1 Yes
+    --("allow_page_locks", [t|Maybe Bool|]),
+-- has_filter            sys     bit                        1 Yes
+    --("has_filter", [t|Maybe Bool|]),
+-- filter_definition     sys     nvarchar                 max Yes
+    --("filter_definition", [t|Maybe ByteString|])
+  ]
+  [derivingShow])

relational-schemas/src/Database/Relational/Schema/SQLServerSyscat/Types.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Database.Relational.Schema.SQLServerSyscat.Types where
+
+import Data.Int (Int32)
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+  "sys" "types"
+  [
+-- View "sys.types"
+-- column                schema  type                length   NULL
+-- --------------------- ------- ------------------- -------- ------
+-- name                  sys     sysname(nvarchar)        128 No
+    ("name", [t|String|]),
+-- system_type_id        sys     tinyint                    1 No
+    --("system_type_id", [t|Int32|]),
+-- user_type_id          sys     int                        4 No
+    ("user_type_id", [t|Int32|]),
+-- schema_id             sys     int                        4 No
+    ("schema_id", [t|Int32|])--,
+-- principal_id          sys     int                        4 Yes
+    --("principal_id", [t|Maybe Int32|]),
+-- max_length            sys     int                        4 No
+    --("max_length", [t|Int32|]),
+-- precision             sys     tinyint                    1 No
+    --("precision", [t|Int32|]),
+-- scale                 sys     tinyint                    1 No
+    --("scale", [t|Int32|]),
+-- collation_name        sys     sysname(nvarchar)        128 Yes
+    --("collation_name", [t|Maybe String|]),
+-- is_nullable           sys     bit                        1 Yes
+    --("is_nullable", [t|Maybe Bool|]),
+-- is_user_defined       sys     bit                        1 No
+    --("is_user_defined", [t|Bool|]),
+-- is_assembly_type      sys     bit                        1 No
+    --("is_assembly_type", [t|Bool|]),
+-- default_object_id     sys     int                        4 No
+    --("default_object_id", [t|Int32|]),
+-- rule_object_id        sys     int                        4 No
+    --("rule_object_id", [t|Int32|]),
+-- is_table_type         sys     bit                        1 No
+    --("is_table_type", [t|Bool|])
+  ]
+  [derivingShow])