Merge MySQL driver.

relational-query-HDBC/example/mysql/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2013, krdlab
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of krdlab nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

relational-query-HDBC/example/mysql/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

relational-query-HDBC/example/mysql/example.cabal

@@ -0,0 +1,38 @@
+name:                example
+version:             0.1.0.0
+synopsis:            mysql driver example
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              krdlab
+maintainer:          krdlab@gmail.com
+-- copyright:           
+-- category:            
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+executable example
+  hs-source-dirs:
+    src
+  main-is:
+    Main.hs
+  -- other-modules:       
+  other-extensions:
+      TemplateHaskell
+    , FlexibleInstances
+    , MultiParamTypeClasses
+    , MonadComprehensions
+  build-depends:
+      base >=4.6 && <5
+    , template-haskell >=2.8
+    , HDBC >=2.3
+    , HDBC-mysql >=0.6 && <0.7
+    , HDBC-session
+    , names-th
+    , relational-query
+    , relational-query-HDBC
+    , relational-mysql
+    , time
+  default-language:
+    Haskell2010

relational-query-HDBC/example/mysql/setup.sql

@@ -0,0 +1,25 @@
+CREATE DATABASE IF NOT EXISTS TEST DEFAULT CHARACTER SET UTF8;
+
+DROP TABLE IF EXISTS TEST.user;
+CREATE TABLE TEST.user (
+      id            BIGINT PRIMARY KEY
+    , name          VARCHAR(32) NOT NULL
+    , email         VARCHAR(255) NOT NULL UNIQUE
+    , passwd_hash   VARCHAR(512) NOT NULL
+    , completed     TINYINT(1) NOT NULL DEFAULT 0
+    , deleted       TINYINT(1) NOT NULL DEFAULT 0
+    , frozen        TINYINT(1) NOT NULL DEFAULT 0
+    , memo          TEXT NOT NULL
+    , created_at    DATE NOT NULL
+    , updated_at    DATE NOT NULL
+);
+
+INSERT INTO TEST.user
+    (id, name, email, passwd_hash, completed, deleted, frozen, memo, created_at, updated_at)
+    VALUES
+    (1, 'krdlab', 'krdlab@gmail.com', 'dummy hashed password 1', 1, 0, 0, '', '2014-02-01', '2014-02-01'),
+    (2, 'foo',    'foo@example.com',  'dummy hashed password 2', 0, 0, 0, '', '2014-02-10', '2014-02-10'),
+    (3, 'bar',    'bar@example.com',  'dummy hashed password 3', 1, 0, 1, 'limit exceeded', '2014-02-11', '2014-02-20')
+    ;
+
+GRANT ALL PRIVILEGES ON TEST.user TO 'hrr-tester'@'127.0.0.1';

relational-query-HDBC/example/mysql/src/Example/DataSource.hs

@@ -0,0 +1,33 @@
+module Example.DataSource
+    (
+      config
+    , connect
+    , defineTable
+    )
+    where
+
+import Language.Haskell.TH                  (Q, Dec, TypeQ)
+import Language.Haskell.TH.Name.CamelCase   (ConName)
+
+import Database.HDBC.Query.TH               (defineTableFromDB)
+import Database.HDBC.Schema.Driver          (typeMap)
+import Database.HDBC.Schema.MySQL           (driverMySQL)
+import Database.HDBC.MySQL                  ( Connection
+                                            , connectMySQL
+                                            , MySQLConnectInfo(..)
+                                            , defaultMySQLConnectInfo
+                                            )
+
+config :: MySQLConnectInfo
+config = defaultMySQLConnectInfo {
+              mysqlUser     = "hrr-tester"
+            , mysqlPassword = ""
+            , mysqlDatabase = "TEST"
+            , mysqlHost     = "127.0.0.1"
+            }
+
+connect :: IO Connection
+connect = connectMySQL config
+
+defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
+defineTable tmap = defineTableFromDB connect (driverMySQL { typeMap = tmap })

relational-query-HDBC/example/mysql/src/Example/User.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Example.User where
+
+import Prelude hiding (id)
+import Example.DataSource (defineTable)
+
+$(defineTable
+    []
+    "TEST" "user" [])

