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
|
module Database.HDBC.PostgreSQL.Utils where
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Database.HDBC(throwSqlError)
import Database.HDBC.Types
import Database.HDBC.PostgreSQL.Types
import Control.Concurrent.MVar
import Foreign.C.Types
import Control.Exception
import Foreign.Storable
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Data.Word
import qualified Data.ByteString.UTF8 as BUTF8
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BCHAR8
#ifndef __HUGS__
-- Hugs includes this in Data.ByteString
import qualified Data.ByteString.Unsafe as B
#endif
raiseError :: String -> Word32 -> (Ptr CConn) -> IO a
raiseError msg code cconn =
do rc <- pqerrorMessage cconn
bs <- B.packCString rc
let str = BUTF8.toString bs
throwSqlError $ SqlError {seState = "",
seNativeError = fromIntegral code,
seErrorMsg = msg ++ ": " ++ str}
{- This is a little hairy.
We have a Conn object that is actually a finalizeonce wrapper around
the real object. We use withConn to dereference the foreign pointer,
and then extract the pointer to the real object from the finalizeonce struct.
But, when we close the connection, we need the finalizeonce struct, so that's
done by withRawConn.
Ditto for statements. -}
withConn :: Conn -> (Ptr CConn -> IO b) -> IO b
withConn (_lock,conn) = withForeignPtr conn
-- Perform the associated action with the connection lock held.
-- Care must be taken with the use of this as it is *not* re-entrant. Calling it
-- a second time in the same thread will cause dead-lock.
-- (A better approach would be to use RLock from concurrent-extra)
withConnLocked :: Conn -> (Ptr CConn -> IO b) -> IO b
withConnLocked c@(lock,_) a = withConn c (\cconn -> withMVar lock (\_ -> a cconn))
withRawConn :: Conn -> (Ptr CConn -> IO b) -> IO b
withRawConn (_lock,conn) = withForeignPtr conn
withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b
withStmt = withForeignPtr
withRawStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b
withRawStmt = withForeignPtr
withCStringArr0 :: [SqlValue] -> (Ptr CString -> IO a) -> IO a
withCStringArr0 inp action = withAnyArr0 convfunc freefunc inp action
where convfunc SqlNull = return nullPtr
{-
convfunc y@(SqlZonedTime _) = convfunc (SqlString $
"TIMESTAMP WITH TIME ZONE '" ++
fromSql y ++ "'")
-}
convfunc y@(SqlUTCTime _) = convfunc (SqlZonedTime (fromSql y))
convfunc y@(SqlEpochTime _) = convfunc (SqlZonedTime (fromSql y))
convfunc (SqlByteString x) = cstrUtf8BString (cleanUpBSNulls x)
convfunc x = cstrUtf8BString (fromSql x)
freefunc x =
if x == nullPtr
then return ()
else free x
cleanUpBSNulls :: B.ByteString -> B.ByteString
cleanUpBSNulls bs | 0 `B.notElem` bs = bs
| otherwise = B.concatMap convfunc bs
where convfunc 0 = bsForNull
convfunc x = B.singleton x
bsForNull = BCHAR8.pack "\\000"
withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer
-> (Ptr b -> IO ()) -- ^ Function that frees generated data
-> [a] -- ^ List of input data
-> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array
-> IO c -- ^ Return value
withAnyArr0 input2ptract freeact inp action =
bracket (mapM input2ptract inp)
(\clist -> mapM_ freeact clist)
(\clist -> withArray0 nullPtr clist action)
cstrUtf8BString :: B.ByteString -> IO CString
cstrUtf8BString bs = do
B.unsafeUseAsCStringLen bs $ \(s,len) -> do
res <- mallocBytes (len+1)
-- copy in
copyBytes res s len
-- null terminate
poke (plusPtr res len) (0::CChar)
-- return ptr
return res
foreign import ccall unsafe "libpq-fe.h PQerrorMessage"
pqerrorMessage :: Ptr CConn -> IO CString
|
