Commits

Bryan O'Sullivan committed c0a0add

Implement ping

Comments (0)

Files changed (2)

Database/MySQL.hs

     -- * Connection management
     , connect
     , close
+    , ping
     ) where
 
 import Data.Typeable (Typeable)
 import Data.IORef
 import Data.Word (Word16)
 import Foreign.C.String
+import Foreign.C.Types
 import Foreign.ForeignPtr hiding (newForeignPtr)
 import Foreign.Concurrent
 import Foreign.Ptr
     } deriving (Eq, Read, Show, Typeable)
 
 data MySQLError = ConnectionError {
-      errNumber :: Int
+      errFunction :: String
+    , errNumber :: Int
     , errMessage :: String
     } deriving (Eq, Show, Typeable)
 
 
 data Connection = Connection {
       connFP :: ForeignPtr MYSQL
-    , connClose :: Closer
+    , connClose :: Ptr MYSQL -> IO ()
     }
 
 data Option = Option
               mysql_real_connect ptr0 chost cuser cpass cdb
                                  (fromIntegral connectPort)
   when (ptr == nullPtr) $
-    connectionError ptr0
+    connectionError "connect" ptr0
   fp <- newForeignPtr ptr $ realClose closed ptr
   return Connection {
                connFP = fp
              , connClose = realClose closed
              }
 
-withString :: String -> (CString -> IO a) -> IO a
-withString [] act = act nullPtr
-withString xs act = withCString xs act
-
 close :: Connection -> IO ()
-close Connection{..} = withForeignPtr connFP connClose
+close conn = withConn conn (connClose conn)
 
 realClose :: IORef Bool -> Ptr MYSQL -> IO ()
 realClose closeInfo ptr = do
   wasClosed <- atomicModifyIORef closeInfo $ \prev -> (True, prev)
   unless wasClosed . withRTSSignalsBlocked $ mysql_close ptr
 
-connectionError :: Ptr MYSQL -> IO a
-connectionError ptr = do
+ping :: Connection -> IO ()
+ping conn = withConn conn $ \ptr ->
+            withRTSSignalsBlocked (mysql_ping ptr) >>= check "ping" ptr
+
+withConn :: Connection -> (Ptr MYSQL -> IO a) -> IO a
+withConn conn = withForeignPtr (connFP conn)
+
+withString :: String -> (CString -> IO a) -> IO a
+withString [] act = act nullPtr
+withString xs act = withCString xs act
+
+check :: String -> Ptr MYSQL -> CInt -> IO ()
+check func ptr r = unless (r == 0) $ connectionError func ptr
+
+connectionError :: String -> Ptr MYSQL -> IO a
+connectionError func ptr = do
   errno <- mysql_errno ptr
   msg <- peekCString =<< mysql_error ptr
-  throw $ ConnectionError (fromIntegral errno) msg
-  
-type Closer = Ptr MYSQL -> IO ()
+  throw $ ConnectionError func (fromIntegral errno) msg

Database/MySQL/C.hsc

     , mysql_init
     , mysql_real_connect
     , mysql_close
+    , mysql_ping
     -- * Error handling
     , mysql_errno
     , mysql_error
 foreign import ccall unsafe mysql_close
     :: Ptr MYSQL -> IO ()
 
+foreign import ccall unsafe mysql_ping
+    :: Ptr MYSQL -> IO CInt
+
 foreign import ccall unsafe mysql_errno
     :: Ptr MYSQL -> IO CInt