1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
-- -*- 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)
#include <libpq-fe.h>
#include <pg_config.h>
-- | 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 = unsafePerformIO $ 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 = connectPostgreSQL_helper True
connectPostgreSQL' :: String -> IO Impl.Connection
connectPostgreSQL' = connectPostgreSQL_helper False
connectPostgreSQL_helper :: Bool -> String -> IO Impl.Connection
connectPostgreSQL_helper auto_transaction args =
B.useAsCString (BUTF8.fromString args) $
\cs -> do ptr <- pqconnectdb 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
#{const CONNECTION_OK} -> mkConn auto_transaction args (connLock,fptr)
_ -> raiseError "connectPostgreSQL" status ptr
-- FIXME: environment vars may have changed, should use pgsql enquiries
-- for clone.
mkConn :: Bool -> String -> Conn -> IO Impl.Connection
mkConn auto_transaction args conn = withConn conn $
\cconn ->
do children <- newMVar []
when auto_transaction $ begin_transaction conn children
protover <- pqprotocolVersion cconn
serverver <- pqserverVersion cconn
let clientver = #{const_str PG_VERSION}
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 connstr = bracket (connectPostgreSQL connstr) (disconnect)
withPostgreSQL' :: String -> (Impl.Connection -> IO a) -> IO a
withPostgreSQL' connstr = bracket (connectPostgreSQL' connstr) (disconnect)
--------------------------------------------------
-- Guts here
--------------------------------------------------
begin_transaction :: Conn -> ChildList -> IO ()
begin_transaction o children = frun o children "BEGIN" [] >> return ()
frunRaw :: Conn -> ChildList -> String -> IO ()
frunRaw o children query =
do sth <- newSth o children query
executeRaw sth
finish sth
return ()
frun :: Conn -> ChildList -> String -> [SqlValue] -> IO Integer
frun o children query args =
do sth <- newSth o children query
res <- execute sth args
finish sth
return res
fcommit :: Bool -> Conn -> ChildList -> IO ()
fcommit begin o cl = do _ <- frun o cl "COMMIT" []
when begin $ begin_transaction o cl
frollback :: Bool -> Conn -> ChildList -> IO ()
frollback begin o cl = do _ <- frun o cl "ROLLBACK" []
when begin $ begin_transaction o cl
fgetTables :: (Convertible SqlValue a) => Conn -> ChildList -> IO [a]
fgetTables conn children =
do sth <- newSth conn children
"select table_name from information_schema.tables where \
\table_schema != 'pg_catalog' AND table_schema != \
\'information_schema'"
_ <- execute sth []
res1 <- fetchAllRows' sth
let res = map fromSql $ concat res1
return $ seq (length res) res
fdescribeTable :: Conn -> ChildList -> String -> IO [(String, SqlColDesc)]
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 == False))
desccol x =
error $ "Got unexpected result from pg_attribute: " ++ show x
fdisconnect :: Conn -> ChildList -> IO ()
fdisconnect (lock, fptr) childList = do
closeAllChildren childList
modifyMVar_ lock $ \_ ->
finalizeForeignPtr 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 #{type ConnStatusType}
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
|
