{-# LINE 1 "Database/HDBC/PostgreSQL/Connection.hsc" #-}
-- -*- mode: haskell; -*-
-- Above line for hugs
{-# LANGUAGE FlexibleContexts #-}

module Database.HDBC.PostgreSQL.Connection
        (connectPostgreSQL, withPostgreSQL,
         connectPostgreSQL', withPostgreSQL',
         Impl.begin, Impl.Connection())
 where

import Database.HDBC
import Database.HDBC.DriverUtils
import qualified Database.HDBC.PostgreSQL.ConnectionImpl as Impl
import Database.HDBC.PostgreSQL.Types
import Database.HDBC.PostgreSQL.Statement
import Database.HDBC.PostgreSQL.PTypeConv
import Foreign.C.Types
import Foreign.C.String
import Database.HDBC.PostgreSQL.Utils
import Foreign.ForeignPtr
import Foreign.Ptr
import Data.Word
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BUTF8
import Control.Monad (when)
import Control.Concurrent.MVar
import System.IO (stderr, hPutStrLn)
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception(bracket)
import Data.Convertible (Convertible)





-- | A global lock only used when libpq is /not/ thread-safe.  In that situation
-- this mvar is used to serialize access to the FFI calls marked as /safe/.
globalConnLock :: MVar ()
{-# NOINLINE globalConnLock #-}
globalConnLock :: MVar ()
globalConnLock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()

{- | Connect to a PostgreSQL server.

See <http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT> for the meaning
of the connection string. -}
connectPostgreSQL :: String -> IO Impl.Connection
connectPostgreSQL :: String -> IO Connection
connectPostgreSQL = Bool -> String -> IO Connection
connectPostgreSQL_helper Bool
True

connectPostgreSQL' :: String -> IO Impl.Connection
connectPostgreSQL' :: String -> IO Connection
connectPostgreSQL' = Bool -> String -> IO Connection
connectPostgreSQL_helper Bool
False

connectPostgreSQL_helper :: Bool -> String -> IO Impl.Connection
connectPostgreSQL_helper :: Bool -> String -> IO Connection
connectPostgreSQL_helper Bool
auto_transaction String
args =
  ByteString -> (CString -> IO Connection) -> IO Connection
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString (String -> ByteString
BUTF8.fromString String
args) ((CString -> IO Connection) -> IO Connection)
-> (CString -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$
  \CString
cs -> do ptr <- CString -> IO (Ptr CConn)
pqconnectdb CString
cs
            threadSafe <- pqisThreadSafe ptr
            connLock <- if threadSafe==0 -- Also check GHC.Conc.numCapabilities here?
                          then do hPutStrLn stderr "WARNING: libpq is not threadsafe, \
                                          \serializing all libpq FFI calls.  \
                                          \(Consider recompiling libpq with \
                                          \--enable-thread-safety.\n"
                                  return globalConnLock
                          else newMVar ()
            status <- pqstatus ptr
            fptr <- newForeignPtr pqfinish ptr
            case status of
                     Word32
0 -> Bool -> String -> Conn -> IO Connection
mkConn Bool
auto_transaction String
args (MVar ()
connLock,ForeignPtr CConn
fptr)
{-# LINE 69 "Database/HDBC/PostgreSQL/Connection.hsc" #-}
                     Word32
_ -> String -> Word32 -> Ptr CConn -> IO Connection
forall a. String -> Word32 -> Ptr CConn -> IO a
raiseError String
"connectPostgreSQL" Word32
status Ptr CConn
ptr

-- FIXME: environment vars may have changed, should use pgsql enquiries
-- for clone.
mkConn :: Bool -> String -> Conn -> IO Impl.Connection
mkConn :: Bool -> String -> Conn -> IO Connection
mkConn Bool
auto_transaction String
args Conn
conn = Conn -> (Ptr CConn -> IO Connection) -> IO Connection
forall b. Conn -> (Ptr CConn -> IO b) -> IO b
withConn Conn
conn ((Ptr CConn -> IO Connection) -> IO Connection)
-> (Ptr CConn -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$
  \Ptr CConn
cconn ->
    do children <- [Weak Statement] -> IO (MVar [Weak Statement])
forall a. a -> IO (MVar a)
newMVar []
       when auto_transaction $ begin_transaction conn children
       protover <- pqprotocolVersion cconn
       serverver <- pqserverVersion cconn
       let clientver = String
"18.3 (Ubuntu 18.3-1)"
{-# LINE 81 "Database/HDBC/PostgreSQL/Connection.hsc" #-}
       let rconn = Impl.Connection {
                            Impl.disconnect = fdisconnect conn children,
                            Impl.begin = if auto_transaction
                                         then return ()
                                         else begin_transaction conn children,
                            Impl.commit = fcommit auto_transaction conn children,
                            Impl.rollback = frollback auto_transaction conn children,
                            Impl.runRaw = frunRaw conn children,
                            Impl.run = frun conn children,
                            Impl.prepare = newSth conn children,
                            Impl.clone = connectPostgreSQL args,
                            Impl.hdbcDriverName = "postgresql",
                            Impl.hdbcClientVer = clientver,
                            Impl.proxiedClientName = "postgresql",
                            Impl.proxiedClientVer = show protover,
                            Impl.dbServerVer = show serverver,
                            Impl.dbTransactionSupport = True,
                            Impl.getTables = fgetTables conn children,
                            Impl.describeTable = fdescribeTable conn children}
       _ <- quickQuery rconn "SET client_encoding TO utf8;" []
       return rconn

-- | Connect to a PostgreSQL server,  and automatically disconnect
-- if the handler exits normally or throws an exception.
withPostgreSQL :: String -> (Impl.Connection -> IO a) -> IO a
withPostgreSQL :: forall a. String -> (Connection -> IO a) -> IO a
withPostgreSQL String
connstr = IO Connection
-> (Connection -> IO ()) -> (Connection -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Connection
connectPostgreSQL String
connstr) (Connection -> IO ()
forall conn. IConnection conn => conn -> IO ()
disconnect)

withPostgreSQL' :: String -> (Impl.Connection -> IO a) -> IO a
withPostgreSQL' :: forall a. String -> (Connection -> IO a) -> IO a
withPostgreSQL' String
connstr = IO Connection
-> (Connection -> IO ()) -> (Connection -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Connection
connectPostgreSQL' String
connstr) (Connection -> IO ()
forall conn. IConnection conn => conn -> IO ()
disconnect)

--------------------------------------------------
-- Guts here
--------------------------------------------------

begin_transaction :: Conn -> ChildList -> IO ()
begin_transaction :: Conn -> MVar [Weak Statement] -> IO ()
begin_transaction Conn
o MVar [Weak Statement]
children = Conn -> MVar [Weak Statement] -> String -> [SqlValue] -> IO Integer
frun Conn
o MVar [Weak Statement]
children String
"BEGIN" [] IO Integer -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

frunRaw :: Conn -> ChildList -> String -> IO ()
frunRaw :: Conn -> MVar [Weak Statement] -> String -> IO ()
frunRaw Conn
o MVar [Weak Statement]
children String
query =
    do sth <- Conn -> MVar [Weak Statement] -> String -> IO Statement
newSth Conn
o MVar [Weak Statement]
children String
query
       executeRaw sth
       finish sth
       return ()

frun :: Conn -> ChildList -> String -> [SqlValue] -> IO Integer
frun :: Conn -> MVar [Weak Statement] -> String -> [SqlValue] -> IO Integer
frun Conn
o MVar [Weak Statement]
children String
query [SqlValue]
args =
    do sth <- Conn -> MVar [Weak Statement] -> String -> IO Statement
newSth Conn
o MVar [Weak Statement]
children String
query
       res <- execute sth args
       finish sth
       return res

fcommit :: Bool -> Conn -> ChildList -> IO ()
fcommit :: Bool -> Conn -> MVar [Weak Statement] -> IO ()
fcommit Bool
begin Conn
o MVar [Weak Statement]
cl = do _ <- Conn -> MVar [Weak Statement] -> String -> [SqlValue] -> IO Integer
frun Conn
o MVar [Weak Statement]
cl String
"COMMIT" []
                        when begin $ begin_transaction o cl

frollback :: Bool -> Conn -> ChildList -> IO ()
frollback :: Bool -> Conn -> MVar [Weak Statement] -> IO ()
frollback Bool
begin Conn
o MVar [Weak Statement]
cl =  do _ <- Conn -> MVar [Weak Statement] -> String -> [SqlValue] -> IO Integer
frun Conn
o MVar [Weak Statement]
cl String
"ROLLBACK" []
                           when begin $ begin_transaction o cl

fgetTables :: (Convertible SqlValue a) => Conn -> ChildList -> IO [a]
fgetTables :: forall a.
Convertible SqlValue a =>
Conn -> MVar [Weak Statement] -> IO [a]
fgetTables Conn
conn MVar [Weak Statement]
children =
    do sth <- Conn -> MVar [Weak Statement] -> String -> IO Statement
newSth Conn
conn MVar [Weak Statement]
children
              String
"select table_name from information_schema.tables where \
               \table_schema != 'pg_catalog' AND table_schema != \
               \'information_schema'"
       _ <- execute sth []
       res1 <- fetchAllRows' sth
       let res = (SqlValue -> a) -> [SqlValue] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map SqlValue -> a
forall a. Convertible SqlValue a => SqlValue -> a
fromSql ([SqlValue] -> [a]) -> [SqlValue] -> [a]
forall a b. (a -> b) -> a -> b
$ [[SqlValue]] -> [SqlValue]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SqlValue]]
res1
       return $ seq (length res) res

fdescribeTable :: Conn -> ChildList -> String -> IO [(String, SqlColDesc)]
fdescribeTable :: Conn
-> MVar [Weak Statement] -> String -> IO [(String, SqlColDesc)]
fdescribeTable Conn
o MVar [Weak Statement]
cl String
table = Conn
-> MVar [Weak Statement]
-> Maybe String
-> String
-> IO [(String, SqlColDesc)]
fdescribeSchemaTable Conn
o MVar [Weak Statement]
cl Maybe String
forall a. Maybe a
Nothing String
table

fdescribeSchemaTable :: Conn -> ChildList -> Maybe String -> String -> IO [(String, SqlColDesc)]
fdescribeSchemaTable :: Conn
-> MVar [Weak Statement]
-> Maybe String
-> String
-> IO [(String, SqlColDesc)]
fdescribeSchemaTable Conn
o MVar [Weak Statement]
cl Maybe String
maybeSchema String
table =
    do sth <- Conn -> MVar [Weak Statement] -> String -> IO Statement
newSth Conn
o MVar [Weak Statement]
cl
              (String
"SELECT attname, atttypid, attlen, format_type(atttypid, atttypmod), attnotnull " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               String
"FROM pg_attribute, pg_class, pg_namespace ns " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               String
"WHERE relname = ? and attnum > 0 and attisdropped IS FALSE " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               (if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
maybeSchema then String
"and ns.nspname = ? " else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
               String
"and attrelid = pg_class.oid and relnamespace = ns.oid order by attnum")
       let params = String -> SqlValue
forall a. Convertible a SqlValue => a -> SqlValue
toSql String
table SqlValue -> [SqlValue] -> [SqlValue]
forall a. a -> [a] -> [a]
: (if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
maybeSchema then [String -> SqlValue
forall a. Convertible a SqlValue => a -> SqlValue
toSql (String -> SqlValue) -> String -> SqlValue
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
maybeSchema] else [])
       _ <- execute sth params
       res <- fetchAllRows' sth
       return $ map desccol res
    where
      desccol :: [SqlValue] -> (a, SqlColDesc)
desccol [SqlValue
attname, SqlValue
atttypid, SqlValue
attlen, SqlValue
formattedtype, SqlValue
attnotnull] =
          (SqlValue -> a
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
attname,
           Word32 -> Int -> String -> Bool -> SqlColDesc
colDescForPGAttr (SqlValue -> Word32
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
atttypid) (SqlValue -> Int
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
attlen) (SqlValue -> String
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
formattedtype) (SqlValue -> Bool
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
attnotnull Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False))
      desccol [SqlValue]
x =
          String -> (a, SqlColDesc)
forall a. HasCallStack => String -> a
error (String -> (a, SqlColDesc)) -> String -> (a, SqlColDesc)
forall a b. (a -> b) -> a -> b
$ String
"Got unexpected result from pg_attribute: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SqlValue] -> String
forall a. Show a => a -> String
show [SqlValue]
x

fdisconnect :: Conn -> ChildList -> IO ()
fdisconnect :: Conn -> MVar [Weak Statement] -> IO ()
fdisconnect (MVar ()
lock, ForeignPtr CConn
fptr) MVar [Weak Statement]
childList = do
  MVar [Weak Statement] -> IO ()
closeAllChildren MVar [Weak Statement]
childList
  MVar () -> (() -> IO ()) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ ->
    ForeignPtr CConn -> IO ()
forall a. ForeignPtr a -> IO ()
finalizeForeignPtr ForeignPtr CConn
fptr

foreign import ccall safe "libpq-fe.h PQconnectdb"
  pqconnectdb :: CString -> IO (Ptr CConn)

foreign import ccall safe "libpq-fe.h PQstatus"
  pqstatus :: Ptr CConn -> IO Word32
{-# LINE 184 "Database/HDBC/PostgreSQL/Connection.hsc" #-}

foreign import ccall safe "libpq-fe.h &PQfinish"
  pqfinish :: FunPtr (Ptr CConn -> IO ())

foreign import ccall safe "libpq-fe.h PQprotocolVersion"
  pqprotocolVersion :: Ptr CConn -> IO CInt

foreign import ccall safe "libpq-fe.h PQserverVersion"
  pqserverVersion :: Ptr CConn -> IO CInt

foreign import ccall safe "libpq.fe.h PQisthreadsafe"
  pqisThreadSafe :: Ptr CConn -> IO Int