Bryan O'Sullivan avatar Bryan O'Sullivan committed 89db97b

Basic result fetching.

Comments (0)

Files changed (2)

Database/MySQL.hs

     , Option(..)
     , defaultConnectInfo
     , Connection
-    , Result(resConnection)
+    , Result(resConnection, resFields)
     , Field
     , Type
     , MySQLError(errFunction, errNumber, errMessage)
     -- ** Results
     , fieldCount
     , affectedRows
+    -- * Working with results
     , storeResult
-    -- * Working with results
+    , fetchRow
     , fetchFields
     -- * General information
     , clientInfo
     , clientVersion
     ) where
 
-import Data.ByteString.Char8
+import Data.ByteString.Char8 (ByteString)
 import Data.ByteString.Internal
 import Data.ByteString.Unsafe
     
 
 data Result = Result {
       resFP :: ForeignPtr MYSQL_RES
+    , resFields :: {-# UNPACK #-} !Int
     , resConnection :: Connection
     }
 
               mysql_real_connect ptr0 chost cuser cpass cdb
                                  (fromIntegral connectPort)
   when (ptr == nullPtr) $
-    connectionError "connect" ptr0
+    connectionError_ "connect" ptr0
   fp <- newForeignPtr ptr $ realClose closed ptr
   return Connection {
                connFP = fp
 
 ping :: Connection -> IO ()
 ping conn = withConn conn $ \ptr ->
-            withRTSSignalsBlocked (mysql_ping ptr) >>= check "ping" ptr
+            withRTSSignalsBlocked (mysql_ping ptr) >>= check "ping" conn
 
 threadId :: Connection -> IO Word
 threadId conn = fromIntegral <$> withConn conn mysql_thread_id
 setCharacterSet conn cs =
   withCString cs $ \ccs ->
     withConn conn $ \ptr ->
-        mysql_set_character_set ptr ccs >>= check "setCharacterSet" ptr
+        mysql_set_character_set ptr ccs >>= check "setCharacterSet" conn
 
 characterSet :: Connection -> IO String
 characterSet conn = withConn conn $ \ptr ->
-                        peekCString =<< mysql_character_set_name ptr
+  peekCString =<< mysql_character_set_name ptr
 
 sslCipher :: Connection -> IO (Maybe String)
-sslCipher conn = withConn conn $ \ptr -> do
-  name <- mysql_get_ssl_cipher ptr
-  if name == nullPtr
-    then return Nothing
-    else Just <$> peekCString name
+sslCipher conn = withConn conn $ \ptr ->
+  withPtr peekCString =<< mysql_get_ssl_cipher ptr
 
 serverStatus :: Connection -> IO String
 serverStatus conn = withConn conn $ \ptr -> do
   st <- withRTSSignalsBlocked $ mysql_stat ptr
-  check "serverStatus" ptr (ptrToIntPtr st)
+  checkNull "serverStatus" conn st
   peekCString st
 
 clientInfo :: String
 
 autocommit :: Connection -> Bool -> IO ()
 autocommit conn onOff = withConn conn $ \ptr ->
-   withRTSSignalsBlocked (mysql_autocommit ptr b) >>= check "autocommit" ptr
+   withRTSSignalsBlocked (mysql_autocommit ptr b) >>= check "autocommit" conn
  where b = if onOff then 1 else 0
 
 changeUser :: Connection -> String -> String -> Maybe String -> IO ()
     withMaybeString mdb $ \cdb ->
      withConn conn $ \ptr ->
       withRTSSignalsBlocked (mysql_change_user ptr cuser cpass cdb) >>=
-      check "changeUser" ptr
+      check "changeUser" conn
 
 selectDB :: Connection -> String -> IO ()
 selectDB conn db = 
   withCString db $ \cdb ->
     withConn conn $ \ptr ->
-      withRTSSignalsBlocked (mysql_select_db ptr cdb) >>= check "selectDB" ptr
+      withRTSSignalsBlocked (mysql_select_db ptr cdb) >>= check "selectDB" conn
 
 query :: Connection -> ByteString -> IO ()
 query conn q = withConn conn $ \ptr ->
   unsafeUseAsCStringLen q $ \(p,l) ->
-  mysql_real_query ptr p (fromIntegral l) >>= check "query" ptr
+  mysql_real_query ptr p (fromIntegral l) >>= check "query" conn
 
 fieldCount :: Connection -> IO Int
 fieldCount conn = withConn conn $ fmap fromIntegral . mysql_field_count
 
 storeResult :: Connection -> IO (Maybe Result)
 storeResult conn = withConn conn $ \ptr -> do
-  res <- mysql_store_result ptr
+  res <- withRTSSignalsBlocked $ mysql_store_result ptr
+  fields <- mysql_field_count ptr
   if res == nullPtr
-    then do
-      n <- mysql_field_count ptr
-      if n == 0
-        then return Nothing
-        else connectionError "storeResult" ptr
+    then if fields == 0
+         then return Nothing
+         else connectionError "storeResult" conn
     else do
       fp <- newForeignPtr res $ mysql_free_result res
       return . Just $ Result {
                    resFP = fp
+                 , resFields = fromIntegral fields
                  , resConnection = conn
                  }
 
+fetchRow :: Result -> IO [Maybe ByteString]
+fetchRow res@Result{..}
+    | resFields == 0 = return []
+    | otherwise      = withRes res $ \ptr -> do
+  rowPtr <- mysql_fetch_row ptr
+  if rowPtr == nullPtr
+    then return []
+    else do
+      lenPtr <- mysql_fetch_lengths ptr
+      checkNull "fetchRow" resConnection lenPtr
+      let go len = withPtr $ \colPtr ->
+                   create (fromIntegral len) $ \d ->
+                   memcpy d (castPtr colPtr) (fromIntegral len)
+      sequence =<< zipWith go <$> peekArray resFields lenPtr
+                              <*> peekArray resFields rowPtr
+
 fetchFields :: Result -> IO [Field]
 fetchFields res = withRes res $ \ptr -> do
   fptr <- withRTSSignalsBlocked $ mysql_fetch_fields ptr
 withMaybeString Nothing act = act nullPtr
 withMaybeString (Just xs) act = withCString xs act
 
-check :: Num a => String -> Ptr MYSQL -> a -> IO ()
-check func ptr r = unless (r == 0) $ connectionError func ptr
+check :: Num a => String -> Connection -> a -> IO ()
+check func conn r = unless (r == 0) $ connectionError func conn
 {-# INLINE check #-}
 
-connectionError :: String -> Ptr MYSQL -> IO a
-connectionError func ptr = do
+checkNull :: String -> Connection -> Ptr a -> IO ()
+checkNull func conn p = when (p == nullPtr) $ connectionError func conn
+{-# INLINE checkNull #-}
+
+withPtr :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
+withPtr act p | p == nullPtr = return Nothing
+              | otherwise    = Just <$> act p
+
+connectionError :: String -> Connection -> IO a
+connectionError func conn = withConn conn $ connectionError_ func
+
+connectionError_ :: String -> Ptr MYSQL -> IO a
+connectionError_ func ptr =do
   errno <- mysql_errno ptr
   msg <- peekCString =<< mysql_error ptr
   throw $ ConnectionError func (fromIntegral errno) msg

Database/MySQL/C.hsc

     -- * Low-level types
     , MYSQL
     , MYSQL_RES
-    , MYSQL_STMT
+    , MYSQL_ROW
     , MyBool
     -- * Connection management
     , mysql_init
     , mysql_field_count
     , mysql_affected_rows
     , mysql_store_result
+    , mysql_use_result
+    , mysql_fetch_lengths
+    , mysql_fetch_row
     -- * Working with results
     , mysql_free_result
     , mysql_fetch_fields
     -- * Error handling
     , mysql_errno
     , mysql_error
-    , mysql_stmt_errno
-    , mysql_stmt_error
     -- * Support functions
     , withRTSSignalsBlocked
     ) where
 import Foreign.C.Types
 import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)
 import Foreign.Ptr (Ptr, castPtr, nullPtr)
-import Foreign.Storable (Storable(..))
 import System.IO.Unsafe (unsafePerformIO)
 import Foreign.Storable
 import Data.Typeable (Typeable)
 
 data MYSQL
 data MYSQL_RES
-data MYSQL_STMT
+type MYSQL_ROW = Ptr (Ptr CChar)
 type MyBool = CChar
 
 -- | Column types supported by MySQL.
 foreign import ccall unsafe mysql_store_result
     :: Ptr MYSQL -> IO (Ptr MYSQL_RES)
 
+foreign import ccall unsafe mysql_use_result
+    :: Ptr MYSQL -> IO (Ptr MYSQL_RES)
+
 foreign import ccall unsafe mysql_free_result
     :: Ptr MYSQL_RES -> IO ()
 
 foreign import ccall unsafe mysql_fetch_fields
     :: Ptr MYSQL_RES -> IO (Ptr Field)
 
+foreign import ccall unsafe mysql_fetch_row
+    :: Ptr MYSQL_RES -> IO MYSQL_ROW
+
+foreign import ccall unsafe mysql_fetch_lengths
+    :: Ptr MYSQL_RES -> IO (Ptr CULong)
+
 foreign import ccall safe mysql_real_escape_string
     :: Ptr MYSQL -> CString -> CString -> CULong -> IO CULong
 
 
 foreign import ccall safe mysql_error
     :: Ptr MYSQL -> IO CString
-
-foreign import ccall safe mysql_stmt_errno
-    :: Ptr MYSQL_STMT -> IO CInt
-
-foreign import ccall safe mysql_stmt_error
-    :: Ptr MYSQL_STMT -> IO CString
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.