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
import qualified Data.ByteString.Unsafe as B
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}
withConn :: Conn -> (Ptr CConn -> IO b) -> IO b
withConn (_lock,conn) = genericUnwrap conn
withConnLocked :: Conn -> (Ptr CConn -> IO b) -> IO b
withConnLocked c@(lock,_) a = withConn c (\cconn -> withMVar lock (\_ -> a cconn))
withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b
withRawConn (_lock,conn) = withForeignPtr conn
withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b
withStmt = genericUnwrap
withRawStmt :: Stmt -> (Ptr WrappedCStmt -> 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@(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))
-> (Ptr b -> IO ())
-> [a]
-> (Ptr (Ptr b) -> IO c)
-> IO c
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)
copyBytes res s len
poke (plusPtr res len) (0::CChar)
return res
genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b
genericUnwrap fptr action = withForeignPtr fptr (\structptr ->
do objptr <- (\hsc_ptr -> peekByteOff hsc_ptr 0) structptr
action objptr
)
foreign import ccall unsafe "libpq-fe.h PQerrorMessage"
pqerrorMessage :: Ptr CConn -> IO CString