{-# 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 = ("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 -- ^ owner name
               -> String -- ^ table name
               -> IO [String] -- ^ primary key names
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)

-- | Driver for Oracle DB
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 }