module Database.HDBC.ODBC.Statement where
import Database.HDBC.Types
import Database.HDBC
import Database.HDBC.DriverUtils
import Database.HDBC.ODBC.Types
import Database.HDBC.ODBC.Utils
import Database.HDBC.ODBC.TypeConv
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Concurrent.MVar
import Foreign.C.String
import Foreign.Marshal
import Foreign.Storable
import Control.Monad
import Data.List
import Data.Word
import Data.Int
import Control.Exception
import System.IO
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BUTF8
import qualified Data.ByteString.Unsafe as B
l _ = return ()
fGetQueryInfo iconn children query =
do l "in fGetQueryInfo"
sstate <- newSState iconn query
addChild children (wrapStmt sstate)
fakeExecute' sstate
fakeExecute' sstate = withConn (dbo sstate) $ \cconn ->
withCStringLen (squery sstate) $ \(cquery, cqlen) ->
alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
do l "in fexecute"
rc1 <- sqlAllocStmtHandle 3 cconn psthptr
sthptr <- peek psthptr
wrappedsthptr <- withRawConn (dbo sstate)
(\rawconn -> wrapstmt sthptr rawconn)
fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
checkError "execute allocHandle" (DbcHandle cconn) rc1
sqlPrepare sthptr cquery (fromIntegral cqlen) >>=
checkError "execute prepare" (StmtHandle sthptr)
parmInfo <- fgetparminfo sthptr
colInfo <- fgetcolinfo sthptr
return (parmInfo, colInfo)
data SState =
SState { stomv :: MVar (Maybe Stmt),
dbo :: Conn,
squery :: String,
colinfomv :: MVar [(String, SqlColDesc)]}
newSState :: Conn -> String -> IO SState
newSState indbo query =
do newstomv <- newMVar Nothing
newcolinfomv <- newMVar []
return SState {stomv = newstomv,
dbo = indbo, squery = query,
colinfomv = newcolinfomv}
wrapStmt :: SState -> Statement
wrapStmt sstate =
Statement {execute = fexecute sstate,
executeMany = fexecutemany sstate,
finish = public_ffinish sstate,
fetchRow = ffetchrow sstate,
originalQuery = (squery sstate),
getColumnNames = readMVar (colinfomv sstate)
>>= (return . map fst),
describeResult = readMVar (colinfomv sstate)}
newSth :: Conn -> ChildList -> String -> IO Statement
newSth indbo mchildren query =
do l "in newSth"
sstate <- newSState indbo query
let retval = wrapStmt sstate
addChild mchildren retval
return retval
makesth iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
withConn iconn $ \cconn ->
withCString "" $ \emptycs ->
do rc1 <- sqlAllocStmtHandle 3 cconn psthptr
sthptr <- peek psthptr
wrappedsthptr <- withRawConn iconn
(\rawconn -> wrapstmt sthptr rawconn)
fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
checkError (name ++ " allocHandle") (DbcHandle cconn) rc1
return fsthptr
wrapTheStmt iconn fsthptr =
do sstate <- newSState iconn ""
sstate <- newSState iconn ""
swapMVar (stomv sstate) (Just fsthptr)
let sth = wrapStmt sstate
return (sth, sstate)
fgettables iconn =
do fsthptr <- makesth iconn "fgettables"
l "fgettables: after makesth"
withStmt fsthptr (\sthptr ->
simpleSqlTables sthptr >>=
checkError "gettables simpleSqlTables"
(StmtHandle sthptr)
)
l "fgettables: after withStmt"
(sth, sstate) <- wrapTheStmt iconn fsthptr
withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))
l "fgettables: after wrapTheStmt"
results <- fetchAllRows' sth
l ("fgettables: results: " ++ (show results))
return $ map (\x -> fromSql (x !! 2)) results
fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $
\(cs, csl) ->
do fsthptr <- makesth iconn "fdescribetable"
withStmt fsthptr (\sthptr ->
simpleSqlColumns sthptr cs (fromIntegral csl) >>=
checkError "fdescribetable simpleSqlColumns"
(StmtHandle sthptr)
)
(sth, sstate) <- wrapTheStmt iconn fsthptr
withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))
results <- fetchAllRows' sth
l (show results)
return $ map fromOTypeCol results
fexecute sstate args = withConn (dbo sstate) $ \cconn ->
B.useAsCStringLen (BUTF8.fromString (squery sstate)) $
\(cquery, cqlen) ->
alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
do l $ "in fexecute: " ++ show (squery sstate) ++ show args
public_ffinish sstate
rc1 <- sqlAllocStmtHandle 3 cconn psthptr
sthptr <- peek psthptr
wrappedsthptr <- withRawConn (dbo sstate)
(\rawconn -> wrapstmt sthptr rawconn)
fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
checkError "execute allocHandle" (DbcHandle cconn) rc1
sqlPrepare sthptr cquery (fromIntegral cqlen) >>=
checkError "execute prepare" (StmtHandle sthptr)
argsToFree <- zipWithM (bindCol sthptr) args [1..]
l $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args
r <- sqlExecute sthptr
mapM_ (\(x, y) -> touchForeignPtr x >> touchForeignPtr y)
(concat argsToFree)
case r of
100 -> return ()
x -> checkError "execute execute" (StmtHandle sthptr) x
rc <- getNumResultCols sthptr
case rc of
0 -> do rowcount <- getSqlRowCount sthptr
ffinish fsthptr
swapMVar (colinfomv sstate) []
touchForeignPtr fsthptr
return (fromIntegral rowcount)
colcount -> do fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)
swapMVar (stomv sstate) (Just fsthptr)
touchForeignPtr fsthptr
return 0
getNumResultCols sthptr = alloca $ \pcount ->
do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols"
(StmtHandle sthptr)
peek pcount
bindCol sthptr arg icol = alloca $ \pdtype ->
alloca $ \pcolsize ->
alloca $ \pdecdigits ->
alloca $ \pnullable ->
do l $ "Binding col " ++ show icol ++ ": " ++ show arg
rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits
pnullable
l $ "rc1 is " ++ show (isOK rc1)
when (not (isOK rc1)) $
do poke pdtype 1
poke pcolsize 0
poke pdecdigits 0
coltype <- peek pdtype
colsize <- peek pcolsize
decdigits <- peek pdecdigits
l $ "Results: " ++ show (coltype, colsize, decdigits)
case arg of
SqlNull ->
do l "Binding null"
rc2 <- sqlBindParameter sthptr (fromIntegral icol)
1
1 coltype colsize decdigits
nullPtr 0 nullDataHDBC
checkError ("bindparameter NULL " ++ show icol)
(StmtHandle sthptr) rc2
return []
x -> do
(csptr, cslen) <- cstrUtf8BString (fromSql x)
do pcslen <- malloc
poke pcslen (fromIntegral cslen)
rc2 <- sqlBindParameter sthptr (fromIntegral icol)
1
1 coltype
(if isOK rc1 then colsize else fromIntegral cslen + 1) decdigits
csptr (fromIntegral cslen + 1) pcslen
if isOK rc2
then do
fp1 <- newForeignPtr finalizerFree pcslen
fp2 <- newForeignPtr finalizerFree csptr
return [(fp1, fp2)]
else do
free pcslen
free csptr
checkError ("bindparameter " ++ show icol)
(StmtHandle sthptr) rc2
return []
getSqlRowCount cstmt = alloca $ \prows ->
do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt)
peek prows
cstrUtf8BString :: B.ByteString -> IO CStringLen
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, len)
ffetchrow :: SState -> IO (Maybe [SqlValue])
ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt ->
case stmt of
Nothing -> l "ffr nos" >> return (stmt, Nothing)
Just cmstmt -> withStmt cmstmt $ \cstmt ->
do rc <- sqlFetch cstmt
if rc == 100
then do l "no more rows"
ffinish cmstmt
return (Nothing, Nothing)
else do l "getting stuff"
checkError "sqlFetch" (StmtHandle cstmt) rc
ncols <- getNumResultCols cstmt
l $ "ncols: " ++ show ncols
res <- mapM (getCol cstmt )
[1..ncols]
return (stmt, Just res)
where getCol cstmt icol =
do let defaultLen = 128
colinfo <- readMVar (colinfomv sstate)
l $ "getCol: colinfo is " ++ show colinfo ++ ", icol " ++ show icol
let cBinding = case colType (snd (colinfo !! ((fromIntegral icol) 1))) of
SqlBinaryT -> 2
SqlVarBinaryT -> 2
SqlLongVarBinaryT -> 2
_ -> 1
alloca $ \plen ->
allocaBytes defaultLen $ \buf ->
do res <- sqlGetData cstmt (fromIntegral icol) cBinding
buf (fromIntegral defaultLen) plen
case res of
0 ->
do len <- peek plen
case len of
1 -> return SqlNull
4 -> fail $ "Unexpected SQL_NO_TOTAL"
len -> do bs <- B.packCStringLen (buf, fromIntegral len)
l $ "col is: " ++ show (BUTF8.toString bs)
return (SqlByteString bs)
1 ->
do len <- peek plen
allocaBytes (fromIntegral len + 1) $ \buf2 ->
do sqlGetData cstmt (fromIntegral icol) cBinding
buf2 (fromIntegral len + 1) plen
>>= checkError "sqlGetData" (StmtHandle cstmt)
len2 <- peek plen
let firstbuf = case cBinding of
2 -> defaultLen
_ -> defaultLen 1
bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf))
(B.packCStringLen (buf2, fromIntegral len2))
l $ "col is: " ++ (BUTF8.toString bs)
return (SqlByteString bs)
res -> raiseError "sqlGetData" res (StmtHandle cstmt)
fgetcolinfo cstmt =
do ncols <- getNumResultCols cstmt
mapM getname [1..ncols]
where getname icol = alloca $ \colnamelp ->
allocaBytes 128 $ \cscolname ->
alloca $ \datatypeptr ->
alloca $ \colsizeptr ->
alloca $ \nullableptr ->
do sqlDescribeCol cstmt icol cscolname 127 colnamelp
datatypeptr colsizeptr nullPtr nullableptr
colnamelen <- peek colnamelp
colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen)
let colname = BUTF8.toString colnamebs
datatype <- peek datatypeptr
colsize <- peek colsizeptr
nullable <- peek nullableptr
return $ fromOTypeInfo colname datatype colsize nullable
fexecutemany :: SState -> [[SqlValue]] -> IO ()
fexecutemany sstate arglist =
mapM_ (fexecute sstate) arglist >> return ()
public_ffinish sstate =
do l "public_ffinish"
modifyMVar_ (stomv sstate) worker
where worker Nothing = return Nothing
worker (Just sth) = ffinish sth >> return Nothing
ffinish :: Stmt -> IO ()
ffinish p = withRawStmt p $ sqlFreeHandleSth_app
foreign import ccall unsafe "hdbc-odbc-helper.h wrapobjodbc"
wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt)
foreign import ccall unsafe "sql.h SQLDescribeCol"
sqlDescribeCol :: Ptr CStmt
-> Int16
-> CString
-> Int16
-> Ptr (Int16)
-> Ptr (Int16)
-> Ptr (Word32)
-> Ptr (Int16)
-> Ptr (Int16)
-> IO Int16
foreign import ccall unsafe "sql.h SQLGetData"
sqlGetData :: Ptr CStmt
-> Word16
-> Int16
-> CString
-> Int32
-> Ptr (Int32)
-> IO Int16
foreign import ccall unsafe "hdbc-odbc-helper.h sqlFreeHandleSth_app"
sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO ()
foreign import ccall unsafe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer"
sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ())
foreign import ccall unsafe "sql.h SQLPrepare"
sqlPrepare :: Ptr CStmt -> CString -> Int32
-> IO Int16
foreign import ccall unsafe "sql.h SQLExecute"
sqlExecute :: Ptr CStmt -> IO Int16
foreign import ccall unsafe "sql.h SQLAllocHandle"
sqlAllocStmtHandle :: Int16 -> Ptr CConn ->
Ptr (Ptr CStmt) -> IO Int16
foreign import ccall unsafe "sql.h SQLNumResultCols"
sqlNumResultCols :: Ptr CStmt -> Ptr Int16
-> IO Int16
foreign import ccall unsafe "sql.h SQLRowCount"
sqlRowCount :: Ptr CStmt -> Ptr Int32 -> IO Int16
foreign import ccall unsafe "sql.h SQLBindParameter"
sqlBindParameter :: Ptr CStmt
-> Word16
-> Int16
-> Int16
-> Int16
-> Word32
-> Int16
-> CString
-> Int32
-> Ptr Int32
-> IO Int16
foreign import ccall unsafe "hdbc-odbc-helper.h &nullDataHDBC"
nullDataHDBC :: Ptr Int32
foreign import ccall unsafe "sql.h SQLDescribeParam"
sqlDescribeParam :: Ptr CStmt
-> Word16
-> Ptr Int16
-> Ptr Word32
-> Ptr Int16
-> Ptr Int16
-> IO Int16
foreign import ccall unsafe "sql.h SQLFetch"
sqlFetch :: Ptr CStmt -> IO Int16
foreign import ccall unsafe "hdbc-odbc-helper.h simpleSqlTables"
simpleSqlTables :: Ptr CStmt -> IO Int16
foreign import ccall unsafe "hdbc-odbc-helper.h simpleSqlColumns"
simpleSqlColumns :: Ptr CStmt -> Ptr CChar ->
Int16 -> IO Int16
fgetparminfo cstmt =
do ncols <- getNumParams cstmt
mapM getname [1..ncols]
where getname icol =
alloca $ \datatypeptr ->
alloca $ \colsizeptr ->
alloca $ \nullableptr ->
do poke datatypeptr 127
res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol)
datatypeptr colsizeptr nullPtr nullableptr
putStrLn $ show res
datatype <- peek datatypeptr
colsize <- peek colsizeptr
nullable <- peek nullableptr
return $ snd $ fromOTypeInfo "" datatype colsize nullable
getNumParams sthptr = alloca $ \pcount ->
do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols"
(StmtHandle sthptr)
peek pcount
foreign import ccall unsafe "sql.h SQLNumParams"
sqlNumParams :: Ptr CStmt -> Ptr Int16
-> IO Int16