{-# 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 CConn
ptr <- CString -> IO (Ptr CConn)
pqconnectdb CString
cs
            Int
threadSafe <- Ptr CConn -> IO Int
pqisThreadSafe Ptr CConn
ptr
            MVar ()
connLock <- if Int
threadSafeInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 -- Also check GHC.Conc.numCapabilities here?
                          then do Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"WARNING: libpq is not threadsafe, \
                                          \serializing all libpq FFI calls.  \
                                          \(Consider recompiling libpq with \
                                          \--enable-thread-safety.\n"
                                  MVar () -> IO (MVar ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MVar ()
globalConnLock
                          else () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
            Word32
status <- Ptr CConn -> IO Word32
pqstatus Ptr CConn
ptr
            ForeignPtr CConn
fptr <- FinalizerPtr CConn -> Ptr CConn -> IO (ForeignPtr CConn)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr CConn
pqfinish Ptr CConn
ptr
            case Word32
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 MVar [Weak Statement]
children <- [Weak Statement] -> IO (MVar [Weak Statement])
forall a. a -> IO (MVar a)
newMVar []
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
auto_transaction (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Conn -> MVar [Weak Statement] -> IO ()
begin_transaction Conn
conn MVar [Weak Statement]
children
       CInt
protover <- Ptr CConn -> IO CInt
pqprotocolVersion Ptr CConn
cconn
       CInt
serverver <- Ptr CConn -> IO CInt
pqserverVersion Ptr CConn
cconn
       let clientver :: String
clientver = String
"15.4 (Debian 15.4-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}
       [[SqlValue]]
_ <- Connection -> String -> [SqlValue] -> IO [[SqlValue]]
forall conn.
IConnection conn =>
conn -> String -> [SqlValue] -> IO [[SqlValue]]
quickQuery Connection
rconn String
"SET client_encoding TO utf8;" []
       Connection -> IO Connection
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
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 Statement
sth <- Conn -> MVar [Weak Statement] -> String -> IO Statement
newSth Conn
o MVar [Weak Statement]
children String
query
       Statement -> IO ()
executeRaw Statement
sth
       Statement -> IO ()
finish Statement
sth
       () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 Statement
sth <- Conn -> MVar [Weak Statement] -> String -> IO Statement
newSth Conn
o MVar [Weak Statement]
children String
query
       Integer
res <- Statement -> [SqlValue] -> IO Integer
execute Statement
sth [SqlValue]
args
       Statement -> IO ()
finish Statement
sth
       Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
res

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

frollback :: Bool -> Conn -> ChildList -> IO ()
frollback :: Bool -> Conn -> MVar [Weak Statement] -> IO ()
frollback Bool
begin Conn
o MVar [Weak Statement]
cl =  do Integer
_ <- Conn -> MVar [Weak Statement] -> String -> [SqlValue] -> IO Integer
frun Conn
o MVar [Weak Statement]
cl String
"ROLLBACK" []
                           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
begin (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Conn -> MVar [Weak Statement] -> IO ()
begin_transaction Conn
o MVar [Weak Statement]
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 Statement
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'"
       Integer
_ <- Statement -> [SqlValue] -> IO Integer
execute Statement
sth []
       [[SqlValue]]
res1 <- Statement -> IO [[SqlValue]]
fetchAllRows' Statement
sth
       let res :: [a]
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
       [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> IO [a]) -> [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a b. a -> b -> b
seq ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
res) [a]
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 Statement
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 :: [SqlValue]
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 [])
       Integer
_ <- Statement -> [SqlValue] -> IO Integer
execute Statement
sth [SqlValue]
params
       [[SqlValue]]
res <- Statement -> IO [[SqlValue]]
fetchAllRows' Statement
sth
       [(String, SqlColDesc)] -> IO [(String, SqlColDesc)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, SqlColDesc)] -> IO [(String, SqlColDesc)])
-> [(String, SqlColDesc)] -> IO [(String, SqlColDesc)]
forall a b. (a -> b) -> a -> b
$ ([SqlValue] -> (String, SqlColDesc))
-> [[SqlValue]] -> [(String, SqlColDesc)]
forall a b. (a -> b) -> [a] -> [b]
map [SqlValue] -> (String, SqlColDesc)
forall {a}. Convertible SqlValue a => [SqlValue] -> (a, SqlColDesc)
desccol [[SqlValue]]
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