-- -*- mode: haskell; -*- {-# CFILES hdbc-odbc-helper.c #-} -- Above line for hugs {-# LANGUAGE EmptyDataDecls #-} module Database.HDBC.ODBC.Statement ( fGetQueryInfo, newSth, fgettables, fdescribetable ) 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.String (castCUCharToChar) import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Ptr import Control.Applicative import Control.Concurrent.MVar import Foreign.C.String import Foreign.Marshal import Foreign.Storable import Control.Monad import Data.Word import Data.Time.Calendar (fromGregorian) import Data.Time.LocalTime (TimeOfDay(TimeOfDay), LocalTime(LocalTime)) import Data.Int import Data.Maybe (catMaybes, fromMaybe) import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import qualified Data.ByteString.Unsafe as B import Unsafe.Coerce (unsafeCoerce) import System.IO (hPutStrLn, stderr) import Debug.Trace l :: String -> IO () l _ = return () -- l m = hPutStrLn stderr ("\n" ++ m) #ifdef mingw32_HOST_OS #include #endif #include #include #ifdef mingw32_HOST_OS #let CALLCONV = "stdcall" #else #let CALLCONV = "ccall" #endif fGetQueryInfo :: Conn -> ChildList -> String -> IO ([SqlColDesc], [(String, SqlColDesc)]) fGetQueryInfo iconn children query = do l "in fGetQueryInfo" sstate <- newSState iconn query addChild children (wrapStmt sstate) -- We get error if we forget this one. Not sure why. fakeExecute' sstate fakeExecute' :: SState -> IO ([SqlColDesc], [(String, SqlColDesc)]) fakeExecute' sstate = withConn (dbo sstate) $ \cconn -> withCStringLen (squery sstate) $ \(cquery, cqlen) -> alloca $ \(psthptr::Ptr (Ptr CStmt)) -> do l "in fexecute" -- public_ffinish sstate rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} 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) -- parmCount <- getNumParams sthptr parmInfo <- fgetparminfo sthptr -- rc <- getNumResultCols sthptr colInfo <- fgetcolinfo sthptr return (parmInfo, colInfo) -- | The Stament State data SState = SState { stomv :: MVar (Maybe Stmt) , dbo :: Conn , squery :: String , colinfomv :: MVar [(String, SqlColDesc)] , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})]) } -- FIXME: we currently do no prepare optimization whatsoever. newSState :: Conn -> String -> IO SState newSState indbo query = do newstomv <- newMVar Nothing newcolinfomv <- newMVar [] newBindCols <- newMVar Nothing return SState { stomv = newstomv , dbo = indbo , squery = query , colinfomv = newcolinfomv , bindColsMV = newBindCols } wrapStmt :: SState -> Statement wrapStmt sstate = Statement { execute = fexecute sstate , executeRaw = return () , 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 :: Conn -> [Char] -> IO (ForeignPtr WrappedCStmt) makesth iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) -> withConn iconn $ \cconn -> withCString "" $ \emptycs -> do rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} 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 :: Conn -> Stmt -> IO (Statement, SState) wrapTheStmt iconn fsthptr = do sstate <- newSState iconn "" sstate <- newSState iconn "" swapMVar (stomv sstate) (Just fsthptr) let sth = wrapStmt sstate return (sth, sstate) fgettables :: Conn -> IO [String] 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 :: Conn -> String -> IO [(String, SqlColDesc)] 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 {- For now, we try to just handle things as simply as possible. FIXME lots of room for improvement here (types, etc). -} fexecute :: SState -> [SqlValue] -> IO Integer 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 #{const SQL_HANDLE_STMT} 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) bindArgs <- zipWithM (bindParam sthptr) args [1..] l $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args r <- sqlExecute sthptr mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs) case r of #{const SQL_NO_DATA} -> return () -- Update that did nothing 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 :: Ptr CStmt -> IO #{type SQLSMALLINT} getNumResultCols sthptr = alloca $ \pcount -> do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" (StmtHandle sthptr) peek pcount -- Bind a parameter column before execution. bindParam :: Ptr CStmt -> SqlValue -> Word16 -> IO (Maybe (Ptr #{type SQLLEN}, Ptr CChar)) bindParam sthptr arg icol = alloca $ \pdtype -> alloca $ \pcolsize -> alloca $ \pdecdigits -> alloca $ \pnullable -> {- We have to start by getting the SQL type of the column so we can send the correct type back to the server. Sigh. If the ODBC backend won't tell us the type, we fake it. We've got an annoying situation with error handling. Must make sure that all data is freed, but if there's an error, we have to raise it and the caller never gets to freed the allocated data to-date. So, make sure we either free of have foreignized everything before control passes out of this function. -} do l $ "Binding col " ++ show icol ++ ": " ++ show arg rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable l $ "rc1 is " ++ show (isOK rc1) coltype <- if isOK rc1 then Just <$> peek pdtype else return Nothing colsize <- if isOK rc1 then Just <$> peek pcolsize else return Nothing decdigits <- if isOK rc1 then Just <$> peek pdecdigits else return Nothing l $ "Results: " ++ show (coltype, colsize, decdigits) case arg of SqlNull -> -- NULL parameter, bind it as such. do l "Binding null" rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT} #{const SQL_C_CHAR} (fromMaybe #{const SQL_CHAR} coltype) (fromMaybe 0 colsize) (fromMaybe 0 decdigits) nullPtr 0 nullDataHDBC checkError ("bindparameter NULL " ++ show icol) (StmtHandle sthptr) rc2 return Nothing x -> do -- Otherwise, we have to allocate RAM, make sure it's -- not freed now, and pass it along... boundValue <- bindSqlValue x do pcslen <- malloc poke pcslen . fromIntegral $ bvBufferSize boundValue rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT} (bvValueType boundValue) (fromMaybe (bvDefaultColumnType boundValue) coltype) (fromMaybe (bvDefaultColumnSize boundValue) colsize) (fromMaybe (bvDefaultDecDigits boundValue) decdigits) (castPtr $ bvBuffer boundValue) (bvBufferSize boundValue) pcslen if isOK rc2 then do -- We bound it. Make foreignPtrs and return. return $ Just (pcslen, castPtr $ bvBuffer boundValue) else do -- Binding failed. Free the data and raise -- error. free pcslen free (bvBuffer boundValue) checkError ("bindparameter " ++ show icol) (StmtHandle sthptr) rc2 return Nothing -- will never get hit getSqlRowCount :: Ptr CStmt -> IO Int32 getSqlRowCount cstmt = alloca $ \prows -> do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt) peek prows --note: As of ODBC-3.52, the row count is only a C int, ie 32bit. data BoundValue = BoundValue -- | Type of the value in the buffer { bvValueType :: #{type SQLSMALLINT} -- | Type of the SQL value to use if ODBC driver doesn't report one , bvDefaultColumnType :: #{type SQLSMALLINT} , bvDefaultColumnSize :: #{type SQLULEN} , bvDefaultDecDigits :: #{type SQLSMALLINT} , bvBuffer :: Ptr () , bvBufferSize :: #{type SQLLEN} } deriving (Show) -- | Marshals given SqlValue returning intended ValueType, default ColumnType, -- and a CStringLen with a buffer containing bound value. Pointer in the CStringLen -- structure must be freed by caller bindSqlValue :: SqlValue -> IO BoundValue bindSqlValue sqlValue = case sqlValue of SqlString s -> do (wstrPtr, wstrLen) <- newCWStringLen s let result = BoundValue { bvValueType = #{const SQL_C_WCHAR} , bvDefaultColumnType = #{const SQL_WCHAR} , bvDefaultColumnSize = fromIntegral wstrLen , bvDefaultDecDigits = 0 , bvBuffer = castPtr wstrPtr , bvBufferSize = fromIntegral $ wstrLen * #{size wchar_t} } l $ "bind SqlString " ++ s ++ ": " ++ show result return result SqlByteString bs -> B.unsafeUseAsCStringLen bs $ \(s,len) -> do res <- mallocBytes len copyBytes res s len let result = BoundValue { bvValueType = #{const SQL_C_BINARY} , bvDefaultColumnType = #{const SQL_BINARY} , bvDefaultColumnSize = fromIntegral len , bvDefaultDecDigits = 0 , bvBuffer = castPtr res , bvBufferSize = fromIntegral len } l $ "bind SqlByteString " ++ show bs ++ ": " ++ show result return result -- | This is rather hacky, I just replicate the behaviour of a previous version x -> do l $ "bind other " ++ show x bsResult <- bindSqlValue $ SqlByteString (fromSql x) let result = bsResult { bvValueType = #{const SQL_C_CHAR} , bvDefaultColumnType = #{const SQL_CHAR} } l $ "bound other " ++ show x ++ ": " ++ show result return result ffetchrow :: SState -> IO (Maybe [SqlValue]) ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt -> do l $ "ffetchrow" case stmt of Nothing -> do l "ffetchrow: no statement" return (stmt, Nothing) Just cmstmt -> withStmt cmstmt $ \cstmt -> do bindCols <- getBindCols sstate cstmt l "ffetchrow: fetching" rc <- sqlFetch cstmt if rc == #{const SQL_NO_DATA} then do l "ffetchrow: no more rows" ffinish cmstmt return (Nothing, Nothing) else do l "ffetchrow: fetching data" checkError "sqlFetch" (StmtHandle cstmt) rc sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO} then mapM (bindColToSqlValue cstmt) bindCols else raiseError "sqlGetData" rc (StmtHandle cstmt) return (stmt, Just sqlValues) getBindCols :: SState -> Ptr CStmt -> IO [(BindCol, Ptr #{type SQLLEN})] getBindCols sstate cstmt = do l "getBindCols" modifyMVar (bindColsMV sstate) $ \mBindCols -> case mBindCols of Nothing -> do cols <- getNumResultCols cstmt pBindCols <- mapM (mkBindCol sstate cstmt) [1 .. cols] return (Just pBindCols, pBindCols) Just bindCols -> do return (mBindCols, bindCols) -- This is only for String data. For binary fix should be very easy. Just check the column type and use buflen instead of buflen - 1 getLongColData cstmt bindCol = do let (BindColString buf bufLen col) = bindCol l $ "buflen: " ++ show bufLen bs <- B.packCStringLen (buf, fromIntegral (bufLen - 1)) l $ "sql_no_total col " ++ show (BUTF8.toString bs) bs2 <- getRestLongColData cstmt #{const SQL_CHAR} col bs return $ SqlByteString bs2 getRestLongColData cstmt cBinding icol acc = do l "getLongColData" alloca $ \plen -> allocaBytes colBufSizeMaximum $ \buf -> do res <- sqlGetData cstmt (fromIntegral icol) cBinding buf (fromIntegral colBufSizeMaximum) plen if res == #{const SQL_SUCCESS} || res == #{const SQL_SUCCESS_WITH_INFO} then do len <- peek plen if len == #{const SQL_NO_DATA} then return acc else do let bufmax = fromIntegral $ colBufSizeMaximum - 1 bs <- B.packCStringLen (buf, fromIntegral (if len == #{const SQL_NO_TOTAL} || len > bufmax then bufmax else len)) l $ "sql_no_total col is: " ++ show (BUTF8.toString bs) let newacc = B.append acc bs if len /= #{const SQL_NO_TOTAL} && len <= bufmax then return newacc else getRestLongColData cstmt cBinding icol newacc else raiseError "sqlGetData" res (StmtHandle cstmt) -- TODO: This code does not deal well with data that is extremely large, -- where multiple fetches are required. getColData cstmt cBinding icol = do alloca $ \plen -> allocaBytes colBufSizeDefault $ \buf -> do res <- sqlGetData cstmt (fromIntegral icol) cBinding buf (fromIntegral colBufSizeDefault) plen case res of #{const SQL_SUCCESS} -> do len <- peek plen case len of #{const SQL_NULL_DATA} -> return SqlNull #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL" _ -> do bs <- B.packCStringLen (buf, fromIntegral len) l $ "col is: " ++ show (BUTF8.toString bs) return (SqlByteString bs) #{const SQL_SUCCESS_WITH_INFO} -> 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 #{const SQL_C_BINARY} -> colBufSizeDefault _ -> colBufSizeDefault - 1 -- strip off NUL bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf)) (B.packCStringLen (buf2, fromIntegral len2)) l $ "col is: " ++ (BUTF8.toString bs) return (SqlByteString bs) _ -> raiseError "sqlGetData" res (StmtHandle cstmt) -- | ffetchrowBaseline is used for benchmarking fetches without the -- overhead of marshalling values. ffetchrowBaseline sstate = do Just cmstmt <- readMVar (stomv sstate) withStmt cmstmt $ \cstmt -> do rc <- sqlFetch cstmt if rc == #{const SQL_NO_DATA} then do ffinish cmstmt return Nothing else do return (Just []) data ColBuf -- These correspond to the C type identifiers found here: -- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx -- The Ptr values point to the appropriate C types data BindCol = BindColString (Ptr CChar) #{type SQLLEN} #{type SQLUSMALLINT} | BindColWString (Ptr CWchar) #{type SQLLEN} #{type SQLUSMALLINT} | BindColBit (Ptr CUChar) | BindColTinyInt (Ptr CChar) | BindColShort (Ptr CShort) | BindColLong (Ptr CLong) | BindColBigInt (Ptr #{type SQLBIGINT}) | BindColFloat (Ptr CFloat) | BindColDouble (Ptr CDouble) | BindColBinary (Ptr CUChar) #{type SQLLEN} #{type SQLUSMALLINT} | BindColDate (Ptr StructDate) | BindColTime (Ptr StructTime) | BindColTimestamp (Ptr StructTimestamp) | BindColGetData #{type SQLUSMALLINT} -- Intervals and GUIDs have not been implemented, since there is no -- equivalent SqlValue for these. -- -- | BindColInterval -- typedef struct tagSQL_INTERVAL_STRUCT -- { -- SQLINTERVAL interval_type; -- SQLSMALLINT interval_sign; -- union { -- SQL_YEAR_MONTH_STRUCT year_month; -- SQL_DAY_SECOND_STRUCT day_second; -- } intval; -- } SQL_INTERVAL_STRUCT; -- typedef enum -- { -- SQL_IS_YEAR = 1, -- SQL_IS_MONTH = 2, -- SQL_IS_DAY = 3, -- SQL_IS_HOUR = 4, -- SQL_IS_MINUTE = 5, -- SQL_IS_SECOND = 6, -- SQL_IS_YEAR_TO_MONTH = 7, -- SQL_IS_DAY_TO_HOUR = 8, -- SQL_IS_DAY_TO_MINUTE = 9, -- SQL_IS_DAY_TO_SECOND = 10, -- SQL_IS_HOUR_TO_MINUTE = 11, -- SQL_IS_HOUR_TO_SECOND = 12, -- SQL_IS_MINUTE_TO_SECOND = 13 -- } SQLINTERVAL; -- -- typedef struct tagSQL_YEAR_MONTH -- { -- SQLUINTEGER year; -- SQLUINTEGER month; -- } SQL_YEAR_MONTH_STRUCT; -- -- typedef struct tagSQL_DAY_SECOND -- { -- SQLUINTEGER day; -- SQLUINTEGER hour; -- SQLUINTEGER minute; -- SQLUINTEGER second; -- SQLUINTEGER fraction; -- } SQL_DAY_SECOND_STRUCT; -- | BindColGUID (Ptr StructGUID) -- | StructDate is used to marshal the DATE_STRUCT -- This struct, and the ones which follow, are described here: -- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx data StructDate = StructDate #{type SQLSMALLINT} -- year #{type SQLUSMALLINT} -- month #{type SQLUSMALLINT} -- day deriving Show instance Storable StructDate where sizeOf _ = #{size DATE_STRUCT} alignment _ = alignment (undefined :: CLong) poke p (StructDate year month day) = do #{poke DATE_STRUCT, year} p year #{poke DATE_STRUCT, month} p month #{poke DATE_STRUCT, day} p day peek p = return StructDate `ap` (#{peek DATE_STRUCT, year} p) `ap` (#{peek DATE_STRUCT, month} p) `ap` (#{peek DATE_STRUCT, day} p) -- | StructTime is used to marshals the TIME_STRUCT: data StructTime = StructTime #{type SQLUSMALLINT} -- hour #{type SQLUSMALLINT} -- minute #{type SQLUSMALLINT} -- second instance Storable StructTime where sizeOf _ = #{size TIME_STRUCT} alignment _ = alignment (undefined :: CLong) poke p (StructTime hour minute second) = do #{poke TIME_STRUCT, hour} p hour #{poke TIME_STRUCT, minute} p minute #{poke TIME_STRUCT, second} p second peek p = return StructTime `ap` (#{peek TIME_STRUCT, hour} p) `ap` (#{peek TIME_STRUCT, minute} p) `ap` (#{peek TIME_STRUCT, second} p) -- | StructTimestamp is used to marshal the TIMESTAMP_STRUCT; data StructTimestamp = StructTimestamp #{type SQLSMALLINT} -- year #{type SQLUSMALLINT} -- month #{type SQLUSMALLINT} -- day #{type SQLUSMALLINT} -- hour #{type SQLUSMALLINT} -- minute #{type SQLUSMALLINT} -- second #{type SQLUINTEGER} -- fraction instance Storable StructTimestamp where sizeOf _ = #{size TIMESTAMP_STRUCT} alignment _ = alignment (undefined :: CLong) poke p (StructTimestamp year month day hour minute second fraction) = do #{poke TIMESTAMP_STRUCT, year} p year #{poke TIMESTAMP_STRUCT, month} p month #{poke TIMESTAMP_STRUCT, day} p day #{poke TIMESTAMP_STRUCT, hour} p hour #{poke TIMESTAMP_STRUCT, minute} p minute #{poke TIMESTAMP_STRUCT, second} p second #{poke TIMESTAMP_STRUCT, fraction} p fraction peek p = return StructTimestamp `ap` (#{peek TIMESTAMP_STRUCT, year} p) `ap` (#{peek TIMESTAMP_STRUCT, month} p) `ap` (#{peek TIMESTAMP_STRUCT, day} p) `ap` (#{peek TIMESTAMP_STRUCT, hour} p) `ap` (#{peek TIMESTAMP_STRUCT, minute} p) `ap` (#{peek TIMESTAMP_STRUCT, second} p) `ap` (#{peek TIMESTAMP_STRUCT, fraction} p) -- | StructGUID -- data StructGUID = StructGUID -- #{type DWORD} -- ^ Data1 -- #{type WORD} -- ^ Data2 -- #{type WORD} -- ^ Data3 -- [#{type BYTE}] -- ^ Data4[8] -- -- instance Storable StructGUID where -- sizeOf _ = #{size SQLGUID} -- alignment _ = alignment (undefined :: CLong) -- poke p (StructGUID data1 data2 data3 data4) = do -- #{poke SQLGUID, Data1} p data1 -- #{poke SQLGUID, Data2} p data2 -- #{poke SQLGUID, Data3} p data3 -- pokeArray (p `plusPtr` #{offset SQLGUID, Data4}) data4 -- peek p = return StructGUID -- `ap` (#{peek SQLGUID, Data1} p) -- `ap` (#{peek SQLGUID, Data2} p) -- `ap` (#{peek SQLGUID, Data3} p) -- `ap` (peekArray 8 (p `plusPtr` #{offset SQLGUID, Data4})) -- | This function binds the data in a column to a value of type -- BindCol, using the default conversion scheme described here: -- http://msdn.microsoft.com/en-us/library/ms716298(v=VS.85).aspx -- The corresponding C types are here: -- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx -- These values are then ready for fetching. -- Documentation about SQLBindCol can be found here: -- http://msdn.microsoft.com/en-us/library/ms711010(v=vs.85).aspx -- -- Our implementation follows this code: -- http://publib.boulder.ibm.com/infocenter/iseries/v5r3/index.jsp?topic=%2Fcli%2Frzadpfndecol.htm -- We have to make use of the column type and length information. -- These are given by SQLDescribeCol, which is stored in colinfomv. -- SQLDescribeCol can tell use the data type, and the size of a column (in -- characters, so add 1 for the null terminator), or the number of decimal -- digits that can be held. -- To find out type, and how much memory to allocate, we could also use: -- SQLColAttribute( ..., SQL_DESC_TYPE , ... ) -- SQLColAttribute( ..., SQL_DESC_OCTET_LENGTH , ... ) -- -- Further examples of how to use SQLBindCol are here, though these make use -- of SQLDescribeCol: -- http://msdn.microsoft.com/en-us/library/ms710118(v=vs.85).aspx -- This implementation makes use of Column-Wise binding. Further improvements -- might be had by using Row-Wise binding. mkBindCol :: SState -> Ptr CStmt -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN}) mkBindCol sstate cstmt col = do l "mkBindCol" colInfo <- readMVar (colinfomv sstate) let colDesc = (snd (colInfo !! ((fromIntegral col) -1))) case colType colDesc of SqlCharT -> mkBindColStringEC cstmt col' (colSize colDesc) SqlVarCharT -> mkBindColStringEC cstmt col' (colSize colDesc) SqlLongVarCharT -> mkBindColString cstmt col' (colSize colDesc) SqlWCharT -> mkBindColWStringEC cstmt col' (colSize colDesc) SqlWVarCharT -> mkBindColWStringEC cstmt col' (colSize colDesc) SqlWLongVarCharT -> mkBindColWString cstmt col' (colSize colDesc) SqlDecimalT -> mkBindColString cstmt col' (colSize colDesc) SqlNumericT -> mkBindColString cstmt col' (colSize colDesc) SqlBitT -> mkBindColBit cstmt col' (colSize colDesc) SqlTinyIntT -> mkBindColTinyInt cstmt col' (colSize colDesc) SqlSmallIntT -> mkBindColShort cstmt col' (colSize colDesc) SqlIntegerT -> mkBindColLong cstmt col' (colSize colDesc) SqlBigIntT -> mkBindColBigInt cstmt col' (colSize colDesc) SqlRealT -> mkBindColFloat cstmt col' (colSize colDesc) SqlFloatT -> mkBindColDouble cstmt col' (colSize colDesc) SqlDoubleT -> mkBindColDouble cstmt col' (colSize colDesc) SqlBinaryT -> mkBindColBinary cstmt col' (colSize colDesc) SqlVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc) SqlLongVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc) SqlDateT -> mkBindColDate cstmt col' (colSize colDesc) SqlTimeT -> mkBindColTime cstmt col' (colSize colDesc) SqlTimestampT -> mkBindColTimestamp cstmt col' (colSize colDesc) -- SqlIntervalT i -> mkBindColInterval cstmt col' (colSize colDesc) i -- SqlGUIDT -> mkBindColGUID cstmt col' (colSize colDesc) _ -> mkBindColGetData col' -- The following are not supported by ODBC: -- SqlUTCDateTimeT -- SqlUTCTimeT -- SqlTimeWithZoneT -- SqlTimestampWithZoneT where col' = fromIntegral col colBufSizeDefault = 1024 colBufSizeMaximum = 4096 utf8EncodingMaximum = 6 wcSize = 2 -- The functions that follow do the marshalling from C into a Haskell type mkBindColString cstmt col mColSize = do l "mkBindCol: BindColString" let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize let bufLen = sizeOf (undefined :: CChar) * (colSize + 1) buf <- mallocBytes bufLen pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColString buf (fromIntegral bufLen) col, pStrLen) mkBindColStringEC cstmt col = mkBindColString cstmt col . fmap (* utf8EncodingMaximum) mkBindColWString cstmt col mColSize = do l "mkBindCol: BindColWString" let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize let bufLen = sizeOf (undefined :: CWchar) * (colSize + 1) buf <- mallocBytes bufLen pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColWString buf (fromIntegral bufLen) col, pStrLen) mkBindColWStringEC cstmt col = mkBindColString cstmt col . fmap extendFactor where extendFactor sz = sz * ((utf8EncodingMaximum + wcSize - 1) `quot` wcSize) mkBindColBit cstmt col mColSize = do l "mkBindCol: BindColBit" let bufLen = sizeOf (undefined :: CChar) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBit buf, pStrLen) mkBindColTinyInt cstmt col mColSize = do l "mkBindCol: BindColTinyInt" let bufLen = sizeOf (undefined :: CUChar) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTinyInt buf, pStrLen) mkBindColShort cstmt col mColSize = do l "mkBindCol: BindColShort" let bufLen = sizeOf (undefined :: CShort) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColShort buf, pStrLen) mkBindColLong cstmt col mColSize = do l "mkBindCol: BindColSize" let bufLen = sizeOf (undefined :: CLong) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColLong buf, pStrLen) mkBindColBigInt cstmt col mColSize = do l "mkBindCol: BindColBigInt" let bufLen = sizeOf (undefined :: CInt) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBigInt buf, pStrLen) mkBindColFloat cstmt col mColSize = do l "mkBindCol: BindColFloat" let bufLen = sizeOf (undefined :: CFloat) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColFloat buf, pStrLen) mkBindColDouble cstmt col mColSize = do l "mkBindCol: BindColDouble" let bufLen = sizeOf (undefined :: CDouble) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColDouble buf, pStrLen) mkBindColBinary cstmt col mColSize = do l "mkBindCol: BindColBinary" let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize let bufLen = sizeOf (undefined :: CUChar) * (colSize + 1) buf <- mallocBytes bufLen pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_BINARY}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBinary buf (fromIntegral bufLen) col, pStrLen) mkBindColDate cstmt col mColSize = do l "mkBindCol: BindColDate" let bufLen = sizeOf (undefined :: StructDate) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColDate buf, pStrLen) mkBindColTime cstmt col mColSize = do l "mkBindCol: BindColTime" let bufLen = sizeOf (undefined :: StructTime) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTime buf, pStrLen) mkBindColTimestamp cstmt col mColSize = do l "mkBindCol: BindColTimestamp" let bufLen = sizeOf (undefined :: StructTimestamp) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTimestamp buf, pStrLen) mkBindColGetData col = do l "mkBindCol: BindColGetData" return (BindColGetData col, nullPtr) freeBindCol :: BindCol -> IO () freeBindCol (BindColString buf _ _) = free buf freeBindCol (BindColWString buf _ _) = free buf freeBindCol (BindColBit buf) = free buf freeBindCol (BindColTinyInt buf) = free buf freeBindCol (BindColShort buf) = free buf freeBindCol (BindColLong buf) = free buf freeBindCol (BindColBigInt buf) = free buf freeBindCol (BindColFloat buf) = free buf freeBindCol (BindColDouble buf) = free buf freeBindCol (BindColBinary buf _ _) = free buf freeBindCol (BindColDate buf) = free buf freeBindCol (BindColTime buf) = free buf freeBindCol (BindColTimestamp buf) = free buf freeBindCol (BindColGetData _ ) = return () -- | This assumes that SQL_ATTR_MAX_LENGTH is set to zero, otherwise, we -- cannot detect truncated columns. See "returning Data in Bound Columns": -- http://msdn.microsoft.com/en-us/library/ms712424(v=vs.85).aspx -- Also note that the strLen value of SQL_NTS denotes a null terminated string, -- but is only valid as input, so we don't make use of it here: -- http://msdn.microsoft.com/en-us/library/ms713532(v=VS.85).aspx bindColToSqlValue :: Ptr CStmt -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue bindColToSqlValue pcstmt (BindColGetData col, _) = do l "bindColToSqlValue: BindColGetData" getColData pcstmt #{const SQL_CHAR} col bindColToSqlValue pcstmt (bindCol, pStrLen) = do l "bindColToSqlValue" strLen <- peek pStrLen case strLen of #{const SQL_NULL_DATA} -> return SqlNull #{const SQL_NO_TOTAL} -> getLongColData pcstmt bindCol _ -> bindColToSqlValue' pcstmt bindCol strLen -- | This is a worker function for `bindcolToSqlValue`. Note that the case -- where the data is null should already be handled by this stage. bindColToSqlValue' :: Ptr CStmt -> BindCol -> #{type SQLLEN} -> IO SqlValue bindColToSqlValue' pcstmt (BindColString buf bufLen col) strLen | bufLen >= strLen = do bs <- B.packCStringLen (buf, fromIntegral strLen) l $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show strLen return $ SqlByteString bs | otherwise = getColData pcstmt #{const SQL_CHAR} col bindColToSqlValue' pcstmt (BindColWString buf bufLen col) strLen | bufLen >= strLen = do bs <- B.packCStringLen (castPtr buf, fromIntegral strLen) l $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen return $ SqlByteString bs | otherwise = getColData pcstmt #{const SQL_CHAR} col bindColToSqlValue' _ (BindColBit buf) strLen = do bit <- peek buf l $ "bindColToSqlValue BindColBit " ++ show bit return $ SqlChar (castCUCharToChar bit) bindColToSqlValue' _ (BindColTinyInt buf) strLen = do tinyInt <- peek buf l $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt return $ SqlChar (castCCharToChar tinyInt) bindColToSqlValue' _ (BindColShort buf) strLen = do short <- peek buf l $ "bindColToSqlValue BindColShort" ++ show short return $ SqlInt32 (fromIntegral short) bindColToSqlValue' _ (BindColLong buf) strLen = do long <- peek buf l $ "bindColToSqlValue BindColLong " ++ show long return $ SqlInt32 (fromIntegral long) bindColToSqlValue' _ (BindColBigInt buf) strLen = do bigInt <- peek buf l $ "bindColToSqlValue BindColBigInt " ++ show bigInt return $ SqlInt64 (fromIntegral bigInt) bindColToSqlValue' _ (BindColFloat buf) strLen = do float <- peek buf l $ "bindColToSqlValue BindColFloat " ++ show float return $ SqlDouble (realToFrac float) bindColToSqlValue' _ (BindColDouble buf) strLen = do double <- peek buf l $ "bindColToSqlValue BindColDouble " ++ show double return $ SqlDouble (realToFrac double) bindColToSqlValue' pcstmt (BindColBinary buf bufLen col) strLen | bufLen >= strLen = do bs <- B.packCStringLen (castPtr buf, fromIntegral strLen) l $ "bindColToSqlValue BindColBinary " ++ show bs return $ SqlByteString bs | otherwise = getColData pcstmt (#{const SQL_C_BINARY}) col bindColToSqlValue' _ (BindColDate buf) strLen = do StructDate year month day <- peek buf l $ "bindColToSqlValue BindColDate" return $ SqlLocalDate $ fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day) bindColToSqlValue' _ (BindColTime buf) strLen = do StructTime hour minute second <- peek buf l $ "bindColToSqlValue BindColTime" return $ SqlLocalTimeOfDay $ TimeOfDay (fromIntegral hour) (fromIntegral minute) (fromIntegral second) bindColToSqlValue' _ (BindColTimestamp buf) strLen = do StructTimestamp year month day hour minute second nanosecond <- peek buf l $ "bindColToSqlValue BindColTimestamp" return $ SqlLocalTime $ LocalTime (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) (TimeOfDay (fromIntegral hour) (fromIntegral minute) (fromIntegral second + (fromIntegral nanosecond / 1000000000))) bindColToSqlValue' _ (BindColGetData _) _ = error "bindColToSqlValue': unexpected BindColGetData!" fgetcolinfo :: Ptr CStmt -> IO [(String, SqlColDesc)] 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 -- FIXME: needs a faster algorithm. fexecutemany :: SState -> [[SqlValue]] -> IO () fexecutemany sstate arglist = mapM_ (fexecute sstate) arglist >> return () -- Finish and change state public_ffinish :: SState -> IO () public_ffinish sstate = do l "public_ffinish" modifyMVar_ (stomv sstate) freeMStmt modifyMVar_ (bindColsMV sstate) freeBindCols where freeMStmt Nothing = return Nothing freeMStmt (Just sth) = ffinish sth >> return Nothing freeBindCols Nothing = return Nothing freeBindCols (Just bindCols) = do l "public_ffinish: freeing bindcols" mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols return Nothing ffinish :: Stmt -> IO () ffinish stmt = withRawStmt stmt $ sqlFreeHandleSth_app foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc" wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt) foreign import #{CALLCONV} safe "sql.h SQLDescribeCol" sqlDescribeCol :: Ptr CStmt -> #{type SQLSMALLINT} -- ^ Column number -> CString -- ^ Column name -> #{type SQLSMALLINT} -- ^ Buffer length -> Ptr (#{type SQLSMALLINT}) -- ^ name length ptr -> Ptr (#{type SQLSMALLINT}) -- ^ data type ptr -> Ptr (#{type SQLULEN}) -- ^ column size ptr -> Ptr (#{type SQLSMALLINT}) -- ^ decimal digits ptr -> Ptr (#{type SQLSMALLINT}) -- ^ nullable ptr -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLGetData" sqlGetData :: Ptr CStmt -- ^ statement handle -> #{type SQLUSMALLINT} -- ^ Column number -> #{type SQLSMALLINT} -- ^ target type -> CString -- ^ target value pointer (void * in C) -> #{type SQLLEN} -- ^ buffer len -> Ptr (#{type SQLLEN}) -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLBindCol" sqlBindCol :: Ptr CStmt -- ^ statement handle -> #{type SQLUSMALLINT} -- ^ Column number -> #{type SQLSMALLINT} -- ^ target type -> Ptr ColBuf -- ^ target value pointer (void * in C) -> #{type SQLLEN} -- ^ buffer len -> Ptr (#{type SQLLEN}) -- ^ strlen_or_indptr -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleSth_app" sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO () foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer" sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ()) foreign import #{CALLCONV} safe "sql.h SQLPrepare" sqlPrepare :: Ptr CStmt -> CString -> #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLExecute" sqlExecute :: Ptr CStmt -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLAllocHandle" sqlAllocStmtHandle :: #{type SQLSMALLINT} -> Ptr CConn -> Ptr (Ptr CStmt) -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLNumResultCols" sqlNumResultCols :: Ptr CStmt -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLRowCount" sqlRowCount :: Ptr CStmt -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLBindParameter" sqlBindParameter :: Ptr CStmt -- ^ Statement handle -> #{type SQLUSMALLINT} -- ^ Parameter Number -> #{type SQLSMALLINT} -- ^ Input or output -> #{type SQLSMALLINT} -- ^ Value type -> #{type SQLSMALLINT} -- ^ Parameter type -> #{type SQLULEN} -- ^ column size -> #{type SQLSMALLINT} -- ^ decimal digits -> CString -- ^ Parameter value pointer -> #{type SQLLEN} -- ^ buffer length -> Ptr #{type SQLLEN} -- ^ strlen_or_indptr -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h &nullDataHDBC" nullDataHDBC :: Ptr #{type SQLLEN} foreign import #{CALLCONV} safe "sql.h SQLDescribeParam" sqlDescribeParam :: Ptr CStmt -> #{type SQLUSMALLINT} -- ^ parameter number -> Ptr #{type SQLSMALLINT} -- ^ data type ptr -> Ptr #{type SQLULEN} -- ^ parameter size ptr -> Ptr #{type SQLSMALLINT} -- ^ dec digits ptr -> Ptr #{type SQLSMALLINT} -- ^ nullable ptr -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLFetch" sqlFetch :: Ptr CStmt -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables" simpleSqlTables :: Ptr CStmt -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns" simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> #{type SQLSMALLINT} -> IO #{type SQLRETURN} fgetparminfo :: Ptr CStmt -> IO [SqlColDesc] fgetparminfo cstmt = do ncols <- getNumParams cstmt mapM getname [1..ncols] where getname icol = -- alloca $ \colnamelp -> -- allocaBytes 128 $ \cscolname -> alloca $ \datatypeptr -> alloca $ \colsizeptr -> alloca $ \nullableptr -> do poke datatypeptr 127 -- to test if sqlDescribeParam actually writes something to the area res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol) -- cscolname 127 colnamelp datatypeptr colsizeptr nullPtr nullableptr putStrLn $ show res -- We need proper error handling here. Not all ODBC drivers supports SQLDescribeParam. -- Not supporting SQLDescribeParam is quite allright according to the ODBC standard. datatype <- peek datatypeptr colsize <- peek colsizeptr nullable <- peek nullableptr return $ snd $ fromOTypeInfo "" datatype colsize nullable getNumParams :: Ptr CStmt -> IO Int16 getNumParams sthptr = alloca $ \pcount -> do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" (StmtHandle sthptr) peek pcount foreign import #{CALLCONV} safe "sql.h SQLNumParams" sqlNumParams :: Ptr CStmt -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN}