{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.HDBC.Schema.SQLServer (
driverSQLServer,
) where
import qualified Database.Relational.Schema.SQLServer.Columns as Columns
import qualified Database.Relational.Schema.SQLServer.Types as Types
import Control.Applicative ((<$>), (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
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, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)
import Database.Record (FromSql, ToSql)
import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn,
notNull, primaryKeyQuerySQL)
import Database.Relational.Schema.SQLServer.Columns (Columns)
import Database.Relational.Schema.SQLServer.Types (Types)
import Database.Relational.Schema.SQLServer (config)
import Language.Haskell.TH (TypeQ)
instance FromSql SqlValue Columns
instance ToSql SqlValue Columns
instance FromSql SqlValue Types
instance ToSql SqlValue Types
logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = ("SQLServer: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
putLog :: LogChan -> String -> IO ()
putLog :: LogChan -> String -> IO ()
putLog lchan :: LogChan
lchan = LogChan -> String -> IO ()
putVerbose LogChan
lchan (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
compileError :: LogChan -> String -> MaybeT IO a
compileError :: LogChan -> String -> MaybeT IO a
compileError lchan :: LogChan
lchan = LogChan -> String -> MaybeT IO a
forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan (String -> MaybeT IO a)
-> (String -> String) -> String -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
getPrimaryKey' :: IConnection conn
=> conn
-> LogChan
-> String
-> String
-> IO [String]
getPrimaryKey' :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn :: conn
conn lchan :: LogChan
lchan scm :: String
scm tbl :: String
tbl = do
[String]
prims <- [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> conn
-> Query (String, String) (Maybe String)
-> (String, String)
-> IO [Maybe String]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn Query (String, String) (Maybe String)
primaryKeyQuerySQL (String
scm,String
tbl)
let primColumns :: [String]
primColumns = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalizeColumn [String]
prims
LogChan -> String -> IO ()
putLog LogChan
lchan (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "getPrimaryKey: keys=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
primColumns
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primColumns
getColumns' :: IConnection conn
=> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getColumns' :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' tmap :: TypeMap
tmap conn :: conn
conn lchan :: LogChan
lchan scm :: String
scm tbl :: String
tbl = (TypeMap, [Int])
-> ((TypeMap, [Int]) -> (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int])
-> IO (TypeMap, [Int])
forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO ([], []) (TypeMap, [Int]) -> (TypeMap, [Int])
forall a. a -> a
id (MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int])
forall a b. (a -> b) -> a -> b
$ do
[((Columns, Types), String)]
rows <- IO [((Columns, Types), String)]
-> MaybeT IO [((Columns, Types), String)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [((Columns, Types), String)]
-> MaybeT IO [((Columns, Types), String)])
-> IO [((Columns, Types), String)]
-> MaybeT IO [((Columns, Types), String)]
forall a b. (a -> b) -> a -> b
$ conn
-> Query (String, String) ((Columns, Types), String)
-> (String, String)
-> IO [((Columns, Types), String)]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn Query (String, String) ((Columns, Types), String)
columnTypeQuerySQL (String
scm, String
tbl)
Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [((Columns, Types), String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((Columns, Types), String)]
rows) MaybeT IO () -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
LogChan -> String -> MaybeT IO ()
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
("getFields: No columns found: schema = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
scm String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", table = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tbl)
let columnId :: ((Columns, b), b) -> Int32
columnId ((cols :: Columns
cols,_),_) = Columns -> Int32
Columns.columnId Columns
cols Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- 1
let notNullIdxs :: [Int]
notNullIdxs = (((Columns, Types), String) -> Int)
-> [((Columns, Types), String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int)
-> (((Columns, Types), String) -> Int32)
-> ((Columns, Types), String)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Columns, Types), String) -> Int32
forall b b. ((Columns, b), b) -> Int32
columnId) ([((Columns, Types), String)] -> [Int])
-> ([((Columns, Types), String)] -> [((Columns, Types), String)])
-> [((Columns, Types), String)]
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Columns, Types), String) -> Bool)
-> [((Columns, Types), String)] -> [((Columns, Types), String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Columns, Types), String) -> Bool
notNull ([((Columns, Types), String)] -> [Int])
-> [((Columns, Types), String)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [((Columns, Types), String)]
rows
IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ())
-> (String -> IO ()) -> String -> MaybeT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogChan -> String -> IO ()
putLog LogChan
lchan
(String -> MaybeT IO ()) -> String -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ "getFields: num of columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([((Columns, Types), String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((Columns, Types), String)]
rows)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", not null columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
notNullIdxs
let getType' :: ((Columns, Types), String) -> MaybeT IO (String, TypeQ)
getType' rec' :: ((Columns, Types), String)
rec'@((_,typs :: Types
typs),typScms :: String
typScms) =
Maybe (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ
-> ((Columns, Types), String) -> Maybe (String, TypeQ)
getType (TypeMap -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) ((Columns, Types), String)
rec') MaybeT IO (String, TypeQ)
-> MaybeT IO (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
LogChan -> String -> MaybeT IO (String, TypeQ)
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
("Type mapping is not defined against SQLServer type: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typScms String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Types -> String
Types.name Types
typs)
TypeMap
types <- (((Columns, Types), String) -> MaybeT IO (String, TypeQ))
-> [((Columns, Types), String)] -> MaybeT IO TypeMap
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Columns, Types), String) -> MaybeT IO (String, TypeQ)
getType' [((Columns, Types), String)]
rows
(TypeMap, [Int]) -> MaybeT IO (TypeMap, [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)
driverSQLServer :: IConnection conn => Driver conn
driverSQLServer :: Driver conn
driverSQLServer =
Driver conn
forall conn. IConnection conn => Driver conn
emptyDriver { getFieldsWithMap :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFieldsWithMap = TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' }
{ getPrimaryKey :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey = conn -> LogChan -> String -> String -> IO [String]
forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' }
{ driverConfig :: Config
driverConfig = Config
config }