{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
module Database.HDBC.Schema.Oracle
( driverOracle
) where
import Control.Applicative ((<$>), (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import Data.Char (toUpper)
import Data.Map (fromList)
import Data.Maybe (catMaybes)
import Language.Haskell.TH (TypeQ)
import Database.HDBC (IConnection, SqlValue)
import Database.Record (FromSql, ToSql)
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.Relational.Schema.Oracle
( normalizeColumn, notNull, getType
, columnsQuerySQL, primaryKeyQuerySQL
)
import Database.Relational.Schema.Oracle.TabColumns (DbaTabColumns)
import qualified Database.Relational.Schema.Oracle.TabColumns as Cols
import Database.Relational.Schema.Oracle (config)
instance FromSql SqlValue DbaTabColumns
instance ToSql SqlValue DbaTabColumns
logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = ("Oracle: " 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 owner' :: String
owner' tbl' :: String
tbl' = do
let owner :: String
owner = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
owner'
tbl :: String
tbl = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
[String]
prims <- (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalizeColumn ([String] -> [String])
-> ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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
owner, String
tbl)
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]
prims
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
prims
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 owner' :: String
owner' 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
let owner :: String
owner = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
owner'
tbl :: String
tbl = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
[DbaTabColumns]
cols <- IO [DbaTabColumns] -> MaybeT IO [DbaTabColumns]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [DbaTabColumns] -> MaybeT IO [DbaTabColumns])
-> IO [DbaTabColumns] -> MaybeT IO [DbaTabColumns]
forall a b. (a -> b) -> a -> b
$ conn
-> Query (String, String) DbaTabColumns
-> (String, String)
-> IO [DbaTabColumns]
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) DbaTabColumns
columnsQuerySQL (String
owner, 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
$ [DbaTabColumns] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DbaTabColumns]
cols) 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: owner = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
owner String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", table = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tbl)
let notNullIdxs :: [Int]
notNullIdxs = ((Int, DbaTabColumns) -> Int) -> [(Int, DbaTabColumns)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, DbaTabColumns) -> Int
forall a b. (a, b) -> a
fst ([(Int, DbaTabColumns)] -> [Int])
-> ([DbaTabColumns] -> [(Int, DbaTabColumns)])
-> [DbaTabColumns]
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, DbaTabColumns) -> Bool)
-> [(Int, DbaTabColumns)] -> [(Int, DbaTabColumns)]
forall a. (a -> Bool) -> [a] -> [a]
filter (DbaTabColumns -> Bool
notNull (DbaTabColumns -> Bool)
-> ((Int, DbaTabColumns) -> DbaTabColumns)
-> (Int, DbaTabColumns)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, DbaTabColumns) -> DbaTabColumns
forall a b. (a, b) -> b
snd) ([(Int, DbaTabColumns)] -> [(Int, DbaTabColumns)])
-> ([DbaTabColumns] -> [(Int, DbaTabColumns)])
-> [DbaTabColumns]
-> [(Int, DbaTabColumns)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [DbaTabColumns] -> [(Int, DbaTabColumns)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([DbaTabColumns] -> [Int]) -> [DbaTabColumns] -> [Int]
forall a b. (a -> b) -> a -> b
$ [DbaTabColumns]
cols
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 ([DbaTabColumns] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DbaTabColumns]
cols) 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' :: DbaTabColumns -> MaybeT IO (String, TypeQ)
getType' col :: DbaTabColumns
col =
Maybe (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> DbaTabColumns -> Maybe (String, TypeQ)
getType (TypeMap -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) DbaTabColumns
col) 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 Oracle DB type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show (DbaTabColumns -> Maybe String
Cols.dataType DbaTabColumns
col))
TypeMap
types <- (DbaTabColumns -> MaybeT IO (String, TypeQ))
-> [DbaTabColumns] -> MaybeT IO TypeMap
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DbaTabColumns -> MaybeT IO (String, TypeQ)
getType' [DbaTabColumns]
cols
(TypeMap, [Int]) -> MaybeT IO (TypeMap, [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)
driverOracle :: IConnection conn => Driver conn
driverOracle :: Driver conn
driverOracle =
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 }