module Database.HDBC.PostgreSQL.Connection
(connectPostgreSQL, Impl.Connection())
where
import Database.HDBC.Types
import Database.HDBC
import Database.HDBC.DriverUtils
import Database.HDBC.ColTypes
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 Foreign.Marshal
import Foreign.Storable
import Database.HDBC.PostgreSQL.Utils
import Foreign.ForeignPtr
import Foreign.Ptr
import Data.Word
import Data.Maybe
import Control.Concurrent.MVar
connectPostgreSQL :: String -> IO Impl.Connection
connectPostgreSQL args = withCString args $
\cs -> do ptr <- pqconnectdb cs
status <- pqstatus ptr
wrappedptr <- wrapconn ptr nullPtr
fptr <- newForeignPtr pqfinishptr wrappedptr
case status of
0 -> mkConn args fptr
_ -> raiseError "connectPostgreSQL" status ptr
mkConn :: String -> Conn -> IO Impl.Connection
mkConn args conn = withConn conn $
\cconn ->
do children <- newMVar []
begin_transaction conn children
protover <- pqprotocolVersion cconn
serverver <- pqserverVersion cconn
let clientver = "8.2.5"
return $ Impl.Connection {
Impl.disconnect = fdisconnect conn children,
Impl.commit = fcommit conn children,
Impl.rollback = frollback 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}
begin_transaction :: Conn -> ChildList -> IO ()
begin_transaction o children = frun o children "BEGIN" [] >> return ()
frun o children query args =
do sth <- newSth o children query
res <- execute sth args
finish sth
return res
fcommit o cl = do frun o cl "COMMIT" []
begin_transaction o cl
frollback o cl = do frun o cl "ROLLBACK" []
begin_transaction o cl
fgetTables conn children =
do sth <- newSth conn children "select table_name from information_schema.tables where table_schema = 'public'"
execute sth []
res1 <- fetchAllRows' sth
let res = map fromSql $ concat res1
return $ seq (length res) res
fdescribeTable o cl table = fdescribeSchemaTable o cl Nothing table
fdescribeSchemaTable :: Conn -> ChildList -> Maybe String -> String -> IO [(String, SqlColDesc)]
fdescribeSchemaTable o cl maybeSchema table =
do sth <- newSth o cl
("SELECT attname, atttypid, attlen, format_type(atttypid, atttypmod), attnotnull " ++
"FROM pg_attribute, pg_class, pg_namespace ns " ++
"WHERE relname = ? and attnum > 0 and attisdropped IS FALSE " ++
(if isJust maybeSchema then "and ns.nspname = ? " else "") ++
"and attrelid = pg_class.oid and relnamespace = ns.oid order by attnum")
let params = toSql table : (if isJust maybeSchema then [toSql $ fromJust maybeSchema] else [])
execute sth params
res <- fetchAllRows' sth
return $ map desccol res
where
desccol [attname, atttypid, attlen, formattedtype, attnotnull] =
(fromSql attname,
colDescForPGAttr (fromSql atttypid) (fromSql attlen) (fromSql formattedtype) (fromSql attnotnull == 'f'))
desccol x =
error $ "Got unexpected result from pg_attribute: " ++ show x
fdisconnect conn mchildren =
do closeAllChildren mchildren
withRawConn conn $ pqfinish
foreign import ccall unsafe "libpq-fe.h PQconnectdb"
pqconnectdb :: CString -> IO (Ptr CConn)
foreign import ccall unsafe "hdbc-postgresql-helper.h wrapobjpg"
wrapconn :: Ptr CConn -> Ptr WrappedCConn -> IO (Ptr WrappedCConn)
foreign import ccall unsafe "libpq-fe.h PQstatus"
pqstatus :: Ptr CConn -> IO Word32
foreign import ccall unsafe "hdbc-postgresql-helper.h PQfinish_app"
pqfinish :: Ptr WrappedCConn -> IO ()
foreign import ccall unsafe "hdbc-postgresql-helper.h &PQfinish_finalizer"
pqfinishptr :: FunPtr (Ptr WrappedCConn -> IO ())
foreign import ccall unsafe "libpq-fe.h PQprotocolVersion"
pqprotocolVersion :: Ptr CConn -> IO CInt
foreign import ccall unsafe "libpq-fe.h PQserverVersion"
pqserverVersion :: Ptr CConn -> IO CInt