{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}

-- |
-- Module      : Database.HDBC.Schema.Oracle
-- Copyright   : 2013 Shohei Yasutake, 2017-2019 Kei Hibiono
-- License     : BSD3
--
-- Maintainer  : amutake.s@gmail.com
-- Stability   : experimental
-- Portability : unknown
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 = (String
"Oracle: " forall a. [a] -> [a] -> [a]
++)

putLog :: LogChan -> String -> IO ()
putLog :: LogChan -> String -> IO ()
putLog LogChan
lchan = LogChan -> String -> IO ()
putVerbose LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix

compileError :: LogChan -> String -> MaybeT IO a
compileError :: forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan = forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix

getPrimaryKey' :: IConnection conn
               => conn
               -> LogChan
               -> String -- ^ owner name
               -> String -- ^ table name
               -> IO [String] -- ^ primary key names
getPrimaryKey' :: forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn
conn LogChan
lchan String
owner' String
tbl' = do
    let owner :: String
owner = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
owner'
        tbl :: String
tbl = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
    [String]
prims <- forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalizeColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        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 forall a b. (a -> b) -> a -> b
$ String
"getPrimaryKey: keys = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
prims
    forall (m :: * -> *) a. Monad m => a -> m a
return [String]
prims

getColumns' :: IConnection conn
            => TypeMap
            -> conn
            -> LogChan
            -> String
            -> String
            -> IO ([(String, TypeQ)], [Int])
getColumns' :: forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' TypeMap
tmap conn
conn LogChan
lchan String
owner' String
tbl' = forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO ([], []) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ do
    let owner :: String
owner = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
owner'
        tbl :: String
tbl = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
    [DbaTabColumns]
cols <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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)
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DbaTabColumns]
cols) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
        (String
"getFields: No columns found: owner = " forall a. [a] -> [a] -> [a]
++ String
owner forall a. [a] -> [a] -> [a]
++ String
", table = " forall a. [a] -> [a] -> [a]
++ String
tbl)
    let notNullIdxs :: [Int]
notNullIdxs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (DbaTabColumns -> Bool
notNull forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ [DbaTabColumns]
cols
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogChan -> String -> IO ()
putLog LogChan
lchan forall a b. (a -> b) -> a -> b
$
        String
"getFields: num of columns = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DbaTabColumns]
cols) forall a. [a] -> [a] -> [a]
++
        String
", not null columns = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Int]
notNullIdxs
    let getType' :: DbaTabColumns -> MaybeT IO (String, TypeQ)
getType' DbaTabColumns
col =
          forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> DbaTabColumns -> Maybe (String, TypeQ)
getType (forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) DbaTabColumns
col) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan
          (String
"Type mapping is not defined against Oracle DB type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (DbaTabColumns -> Maybe String
Cols.dataType DbaTabColumns
col))
    TypeMap
types <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)

-- | Driver for Oracle DB
driverOracle :: IConnection conn => Driver conn
driverOracle :: forall conn. IConnection conn => Driver conn
driverOracle =
    forall conn. IConnection conn => Driver conn
emptyDriver { getFieldsWithMap :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFieldsWithMap = forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' }
                { getPrimaryKey :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey = forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' }
                { driverConfig :: Config
driverConfig  = Config
config }