Commits

Bryan O'Sullivan committed 5e80e82

Move files around

  • Participants
  • Parent commits 923a9a8

Comments (0)

Files changed (7)

File Database/MySQL.hs

-{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface, RecordWildCards #-}
-
-module Database.MySQL
-    (
-    -- * Resource management
-    -- $mgmt
-    -- * Types
-      ConnectInfo(..)
-    , SSLInfo(..)
-    , Seconds
-    , Protocol(..)
-    , Option(..)
-    , defaultConnectInfo
-    , defaultSSLInfo
-    , Connection
-    , Result
-    , Field
-    , Type(..)
-    , Row
-    , MySQLError(errFunction, errNumber, errMessage)
-    -- * Connection management
-    , connect
-    , close
-    , autocommit
-    , ping
-    , changeUser
-    , selectDB
-    , setCharacterSet
-    -- ** Connection information
-    , threadId
-    , serverInfo
-    , hostInfo
-    , protocolInfo
-    , characterSet
-    , sslCipher
-    , serverStatus
-    -- * Querying
-    , query
-    -- ** Escaping
-    , escape
-    -- ** Results
-    , fieldCount
-    , affectedRows
-    -- * Working with results
-    , isResultValid
-    , freeResult
-    , storeResult
-    , useResult
-    , fetchRow
-    , fetchFields
-    , dataSeek
-    , rowSeek
-    , rowTell
-    -- ** Multiple results
-    , nextResult
-    -- * Transactions
-    , commit
-    , rollback
-    -- * General information
-    , clientInfo
-    , clientVersion
-    ) where
-
-import Data.ByteString.Char8 ()
-import Data.ByteString.Internal
-import Data.ByteString.Unsafe
-import Database.MySQL.Types
-import System.Mem.Weak
-import Data.List    
-import Control.Applicative
-import Data.Int
-import Data.Typeable (Typeable)
-import Control.Exception
-import Control.Monad
-import Database.MySQL.C
-import System.IO.Unsafe
-import Data.IORef
-import Data.Word
-import Foreign.C.String
-import Foreign.C.Types
-import Foreign.ForeignPtr hiding (newForeignPtr)
-import Foreign.Concurrent
-import Foreign.Marshal.Array
-import Foreign.Ptr
-
--- $mgmt
---
--- Our rules for managing 'Connection' and 'Result' values are
--- unfortunately complicated, thanks to MySQL's lifetime rules.
---
--- At the C @libmysqlclient@ level, a single @MYSQL@ connection may
--- cause multiple @MYSQL_RES@ result values to be created over the
--- course of multiple queries, but only one of these @MYSQL_RES@
--- values may be alive at a time.  The programmer is responsible for
--- knowing when to call @mysql_free_result@.
---
--- Meanwhile, up in Haskell-land, we'd like both 'Connection' and
--- 'Result' values to be managed either manually or automatically. In
--- particular, we want finalizers to tidy up after a messy programmer,
--- and we'd prefer it if people didn't need to be mindful of calling
--- @mysql_free_result@. This means that we must wrestle with the
--- lifetime rules. An obvious approach would be to use some monad and
--- type magic to enforce those rules, but then we'd end up with an
--- awkward API.
---
--- Instead, we allow 'Result' values to stay alive for arbitrarily
--- long times, while preserving the right to mark them as
--- invalid. Since all functions over @Result@ values are in the 'IO'
--- monad, we don't risk disrupting pure code by introducing this
--- mutability. Code that tries to access a @Result@ that fails
--- 'isResultValid' will be thrown a 'MySQLError'. This should /not/
--- occur in normal code, so there should be no need to test a @Result@
--- for validity.
---
--- A 'Result' must be able to keep a 'Connection' alive so that a
--- streaming @Result@ constructed by 'useResult' can continue to pull
--- data from the server, but a @Connection@ must (a) be able to cause
--- the @MYSQL_RES@ behind a @Result@ to be deleted at a moment's notice,
--- while (b) not artificially prolonging the life of either the @Result@
--- or its @MYSQL_RES@.
-
-data ConnectInfo = ConnectInfo {
-      connectHost :: String
-    , connectPort :: Word16
-    , connectUser :: String
-    , connectPassword :: String
-    , connectDatabase :: String
-    , connectOptions :: [Option]
-    , connectPath :: FilePath
-    , connectSSL :: Maybe SSLInfo
-    } deriving (Eq, Read, Show, Typeable)
-
-data SSLInfo = SSLInfo {
-      sslKey :: FilePath
-    , sslCert :: FilePath
-    , sslCA :: FilePath
-    , sslCAPath :: FilePath
-    , sslCiphers :: String -- ^ Comma-separated list of cipher names.
-    } deriving (Eq, Read, Show, Typeable)
-
-data MySQLError = ConnectionError {
-      errFunction :: String
-    , errNumber :: Int
-    , errMessage :: String
-    } | ResultError {
-      errFunction :: String
-    , errNumber :: Int
-    , errMessage :: String
-    } deriving (Eq, Show, Typeable)
-
-instance Exception MySQLError
-
-data Connection = Connection {
-      connFP :: ForeignPtr MYSQL
-    , connClose :: IO ()
-    , connResult :: IORef (Maybe (Weak Result))
-    }
-
-data Result = Result {
-      resFP :: ForeignPtr MYSQL_RES
-    , resFields :: {-# UNPACK #-} !Int
-    , resConnection :: Connection
-    , resValid :: IORef Bool
-    , resFetchFields :: Ptr MYSQL_RES -> IO (Ptr Field)
-    , resFetchRow :: Ptr MYSQL_RES -> IO MYSQL_ROW
-    , resFetchLengths :: Ptr MYSQL_RES -> IO (Ptr CULong)
-    } | EmptyResult
-
-defaultConnectInfo :: ConnectInfo
-defaultConnectInfo = ConnectInfo {
-                       connectHost = "localhost"
-                     , connectPort = 3306
-                     , connectUser = "root"
-                     , connectPassword = ""
-                     , connectDatabase = "test"
-                     , connectOptions = []
-                     , connectPath = ""
-                     , connectSSL = Nothing
-                     }
-
-defaultSSLInfo :: SSLInfo
-defaultSSLInfo = SSLInfo {
-                   sslKey = ""
-                 , sslCert = ""
-                 , sslCA = ""
-                 , sslCAPath = ""
-                 , sslCiphers = ""
-                 }
-
-connect :: ConnectInfo -> IO Connection
-connect ConnectInfo{..} = do
-  closed <- newIORef False
-  ptr0 <- mysql_init nullPtr
-  case connectSSL of
-    Nothing -> return ()
-    Just SSLInfo{..} -> withString sslKey $ \ckey ->
-                         withString sslCert $ \ccert ->
-                          withString sslCA $ \cca ->
-                           withString sslCAPath $ \ccapath ->
-                            withString sslCiphers $ \ccipher ->
-                             mysql_ssl_set ptr0 ckey ccert cca ccapath ccipher
-                             >> return ()
-  forM_ connectOptions $ \opt -> do
-    r <- mysql_options ptr0 opt
-    unless (r == 0) $ connectionError_ "connect" ptr0
-  let flags = foldl' (+) 0 . map toConnectFlag $ connectOptions
-  ptr <- withString connectHost $ \chost ->
-          withString connectUser $ \cuser ->
-           withString connectPassword $ \cpass ->
-            withString connectDatabase $ \cdb ->
-             withString connectPath $ \cpath ->
-              withRTSSignalsBlocked $
-               mysql_real_connect ptr0 chost cuser cpass cdb
-                                  (fromIntegral connectPort) cpath flags
-  when (ptr == nullPtr) $
-    connectionError_ "connect" ptr0
-  res <- newIORef Nothing
-  let realClose = do
-        cleanupConnResult res
-        wasClosed <- atomicModifyIORef closed $ \prev -> (True, prev)
-        unless wasClosed . withRTSSignalsBlocked $ mysql_close ptr
-  fp <- newForeignPtr ptr realClose
-  return Connection {
-               connFP = fp
-             , connClose = realClose
-             , connResult = res
-             }
-
--- | Delete the 'MYSQL_RES' behind a 'Result' immediately, and mark
--- the 'Result' as invalid.
-cleanupConnResult :: IORef (Maybe (Weak Result)) -> IO ()
-cleanupConnResult res = do
-  prev <- readIORef res
-  case prev of
-    Nothing -> return ()
-    Just w -> maybe (return ()) freeResult =<< deRefWeak w
-
-close :: Connection -> IO ()
-close = connClose
-{-# INLINE close #-}
-
-ping :: Connection -> IO ()
-ping conn = withConn conn $ \ptr ->
-            withRTSSignalsBlocked (mysql_ping ptr) >>= check "ping" conn
-
-threadId :: Connection -> IO Word
-threadId conn = fromIntegral <$> withConn conn mysql_thread_id
-
-serverInfo :: Connection -> IO String
-serverInfo conn = withConn conn $ \ptr ->
-                  peekCString =<< mysql_get_server_info ptr
-
-hostInfo :: Connection -> IO String
-hostInfo conn = withConn conn $ \ptr ->
-                peekCString =<< mysql_get_host_info ptr
-
-protocolInfo :: Connection -> IO Word
-protocolInfo conn = withConn conn $ \ptr ->
-                    fromIntegral <$> mysql_get_proto_info ptr
-
-setCharacterSet :: Connection -> String -> IO ()
-setCharacterSet conn cs =
-  withCString cs $ \ccs ->
-    withConn conn $ \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
-
-sslCipher :: Connection -> IO (Maybe String)
-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
-  checkNull "serverStatus" conn st
-  peekCString st
-
-clientInfo :: String
-clientInfo = unsafePerformIO $ peekCString mysql_get_client_info
-{-# NOINLINE clientInfo #-}
-
-clientVersion :: Word
-clientVersion = fromIntegral mysql_get_client_version
-{-# NOINLINE clientVersion #-}
-
-autocommit :: Connection -> Bool -> IO ()
-autocommit conn onOff = withConn conn $ \ptr ->
-   withRTSSignalsBlocked (mysql_autocommit ptr b) >>= check "autocommit" conn
- where b = if onOff then 1 else 0
-
-changeUser :: Connection -> String -> String -> Maybe String -> IO ()
-changeUser conn user pass mdb =
-  withCString user $ \cuser ->
-   withCString pass $ \cpass ->
-    withMaybeString mdb $ \cdb ->
-     withConn conn $ \ptr ->
-      withRTSSignalsBlocked (mysql_change_user ptr cuser cpass cdb) >>=
-      check "changeUser" conn
-
-selectDB :: Connection -> String -> IO ()
-selectDB conn db = 
-  withCString db $ \cdb ->
-    withConn conn $ \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" conn
-
-fieldCount :: Either Connection Result -> IO Int
-fieldCount (Right EmptyResult) = return 0
-fieldCount (Right res)         = return (resFields res)
-fieldCount (Left conn)         =
-    withConn conn $ fmap fromIntegral . mysql_field_count
-
-affectedRows :: Connection -> IO Int64
-affectedRows conn = withConn conn $ fmap fromIntegral . mysql_affected_rows
-
-storeResult :: Connection -> IO Result
-storeResult = frobResult "storeResult" mysql_store_result
-              mysql_fetch_fields_nonblock
-              mysql_fetch_row_nonblock
-              mysql_fetch_lengths_nonblock
-
-useResult :: Connection -> IO Result
-useResult = frobResult "useResult" mysql_use_result
-            (withRTSSignalsBlocked . mysql_fetch_fields)
-            (withRTSSignalsBlocked . mysql_fetch_row)
-            (withRTSSignalsBlocked . mysql_fetch_lengths)
-
-frobResult :: String
-           -> (Ptr MYSQL -> IO (Ptr MYSQL_RES))
-           -> (Ptr MYSQL_RES -> IO (Ptr Field))
-           -> (Ptr MYSQL_RES -> IO MYSQL_ROW)
-           -> (Ptr MYSQL_RES -> IO (Ptr CULong))
-           -> Connection -> IO Result
-frobResult func frob fetchFieldsFunc fetchRowFunc fetchLengthsFunc conn =
-  withConn conn $ \ptr -> do
-    cleanupConnResult (connResult conn)
-    res <- withRTSSignalsBlocked $ frob ptr
-    fields <- mysql_field_count ptr
-    valid <- newIORef True
-    if res == nullPtr
-      then if fields == 0
-           then return EmptyResult
-           else connectionError func conn
-      else do
-        fp <- newForeignPtr res $ freeResult_ valid res
-        let ret = Result {
-                    resFP = fp
-                  , resFields = fromIntegral fields
-                  , resConnection = conn
-                  , resValid = valid
-                  , resFetchFields = fetchFieldsFunc
-                  , resFetchRow = fetchRowFunc
-                  , resFetchLengths = fetchLengthsFunc
-                  }
-        weak <- mkWeakPtr ret (Just (freeResult_ valid res))
-        writeIORef (connResult conn) (Just weak)
-        return ret
-
-freeResult :: Result -> IO ()
-freeResult Result{..}      = withForeignPtr resFP $ freeResult_ resValid
-freeResult EmptyResult{..} = return ()
-
-isResultValid :: Result -> IO Bool
-isResultValid Result{..}  = readIORef resValid
-isResultValid EmptyResult = return False
-            
-freeResult_ :: IORef Bool -> Ptr MYSQL_RES -> IO ()
-freeResult_ valid ptr = do
-  wasValid <- atomicModifyIORef valid $ \prev -> (False, prev)
-  when wasValid $ mysql_free_result ptr
-    
-fetchRow :: Result -> IO [Maybe ByteString]
-fetchRow res@Result{..}  = withRes "fetchRow" res $ \ptr -> do
-  rowPtr <- resFetchRow ptr
-  if rowPtr == nullPtr
-    then return []
-    else do
-      lenPtr <- resFetchLengths 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
-fetchRow EmptyResult{..} = return []
-
-fetchFields :: Result -> IO [Field]
-fetchFields res@Result{..} = withRes "fetchFields" res $ \ptr -> do
-  peekArray resFields =<< resFetchFields ptr
-fetchFields EmptyResult{..} = return []
-
-newtype Row = Row MYSQL_ROW_OFFSET
-
-dataSeek :: Result -> Int64 -> IO ()
-dataSeek res row = withRes "dataSeek" res $ \ptr ->
-  mysql_data_seek ptr (fromIntegral row)
-
-rowTell :: Result -> IO Row
-rowTell res = withRes "rowTell" res $ \ptr ->
-  Row <$> mysql_row_tell ptr
-
-rowSeek :: Result -> Row -> IO Row
-rowSeek res (Row row) = withRes "rowSeek" res $ \ptr ->
-  Row <$> mysql_row_seek ptr row
-
-nextResult :: Connection -> IO Bool
-nextResult conn = withConn conn $ \ptr -> do
-  i <- withRTSSignalsBlocked $ mysql_next_result ptr
-  case i of
-    0  -> return True
-    -1 -> return False
-    _  -> connectionError "nextResult" conn
-
-commit :: Connection -> IO ()
-commit conn = withConn conn $ \ptr ->
-              mysql_commit ptr >>= check "commit" conn
-
-rollback :: Connection -> IO ()
-rollback conn = withConn conn $ \ptr ->
-                mysql_rollback ptr >>= check "rollback" conn
-
-escape :: Connection -> ByteString -> IO ByteString
-escape conn bs = withConn conn $ \ptr ->
-  unsafeUseAsCStringLen bs $ \(p,l) ->
-    createAndTrim (l*2 + 1) $ \to ->
-      fromIntegral <$> mysql_real_escape_string ptr (castPtr to) p
-                                                (fromIntegral l)
-
-withConn :: Connection -> (Ptr MYSQL -> IO a) -> IO a
-withConn conn = withForeignPtr (connFP conn)
-
-withRes :: String -> Result -> (Ptr MYSQL_RES -> IO a) -> IO a
-withRes func res act = do
-  valid <- readIORef (resValid res)
-  unless valid . throw $ ResultError func 0 "result is no longer usable"
-  withForeignPtr (resFP res) act
-
-withString :: String -> (CString -> IO a) -> IO a
-withString [] act = act nullPtr
-withString xs act = withCString xs act
-
-withMaybeString :: Maybe String -> (CString -> IO a) -> IO a
-withMaybeString Nothing act = act nullPtr
-withMaybeString (Just xs) act = withCString xs act
-
-check :: Num a => String -> Connection -> a -> IO ()
-check func conn r = unless (r == 0) $ connectionError func conn
-{-# INLINE check #-}
-
-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

File Database/MySQL/Base.hs

+{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface, RecordWildCards #-}
+
+module Database.MySQL.Base
+    (
+    -- * Resource management
+    -- $mgmt
+    -- * Types
+      ConnectInfo(..)
+    , SSLInfo(..)
+    , Seconds
+    , Protocol(..)
+    , Option(..)
+    , defaultConnectInfo
+    , defaultSSLInfo
+    , Connection
+    , Result
+    , Field
+    , Type(..)
+    , Row
+    , MySQLError(errFunction, errNumber, errMessage)
+    -- * Connection management
+    , connect
+    , close
+    , autocommit
+    , ping
+    , changeUser
+    , selectDB
+    , setCharacterSet
+    -- ** Connection information
+    , threadId
+    , serverInfo
+    , hostInfo
+    , protocolInfo
+    , characterSet
+    , sslCipher
+    , serverStatus
+    -- * Querying
+    , query
+    -- ** Escaping
+    , escape
+    -- ** Results
+    , fieldCount
+    , affectedRows
+    -- * Working with results
+    , isResultValid
+    , freeResult
+    , storeResult
+    , useResult
+    , fetchRow
+    , fetchFields
+    , dataSeek
+    , rowSeek
+    , rowTell
+    -- ** Multiple results
+    , nextResult
+    -- * Transactions
+    , commit
+    , rollback
+    -- * General information
+    , clientInfo
+    , clientVersion
+    ) where
+
+import Data.ByteString.Char8 ()
+import Data.ByteString.Internal
+import Data.ByteString.Unsafe
+import Database.MySQL.Base.Types
+import System.Mem.Weak
+import Data.List    
+import Control.Applicative
+import Data.Int
+import Data.Typeable (Typeable)
+import Control.Exception
+import Control.Monad
+import Database.MySQL.Base.C
+import System.IO.Unsafe
+import Data.IORef
+import Data.Word
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.ForeignPtr hiding (newForeignPtr)
+import Foreign.Concurrent
+import Foreign.Marshal.Array
+import Foreign.Ptr
+
+-- $mgmt
+--
+-- Our rules for managing 'Connection' and 'Result' values are
+-- unfortunately complicated, thanks to MySQL's lifetime rules.
+--
+-- At the C @libmysqlclient@ level, a single @MYSQL@ connection may
+-- cause multiple @MYSQL_RES@ result values to be created over the
+-- course of multiple queries, but only one of these @MYSQL_RES@
+-- values may be alive at a time.  The programmer is responsible for
+-- knowing when to call @mysql_free_result@.
+--
+-- Meanwhile, up in Haskell-land, we'd like both 'Connection' and
+-- 'Result' values to be managed either manually or automatically. In
+-- particular, we want finalizers to tidy up after a messy programmer,
+-- and we'd prefer it if people didn't need to be mindful of calling
+-- @mysql_free_result@. This means that we must wrestle with the
+-- lifetime rules. An obvious approach would be to use some monad and
+-- type magic to enforce those rules, but then we'd end up with an
+-- awkward API.
+--
+-- Instead, we allow 'Result' values to stay alive for arbitrarily
+-- long times, while preserving the right to mark them as
+-- invalid. Since all functions over @Result@ values are in the 'IO'
+-- monad, we don't risk disrupting pure code by introducing this
+-- mutability. Code that tries to access a @Result@ that fails
+-- 'isResultValid' will be thrown a 'MySQLError'. This should /not/
+-- occur in normal code, so there should be no need to test a @Result@
+-- for validity.
+--
+-- A 'Result' must be able to keep a 'Connection' alive so that a
+-- streaming @Result@ constructed by 'useResult' can continue to pull
+-- data from the server, but a @Connection@ must (a) be able to cause
+-- the @MYSQL_RES@ behind a @Result@ to be deleted at a moment's notice,
+-- while (b) not artificially prolonging the life of either the @Result@
+-- or its @MYSQL_RES@.
+
+data ConnectInfo = ConnectInfo {
+      connectHost :: String
+    , connectPort :: Word16
+    , connectUser :: String
+    , connectPassword :: String
+    , connectDatabase :: String
+    , connectOptions :: [Option]
+    , connectPath :: FilePath
+    , connectSSL :: Maybe SSLInfo
+    } deriving (Eq, Read, Show, Typeable)
+
+data SSLInfo = SSLInfo {
+      sslKey :: FilePath
+    , sslCert :: FilePath
+    , sslCA :: FilePath
+    , sslCAPath :: FilePath
+    , sslCiphers :: String -- ^ Comma-separated list of cipher names.
+    } deriving (Eq, Read, Show, Typeable)
+
+data MySQLError = ConnectionError {
+      errFunction :: String
+    , errNumber :: Int
+    , errMessage :: String
+    } | ResultError {
+      errFunction :: String
+    , errNumber :: Int
+    , errMessage :: String
+    } deriving (Eq, Show, Typeable)
+
+instance Exception MySQLError
+
+data Connection = Connection {
+      connFP :: ForeignPtr MYSQL
+    , connClose :: IO ()
+    , connResult :: IORef (Maybe (Weak Result))
+    }
+
+data Result = Result {
+      resFP :: ForeignPtr MYSQL_RES
+    , resFields :: {-# UNPACK #-} !Int
+    , resConnection :: Connection
+    , resValid :: IORef Bool
+    , resFetchFields :: Ptr MYSQL_RES -> IO (Ptr Field)
+    , resFetchRow :: Ptr MYSQL_RES -> IO MYSQL_ROW
+    , resFetchLengths :: Ptr MYSQL_RES -> IO (Ptr CULong)
+    } | EmptyResult
+
+defaultConnectInfo :: ConnectInfo
+defaultConnectInfo = ConnectInfo {
+                       connectHost = "localhost"
+                     , connectPort = 3306
+                     , connectUser = "root"
+                     , connectPassword = ""
+                     , connectDatabase = "test"
+                     , connectOptions = []
+                     , connectPath = ""
+                     , connectSSL = Nothing
+                     }
+
+defaultSSLInfo :: SSLInfo
+defaultSSLInfo = SSLInfo {
+                   sslKey = ""
+                 , sslCert = ""
+                 , sslCA = ""
+                 , sslCAPath = ""
+                 , sslCiphers = ""
+                 }
+
+connect :: ConnectInfo -> IO Connection
+connect ConnectInfo{..} = do
+  closed <- newIORef False
+  ptr0 <- mysql_init nullPtr
+  case connectSSL of
+    Nothing -> return ()
+    Just SSLInfo{..} -> withString sslKey $ \ckey ->
+                         withString sslCert $ \ccert ->
+                          withString sslCA $ \cca ->
+                           withString sslCAPath $ \ccapath ->
+                            withString sslCiphers $ \ccipher ->
+                             mysql_ssl_set ptr0 ckey ccert cca ccapath ccipher
+                             >> return ()
+  forM_ connectOptions $ \opt -> do
+    r <- mysql_options ptr0 opt
+    unless (r == 0) $ connectionError_ "connect" ptr0
+  let flags = foldl' (+) 0 . map toConnectFlag $ connectOptions
+  ptr <- withString connectHost $ \chost ->
+          withString connectUser $ \cuser ->
+           withString connectPassword $ \cpass ->
+            withString connectDatabase $ \cdb ->
+             withString connectPath $ \cpath ->
+              withRTSSignalsBlocked $
+               mysql_real_connect ptr0 chost cuser cpass cdb
+                                  (fromIntegral connectPort) cpath flags
+  when (ptr == nullPtr) $
+    connectionError_ "connect" ptr0
+  res <- newIORef Nothing
+  let realClose = do
+        cleanupConnResult res
+        wasClosed <- atomicModifyIORef closed $ \prev -> (True, prev)
+        unless wasClosed . withRTSSignalsBlocked $ mysql_close ptr
+  fp <- newForeignPtr ptr realClose
+  return Connection {
+               connFP = fp
+             , connClose = realClose
+             , connResult = res
+             }
+
+-- | Delete the 'MYSQL_RES' behind a 'Result' immediately, and mark
+-- the 'Result' as invalid.
+cleanupConnResult :: IORef (Maybe (Weak Result)) -> IO ()
+cleanupConnResult res = do
+  prev <- readIORef res
+  case prev of
+    Nothing -> return ()
+    Just w -> maybe (return ()) freeResult =<< deRefWeak w
+
+close :: Connection -> IO ()
+close = connClose
+{-# INLINE close #-}
+
+ping :: Connection -> IO ()
+ping conn = withConn conn $ \ptr ->
+            withRTSSignalsBlocked (mysql_ping ptr) >>= check "ping" conn
+
+threadId :: Connection -> IO Word
+threadId conn = fromIntegral <$> withConn conn mysql_thread_id
+
+serverInfo :: Connection -> IO String
+serverInfo conn = withConn conn $ \ptr ->
+                  peekCString =<< mysql_get_server_info ptr
+
+hostInfo :: Connection -> IO String
+hostInfo conn = withConn conn $ \ptr ->
+                peekCString =<< mysql_get_host_info ptr
+
+protocolInfo :: Connection -> IO Word
+protocolInfo conn = withConn conn $ \ptr ->
+                    fromIntegral <$> mysql_get_proto_info ptr
+
+setCharacterSet :: Connection -> String -> IO ()
+setCharacterSet conn cs =
+  withCString cs $ \ccs ->
+    withConn conn $ \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
+
+sslCipher :: Connection -> IO (Maybe String)
+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
+  checkNull "serverStatus" conn st
+  peekCString st
+
+clientInfo :: String
+clientInfo = unsafePerformIO $ peekCString mysql_get_client_info
+{-# NOINLINE clientInfo #-}
+
+clientVersion :: Word
+clientVersion = fromIntegral mysql_get_client_version
+{-# NOINLINE clientVersion #-}
+
+autocommit :: Connection -> Bool -> IO ()
+autocommit conn onOff = withConn conn $ \ptr ->
+   withRTSSignalsBlocked (mysql_autocommit ptr b) >>= check "autocommit" conn
+ where b = if onOff then 1 else 0
+
+changeUser :: Connection -> String -> String -> Maybe String -> IO ()
+changeUser conn user pass mdb =
+  withCString user $ \cuser ->
+   withCString pass $ \cpass ->
+    withMaybeString mdb $ \cdb ->
+     withConn conn $ \ptr ->
+      withRTSSignalsBlocked (mysql_change_user ptr cuser cpass cdb) >>=
+      check "changeUser" conn
+
+selectDB :: Connection -> String -> IO ()
+selectDB conn db = 
+  withCString db $ \cdb ->
+    withConn conn $ \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" conn
+
+fieldCount :: Either Connection Result -> IO Int
+fieldCount (Right EmptyResult) = return 0
+fieldCount (Right res)         = return (resFields res)
+fieldCount (Left conn)         =
+    withConn conn $ fmap fromIntegral . mysql_field_count
+
+affectedRows :: Connection -> IO Int64
+affectedRows conn = withConn conn $ fmap fromIntegral . mysql_affected_rows
+
+storeResult :: Connection -> IO Result
+storeResult = frobResult "storeResult" mysql_store_result
+              mysql_fetch_fields_nonblock
+              mysql_fetch_row_nonblock
+              mysql_fetch_lengths_nonblock
+
+useResult :: Connection -> IO Result
+useResult = frobResult "useResult" mysql_use_result
+            (withRTSSignalsBlocked . mysql_fetch_fields)
+            (withRTSSignalsBlocked . mysql_fetch_row)
+            (withRTSSignalsBlocked . mysql_fetch_lengths)
+
+frobResult :: String
+           -> (Ptr MYSQL -> IO (Ptr MYSQL_RES))
+           -> (Ptr MYSQL_RES -> IO (Ptr Field))
+           -> (Ptr MYSQL_RES -> IO MYSQL_ROW)
+           -> (Ptr MYSQL_RES -> IO (Ptr CULong))
+           -> Connection -> IO Result
+frobResult func frob fetchFieldsFunc fetchRowFunc fetchLengthsFunc conn =
+  withConn conn $ \ptr -> do
+    cleanupConnResult (connResult conn)
+    res <- withRTSSignalsBlocked $ frob ptr
+    fields <- mysql_field_count ptr
+    valid <- newIORef True
+    if res == nullPtr
+      then if fields == 0
+           then return EmptyResult
+           else connectionError func conn
+      else do
+        fp <- newForeignPtr res $ freeResult_ valid res
+        let ret = Result {
+                    resFP = fp
+                  , resFields = fromIntegral fields
+                  , resConnection = conn
+                  , resValid = valid
+                  , resFetchFields = fetchFieldsFunc
+                  , resFetchRow = fetchRowFunc
+                  , resFetchLengths = fetchLengthsFunc
+                  }
+        weak <- mkWeakPtr ret (Just (freeResult_ valid res))
+        writeIORef (connResult conn) (Just weak)
+        return ret
+
+freeResult :: Result -> IO ()
+freeResult Result{..}      = withForeignPtr resFP $ freeResult_ resValid
+freeResult EmptyResult{..} = return ()
+
+isResultValid :: Result -> IO Bool
+isResultValid Result{..}  = readIORef resValid
+isResultValid EmptyResult = return False
+            
+freeResult_ :: IORef Bool -> Ptr MYSQL_RES -> IO ()
+freeResult_ valid ptr = do
+  wasValid <- atomicModifyIORef valid $ \prev -> (False, prev)
+  when wasValid $ mysql_free_result ptr
+    
+fetchRow :: Result -> IO [Maybe ByteString]
+fetchRow res@Result{..}  = withRes "fetchRow" res $ \ptr -> do
+  rowPtr <- resFetchRow ptr
+  if rowPtr == nullPtr
+    then return []
+    else do
+      lenPtr <- resFetchLengths 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
+fetchRow EmptyResult{..} = return []
+
+fetchFields :: Result -> IO [Field]
+fetchFields res@Result{..} = withRes "fetchFields" res $ \ptr -> do
+  peekArray resFields =<< resFetchFields ptr
+fetchFields EmptyResult{..} = return []
+
+newtype Row = Row MYSQL_ROW_OFFSET
+
+dataSeek :: Result -> Int64 -> IO ()
+dataSeek res row = withRes "dataSeek" res $ \ptr ->
+  mysql_data_seek ptr (fromIntegral row)
+
+rowTell :: Result -> IO Row
+rowTell res = withRes "rowTell" res $ \ptr ->
+  Row <$> mysql_row_tell ptr
+
+rowSeek :: Result -> Row -> IO Row
+rowSeek res (Row row) = withRes "rowSeek" res $ \ptr ->
+  Row <$> mysql_row_seek ptr row
+
+nextResult :: Connection -> IO Bool
+nextResult conn = withConn conn $ \ptr -> do
+  i <- withRTSSignalsBlocked $ mysql_next_result ptr
+  case i of
+    0  -> return True
+    -1 -> return False
+    _  -> connectionError "nextResult" conn
+
+commit :: Connection -> IO ()
+commit conn = withConn conn $ \ptr ->
+              mysql_commit ptr >>= check "commit" conn
+
+rollback :: Connection -> IO ()
+rollback conn = withConn conn $ \ptr ->
+                mysql_rollback ptr >>= check "rollback" conn
+
+escape :: Connection -> ByteString -> IO ByteString
+escape conn bs = withConn conn $ \ptr ->
+  unsafeUseAsCStringLen bs $ \(p,l) ->
+    createAndTrim (l*2 + 1) $ \to ->
+      fromIntegral <$> mysql_real_escape_string ptr (castPtr to) p
+                                                (fromIntegral l)
+
+withConn :: Connection -> (Ptr MYSQL -> IO a) -> IO a
+withConn conn = withForeignPtr (connFP conn)
+
+withRes :: String -> Result -> (Ptr MYSQL_RES -> IO a) -> IO a
+withRes func res act = do
+  valid <- readIORef (resValid res)
+  unless valid . throw $ ResultError func 0 "result is no longer usable"
+  withForeignPtr (resFP res) act
+
+withString :: String -> (CString -> IO a) -> IO a
+withString [] act = act nullPtr
+withString xs act = withCString xs act
+
+withMaybeString :: Maybe String -> (CString -> IO a) -> IO a
+withMaybeString Nothing act = act nullPtr
+withMaybeString (Just xs) act = withCString xs act
+
+check :: Num a => String -> Connection -> a -> IO ()
+check func conn r = unless (r == 0) $ connectionError func conn
+{-# INLINE check #-}
+
+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

File Database/MySQL/Base/C.hsc

+{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}
+
+module Database.MySQL.Base.C
+    (
+    -- * Connection management
+      mysql_init
+    , mysql_options
+    , mysql_ssl_set
+    , mysql_real_connect
+    , mysql_close
+    , mysql_ping
+    , mysql_autocommit
+    , mysql_change_user
+    , mysql_select_db
+    , mysql_set_character_set
+    -- ** Connection information
+    , mysql_thread_id
+    , mysql_get_server_info
+    , mysql_get_host_info
+    , mysql_get_proto_info
+    , mysql_character_set_name
+    , mysql_get_ssl_cipher
+    , mysql_stat
+    -- * Querying
+    , mysql_real_query
+    -- ** Escaping
+    , mysql_real_escape_string
+    -- ** Results
+    , mysql_field_count
+    , mysql_affected_rows
+    , mysql_store_result
+    , mysql_use_result
+    , mysql_fetch_lengths
+    , mysql_fetch_lengths_nonblock
+    , mysql_fetch_row
+    , mysql_fetch_row_nonblock
+    -- * Working with results
+    , mysql_free_result
+    , mysql_fetch_fields
+    , mysql_fetch_fields_nonblock
+    , mysql_data_seek
+    , mysql_row_seek
+    , mysql_row_tell
+    -- ** Multiple results
+    , mysql_next_result
+    -- * Transactions
+    , mysql_commit
+    , mysql_rollback
+    -- * General information
+    , mysql_get_client_info
+    , mysql_get_client_version
+    -- * Error handling
+    , mysql_errno
+    , mysql_error
+    -- * Support functions
+    , withRTSSignalsBlocked
+    ) where
+
+#include "mysql.h"
+#include <signal.h>
+
+import Database.MySQL.Base.Types
+import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread)
+import Control.Exception (finally)
+import Foreign.C.Types
+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)
+import Foreign.Ptr (Ptr, nullPtr)
+import System.IO.Unsafe (unsafePerformIO)
+import Foreign.Storable
+import Foreign.Marshal.Utils
+import Data.ByteString.Unsafe
+import Foreign.C.String
+
+-- | Execute an 'IO' action with signals used by GHC's runtime signals
+-- blocked.  The @mysqlclient@ C library does not correctly restart
+-- system calls if they are interrupted by signals, so many MySQL API
+-- calls can unexpectedly fail when called from a Haskell application.
+-- This is most likely to occur if you are linking against GHC's
+-- threaded runtime (using the @-threaded@ option).
+--
+-- This function blocks @SIGALRM@ and @SIGVTALRM@, runs your action,
+-- then unblocks those signals.  If you have a series of HDBC calls
+-- that may block for a period of time, it may be wise to wrap them in
+-- this action.  Blocking and unblocking signals is cheap, but not
+-- free.
+--
+-- Here is an example of an exception that could be avoided by
+-- temporarily blocking GHC's runtime signals:
+--
+-- >  SqlError {
+-- >    seState = "", 
+-- >    seNativeError = 2003, 
+-- >    seErrorMsg = "Can't connect to MySQL server on 'localhost' (4)"
+-- >  }
+withRTSSignalsBlocked :: IO a -> IO a
+withRTSSignalsBlocked act
+    | not rtsSupportsBoundThreads = act
+    | otherwise = runInBoundThread . withForeignPtr rtsSignals $ \set -> do
+  pthread_sigmask (#const SIG_BLOCK) set nullPtr
+  act `finally` pthread_sigmask (#const SIG_UNBLOCK) set nullPtr
+
+rtsSignals :: ForeignPtr SigSet
+rtsSignals = unsafePerformIO $ do
+               fp <- mallocForeignPtr
+               withForeignPtr fp $ \set -> do
+                 sigemptyset set
+                 sigaddset set (#const SIGALRM)
+                 sigaddset set (#const SIGVTALRM)
+               return fp
+{-# NOINLINE rtsSignals #-}
+
+data SigSet
+
+instance Storable SigSet where
+    sizeOf    _ = #{size sigset_t}
+    alignment _ = alignment (undefined :: Ptr CInt)
+
+foreign import ccall unsafe "signal.h sigaddset" sigaddset
+    :: Ptr SigSet -> CInt -> IO ()
+
+foreign import ccall unsafe "signal.h sigemptyset" sigemptyset
+    :: Ptr SigSet -> IO ()
+
+foreign import ccall unsafe "signal.h pthread_sigmask" pthread_sigmask
+    :: CInt -> Ptr SigSet -> Ptr SigSet -> IO ()
+
+foreign import ccall safe mysql_init
+    :: Ptr MYSQL                -- ^ should usually be 'nullPtr'
+    -> IO (Ptr MYSQL)
+
+mysql_options :: Ptr MYSQL -> Option -> IO CInt
+mysql_options ptr opt =
+    case opt of
+      ConnectTimeout secs ->
+        withIntegral secs $ go (#const MYSQL_OPT_CONNECT_TIMEOUT)
+      Compress ->
+        go (#const MYSQL_OPT_COMPRESS) nullPtr
+      NamedPipe ->
+        go (#const MYSQL_OPT_NAMED_PIPE) nullPtr
+      InitCommand cmd ->
+        unsafeUseAsCString cmd $ go (#const MYSQL_INIT_COMMAND)
+      ReadDefaultFile path ->
+        withCString path $ go (#const MYSQL_READ_DEFAULT_FILE)
+      ReadDefaultGroup group ->
+        unsafeUseAsCString group $ go (#const MYSQL_READ_DEFAULT_GROUP)
+      CharsetDir path ->
+        withCString path $ go (#const MYSQL_SET_CHARSET_DIR)
+      CharsetName cs ->
+        withCString cs $ go (#const MYSQL_SET_CHARSET_NAME)
+      LocalInFile b ->
+        withBool b $ go (#const MYSQL_OPT_LOCAL_INFILE)
+      Protocol proto ->
+        withIntegral (fromEnum proto) $ go (#const MYSQL_OPT_PROTOCOL)
+      SharedMemoryBaseName name ->
+        unsafeUseAsCString name $ go (#const MYSQL_SHARED_MEMORY_BASE_NAME)
+      ReadTimeout secs ->
+        withIntegral secs $ go (#const MYSQL_OPT_READ_TIMEOUT)
+      WriteTimeout secs ->
+        withIntegral secs $ go (#const MYSQL_OPT_WRITE_TIMEOUT)
+      UseRemoteConnection ->
+        go (#const MYSQL_OPT_USE_REMOTE_CONNECTION) nullPtr
+      UseEmbeddedConnection ->
+        go (#const MYSQL_OPT_USE_EMBEDDED_CONNECTION) nullPtr
+      GuessConnection ->
+        go (#const MYSQL_OPT_GUESS_CONNECTION) nullPtr
+      ClientIP ip ->
+        unsafeUseAsCString ip $ go (#const MYSQL_SET_CLIENT_IP)
+      SecureAuth b ->
+        withBool b $ go (#const MYSQL_SECURE_AUTH)
+      ReportDataTruncation b ->
+        withBool b $ go (#const MYSQL_REPORT_DATA_TRUNCATION)
+      Reconnect b ->
+        withBool b $ go (#const MYSQL_OPT_RECONNECT)
+      SSLVerifyServerCert b ->
+        withBool b $ go (#const MYSQL_OPT_SSL_VERIFY_SERVER_CERT)
+      -- Other options are accepted by mysql_real_connect, so ignore them.
+      _ -> return 0
+  where
+    go = mysql_options_ ptr
+    withBool b = with (if b then 1 else 0 :: CUInt)
+    withIntegral i = with (fromIntegral i :: CUInt)
+
+foreign import ccall safe "mysql.h mysql_options" mysql_options_
+    :: Ptr MYSQL -> CInt -> Ptr a -> IO CInt
+
+foreign import ccall unsafe mysql_real_connect
+    :: Ptr MYSQL -- ^ Context (from 'mysql_init').
+    -> CString   -- ^ Host name.
+    -> CString   -- ^ User name.
+    -> CString   -- ^ Password.
+    -> CString   -- ^ Database.
+    -> CInt      -- ^ Port.
+    -> CString   -- ^ Unix socket.
+    -> CULong    -- ^ Flags.
+    -> IO (Ptr MYSQL)
+
+foreign import ccall safe mysql_ssl_set
+    :: Ptr MYSQL
+    -> CString                  -- ^ Key.
+    -> CString                  -- ^ Cert.
+    -> CString                  -- ^ CA.
+    -> CString                  -- ^ CA path.
+    -> CString                  -- ^ Ciphers.
+    -> IO MyBool
+
+foreign import ccall unsafe mysql_close
+    :: Ptr MYSQL -> IO ()
+
+foreign import ccall unsafe mysql_ping
+    :: Ptr MYSQL -> IO CInt
+
+foreign import ccall safe mysql_thread_id
+    :: Ptr MYSQL -> IO CULong
+
+foreign import ccall unsafe mysql_autocommit
+    :: Ptr MYSQL -> MyBool -> IO MyBool
+
+foreign import ccall unsafe mysql_change_user
+    :: Ptr MYSQL
+    -> CString                  -- ^ user
+    -> CString                  -- ^ password
+    -> CString                  -- ^ database
+    -> IO MyBool
+
+foreign import ccall unsafe mysql_select_db
+    :: Ptr MYSQL
+    -> CString
+    -> IO CInt
+
+foreign import ccall safe mysql_get_server_info
+    :: Ptr MYSQL -> IO CString
+
+foreign import ccall safe mysql_get_host_info
+    :: Ptr MYSQL -> IO CString
+
+foreign import ccall safe mysql_get_proto_info
+    :: Ptr MYSQL -> IO CUInt
+
+foreign import ccall safe mysql_character_set_name
+    :: Ptr MYSQL -> IO CString
+
+foreign import ccall safe mysql_set_character_set
+    :: Ptr MYSQL -> CString -> IO CInt
+
+foreign import ccall safe mysql_get_ssl_cipher
+    :: Ptr MYSQL -> IO CString
+
+foreign import ccall unsafe mysql_stat
+    :: Ptr MYSQL -> IO CString
+
+foreign import ccall unsafe mysql_real_query
+    :: Ptr MYSQL -> CString -> CULong -> IO CInt
+
+foreign import ccall safe mysql_field_count
+    :: Ptr MYSQL -> IO CUInt
+
+foreign import ccall safe mysql_affected_rows
+    :: Ptr MYSQL -> IO CULLong
+
+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 safe "mysql.h mysql_fetch_fields" mysql_fetch_fields_nonblock
+    :: Ptr MYSQL_RES -> IO (Ptr Field)
+
+foreign import ccall safe mysql_data_seek
+    :: Ptr MYSQL_RES -> CULLong -> IO ()
+
+foreign import ccall safe mysql_row_seek
+    :: Ptr MYSQL_RES -> MYSQL_ROW_OFFSET -> IO MYSQL_ROW_OFFSET
+
+foreign import ccall safe mysql_row_tell
+    :: Ptr MYSQL_RES -> IO MYSQL_ROW_OFFSET
+
+foreign import ccall unsafe mysql_next_result
+    :: Ptr MYSQL -> IO CInt
+
+foreign import ccall unsafe mysql_commit
+    :: Ptr MYSQL -> IO MyBool
+
+foreign import ccall unsafe mysql_rollback
+    :: Ptr MYSQL -> IO MyBool
+
+foreign import ccall unsafe mysql_fetch_row
+    :: Ptr MYSQL_RES -> IO MYSQL_ROW
+
+foreign import ccall safe "mysql.h mysql_fetch_row" mysql_fetch_row_nonblock
+    :: Ptr MYSQL_RES -> IO MYSQL_ROW
+
+foreign import ccall unsafe mysql_fetch_lengths
+    :: Ptr MYSQL_RES -> IO (Ptr CULong)
+
+foreign import ccall safe "mysql.h mysql_fetch_lengths" mysql_fetch_lengths_nonblock
+    :: 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_get_client_info :: CString
+
+foreign import ccall safe mysql_get_client_version :: CULong
+
+foreign import ccall safe mysql_errno
+    :: Ptr MYSQL -> IO CInt
+
+foreign import ccall safe mysql_error
+    :: Ptr MYSQL -> IO CString

File Database/MySQL/Base/Types.hsc

+{-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, ForeignFunctionInterface #-}
+
+module Database.MySQL.Base.Types
+    (
+    -- * Types
+    -- * High-level types
+      Type(..)
+    , Seconds
+    , Protocol(..)
+    , Option(..)
+    , Field(..)
+    , FieldFlag
+    , FieldFlags
+    -- * Low-level types
+    , MYSQL
+    , MYSQL_RES
+    , MYSQL_ROW
+    , MYSQL_ROWS
+    , MYSQL_ROW_OFFSET
+    , MyBool
+    -- * Field flags
+    , hasAllFlags
+    , flagNotNull
+    , flagPrimaryKey
+    , flagUniqueKey
+    , flagMultipleKey
+    , flagUnsigned
+    , flagZeroFill
+    , flagBinary
+    , flagAutoIncrement
+    , flagNumeric
+    , flagNoDefaultValue
+    -- * Connect flags
+    , toConnectFlag
+    ) where
+
+#include "mysql.h"
+
+import Data.Monoid
+import Data.Bits
+import Data.List
+import Control.Applicative
+import Data.Maybe
+import qualified Data.IntMap as IntMap
+import Foreign.C.Types
+import Foreign.Ptr (Ptr)
+import Foreign.Storable
+import Data.Typeable (Typeable)
+import Data.ByteString hiding (intercalate)
+import Data.ByteString.Internal
+import Data.Word
+
+data MYSQL
+data MYSQL_RES
+data MYSQL_ROWS
+type MYSQL_ROW = Ptr (Ptr CChar)
+type MYSQL_ROW_OFFSET = Ptr MYSQL_ROWS
+type MyBool = CChar
+
+-- | Column types supported by MySQL.
+data Type = Decimal
+          | Tiny
+          | Short
+          | Long
+          | Float
+          | Double
+          | Null
+          | Timestamp
+          | LongLong
+          | Int24
+          | Date
+          | Time
+          | DateTime
+          | Year
+          | NewDate
+          | VarChar
+          | Bit
+          | NewDecimal
+          | Enum
+          | Set
+          | TinyBlob
+          | MediumBlob
+          | LongBlob
+          | Blob
+          | VarString
+          | String
+          | Geometry
+            deriving (Enum, Eq, Show, Typeable)
+
+toType :: CInt -> Type
+toType v = IntMap.findWithDefault oops (fromIntegral v) typeMap
+  where
+    oops = error $ "Database.MySQL: unknown field type " ++ show v
+    typeMap = IntMap.fromList [
+               ((#const MYSQL_TYPE_DECIMAL), Decimal),
+               ((#const MYSQL_TYPE_TINY), Tiny),
+               ((#const MYSQL_TYPE_SHORT), Short),
+               ((#const MYSQL_TYPE_LONG), Long),
+               ((#const MYSQL_TYPE_FLOAT), Float),
+               ((#const MYSQL_TYPE_DOUBLE), Double),
+               ((#const MYSQL_TYPE_NULL), Null),
+               ((#const MYSQL_TYPE_TIMESTAMP), Timestamp),
+               ((#const MYSQL_TYPE_LONGLONG), LongLong),
+               ((#const MYSQL_TYPE_DATE), Date),
+               ((#const MYSQL_TYPE_TIME), Time),
+               ((#const MYSQL_TYPE_DATETIME), DateTime),
+               ((#const MYSQL_TYPE_YEAR), Year),
+               ((#const MYSQL_TYPE_NEWDATE), NewDate),
+               ((#const MYSQL_TYPE_VARCHAR), VarChar),
+               ((#const MYSQL_TYPE_BIT), Bit),
+               ((#const MYSQL_TYPE_NEWDECIMAL), NewDecimal),
+               ((#const MYSQL_TYPE_ENUM), Enum),
+               ((#const MYSQL_TYPE_SET), Set),
+               ((#const MYSQL_TYPE_TINY_BLOB), TinyBlob),
+               ((#const MYSQL_TYPE_MEDIUM_BLOB), MediumBlob),
+               ((#const MYSQL_TYPE_LONG_BLOB), LongBlob),
+               ((#const MYSQL_TYPE_BLOB), Blob),
+               ((#const MYSQL_TYPE_VAR_STRING), VarString),
+               ((#const MYSQL_TYPE_STRING), String),
+               ((#const MYSQL_TYPE_GEOMETRY), Geometry)
+              ]
+
+-- | A description of a field (column) of a table.
+data Field = Field {
+      fieldName :: ByteString   -- ^ Name of column.
+    , fieldOrigName :: ByteString -- ^ Original column name, if an alias.
+    , fieldTable :: ByteString -- ^ Table of column, if column was a field.
+    , fieldOrigTable :: ByteString -- ^ Original table name, if table was an alias.
+    , fieldDB :: ByteString        -- ^ Database for table.
+    , fieldCatalog :: ByteString   -- ^ Catalog for table.
+    , fieldDefault :: Maybe ByteString   -- ^ Default value.
+    , fieldLength :: Word          -- ^ Width of column (create length).
+    , fieldMaxLength :: Word    -- ^ Maximum width for selected set.
+    , fieldFlags :: FieldFlags        -- ^ Div flags.
+    , fieldDecimals :: Word -- ^ Number of decimals in field.
+    , fieldCharSet :: Word -- ^ Character set number.
+    , fieldType :: Type
+    } deriving (Eq, Show, Typeable)
+
+newtype FieldFlags = FieldFlags CUInt
+    deriving (Eq, Typeable)
+
+instance Show FieldFlags where
+    show f = '[' : z ++ "]"
+      where z = intercalate "," . catMaybes $ [
+                          flagNotNull ??? "flagNotNull"
+                        , flagPrimaryKey ??? "flagPrimaryKey"
+                        , flagUniqueKey ??? "flagUniqueKey"
+                        , flagMultipleKey ??? "flagMultipleKey"
+                        , flagUnsigned ??? "flagUnsigned"
+                        , flagZeroFill ??? "flagZeroFill"
+                        , flagBinary ??? "flagBinary"
+                        , flagAutoIncrement ??? "flagAutoIncrement"
+                        , flagNumeric ??? "flagNumeric"
+                        , flagNoDefaultValue ??? "flagNoDefaultValue"
+                        ]
+            flag ??? name | f `hasAllFlags` flag = Just name
+                          | otherwise            = Nothing
+
+type FieldFlag = FieldFlags
+
+instance Monoid FieldFlags where
+    mempty = FieldFlags 0
+    {-# INLINE mempty #-}
+    mappend (FieldFlags a) (FieldFlags b) = FieldFlags (a .|. b)
+    {-# INLINE mappend #-}
+
+flagNotNull, flagPrimaryKey, flagUniqueKey, flagMultipleKey :: FieldFlag
+flagNotNull = FieldFlags #const NOT_NULL_FLAG
+flagPrimaryKey = FieldFlags #const PRI_KEY_FLAG
+flagUniqueKey = FieldFlags #const UNIQUE_KEY_FLAG
+flagMultipleKey = FieldFlags #const MULTIPLE_KEY_FLAG
+
+flagUnsigned, flagZeroFill, flagBinary, flagAutoIncrement :: FieldFlag
+flagUnsigned = FieldFlags #const UNSIGNED_FLAG
+flagZeroFill = FieldFlags #const ZEROFILL_FLAG
+flagBinary = FieldFlags #const BINARY_FLAG
+flagAutoIncrement = FieldFlags #const AUTO_INCREMENT_FLAG
+
+flagNumeric, flagNoDefaultValue :: FieldFlag
+flagNumeric = FieldFlags #const NUM_FLAG
+flagNoDefaultValue = FieldFlags #const NO_DEFAULT_VALUE_FLAG
+
+hasAllFlags :: FieldFlags -> FieldFlags -> Bool
+FieldFlags a `hasAllFlags` FieldFlags b = a .&. b == b
+{-# INLINE hasAllFlags #-}
+
+peekField :: Ptr Field -> IO Field
+peekField ptr = do
+  flags <- FieldFlags <$> (#peek MYSQL_FIELD, flags) ptr
+  Field
+   <$> peekS ((#peek MYSQL_FIELD, name)) ((#peek MYSQL_FIELD, name_length))
+   <*> peekS ((#peek MYSQL_FIELD, org_name)) ((#peek MYSQL_FIELD, org_name_length))
+   <*> peekS ((#peek MYSQL_FIELD, table)) ((#peek MYSQL_FIELD, table_length))
+   <*> peekS ((#peek MYSQL_FIELD, org_table)) ((#peek MYSQL_FIELD, org_table_length))
+   <*> peekS ((#peek MYSQL_FIELD, db)) ((#peek MYSQL_FIELD, db_length))
+   <*> peekS ((#peek MYSQL_FIELD, catalog)) ((#peek MYSQL_FIELD, catalog_length))
+   <*> (if flags `hasAllFlags` flagNoDefaultValue
+       then pure Nothing
+       else Just <$> peekS ((#peek MYSQL_FIELD, def)) ((#peek MYSQL_FIELD, def_length)))
+   <*> (uint <$> (#peek MYSQL_FIELD, length) ptr)
+   <*> (uint <$> (#peek MYSQL_FIELD, max_length) ptr)
+   <*> pure flags
+   <*> (uint <$> (#peek MYSQL_FIELD, decimals) ptr)
+   <*> (uint <$> (#peek MYSQL_FIELD, charsetnr) ptr)
+   <*> (toType <$> (#peek MYSQL_FIELD, type) ptr)
+ where
+   uint = fromIntegral :: CUInt -> Word
+   peekS :: (Ptr Field -> IO (Ptr Word8)) -> (Ptr Field -> IO CUInt)
+         -> IO ByteString
+   peekS peekPtr peekLen = do
+     p <- peekPtr ptr
+     l <- peekLen ptr
+     create (fromIntegral l) $ \d -> memcpy d p (fromIntegral l)
+
+instance Storable Field where
+    sizeOf _    = #{size MYSQL_FIELD}
+    alignment _ = alignment (undefined :: Ptr CChar)
+    peek = peekField
+
+type Seconds = Word
+
+data Protocol = TCP
+              | Socket
+              | Pipe
+              | Memory
+                deriving (Eq, Read, Show, Enum, Typeable)
+
+data Option =
+            -- Options accepted by mysq_options.
+              ConnectTimeout Seconds
+            | Compress
+            | NamedPipe
+            | InitCommand ByteString
+            | ReadDefaultFile FilePath
+            | ReadDefaultGroup ByteString
+            | CharsetDir FilePath
+            | CharsetName String
+            | LocalInFile Bool
+            | Protocol Protocol
+            | SharedMemoryBaseName ByteString
+            | ReadTimeout Seconds
+            | WriteTimeout Seconds
+            | UseRemoteConnection
+            | UseEmbeddedConnection
+            | GuessConnection
+            | ClientIP ByteString
+            | SecureAuth Bool
+            | ReportDataTruncation Bool
+            | Reconnect Bool
+            | SSLVerifyServerCert Bool
+            -- Flags accepted by mysql_real_connect.
+            | FoundRows
+            | IgnoreSIGPIPE
+            | IgnoreSpace
+            | Interactive
+            | LocalFiles
+            | MultiResults
+            | MultiStatements
+            | NoSchema
+              deriving (Eq, Read, Show, Typeable)
+
+toConnectFlag :: Option -> CULong
+toConnectFlag Compress  = #const CLIENT_COMPRESS
+toConnectFlag FoundRows = #const CLIENT_FOUND_ROWS
+toConnectFlag IgnoreSIGPIPE = #const CLIENT_IGNORE_SIGPIPE
+toConnectFlag IgnoreSpace = #const CLIENT_IGNORE_SPACE
+toConnectFlag Interactive = #const CLIENT_INTERACTIVE
+toConnectFlag LocalFiles = #const CLIENT_LOCAL_FILES
+toConnectFlag MultiResults = #const CLIENT_MULTI_RESULTS
+toConnectFlag MultiStatements = #const CLIENT_MULTI_STATEMENTS
+toConnectFlag NoSchema = #const CLIENT_NO_SCHEMA
+toConnectFlag _        = 0

File Database/MySQL/C.hsc

-{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}
-
-module Database.MySQL.C
-    (
-    -- * Connection management
-      mysql_init
-    , mysql_options
-    , mysql_ssl_set
-    , mysql_real_connect
-    , mysql_close
-    , mysql_ping
-    , mysql_autocommit
-    , mysql_change_user
-    , mysql_select_db
-    , mysql_set_character_set
-    -- ** Connection information
-    , mysql_thread_id
-    , mysql_get_server_info
-    , mysql_get_host_info
-    , mysql_get_proto_info
-    , mysql_character_set_name
-    , mysql_get_ssl_cipher
-    , mysql_stat
-    -- * Querying
-    , mysql_real_query
-    -- ** Escaping
-    , mysql_real_escape_string
-    -- ** Results
-    , mysql_field_count
-    , mysql_affected_rows
-    , mysql_store_result
-    , mysql_use_result
-    , mysql_fetch_lengths
-    , mysql_fetch_lengths_nonblock
-    , mysql_fetch_row
-    , mysql_fetch_row_nonblock
-    -- * Working with results
-    , mysql_free_result
-    , mysql_fetch_fields
-    , mysql_fetch_fields_nonblock
-    , mysql_data_seek
-    , mysql_row_seek
-    , mysql_row_tell
-    -- ** Multiple results
-    , mysql_next_result
-    -- * Transactions
-    , mysql_commit
-    , mysql_rollback
-    -- * General information
-    , mysql_get_client_info
-    , mysql_get_client_version
-    -- * Error handling
-    , mysql_errno
-    , mysql_error
-    -- * Support functions
-    , withRTSSignalsBlocked
-    ) where
-
-#include "mysql.h"
-#include <signal.h>
-
-import Database.MySQL.Types
-import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread)
-import Control.Exception (finally)
-import Foreign.C.Types
-import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)
-import Foreign.Ptr (Ptr, nullPtr)
-import System.IO.Unsafe (unsafePerformIO)
-import Foreign.Storable
-import Foreign.Marshal.Utils
-import Data.ByteString.Unsafe
-import Foreign.C.String
-
--- | Execute an 'IO' action with signals used by GHC's runtime signals
--- blocked.  The @mysqlclient@ C library does not correctly restart
--- system calls if they are interrupted by signals, so many MySQL API
--- calls can unexpectedly fail when called from a Haskell application.
--- This is most likely to occur if you are linking against GHC's
--- threaded runtime (using the @-threaded@ option).
---
--- This function blocks @SIGALRM@ and @SIGVTALRM@, runs your action,
--- then unblocks those signals.  If you have a series of HDBC calls
--- that may block for a period of time, it may be wise to wrap them in
--- this action.  Blocking and unblocking signals is cheap, but not
--- free.
---
--- Here is an example of an exception that could be avoided by
--- temporarily blocking GHC's runtime signals:
---
--- >  SqlError {
--- >    seState = "", 
--- >    seNativeError = 2003, 
--- >    seErrorMsg = "Can't connect to MySQL server on 'localhost' (4)"
--- >  }
-withRTSSignalsBlocked :: IO a -> IO a
-withRTSSignalsBlocked act
-    | not rtsSupportsBoundThreads = act
-    | otherwise = runInBoundThread . withForeignPtr rtsSignals $ \set -> do
-  pthread_sigmask (#const SIG_BLOCK) set nullPtr
-  act `finally` pthread_sigmask (#const SIG_UNBLOCK) set nullPtr
-
-rtsSignals :: ForeignPtr SigSet
-rtsSignals = unsafePerformIO $ do
-               fp <- mallocForeignPtr
-               withForeignPtr fp $ \set -> do
-                 sigemptyset set
-                 sigaddset set (#const SIGALRM)
-                 sigaddset set (#const SIGVTALRM)
-               return fp
-{-# NOINLINE rtsSignals #-}
-
-data SigSet
-
-instance Storable SigSet where
-    sizeOf    _ = #{size sigset_t}
-    alignment _ = alignment (undefined :: Ptr CInt)
-
-foreign import ccall unsafe "signal.h sigaddset" sigaddset
-    :: Ptr SigSet -> CInt -> IO ()
-
-foreign import ccall unsafe "signal.h sigemptyset" sigemptyset
-    :: Ptr SigSet -> IO ()
-
-foreign import ccall unsafe "signal.h pthread_sigmask" pthread_sigmask
-    :: CInt -> Ptr SigSet -> Ptr SigSet -> IO ()
-
-foreign import ccall safe mysql_init
-    :: Ptr MYSQL                -- ^ should usually be 'nullPtr'
-    -> IO (Ptr MYSQL)
-
-mysql_options :: Ptr MYSQL -> Option -> IO CInt
-mysql_options ptr opt =
-    case opt of
-      ConnectTimeout secs ->
-        withIntegral secs $ go (#const MYSQL_OPT_CONNECT_TIMEOUT)
-      Compress ->
-        go (#const MYSQL_OPT_COMPRESS) nullPtr
-      NamedPipe ->
-        go (#const MYSQL_OPT_NAMED_PIPE) nullPtr
-      InitCommand cmd ->
-        unsafeUseAsCString cmd $ go (#const MYSQL_INIT_COMMAND)
-      ReadDefaultFile path ->
-        withCString path $ go (#const MYSQL_READ_DEFAULT_FILE)
-      ReadDefaultGroup group ->
-        unsafeUseAsCString group $ go (#const MYSQL_READ_DEFAULT_GROUP)
-      CharsetDir path ->
-        withCString path $ go (#const MYSQL_SET_CHARSET_DIR)
-      CharsetName cs ->
-        withCString cs $ go (#const MYSQL_SET_CHARSET_NAME)
-      LocalInFile b ->
-        withBool b $ go (#const MYSQL_OPT_LOCAL_INFILE)
-      Protocol proto ->
-        withIntegral (fromEnum proto) $ go (#const MYSQL_OPT_PROTOCOL)
-      SharedMemoryBaseName name ->
-        unsafeUseAsCString name $ go (#const MYSQL_SHARED_MEMORY_BASE_NAME)
-      ReadTimeout secs ->
-        withIntegral secs $ go (#const MYSQL_OPT_READ_TIMEOUT)
-      WriteTimeout secs ->
-        withIntegral secs $ go (#const MYSQL_OPT_WRITE_TIMEOUT)
-      UseRemoteConnection ->
-        go (#const MYSQL_OPT_USE_REMOTE_CONNECTION) nullPtr
-      UseEmbeddedConnection ->
-        go (#const MYSQL_OPT_USE_EMBEDDED_CONNECTION) nullPtr
-      GuessConnection ->
-        go (#const MYSQL_OPT_GUESS_CONNECTION) nullPtr
-      ClientIP ip ->
-        unsafeUseAsCString ip $ go (#const MYSQL_SET_CLIENT_IP)
-      SecureAuth b ->
-        withBool b $ go (#const MYSQL_SECURE_AUTH)
-      ReportDataTruncation b ->
-        withBool b $ go (#const MYSQL_REPORT_DATA_TRUNCATION)
-      Reconnect b ->
-        withBool b $ go (#const MYSQL_OPT_RECONNECT)
-      SSLVerifyServerCert b ->
-        withBool b $ go (#const MYSQL_OPT_SSL_VERIFY_SERVER_CERT)
-      -- Other options are accepted by mysql_real_connect, so ignore them.
-      _ -> return 0
-  where
-    go = mysql_options_ ptr
-    withBool b = with (if b then 1 else 0 :: CUInt)
-    withIntegral i = with (fromIntegral i :: CUInt)
-
-foreign import ccall safe "mysql.h mysql_options" mysql_options_
-    :: Ptr MYSQL -> CInt -> Ptr a -> IO CInt
-
-foreign import ccall unsafe mysql_real_connect
-    :: Ptr MYSQL -- ^ Context (from 'mysql_init').
-    -> CString   -- ^ Host name.
-    -> CString   -- ^ User name.
-    -> CString   -- ^ Password.
-    -> CString   -- ^ Database.
-    -> CInt      -- ^ Port.
-    -> CString   -- ^ Unix socket.
-    -> CULong    -- ^ Flags.
-    -> IO (Ptr MYSQL)
-
-foreign import ccall safe mysql_ssl_set
-    :: Ptr MYSQL
-    -> CString                  -- ^ Key.
-    -> CString                  -- ^ Cert.
-    -> CString                  -- ^ CA.
-    -> CString                  -- ^ CA path.
-    -> CString                  -- ^ Ciphers.
-    -> IO MyBool
-
-foreign import ccall unsafe mysql_close
-    :: Ptr MYSQL -> IO ()
-
-foreign import ccall unsafe mysql_ping
-    :: Ptr MYSQL -> IO CInt
-
-foreign import ccall safe mysql_thread_id
-    :: Ptr MYSQL -> IO CULong
-
-foreign import ccall unsafe mysql_autocommit
-    :: Ptr MYSQL -> MyBool -> IO MyBool
-
-foreign import ccall unsafe mysql_change_user
-    :: Ptr MYSQL
-    -> CString                  -- ^ user
-    -> CString                  -- ^ password
-    -> CString                  -- ^ database
-    -> IO MyBool
-
-foreign import ccall unsafe mysql_select_db
-    :: Ptr MYSQL
-    -> CString
-    -> IO CInt
-
-foreign import ccall safe mysql_get_server_info
-    :: Ptr MYSQL -> IO CString
-
-foreign import ccall safe mysql_get_host_info
-    :: Ptr MYSQL -> IO CString
-
-foreign import ccall safe mysql_get_proto_info
-    :: Ptr MYSQL -> IO CUInt
-
-foreign import ccall safe mysql_character_set_name
-    :: Ptr MYSQL -> IO CString
-
-foreign import ccall safe mysql_set_character_set
-    :: Ptr MYSQL -> CString -> IO CInt
-
-foreign import ccall safe mysql_get_ssl_cipher
-    :: Ptr MYSQL -> IO CString
-
-foreign import ccall unsafe mysql_stat
-    :: Ptr MYSQL -> IO CString
-
-foreign import ccall unsafe mysql_real_query
-    :: Ptr MYSQL -> CString -> CULong -> IO CInt
-
-foreign import ccall safe mysql_field_count
-    :: Ptr MYSQL -> IO CUInt
-
-foreign import ccall safe mysql_affected_rows
-    :: Ptr MYSQL -> IO CULLong
-
-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 safe "mysql.h mysql_fetch_fields" mysql_fetch_fields_nonblock
-    :: Ptr MYSQL_RES -> IO (Ptr Field)
-
-foreign import ccall safe mysql_data_seek
-    :: Ptr MYSQL_RES -> CULLong -> IO ()
-
-foreign import ccall safe mysql_row_seek
-    :: Ptr MYSQL_RES -> MYSQL_ROW_OFFSET -> IO MYSQL_ROW_OFFSET
-
-foreign import ccall safe mysql_row_tell
-    :: Ptr MYSQL_RES -> IO MYSQL_ROW_OFFSET
-
-foreign import ccall unsafe mysql_next_result
-    :: Ptr MYSQL -> IO CInt
-
-foreign import ccall unsafe mysql_commit
-    :: Ptr MYSQL -> IO MyBool
-
-foreign import ccall unsafe mysql_rollback
-    :: Ptr MYSQL -> IO MyBool
-
-foreign import ccall unsafe mysql_fetch_row
-    :: Ptr MYSQL_RES -> IO MYSQL_ROW
-
-foreign import ccall safe "mysql.h mysql_fetch_row" mysql_fetch_row_nonblock
-    :: Ptr MYSQL_RES -> IO MYSQL_ROW
-
-foreign import ccall unsafe mysql_fetch_lengths
-    :: Ptr MYSQL_RES -> IO (Ptr CULong)
-
-foreign import ccall safe "mysql.h mysql_fetch_lengths" mysql_fetch_lengths_nonblock
-    :: 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_get_client_info :: CString
-
-foreign import ccall safe mysql_get_client_version :: CULong
-
-foreign import ccall safe mysql_errno
-    :: Ptr MYSQL -> IO CInt
-
-foreign import ccall safe mysql_error
-    :: Ptr MYSQL -> IO CString

File Database/MySQL/Types.hsc

-{-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, ForeignFunctionInterface #-}
-
-module Database.MySQL.Types
-    (
-    -- * Types
-    -- * High-level types
-      Type(..)
-    , Seconds
-    , Protocol(..)
-    , Option(..)
-    , Field(..)
-    , FieldFlag
-    , FieldFlags
-    -- * Low-level types
-    , MYSQL
-    , MYSQL_RES
-    , MYSQL_ROW
-    , MYSQL_ROWS
-    , MYSQL_ROW_OFFSET
-    , MyBool
-    -- * Field flags
-    , hasAllFlags
-    , flagNotNull
-    , flagPrimaryKey
-    , flagUniqueKey
-    , flagMultipleKey
-    , flagUnsigned
-    , flagZeroFill
-    , flagBinary
-    , flagAutoIncrement
-    , flagNumeric
-    , flagNoDefaultValue
-    -- * Connect flags
-    , toConnectFlag
-    ) where
-
-#include "mysql.h"
-
-import Data.Monoid
-import Data.Bits
-import Data.List
-import Control.Applicative
-import Data.Maybe
-import qualified Data.IntMap as IntMap
-import Foreign.C.Types
-import Foreign.Ptr (Ptr)
-import Foreign.Storable
-import Data.Typeable (Typeable)
-import Data.ByteString hiding (intercalate)
-import Data.ByteString.Internal
-import Data.Word
-
-data MYSQL
-data MYSQL_RES
-data MYSQL_ROWS
-type MYSQL_ROW = Ptr (Ptr CChar)
-type MYSQL_ROW_OFFSET = Ptr MYSQL_ROWS
-type MyBool = CChar
-
--- | Column types supported by MySQL.
-data Type = Decimal
-          | Tiny
-          | Short
-          | Long
-          | Float
-          | Double
-          | Null
-          | Timestamp
-          | LongLong
-          | Int24
-          | Date
-          | Time
-          | DateTime
-          | Year
-          | NewDate
-          | VarChar
-          | Bit
-          | NewDecimal
-          | Enum
-          | Set
-          | TinyBlob
-          | MediumBlob
-          | LongBlob
-          | Blob
-          | VarString
-          | String
-          | Geometry
-            deriving (Enum, Eq, Show, Typeable)
-
-toType :: CInt -> Type
-toType v = IntMap.findWithDefault oops (fromIntegral v) typeMap
-  where
-    oops = error $ "Database.MySQL: unknown field type " ++ show v
-    typeMap = IntMap.fromList [
-               ((#const MYSQL_TYPE_DECIMAL), Decimal),
-               ((#const MYSQL_TYPE_TINY), Tiny),
-               ((#const MYSQL_TYPE_SHORT), Short),
-               ((#const MYSQL_TYPE_LONG), Long),
-               ((#const MYSQL_TYPE_FLOAT), Float),
-               ((#const MYSQL_TYPE_DOUBLE), Double),
-               ((#const MYSQL_TYPE_NULL), Null),
-               ((#const MYSQL_TYPE_TIMESTAMP), Timestamp),
-               ((#const MYSQL_TYPE_LONGLONG), LongLong),
-               ((#const MYSQL_TYPE_DATE), Date),
-               ((#const MYSQL_TYPE_TIME), Time),
-               ((#const MYSQL_TYPE_DATETIME), DateTime),
-               ((#const MYSQL_TYPE_YEAR), Year),
-               ((#const MYSQL_TYPE_NEWDATE), NewDate),
-               ((#const MYSQL_TYPE_VARCHAR), VarChar),
-               ((#const MYSQL_TYPE_BIT), Bit),
-               ((#const MYSQL_TYPE_NEWDECIMAL), NewDecimal),
-               ((#const MYSQL_TYPE_ENUM), Enum),
-               ((#const MYSQL_TYPE_SET), Set),
-               ((#const MYSQL_TYPE_TINY_BLOB), TinyBlob),
-               ((#const MYSQL_TYPE_MEDIUM_BLOB), MediumBlob),
-               ((#const MYSQL_TYPE_LONG_BLOB), LongBlob),
-               ((#const MYSQL_TYPE_BLOB), Blob),
-               ((#const MYSQL_TYPE_VAR_STRING), VarString),
-               ((#const MYSQL_TYPE_STRING), String),
-               ((#const MYSQL_TYPE_GEOMETRY), Geometry)
-              ]
-
--- | A description of a field (column) of a table.
-data Field = Field {
-      fieldName :: ByteString   -- ^ Name of column.
-    , fieldOrigName :: ByteString -- ^ Original column name, if an alias.
-    , fieldTable :: ByteString -- ^ Table of column, if column was a field.
-    , fieldOrigTable :: ByteString -- ^ Original table name, if table was an alias.
-    , fieldDB :: ByteString        -- ^ Database for table.
-    , fieldCatalog :: ByteString   -- ^ Catalog for table.
-    , fieldDefault :: Maybe ByteString   -- ^ Default value.
-    , fieldLength :: Word          -- ^ Width of column (create length).
-    , fieldMaxLength :: Word    -- ^ Maximum width for selected set.
-    , fieldFlags :: FieldFlags        -- ^ Div flags.
-    , fieldDecimals :: Word -- ^ Number of decimals in field.
-    , fieldCharSet :: Word -- ^ Character set number.
-    , fieldType :: Type
-    } deriving (Eq, Show, Typeable)
-
-newtype FieldFlags = FieldFlags CUInt
-    deriving (Eq, Typeable)
-
-instance Show FieldFlags where
-    show f = '[' : z ++ "]"
-      where z = intercalate "," . catMaybes $ [
-                          flagNotNull ??? "flagNotNull"
-                        , flagPrimaryKey ??? "flagPrimaryKey"
-                        , flagUniqueKey ??? "flagUniqueKey"
-                        , flagMultipleKey ??? "flagMultipleKey"
-                        , flagUnsigned ??? "flagUnsigned"
-                        , flagZeroFill ??? "flagZeroFill"
-                        , flagBinary ??? "flagBinary"
-                        , flagAutoIncrement ??? "flagAutoIncrement"
-                        , flagNumeric ??? "flagNumeric"
-                        , flagNoDefaultValue ??? "flagNoDefaultValue"
-                        ]
-            flag ??? name | f `hasAllFlags` flag = Just name
-                          | otherwise            = Nothing
-
-type FieldFlag = FieldFlags
-
-instance Monoid FieldFlags where
-    mempty = FieldFlags 0
-    {-# INLINE mempty #-}
-    mappend (FieldFlags a) (FieldFlags b) = FieldFlags (a .|. b)
-    {-# INLINE mappend #-}
-
-flagNotNull, flagPrimaryKey, flagUniqueKey, flagMultipleKey :: FieldFlag
-flagNotNull = FieldFlags #const NOT_NULL_FLAG
-flagPrimaryKey = FieldFlags #const PRI_KEY_FLAG
-flagUniqueKey = FieldFlags #const UNIQUE_KEY_FLAG
-flagMultipleKey = FieldFlags #const MULTIPLE_KEY_FLAG
-
-flagUnsigned, flagZeroFill, flagBinary, flagAutoIncrement :: FieldFlag
-flagUnsigned = FieldFlags #const UNSIGNED_FLAG
-flagZeroFill = FieldFlags #const ZEROFILL_FLAG
-flagBinary = FieldFlags #const BINARY_FLAG
-flagAutoIncrement = FieldFlags #const AUTO_INCREMENT_FLAG
-
-flagNumeric, flagNoDefaultValue :: FieldFlag
-flagNumeric = FieldFlags #const NUM_FLAG
-flagNoDefaultValue = FieldFlags #const NO_DEFAULT_VALUE_FLAG
-
-hasAllFlags :: FieldFlags -> FieldFlags -> Bool
-FieldFlags a `hasAllFlags` FieldFlags b = a .&. b == b
-{-# INLINE hasAllFlags #-}
-
-peekField :: Ptr Field -> IO Field
-peekField ptr = do
-  flags <- FieldFlags <$> (#peek MYSQL_FIELD, flags) ptr
-  Field
-   <$> peekS ((#peek MYSQL_FIELD, name)) ((#peek MYSQL_FIELD, name_length))
-   <*> peekS ((#peek MYSQL_FIELD, org_name)) ((#peek MYSQL_FIELD, org_name_length))
-   <*> peekS ((#peek MYSQL_FIELD, table)) ((#peek MYSQL_FIELD, table_length))
-   <*> peekS ((#peek MYSQL_FIELD, org_table)) ((#peek MYSQL_FIELD, org_table_length))
-   <*> peekS ((#peek MYSQL_FIELD, db)) ((#peek MYSQL_FIELD, db_length))
-   <*> peekS ((#peek MYSQL_FIELD, catalog)) ((#peek MYSQL_FIELD, catalog_length))
-   <*> (if flags `hasAllFlags` flagNoDefaultValue
-       then pure Nothing
-       else Just <$> peekS ((#peek MYSQL_FIELD, def)) ((#peek MYSQL_FIELD, def_length)))
-   <*> (uint <$> (#peek MYSQL_FIELD, length) ptr)
-   <*> (uint <$> (#peek MYSQL_FIELD, max_length) ptr)
-   <*> pure flags
-   <*> (uint <$> (#peek MYSQL_FIELD, decimals) ptr)
-   <*> (uint <$> (#peek MYSQL_FIELD, charsetnr) ptr)
-   <*> (toType <$> (#peek MYSQL_FIELD, type) ptr)
- where
-   uint = fromIntegral :: CUInt -> Word
-   peekS :: (Ptr Field -> IO (Ptr Word8)) -> (Ptr Field -> IO CUInt)
-         -> IO ByteString
-   peekS peekPtr peekLen = do
-     p <- peekPtr ptr
-     l <- peekLen ptr
-     create (fromIntegral l) $ \d -> memcpy d p (fromIntegral l)
-
-instance Storable Field where
-    sizeOf _    = #{size MYSQL_FIELD}
-    alignment _ = alignment (undefined :: Ptr CChar)
-    peek = peekField
-
-type Seconds = Word
-
-data Protocol = TCP
-              | Socket
-              | Pipe
-              | Memory
-                deriving (Eq, Read, Show, Enum, Typeable)
-
-data Option =
-            -- Options accepted by mysq_options.
-              ConnectTimeout Seconds
-            | Compress
-            | NamedPipe
-            | InitCommand ByteString
-            | ReadDefaultFile FilePath
-            | ReadDefaultGroup ByteString
-            | CharsetDir FilePath
-            | CharsetName String
-            | LocalInFile Bool
-            | Protocol Protocol
-            | SharedMemoryBaseName ByteString
-            | ReadTimeout Seconds
-            | WriteTimeout Seconds
-            | UseRemoteConnection
-            | UseEmbeddedConnection
-            | GuessConnection
-            | ClientIP ByteString
-            | SecureAuth Bool
-            | ReportDataTruncation Bool
-            | Reconnect Bool
-            | SSLVerifyServerCert Bool
-            -- Flags accepted by mysql_real_connect.
-            | FoundRows
-            | IgnoreSIGPIPE
-            | IgnoreSpace
-            | Interactive
-            | LocalFiles
-            | MultiResults
-            | MultiStatements
-            | NoSchema
-              deriving (Eq, Read, Show, Typeable)
-
-toConnectFlag :: Option -> CULong
-toConnectFlag Compress  = #const CLIENT_COMPRESS
-toConnectFlag FoundRows = #const CLIENT_FOUND_ROWS
-toConnectFlag IgnoreSIGPIPE = #const CLIENT_IGNORE_SIGPIPE
-toConnectFlag IgnoreSpace = #const CLIENT_IGNORE_SPACE
-toConnectFlag Interactive = #const CLIENT_INTERACTIVE
-toConnectFlag LocalFiles = #const CLIENT_LOCAL_FILES
-toConnectFlag MultiResults = #const CLIENT_MULTI_RESULTS
-toConnectFlag MultiStatements = #const CLIENT_MULTI_STATEMENTS
-toConnectFlag NoSchema = #const CLIENT_NO_SCHEMA
-toConnectFlag _        = 0
 
 library
   exposed-modules: