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

-- |
-- Module      : Database.HDBC.Schema.PostgreSQL
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides driver implementation
-- to load PostgreSQL system catalog via HDBC.
module Database.HDBC.Schema.PostgreSQL (
  driverPostgreSQL
  ) where

import Language.Haskell.TH (TypeQ)

import Data.Char (toLower)
import Data.Map (fromList)
import Control.Applicative ((<$>), (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)

import Database.HDBC (IConnection, SqlValue)

import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()

import Database.Record (FromSql, ToSql)

import Database.Relational.Schema.PostgreSQL
  (normalizeColumn, notNull, getType, columnQuerySQL,
   primaryKeyLengthQuerySQL, primaryKeyQuerySQL)
import Database.Relational.Schema.PostgreSQL.PgAttribute (PgAttribute)
import Database.Relational.Schema.PostgreSQL.PgType (PgType)
import qualified Database.Relational.Schema.PostgreSQL.PgType as Type
import Database.Relational.Schema.PostgreSQL (config)

import Database.HDBC.Schema.Driver
  (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
   Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)


instance FromSql SqlValue PgAttribute
instance ToSql SqlValue PgAttribute

instance FromSql SqlValue PgType
instance ToSql SqlValue PgType

logPrefix :: String -> String
logPrefix :: String -> String
logPrefix =  (String
"PostgreSQL: " 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
               -> String
               -> IO [String]
getPrimaryKey' :: forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn
conn LogChan
lchan String
scm' String
tbl' = do
  let scm :: String
scm = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
scm'
      tbl :: String
tbl = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
tbl'
  [Int32]
mayKeyLen <- 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) Int32
primaryKeyLengthQuerySQL (String
scm, String
tbl)
  case [Int32]
mayKeyLen of
    []        ->
      forall (m :: * -> *) a. Monad m => a -> m a
return []
    [Int32
keyLen]  -> do
      [String]
primCols <- forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (Int32 -> Query (String, String) String
primaryKeyQuerySQL Int32
keyLen) (String
scm, String
tbl)
      let primaryKeyCols :: [String]
primaryKeyCols = String -> String
normalizeColumn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
primCols
      LogChan -> String -> IO ()
putLog LogChan
lchan forall a b. (a -> b) -> a -> b
$ String
"getPrimaryKey: primary key = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
primaryKeyCols
      forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primaryKeyCols
    Int32
_:Int32
_:[Int32]
_     -> do
      LogChan -> String -> IO ()
putLog LogChan
lchan   String
"getPrimaryKey: Fail to detect primary key. Something wrong."
      forall (m :: * -> *) a. Monad m => a -> m a
return []

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
scm' 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 scm :: String
scm = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
scm'
      tbl :: String
tbl = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
tbl'
  [Column]
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) Column
columnQuerySQL (String
scm, 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 [Column]
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: schema = " forall a. [a] -> [a] -> [a]
++ String
scm 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 (Column -> 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
$ [Column]
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 [Column]
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' :: Column -> MaybeT IO (String, TypeQ)
getType' Column
col =
        forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> Column -> Maybe (String, TypeQ)
getType (forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) Column
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 PostgreSQL type: " forall a. [a] -> [a] -> [a]
++ PgType -> String
Type.typname (forall a b. (a, b) -> b
snd Column
col))

  TypeMap
types <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Column -> MaybeT IO (String, TypeQ)
getType' [Column]
cols
  forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)

-- | Driver implementation
driverPostgreSQL :: IConnection conn => Driver conn
driverPostgreSQL :: forall conn. IConnection conn => Driver conn
driverPostgreSQL =
  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 }