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 ()
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
fgettables iconn =
do fsthptr <- makesth iconn "fgettables"
withStmt fsthptr (\sthptr ->
simpleSqlTables sthptr >>=
checkError "gettables simpleSqlTables"
(StmtHandle sthptr)
)
sth <- wrapTheStmt iconn fsthptr
results <- fetchAllRows' sth
l (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 <- wrapTheStmt iconn fsthptr
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"
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..]
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 rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits
pnullable
when (not (isOK rc1)) $
do poke pdtype 1
poke pcolsize 0
poke pdecdigits 0
coltype <- peek pdtype
colsize <- peek pcolsize
decdigits <- peek pdecdigits
case arg of
SqlNull ->
do rc2 <- sqlBindParameter sthptr (fromIntegral icol)
1
1 coltype colsize decdigits
nullPtr 0 nullData
checkError ("bindparameter " ++ 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
res <- mapM (getCol cstmt )
[1..ncols]
return (stmt, Just res)
where getCol cstmt icol =
do let defaultLen = 128
colinfo <- readMVar (colinfomv sstate)
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 &nullData"
nullData :: 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