{-# LINE 1 "Database/HDBC/PostgreSQL/Utils.hsc" #-}
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

{-# LINE 21 "Database/HDBC/PostgreSQL/Utils.hsc" #-}
-- Hugs includes this in Data.ByteString
import qualified Data.ByteString.Unsafe as B

{-# LINE 24 "Database/HDBC/PostgreSQL/Utils.hsc" #-}

raiseError :: String -> Word32 -> (Ptr CConn) -> IO a
raiseError :: forall a. String -> Word32 -> Ptr CConn -> IO a
raiseError String
msg Word32
code Ptr CConn
cconn =
    do rc <- Ptr CConn -> IO CString
pqerrorMessage Ptr CConn
cconn
       bs <- B.packCString rc
       let str = ByteString -> String
BUTF8.toString ByteString
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 :: forall b. Conn -> (Ptr CConn -> IO b) -> IO b
withConn (ConnLock
_lock,ForeignPtr CConn
conn) = ForeignPtr CConn -> (Ptr CConn -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CConn
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 :: forall b. Conn -> (Ptr CConn -> IO b) -> IO b
withConnLocked c :: Conn
c@(ConnLock
lock,ForeignPtr CConn
_) Ptr CConn -> IO b
a = Conn -> (Ptr CConn -> IO b) -> IO b
forall b. Conn -> (Ptr CConn -> IO b) -> IO b
withConn Conn
c (\Ptr CConn
cconn -> ConnLock -> (() -> IO b) -> IO b
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ConnLock
lock (\()
_ -> Ptr CConn -> IO b
a Ptr CConn
cconn))

withRawConn :: Conn -> (Ptr CConn -> IO b) -> IO b
withRawConn :: forall b. Conn -> (Ptr CConn -> IO b) -> IO b
withRawConn (ConnLock
_lock,ForeignPtr CConn
conn) = ForeignPtr CConn -> (Ptr CConn -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CConn
conn

withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b
withStmt :: forall b. Stmt -> (Ptr CStmt -> IO b) -> IO b
withStmt = Stmt -> (Ptr CStmt -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr

withRawStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b
withRawStmt :: forall b. Stmt -> (Ptr CStmt -> IO b) -> IO b
withRawStmt = Stmt -> (Ptr CStmt -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr

withCStringArr0 :: [SqlValue] -> (Ptr CString -> IO a) -> IO a
withCStringArr0 :: forall a. [SqlValue] -> (Ptr CString -> IO a) -> IO a
withCStringArr0 [SqlValue]
inp Ptr CString -> IO a
action = (SqlValue -> IO CString)
-> (CString -> IO ())
-> [SqlValue]
-> (Ptr CString -> IO a)
-> IO a
forall a b c.
(a -> IO (Ptr b))
-> (Ptr b -> IO ()) -> [a] -> (Ptr (Ptr b) -> IO c) -> IO c
withAnyArr0 SqlValue -> IO CString
convfunc CString -> IO ()
forall {a}. Ptr a -> IO ()
freefunc [SqlValue]
inp Ptr CString -> IO a
action
    where convfunc :: SqlValue -> IO CString
convfunc SqlValue
SqlNull = CString -> IO CString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CString
forall a. Ptr a
nullPtr
{-
          convfunc y@(SqlZonedTime _) = convfunc (SqlString $
                                                "TIMESTAMP WITH TIME ZONE '" ++
                                                fromSql y ++ "'")
-}
          convfunc y :: SqlValue
y@(SqlUTCTime UTCTime
_) = SqlValue -> IO CString
convfunc (ZonedTime -> SqlValue
SqlZonedTime (SqlValue -> ZonedTime
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
y))
          convfunc y :: SqlValue
y@(SqlEpochTime Integer
_) = SqlValue -> IO CString
convfunc (ZonedTime -> SqlValue
SqlZonedTime (SqlValue -> ZonedTime
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
y))
          convfunc (SqlByteString ByteString
x) = ByteString -> IO CString
cstrUtf8BString (ByteString -> ByteString
cleanUpBSNulls ByteString
x)
          convfunc SqlValue
x = ByteString -> IO CString
cstrUtf8BString (SqlValue -> ByteString
forall a. Convertible SqlValue a => SqlValue -> a
fromSql SqlValue
x)
          freefunc :: Ptr a -> IO ()
freefunc Ptr a
x =
              if Ptr a
x Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr
                 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 else Ptr a -> IO ()
forall {a}. Ptr a -> IO ()
free Ptr a
x

cleanUpBSNulls :: B.ByteString -> B.ByteString
cleanUpBSNulls :: ByteString -> ByteString
cleanUpBSNulls ByteString
bs | Word8
0 Word8 -> ByteString -> Bool
`B.notElem` ByteString
bs = ByteString
bs
                  | Bool
otherwise = (Word8 -> ByteString) -> ByteString -> ByteString
B.concatMap Word8 -> ByteString
convfunc ByteString
bs
  where convfunc :: Word8 -> ByteString
convfunc Word8
0 = ByteString
bsForNull
        convfunc Word8
x = Word8 -> ByteString
B.singleton Word8
x
        bsForNull :: ByteString
bsForNull = String -> ByteString
BCHAR8.pack String
"\\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 :: forall a b c.
(a -> IO (Ptr b))
-> (Ptr b -> IO ()) -> [a] -> (Ptr (Ptr b) -> IO c) -> IO c
withAnyArr0 a -> IO (Ptr b)
input2ptract Ptr b -> IO ()
freeact [a]
inp Ptr (Ptr b) -> IO c
action =
    IO [Ptr b] -> ([Ptr b] -> IO ()) -> ([Ptr b] -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((a -> IO (Ptr b)) -> [a] -> IO [Ptr b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> IO (Ptr b)
input2ptract [a]
inp)
            (\[Ptr b]
clist -> (Ptr b -> IO ()) -> [Ptr b] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ptr b -> IO ()
freeact [Ptr b]
clist)
            (\[Ptr b]
clist -> Ptr b -> [Ptr b] -> (Ptr (Ptr b) -> IO c) -> IO c
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
withArray0 Ptr b
forall a. Ptr a
nullPtr [Ptr b]
clist Ptr (Ptr b) -> IO c
action)

cstrUtf8BString :: B.ByteString -> IO CString
cstrUtf8BString :: ByteString -> IO CString
cstrUtf8BString ByteString
bs = do
    ByteString -> (CStringLen -> IO CString) -> IO CString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO CString) -> IO CString)
-> (CStringLen -> IO CString) -> IO CString
forall a b. (a -> b) -> a -> b
$ \(CString
s,Int
len) -> do
        res <- Int -> IO CString
forall a. Int -> IO (Ptr a)
mallocBytes (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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