relational-query-HDBC/example/mysql/src/Main.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE MonadComprehensions #-}
+module Main where
+
+import Database.Relational.Query    ( query
+                                    , relation
+                                    , aggregateRelation
+                                    , wheres
+                                    , (.=.)
+                                    , (.>=.)
+                                    , (!)
+                                    , (><)
+                                    , value
+                                    , count
+                                    , min'
+                                    , groupBy
+                                    , desc
+                                    , id'
+                                    , relationalQuery
+                                    , Relation
+                                    )
+import Database.HDBC.Session        (withConnectionIO, handleSqlError')
+import Database.HDBC.Record.Query   (runQuery')
+import Database.HDBC                (runRaw, quickQuery', fromSql)
+
+import Data.Time                    (Day, fromGregorian)
+import Data.List                    (isInfixOf)
+import Data.Int                     (Int32, Int64)
+
+import Example.DataSource           (connect)
+import Example.User                 (user)
+import qualified Example.User as U
+
+main :: IO ()
+main = handleSqlError' $ withConnectionIO connect $ \conn -> do
+    setSqlMode conn
+    printResults conn sample1
+    printResults conn sample2
+    printResults conn sample3
+    printResults conn sample4
+    where
+        printResults c q = runQuery' c (relationalQuery q) () >>= print
+
+        completed = relation
+            [ u
+            | u  <- query user
+            , () <- wheres $ u ! U.completed' .=. value 1
+            ]
+
+        sample1 :: Relation () (String, Day)
+        sample1 = relation
+            [ u ! U.name' >< u ! U.createdAt'
+            | u  <- query completed
+            ]
+
+        sample2 :: Relation () (String, Day)
+        sample2 = relation
+            [ u ! U.email' >< u ! U.createdAt'
+            | u  <- query completed
+            , () <- wheres $ u ! U.createdAt' .>=. value (day 2014 2 10)
+            ]
+
+        day = fromGregorian
+
+        sample3 :: Relation () (Int32, Int64)
+        sample3 = aggregateRelation
+            [ c >< count (u ! U.id')
+            | u  <- query user
+            , c  <- groupBy $ u ! U.completed'
+            , () <- desc $ c ! id'
+            ]
+
+        sample4 :: Relation () (Maybe Day)
+        sample4 = aggregateRelation
+            [ min' (u ! U.createdAt')
+            | u  <- query user
+            ]
+
+        setSqlMode conn = do
+            mode <- quickQuery' conn "SELECT @@SESSION.sql_mode" []
+            newmode <- case mode of
+                [[sqlval]] ->
+                    let val = fromSql sqlval in
+                        if "IGNORE_SPACE" `isInfixOf` val
+                            then return val
+                            else return $ val ++ ",IGNORE_SPACE"
+                _          ->
+                    error "failed to get 'sql_mode'"
+            runRaw conn $ "SET SESSION sql_mode = '" ++ newmode ++ "'"
+

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

@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Database.HDBC.Schema.MySQL
+    (
+      driverMySQL
+    )
+    where
+
+import           Prelude                            hiding (length)
+import           Language.Haskell.TH                (TypeQ)
+import qualified Language.Haskell.TH.Lib.Extra      as TH
+import qualified Data.List                          as List
+import           Data.Map                           (fromList)
+
+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.MySQL   ( normalizeColumn
+                                                    , notNull
+                                                    , getType
+                                                    , columnsQuerySQL
+                                                    , primaryKeyQuerySQL
+                                                    )
+
+import           Database.Relational.Schema.MySQLInfo.Columns (Columns)
+import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns
+
+$(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns)
+
+logPrefix :: String -> String
+logPrefix = ("MySQL: " ++)
+
+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
+    primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)
+    let primaryKeyCols = normalizeColumn `fmap` primCols
+    putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
+    return primaryKeyCols
+
+getFields' :: IConnection conn
+           => TypeMap
+           -> conn
+           -> String
+           -> String
+           -> IO ([(String, TypeQ)], [Int])
+getFields' tmap conn scm tbl = do
+    cols <- runQuery' conn columnsQuerySQL (scm, tbl)
+    case cols of
+        [] -> compileErrorIO
+                $ "getFields: No columns found: schema = " ++ scm
+                ++ ", table = " ++ tbl
+        _  -> return ()
+    let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols
+    putLog
+      $  "getFields: num of columns = " ++ show (List.length cols)
+      ++ ", not null columns = " ++ show notNullIdxs
+    types <- mapM getType' cols
+    return (types, notNullIdxs)
+    where
+        getType' col =
+            case getType (fromList tmap) col of
+                Nothing -> compileErrorIO
+                             $ "Type mapping is not defined against MySQL type: "
+                             ++ Columns.dataType col
+                Just p  -> return p
+
+-- | Driver implementation
+driverMySQL :: IConnection conn => Driver conn
+driverMySQL =
+    emptyDriver { getFieldsWithMap = getFields' }
+                { getPrimaryKey    = getPrimaryKey' }

relational-query-HDBC/test/mysql/DB/Source.hs

@@ -0,0 +1,28 @@
+module DB.Source (connect, defineTable) where
+
+import Database.HDBC.MySQL                  ( MySQLConnectInfo(..), defaultMySQLConnectInfo
+                                            , Connection, connectMySQL
+                                            )
+import Database.HDBC.Query.TH               (defineTableFromDB)
+import Database.HDBC.Schema.Driver          (typeMap)
+import Database.HDBC.Schema.MySQL           (driverMySQL)
+import Language.Haskell.TH                  (TypeQ, Q, Dec)
+import Language.Haskell.TH.Name.CamelCase   (ConName)
+
+-- {-# ANN module "HLint: ignore Eta reduce" #-}
+
+config :: MySQLConnectInfo
+config = defaultMySQLConnectInfo
+    { mysqlUser     = "hrr-tester"
+    , mysqlPassword = ""
+    , mysqlDatabase = "TEST"
+    , mysqlHost     = "127.0.0.1"
+    }
+
+connect :: IO Connection
+connect = connectMySQL config
+
+defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
+defineTable tmap =
+    defineTableFromDB connect (driverMySQL { typeMap = tmap })
+

relational-query-HDBC/test/mysql/Spec.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+import Test.Hspec
+
+import Language.Haskell.TH          (runQ)
+import Data.Int                     (Int32)
+import Data.Time                    (LocalTime)
+import Database.HDBC.Session        (withConnectionIO)
+import Database.HDBC.Record.Query   (runQuery')
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query    ( query
+                                    , relation
+                                    , wheres
+                                    , (.=.)
+                                    , (!)
+                                    , value
+                                    , relationalQuery
+                                    )
+import Database.HDBC.Schema.Driver  (getPrimaryKey, getFieldsWithMap)
+import Database.HDBC.Schema.MySQL   (driverMySQL)
+
+import Prelude hiding (id)
+import qualified DB.Source as DB
+
+-- TODO: get and define
+$(DB.defineTable
+    []
+    "TEST" "user" [derivingShow])
+
+main :: IO ()
+main = hspec $ do
+    describe "getPrimaryKey" $ do
+        it "returns one primary key" $ do
+            keys <- withConnectionIO DB.connect $ \c -> getPrimaryKey driverMySQL c "TEST" "test_pk1"
+            keys `shouldBe` ["a"]
+        it "returns two primary keys" $ do
+            keys <- withConnectionIO DB.connect $ \c -> getPrimaryKey driverMySQL c "TEST" "test_pk2"
+            keys `shouldBe` ["a", "b"]
+
+    describe "getFieldsWithMap" $ do
+        it "returns 'NOT NULL' column positions" $ do
+            ( _, ps) <- withConnectionIO DB.connect $ \c -> getFieldsWithMap driverMySQL [] c "TEST" "test_nn1"
+            ps `shouldBe` [0, 2, 4]
+        it "returns column types" $ do
+            (tm,  _) <- withConnectionIO DB.connect $ \c -> getFieldsWithMap driverMySQL [] c "TEST" "test_nn1"
+            types  <- mapM (runQ . snd) tm
+            expect <- mapM runQ [[t|Int32|], [t|Maybe Int32|], [t|String|], [t|Maybe String|], [t|LocalTime|]]
+            types  `shouldBe` expect
+
+    describe "basic tests" $
+        it "returns data types" $ do
+            decs <- runQ $ DB.defineTable [] "TEST" "user" []
+            decs `shouldSatisfy` not . null
+
+    describe "run query" $
+        it "returns some records" $ do
+            let test1 = relation $ do
+                    u  <- query user
+                    wheres $ u ! id' .=. value 1
+                    return (u ! name')
+            rs <- runDB test1
+            rs `shouldSatisfy` not . null
+
+  where
+    runDB q =
+        withConnectionIO DB.connect $ \conn ->
+            runQuery' conn (relationalQuery q) ()
+

relational-query-HDBC/test/mysql/setup.sql

@@ -0,0 +1,33 @@
+CREATE DATABASE IF NOT EXISTS TEST DEFAULT CHARACTER SET UTF8;
+
+DROP TABLE IF EXISTS TEST.test_pk1;
+CREATE TABLE TEST.test_pk1 (a INT, b VARCHAR(32) NOT NULL, PRIMARY KEY (a));
+DROP TABLE IF EXISTS TEST.test_pk2;
+CREATE TABLE TEST.test_pk2 (a INT, b INT, c VARCHAR(32) NOT NULL, PRIMARY KEY (a, b));
+
+DROP TABLE IF EXISTS TEST.test_nn1;
+CREATE TABLE TEST.test_nn1 (a INT, b INT, c VARCHAR(32) NOT NULL, d TEXT, e DATETIME NOT NULL, PRIMARY KEY (a));
+
+DROP TABLE IF EXISTS TEST.user;
+CREATE TABLE TEST.user (
+      id            BIGINT PRIMARY KEY
+    , name          VARCHAR(32) NOT NULL
+    , email         VARCHAR(255) NOT NULL UNIQUE
+    , passwd_hash   VARCHAR(512) NOT NULL
+    , completed     TINYINT(1) NOT NULL DEFAULT 0
+    , deleted       TINYINT(1) NOT NULL DEFAULT 0
+    , frozen        TINYINT(1) NOT NULL DEFAULT 0
+    , memo          TEXT NOT NULL
+    , created_at    DATE NOT NULL
+    , updated_at    DATE NOT NULL
+);
+
+INSERT INTO TEST.user
+    (id, name, email, passwd_hash, completed, deleted, frozen, memo, created_at, updated_at)
+    VALUES
+    (1, 'krdlab', 'krdlab@gmail.com', 'dummy hashed password 1', 1, 0, 0, '', '2014-02-01', '2014-02-01'),
+    (2, 'foo',    'foo@example.com',  'dummy hashed password 2', 0, 0, 0, '', '2014-02-10', '2014-02-10'),
+    (3, 'bar',    'bar@example.com',  'dummy hashed password 3', 1, 0, 1, 'limit exceeded', '2014-02-11', '2014-02-20')
+    ;
+
+GRANT ALL PRIVILEGES ON TEST.* TO 'hrr-tester'@'127.0.0.1';

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

@@ -0,0 +1,111 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Database.Relational.Schema.MySQL
+    ( normalizeColumn
+    , notNull
+    , getType
+    , columnsQuerySQL
+    , primaryKeyQuerySQL
+    )
+    where
+
+import           Data.Int               (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        ( Query
+                                        , query
+                                        , relation'
+                                        , wheres
+                                        , (.=.)
+                                        , (!)
+                                        , (><)
+                                        , placeholder
+                                        , asc
+                                        , value
+                                        )
+import Database.Relational.Query.Type   (relationalQuery)
+
+import           Database.Relational.Schema.MySQLInfo.Columns           (Columns, columns)
+import qualified Database.Relational.Schema.MySQLInfo.Columns           as Columns
+import           Database.Relational.Schema.MySQLInfo.TableConstraints  (tableConstraints)
+import qualified Database.Relational.Schema.MySQLInfo.TableConstraints  as Tabconst
+import           Database.Relational.Schema.MySQLInfo.KeyColumnUsage    (keyColumnUsage)
+import qualified Database.Relational.Schema.MySQLInfo.KeyColumnUsage    as Keycoluse
+
+mapFromSqlDefault :: Map String TypeQ
+mapFromSqlDefault = 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| Int32 |])
+    , ("SMALLINT",   [t| Int32 |])
+    , ("INT",        [t| Int32 |])
+    , ("INTEGER",    [t| Int32 |])
+    , ("BIGINT",     [t| Int64 |])
+    ]
+
+normalizeColumn :: String -> String
+normalizeColumn = map toLower
+
+notNull :: Columns -> Bool
+notNull = (== "NO") . Columns.isNullable
+
+getType :: Map String TypeQ
+        -> Columns
+        -> Maybe (String, TypeQ)
+getType mapFromSql rec = do
+    typ <- Map.lookup key mapFromSql
+           <|>
+           Map.lookup key mapFromSqlDefault
+    return (normalizeColumn $ Columns.columnName rec, mayNull typ)
+    where
+        key = map toUpper $ Columns.dataType rec
+        mayNull typ = if notNull rec
+                      then typ
+                      else [t|Maybe $(typ)|]
+
+columnsQuerySQL :: Query (String, String) Columns
+columnsQuerySQL = relationalQuery columnsRelationFromTable
+    where
+        columnsRelationFromTable = relation' $ do
+            c <- query columns
+            (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tableSchema' .=. ph)
+            (nameP  , ()) <- placeholder (\ph -> wheres $ c ! Columns.tableName'   .=. ph)
+            asc $ c ! Columns.ordinalPosition'
+            return (schemaP >< nameP, c)
+
+primaryKeyQuerySQL :: Query (String, String) String
+primaryKeyQuerySQL = relationalQuery primaryKeyRelation
+    where
+        primaryKeyRelation = relation' $ do
+            cons <- query tableConstraints
+            key  <- query keyColumnUsage
+
+            wheres $ cons ! Tabconst.tableSchema'    .=. key ! Keycoluse.tableSchema'
+            wheres $ cons ! Tabconst.tableName'      .=. key ! Keycoluse.tableName'
+            wheres $ cons ! Tabconst.constraintName' .=. key ! Keycoluse.constraintName'
+
+            (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableSchema' .=. ph)
+            (nameP  , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableName'   .=. ph)
+            wheres $ cons ! Tabconst.constraintType' .=. value "PRIMARY KEY"
+
+            asc $ key ! Keycoluse.ordinalPosition'
+
+            return (schemaP >< nameP, key ! Keycoluse.columnName')

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

@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Database.Relational.Schema.MySQLInfo.Columns where
+
+import Data.Int                     (Int16)
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+    "INFORMATION_SCHEMA" "columns"
+    [ ("table_schema",      [t|String|])
+    , ("table_name",        [t|String|])
+    , ("column_name",       [t|String|])
+    , ("ordinal_position",  [t|Int16|])
+    , ("column_default",    [t|Maybe String|])
+    , ("is_nullable",       [t|String|])
+    , ("data_type",         [t|String|])
+    ]
+    [derivingShow])

relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Database.Relational.Schema.MySQLInfo.KeyColumnUsage where
+
+import Data.Int                     (Int16)
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+    "INFORMATION_SCHEMA" "key_column_usage"
+    [ ("constraint_name"    , [t| String |])
+    , ("table_schema"       , [t| String |])
+    , ("table_name"         , [t| String |])
+    , ("column_name"        , [t| String |])
+    , ("ordinal_position"   , [t| Int16 |])
+    ]
+    [derivingShow])

relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Database.Relational.Schema.MySQLInfo.TableConstraints where
+
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+    "INFORMATION_SCHEMA" "table_constraints"
+    [ ("table_schema"       , [t| String |])
+    , ("table_name"         , [t| String |])
+    , ("constraint_name"    , [t| String |])
+    , ("constraint_type"    , [t| String |])
+    ]
+    [derivingShow])