├── .github └── workflows │ └── tests.yml ├── .gitignore ├── .hgignore ├── .hgtags ├── .travis.yml ├── ChangeLog.md ├── Database └── MySQL │ ├── Base.hs │ └── Base │ ├── C.hsc │ └── Types.hsc ├── LICENSE ├── README.markdown ├── Setup.hs ├── cbits └── mysql_signals.c ├── include └── mysql_signals.h ├── mysql.cabal ├── stack.yaml └── test └── main.hs /.github/workflows/tests.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - master 8 | 9 | jobs: 10 | build: 11 | name: CI 12 | services: 13 | # mysql-service Label used to access the service container 14 | mysql-service: 15 | # Docker Hub image (also with version) 16 | image: mysql:8.0 17 | env: 18 | ## Accessing to Github secrets, where you can store your configuration 19 | MYSQL_USER: test 20 | MYSQL_PASSWORD: test 21 | MYSQL_ROOT_PASSWORD: test 22 | MYSQL_DATABASE: test 23 | ports: 24 | - 33306:3306 25 | # Set health checks to wait until mysql database has started (it takes some seconds to start) 26 | options: >- 27 | --health-cmd="mysqladmin ping" 28 | --health-interval=10s 29 | --health-timeout=5s 30 | --health-retries=3 31 | runs-on: ${{ matrix.os }} 32 | strategy: 33 | fail-fast: false 34 | matrix: 35 | #os: [ubuntu-latest, macos-latest, windows-latest] 36 | os: [ubuntu-latest] 37 | resolver: 38 | #- nightly 39 | - lts-18 40 | - lts-16 41 | - lts-14 42 | 43 | steps: 44 | - name: Clone project 45 | uses: actions/checkout@v2 46 | 47 | - name: Build and run tests 48 | shell: bash 49 | run: | 50 | set -ex 51 | stack upgrade 52 | stack --version 53 | stack test --fast --no-terminal --resolver=${{ matrix.resolver }} 54 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal.sandbox.config 3 | .cabal-sandbox 4 | .stack-work 5 | *~ 6 | *.swp 7 | *.log 8 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | ^(?:cabal-dev|dist|\.cabal-sandbox)$ 2 | ^cabal.sandbox.config$ 3 | \.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$ 4 | ~$ 5 | syntax: glob 6 | .\#* 7 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | 1cec4cc557796690599cbc5b3c72b3da4aad7419 0.1.0.0 2 | 82f4e7c774dfb497c47e555c9ed34a092f9c4a70 0.1.0.1 3 | 5292a58383497dc07949a385738742531ba8babb 0.1.1.0 4 | 5292a58383497dc07949a385738742531ba8babb 0.1.1.0 5 | be4fc2abfa5adb284af9df93d85644267a260bcd 0.1.1.0 6 | 716f62f748a367ee2ba61e24ffdf231b8c20b416 0.1.1.1 7 | f15e9f546d237e19f8bdf5bfa7203630dd7fa1aa 0.1.1.2 8 | e8e7fb13f75afa9e26f4a5b79910842a952fe22f 0.1.1.3 9 | f78ebad0ead5f887c15270a2ae9bf0f7ac43b24b 0.1.1.4 10 | f78ebad0ead5f887c15270a2ae9bf0f7ac43b24b 0.1.1.4 11 | da3b60b3c74377172aa52212a643c35ba26746a1 0.1.1.4 12 | 848925bbd48008d994064805eed71659fc505a38 0.1.1.5 13 | 3b33ee429575d9f0e873394970106fbfa3df54e4 0.1.1.6 14 | 48d6fb5d77c63fb58cbb85e39ecc9bd1bafb8f5d 0.1.1.7 15 | c56f18889e2770ede0cc4a7c34bff45d942e3308 0.1.1.8 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # GHC depends on GMP. You can add other dependencies here as well. 8 | addons: 9 | apt: 10 | packages: 11 | - libgmp-dev 12 | 13 | # Start the database server 14 | services: 15 | - mysql 16 | 17 | # The different configurations we want to test. You could also do things like 18 | # change flags or use --stack-yaml to point to a different file. 19 | matrix: 20 | include: 21 | - env: ARGS="--resolver lts-6" 22 | compiler: ": # lts-6" 23 | - env: ARGS="--resolver lts-9" 24 | compiler: ": # lts-9" 25 | - env: ARGS="--resolver lts-11" 26 | compiler: ": # lts-11" 27 | - env: ARGS="--resolver lts-12" 28 | compiler: ": # lts-12" 29 | - env: ARGS="--resolver nightly" 30 | compiler: ": # nightly" 31 | - env: ARGS="--resolver lts" 32 | compiler: ": # lts osx" 33 | os: osx 34 | 35 | before_install: 36 | # Using compiler above sets CC to an invalid value, so unset it 37 | - unset CC 38 | 39 | # stack 40 | - mkdir -p ~/.local/bin 41 | - export PATH=$HOME/.local/bin:$PATH 42 | - if [ `uname` = "Darwin" ]; 43 | then 44 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin; 45 | else 46 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'; 47 | fi 48 | 49 | # OSX seems to need mysql installed 50 | - if [ `uname` = "Darwin" ]; 51 | then 52 | brew install mysql; 53 | mysql.server start; 54 | fi 55 | 56 | before_script: 57 | - mysql -u root -e "create database IF NOT EXISTS test;" 58 | - mysql -u root -e "create user 'test'@'127.0.0.1';" 59 | - mysql -u root -e "grant select on test.* to 'test'@'127.0.0.1';" 60 | 61 | script: 62 | - stack init $ARGS 63 | - stack build --test --bench --install-ghc --haddock --no-haddock-deps 64 | 65 | cache: 66 | directories: 67 | - $HOME/.stack 68 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.2.1 2 | 3 | * Work around incorrect test for header-file definition of MYSQL_TYPE_JSON (#45 and 51464fa) 4 | 5 | ## 0.2.0.1 6 | 7 | * Make connection finalizer thread safe (#28). 8 | 9 | ## 0.2 10 | 11 | * Remove obsolete `fieldDefault` from `data Field` (#41). 12 | 13 | ## 0.1.7.3 14 | 15 | * Fix error on certain systems introduced by the change in (#40): some implementations of `mysql_config` do not recognise `--libs-sys`, yet return a zero status for attempts to use it. 16 | 17 | ## 0.1.7.2 18 | 19 | * Update .cabal file 20 | 21 | ## 0.1.7.1 22 | 23 | * Use `mysql_config --libs-sys` in Setup.hs if available (#40) 24 | 25 | ## 0.1.7 26 | 27 | * Add support for JSON type 28 | 29 | ## 0.1.6 30 | 31 | * Fix build for mysql 8 32 | 33 | ## 0.1.5 34 | 35 | * Add Semigroup instance for FieldFlags 36 | * Fix some warnings 37 | * Drop testing under GHC 7.8 / lts-2 38 | 39 | ## 0.1.4 40 | 41 | * Expose mysql_thread_end() as `endThread` 42 | 43 | ## 0.1.3 44 | 45 | * Safer concurrency - see https://ro-che.info/articles/2015-04-17-safe-concurrent-mysql-haskell 46 | * Better support for building against MariaDB (not well tested). 47 | * Additional C binding: mysql_get_server_version(). 48 | 49 | ## 0.1.2.1 50 | 51 | * Fix bystestring-valued connectOptions sometimes not being null terminated at the correct place (avoid unsafeUseAsCString). 52 | 53 | ## 0.1.2 54 | 55 | * Fix setup for cabal 1.24 56 | * New maintainer and GitHub location - with many thanks to Bryan O'Sullivan for all of the past work on this module, and for facilitating the transfer of maintenance responsibility. 57 | -------------------------------------------------------------------------------- /Database/MySQL/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface, RecordWildCards #-} 2 | 3 | -- | 4 | -- Module: Database.MySQL.Base 5 | -- Copyright: (c) 2011 MailRank, Inc. 6 | -- License: BSD3 7 | -- Maintainer: Paul Rouse 8 | -- Stability: experimental 9 | -- Portability: portable 10 | -- 11 | -- A low-level client library for the MySQL database, implemented as 12 | -- bindings to the C @mysqlclient@ API. 13 | -- 14 | -- The C library is thread-safe, but uses thread-local state. Therefore, 15 | -- if these bindings are used in a multi-threaded program, "bound" threads 16 | -- should be used (see "Control.Concurrent"). In addition, explicit calls 17 | -- to 'initLibrary', and possibly 'initThread' and 'endThread' may be needed 18 | -- in a multi-threaded program. 19 | 20 | module Database.MySQL.Base 21 | ( 22 | -- * Licensing 23 | -- $license 24 | -- * Resource management 25 | -- $mgmt 26 | -- * Types 27 | ConnectInfo(..) 28 | , SSLInfo(..) 29 | , Seconds 30 | , Protocol(..) 31 | , Option(..) 32 | , defaultConnectInfo 33 | , defaultSSLInfo 34 | , Connection 35 | , Result 36 | , Type(..) 37 | , Row 38 | , MySQLError(errFunction, errNumber, errMessage) 39 | -- * Connection management 40 | , connect 41 | , close 42 | , autocommit 43 | , ping 44 | , changeUser 45 | , selectDB 46 | , setCharacterSet 47 | -- ** Connection information 48 | , threadId 49 | , serverInfo 50 | , hostInfo 51 | , protocolInfo 52 | , characterSet 53 | , sslCipher 54 | , serverStatus 55 | -- * Querying 56 | , query 57 | , insertID 58 | -- ** Escaping 59 | , escape 60 | -- ** Results 61 | , fieldCount 62 | , affectedRows 63 | -- * Working with results 64 | , isResultValid 65 | , freeResult 66 | , storeResult 67 | , useResult 68 | , fetchRow 69 | , fetchFields 70 | , dataSeek 71 | , rowSeek 72 | , rowTell 73 | -- ** Multiple results 74 | , nextResult 75 | -- * Transactions 76 | , commit 77 | , rollback 78 | -- * General information 79 | , clientInfo 80 | , clientVersion 81 | -- * Concurrency 82 | , initLibrary 83 | , initThread 84 | , endThread 85 | ) where 86 | 87 | import Control.Applicative ((<$>), (<*>)) 88 | import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread) 89 | import Control.Exception (Exception, throw) 90 | import Control.Monad (forM_, unless, when) 91 | import Data.ByteString.Char8 () 92 | import Data.ByteString.Internal (ByteString, create, createAndTrim, memcpy) 93 | import Data.ByteString.Unsafe (unsafeUseAsCStringLen) 94 | import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef, writeIORef) 95 | import Data.Int (Int64) 96 | import Data.List (foldl') 97 | import Data.Typeable (Typeable) 98 | import Data.Word (Word, Word16, Word64) 99 | import Database.MySQL.Base.C 100 | import Database.MySQL.Base.Types 101 | import Foreign.C.String (CString, peekCString, withCString) 102 | import Foreign.C.Types (CULong) 103 | import Foreign.Concurrent (newForeignPtr) 104 | import Foreign.ForeignPtr hiding (newForeignPtr) 105 | import Foreign.Marshal.Array (peekArray) 106 | import Foreign.Ptr (Ptr, castPtr, nullPtr) 107 | import System.IO.Unsafe (unsafePerformIO) 108 | import System.Mem.Weak (Weak, deRefWeak, mkWeakPtr) 109 | 110 | -- $license 111 | -- 112 | -- /Important licensing note/: This library is BSD-licensed under the 113 | -- terms of the MySQL FOSS License Exception 114 | -- . 115 | -- 116 | -- Since this library links against the GPL-licensed @mysqlclient@ 117 | -- library, a non-open-source application that uses it /may/ be 118 | -- subject to the terms of the GPL. 119 | 120 | -- $mgmt 121 | -- 122 | -- Our rules for managing 'Connection' and 'Result' values are 123 | -- unfortunately complicated, thanks to MySQL's lifetime rules. 124 | -- 125 | -- At the C @libmysqlclient@ level, a single @MYSQL@ connection may 126 | -- cause multiple @MYSQL_RES@ result values to be created over the 127 | -- course of multiple queries, but only one of these @MYSQL_RES@ 128 | -- values may be alive at a time. The programmer is responsible for 129 | -- knowing when to call @mysql_free_result@. 130 | -- 131 | -- Meanwhile, up in Haskell-land, we'd like both 'Connection' and 132 | -- 'Result' values to be managed either manually or automatically. In 133 | -- particular, we want finalizers to tidy up after a messy programmer, 134 | -- and we'd prefer it if people didn't need to be mindful of calling 135 | -- @mysql_free_result@. This means that we must wrestle with the 136 | -- lifetime rules. An obvious approach would be to use some monad and 137 | -- type magic to enforce those rules, but then we'd end up with an 138 | -- awkward API. 139 | -- 140 | -- Instead, we allow 'Result' values to stay alive for arbitrarily 141 | -- long times, while preserving the right to mark them as 142 | -- invalid. When a @Result@ is marked invalid, its associated 143 | -- @MYSQL_RES@ is freed, and can no longer be used. 144 | -- 145 | -- Since all functions over @Result@ values are in the 'IO' monad, we 146 | -- don't risk disrupting pure code by introducing this notion of 147 | -- invalidity. If code tries to use an invalid @Result@, a 148 | -- 'MySQLError' will be thrown. This should /not/ occur in normal 149 | -- code, so there should be no need to use 'isResultValid' to test a 150 | -- @Result@ for validity. 151 | -- 152 | -- Each of the following functions will invalidate a 'Result': 153 | -- 154 | -- * 'close' 155 | -- 156 | -- * 'freeResult' 157 | -- 158 | -- * 'nextResult' 159 | -- 160 | -- * 'storeResult' 161 | -- 162 | -- * 'useResult' 163 | -- 164 | -- A 'Result' must be able to keep a 'Connection' alive so that a 165 | -- streaming @Result@ constructed by 'useResult' can continue to pull 166 | -- data from the server, but a @Connection@ must (a) be able to cause 167 | -- the @MYSQL_RES@ behind a @Result@ to be deleted at a moment's notice, 168 | -- while (b) not artificially prolonging the life of either the @Result@ 169 | -- or its @MYSQL_RES@. 170 | 171 | data ConnectInfo = ConnectInfo { 172 | connectHost :: String 173 | , connectPort :: Word16 174 | , connectUser :: String 175 | , connectPassword :: String 176 | , connectDatabase :: String 177 | , connectOptions :: [Option] 178 | , connectPath :: FilePath 179 | , connectSSL :: Maybe SSLInfo 180 | } deriving (Eq, Read, Show, Typeable) 181 | 182 | data SSLInfo = SSLInfo { 183 | sslKey :: FilePath 184 | , sslCert :: FilePath 185 | , sslCA :: FilePath 186 | , sslCAPath :: FilePath 187 | , sslCiphers :: String -- ^ Comma-separated list of cipher names. 188 | } deriving (Eq, Read, Show, Typeable) 189 | 190 | -- | The constructors of @MySQLError@ are not currently exported, but they 191 | -- have a consistent set of field names which are exported. These fields are: 192 | -- 193 | -- > errFunction :: String 194 | -- > errNumber :: Int 195 | -- > errMessage :: String 196 | -- 197 | data MySQLError = ConnectionError { 198 | errFunction :: String 199 | , errNumber :: Int 200 | , errMessage :: String 201 | } | ResultError { 202 | errFunction :: String 203 | , errNumber :: Int 204 | , errMessage :: String 205 | } deriving (Eq, Show, Typeable) 206 | 207 | instance Exception MySQLError 208 | 209 | -- | Connection to a MySQL database. 210 | data Connection = Connection { 211 | connFP :: ForeignPtr MYSQL 212 | , connClose :: IO () 213 | , connResult :: IORef (Maybe (Weak Result)) 214 | } deriving (Typeable) 215 | 216 | -- | Result of a database query. 217 | data Result = Result { 218 | resFP :: ForeignPtr MYSQL_RES 219 | , resFields :: {-# UNPACK #-} !Int 220 | , resConnection :: Connection 221 | , resValid :: IORef Bool 222 | , resFetchFields :: Ptr MYSQL_RES -> IO (Ptr Field) 223 | , resFetchRow :: Ptr MYSQL_RES -> IO MYSQL_ROW 224 | , resFetchLengths :: Ptr MYSQL_RES -> IO (Ptr CULong) 225 | , resFreeResult :: Ptr MYSQL_RES -> IO () 226 | } | EmptyResult 227 | deriving (Typeable) 228 | 229 | -- | A row cursor, used by 'rowSeek' and 'rowTell'. 230 | newtype Row = Row MYSQL_ROW_OFFSET 231 | deriving (Typeable) 232 | 233 | -- | Default information for setting up a connection. 234 | -- 235 | -- Defaults are as follows: 236 | -- 237 | -- * Server on @localhost@ 238 | -- 239 | -- * User @root@ 240 | -- 241 | -- * No password 242 | -- 243 | -- * Database @test@ 244 | -- 245 | -- * Character set @utf8@ 246 | -- 247 | -- Use as in the following example: 248 | -- 249 | -- > connect defaultConnectInfo { connectHost = "db.example.com" } 250 | defaultConnectInfo :: ConnectInfo 251 | defaultConnectInfo = ConnectInfo { 252 | connectHost = "localhost" 253 | , connectPort = 3306 254 | , connectUser = "root" 255 | , connectPassword = "" 256 | , connectDatabase = "test" 257 | , connectOptions = [CharsetName "utf8"] 258 | , connectPath = "" 259 | , connectSSL = Nothing 260 | } 261 | 262 | -- | Default (empty) information for setting up an SSL connection. 263 | defaultSSLInfo :: SSLInfo 264 | defaultSSLInfo = SSLInfo { 265 | sslKey = "" 266 | , sslCert = "" 267 | , sslCA = "" 268 | , sslCAPath = "" 269 | , sslCiphers = "" 270 | } 271 | 272 | -- | Connect to a database. 273 | connect :: ConnectInfo -> IO Connection 274 | connect ConnectInfo{..} = do 275 | closed <- newIORef False 276 | ptr0 <- mysql_init nullPtr 277 | case connectSSL of 278 | Nothing -> return () 279 | Just SSLInfo{..} -> withString sslKey $ \ckey -> 280 | withString sslCert $ \ccert -> 281 | withString sslCA $ \cca -> 282 | withString sslCAPath $ \ccapath -> 283 | withString sslCiphers $ \ccipher -> 284 | mysql_ssl_set ptr0 ckey ccert cca ccapath ccipher 285 | >> return () 286 | forM_ connectOptions $ \opt -> do 287 | r <- mysql_options ptr0 opt 288 | unless (r == 0) $ connectionError_ "connect" ptr0 289 | let flags = foldl' (+) 0 . map toConnectFlag $ connectOptions 290 | ptr <- withString connectHost $ \chost -> 291 | withString connectUser $ \cuser -> 292 | withString connectPassword $ \cpass -> 293 | withString connectDatabase $ \cdb -> 294 | withString connectPath $ \cpath -> 295 | mysql_real_connect ptr0 chost cuser cpass cdb 296 | (fromIntegral connectPort) cpath flags 297 | when (ptr == nullPtr) $ 298 | connectionError_ "connect" ptr0 299 | res <- newIORef Nothing 300 | let realClose = do 301 | cleanupConnResult res 302 | wasClosed <- atomicModifyIORef closed $ \prev -> (True, prev) 303 | unless wasClosed $ mysql_close ptr 304 | -- In general, the user of this library is responsible for dealing with thread 305 | -- safety. However, the programmer has no control over the OS thread 306 | -- finalizers are run from so we use 'runInBoundThread' and 'initThread' here. 307 | let myRunInBoundThread = if rtsSupportsBoundThreads then runInBoundThread else id 308 | fp <- newForeignPtr ptr (myRunInBoundThread $ initThread >> realClose) 309 | return Connection { 310 | connFP = fp 311 | , connClose = realClose 312 | , connResult = res 313 | } 314 | 315 | -- | Delete the 'MYSQL_RES' behind a 'Result' immediately, and mark 316 | -- the 'Result' as invalid. 317 | cleanupConnResult :: IORef (Maybe (Weak Result)) -> IO () 318 | cleanupConnResult res = do 319 | prev <- readIORef res 320 | case prev of 321 | Nothing -> return () 322 | Just w -> maybe (return ()) freeResult =<< deRefWeak w 323 | 324 | -- | Close a connection, and mark any outstanding 'Result' as 325 | -- invalid. 326 | close :: Connection -> IO () 327 | close = connClose 328 | {-# INLINE close #-} 329 | 330 | ping :: Connection -> IO () 331 | ping conn = withConn conn $ \ptr -> mysql_ping ptr >>= check "ping" conn 332 | 333 | threadId :: Connection -> IO Word 334 | threadId conn = fromIntegral <$> withConn conn mysql_thread_id 335 | 336 | serverInfo :: Connection -> IO String 337 | serverInfo conn = withConn conn $ \ptr -> 338 | peekCString =<< mysql_get_server_info ptr 339 | 340 | hostInfo :: Connection -> IO String 341 | hostInfo conn = withConn conn $ \ptr -> 342 | peekCString =<< mysql_get_host_info ptr 343 | 344 | protocolInfo :: Connection -> IO Word 345 | protocolInfo conn = withConn conn $ \ptr -> 346 | fromIntegral <$> mysql_get_proto_info ptr 347 | 348 | setCharacterSet :: Connection -> String -> IO () 349 | setCharacterSet conn cs = 350 | withCString cs $ \ccs -> 351 | withConn conn $ \ptr -> 352 | mysql_set_character_set ptr ccs >>= check "setCharacterSet" conn 353 | 354 | characterSet :: Connection -> IO String 355 | characterSet conn = withConn conn $ \ptr -> 356 | peekCString =<< mysql_character_set_name ptr 357 | 358 | sslCipher :: Connection -> IO (Maybe String) 359 | sslCipher conn = withConn conn $ \ptr -> 360 | withPtr peekCString =<< mysql_get_ssl_cipher ptr 361 | 362 | serverStatus :: Connection -> IO String 363 | serverStatus conn = withConn conn $ \ptr -> do 364 | st <- mysql_stat ptr 365 | checkNull "serverStatus" conn st 366 | peekCString st 367 | 368 | clientInfo :: String 369 | clientInfo = unsafePerformIO $ peekCString mysql_get_client_info 370 | {-# NOINLINE clientInfo #-} 371 | 372 | clientVersion :: Word 373 | clientVersion = fromIntegral mysql_get_client_version 374 | {-# NOINLINE clientVersion #-} 375 | 376 | -- | Turn autocommit on or off. 377 | -- 378 | -- By default, MySQL runs with autocommit mode enabled. In this mode, 379 | -- as soon as you modify a table, MySQL stores your modification 380 | -- permanently. 381 | autocommit :: Connection -> Bool -> IO () 382 | autocommit conn onOff = withConn conn $ \ptr -> 383 | mysql_autocommit ptr b >>= check "autocommit" conn 384 | where b = if onOff then 1 else 0 385 | 386 | changeUser :: Connection -> String -> String -> Maybe String -> IO () 387 | changeUser conn user pass mdb = 388 | withCString user $ \cuser -> 389 | withCString pass $ \cpass -> 390 | withMaybeString mdb $ \cdb -> 391 | withConn conn $ \ptr -> 392 | mysql_change_user ptr cuser cpass cdb >>= check "changeUser" conn 393 | 394 | selectDB :: Connection -> String -> IO () 395 | selectDB conn db = 396 | withCString db $ \cdb -> 397 | withConn conn $ \ptr -> 398 | mysql_select_db ptr cdb >>= check "selectDB" conn 399 | 400 | query :: Connection -> ByteString -> IO () 401 | query conn q = withConn conn $ \ptr -> 402 | unsafeUseAsCStringLen q $ \(p,l) -> 403 | mysql_real_query ptr p (fromIntegral l) >>= check "query" conn 404 | 405 | -- | Return the value generated for an @AUTO_INCREMENT@ column by the 406 | -- previous @INSERT@ or @UPDATE@ statement. 407 | -- 408 | -- See 409 | insertID :: Connection -> IO Word64 410 | insertID conn = fromIntegral <$> (withConn conn $ mysql_insert_id) 411 | 412 | -- | Return the number of fields (columns) in a result. 413 | -- 414 | -- * If 'Left' 'Connection', returns the number of columns for the most 415 | -- recent query on the connection. 416 | -- 417 | -- * For 'Right' 'Result', returns the number of columns in each row 418 | -- of this result. 419 | -- 420 | -- The number of columns may legitimately be zero. 421 | fieldCount :: Either Connection Result -> IO Int 422 | fieldCount (Right EmptyResult) = return 0 423 | fieldCount (Right res) = return (resFields res) 424 | fieldCount (Left conn) = 425 | withConn conn $ fmap fromIntegral . mysql_field_count 426 | 427 | affectedRows :: Connection -> IO Int64 428 | affectedRows conn = withConn conn $ fmap fromIntegral . mysql_affected_rows 429 | 430 | -- | Retrieve a complete result. 431 | -- 432 | -- Any previous outstanding 'Result' is first marked as invalid. 433 | storeResult :: Connection -> IO Result 434 | storeResult = frobResult "storeResult" mysql_store_result 435 | mysql_fetch_fields_nonblock 436 | mysql_fetch_row_nonblock 437 | mysql_fetch_lengths_nonblock 438 | mysql_free_result_nonblock 439 | 440 | -- | Initiate a row-by-row retrieval of a result. 441 | -- 442 | -- Any previous outstanding 'Result' is first marked as invalid. 443 | useResult :: Connection -> IO Result 444 | useResult = frobResult "useResult" mysql_use_result 445 | mysql_fetch_fields 446 | mysql_fetch_row 447 | mysql_fetch_lengths 448 | mysql_free_result 449 | 450 | frobResult :: String 451 | -> (Ptr MYSQL -> IO (Ptr MYSQL_RES)) 452 | -> (Ptr MYSQL_RES -> IO (Ptr Field)) 453 | -> (Ptr MYSQL_RES -> IO MYSQL_ROW) 454 | -> (Ptr MYSQL_RES -> IO (Ptr CULong)) 455 | -> (Ptr MYSQL_RES -> IO ()) 456 | -> Connection -> IO Result 457 | frobResult func frob fetchFieldsFunc fetchRowFunc fetchLengthsFunc 458 | myFreeResult conn = 459 | withConn conn $ \ptr -> do 460 | cleanupConnResult (connResult conn) 461 | res <- frob ptr 462 | fields <- mysql_field_count ptr 463 | valid <- newIORef True 464 | if res == nullPtr 465 | then if fields == 0 466 | then return EmptyResult 467 | else connectionError func conn 468 | else do 469 | fp <- newForeignPtr res $ freeResult_ valid myFreeResult res 470 | let ret = Result { 471 | resFP = fp 472 | , resFields = fromIntegral fields 473 | , resConnection = conn 474 | , resValid = valid 475 | , resFetchFields = fetchFieldsFunc 476 | , resFetchRow = fetchRowFunc 477 | , resFetchLengths = fetchLengthsFunc 478 | , resFreeResult = myFreeResult 479 | } 480 | weak <- mkWeakPtr ret (Just (freeResult_ valid myFreeResult res)) 481 | writeIORef (connResult conn) (Just weak) 482 | return ret 483 | 484 | -- | Immediately free the @MYSQL_RES@ value associated with this 485 | -- 'Result', and mark the @Result@ as invalid. 486 | freeResult :: Result -> IO () 487 | freeResult Result{..} = withForeignPtr resFP $ 488 | freeResult_ resValid resFreeResult 489 | freeResult EmptyResult = return () 490 | 491 | -- | Check whether a 'Result' is still valid, i.e. backed by a live 492 | -- @MYSQL_RES@ value. 493 | isResultValid :: Result -> IO Bool 494 | isResultValid Result{..} = readIORef resValid 495 | isResultValid EmptyResult = return False 496 | 497 | freeResult_ :: IORef Bool -> (Ptr MYSQL_RES -> IO ()) -> Ptr MYSQL_RES -> IO () 498 | freeResult_ valid free ptr = do 499 | wasValid <- atomicModifyIORef valid $ \prev -> (False, prev) 500 | when wasValid $ free ptr 501 | 502 | fetchRow :: Result -> IO [Maybe ByteString] 503 | fetchRow res@Result{..} = withRes "fetchRow" res $ \ptr -> do 504 | rowPtr <- resFetchRow ptr 505 | if rowPtr == nullPtr 506 | then return [] 507 | else do 508 | lenPtr <- resFetchLengths ptr 509 | checkNull "fetchRow" resConnection lenPtr 510 | let go len = withPtr $ \colPtr -> 511 | create (fromIntegral len) $ \d -> 512 | memcpy d (castPtr colPtr) (fromIntegral len) 513 | sequence =<< zipWith go <$> peekArray resFields lenPtr 514 | <*> peekArray resFields rowPtr 515 | fetchRow EmptyResult = return [] 516 | 517 | fetchFields :: Result -> IO [Field] 518 | fetchFields res@Result{..} = withRes "fetchFields" res $ \ptr -> do 519 | peekArray resFields =<< resFetchFields ptr 520 | fetchFields EmptyResult = return [] 521 | 522 | dataSeek :: Result -> Int64 -> IO () 523 | dataSeek res row = withRes "dataSeek" res $ \ptr -> 524 | mysql_data_seek ptr (fromIntegral row) 525 | 526 | rowTell :: Result -> IO Row 527 | rowTell res = withRes "rowTell" res $ \ptr -> 528 | Row <$> mysql_row_tell ptr 529 | 530 | rowSeek :: Result -> Row -> IO Row 531 | rowSeek res (Row row) = withRes "rowSeek" res $ \ptr -> 532 | Row <$> mysql_row_seek ptr row 533 | 534 | -- | Read the next statement result. Returns 'True' if another result 535 | -- is available, 'False' otherwise. 536 | -- 537 | -- This function marks the current 'Result' as invalid, if one exists. 538 | nextResult :: Connection -> IO Bool 539 | nextResult conn = withConn conn $ \ptr -> do 540 | cleanupConnResult (connResult conn) 541 | i <- mysql_next_result ptr 542 | case i of 543 | 0 -> return True 544 | -1 -> return False 545 | _ -> connectionError "nextResult" conn 546 | 547 | -- | Commit the current transaction. 548 | commit :: Connection -> IO () 549 | commit conn = withConn conn $ \ptr -> 550 | mysql_commit ptr >>= check "commit" conn 551 | 552 | -- | Roll back the current transaction. 553 | rollback :: Connection -> IO () 554 | rollback conn = withConn conn $ \ptr -> 555 | mysql_rollback ptr >>= check "rollback" conn 556 | 557 | escape :: Connection -> ByteString -> IO ByteString 558 | escape conn bs = withConn conn $ \ptr -> 559 | unsafeUseAsCStringLen bs $ \(p,l) -> 560 | createAndTrim (l*2 + 1) $ \to -> 561 | fromIntegral <$> mysql_real_escape_string ptr (castPtr to) p 562 | (fromIntegral l) 563 | 564 | withConn :: Connection -> (Ptr MYSQL -> IO a) -> IO a 565 | withConn conn = withForeignPtr (connFP conn) 566 | 567 | -- | Call @mysql_library_init@ 568 | -- 569 | -- A single-threaded program can rely on an implicit initialisation done 570 | -- when making the first connection, but a multi-threaded one should call 571 | -- 'initLibrary' separately, and it should be done before other threads 572 | -- might call into this library, since this function is not thread-safe. 573 | -- See 574 | -- and 575 | -- for details. 576 | initLibrary :: IO () 577 | initLibrary = do 578 | r <- mysql_library_init 0 nullPtr nullPtr 579 | if r == 0 580 | then return () 581 | else throw $ ConnectionError "initLibrary" (-1) 582 | "mysql_library_init failed" 583 | 584 | -- | Call @mysql_thread_init@ 585 | -- 586 | -- Again a single-threaded program does not need to call this explicitly. Even 587 | -- in a multi-threaded one, if each connection is made, used, and destroyed 588 | -- in a single thread, it is sufficient to rely on the 'connect' call to do 589 | -- an implicit thread initialisation. But in other cases, for example when 590 | -- using a connection pool, each thread requires explicit initialisation. 591 | -- See 592 | -- and 593 | -- for details. 594 | initThread :: IO () 595 | initThread = do 596 | r <- mysql_thread_init 597 | if r == 0 598 | then return () 599 | else throw $ ConnectionError "initThread" (-1) 600 | "mysql_thread_init failed" 601 | 602 | -- | Call @mysql_thread_end@ 603 | -- 604 | -- This is needed at thread exit to avoid a memory leak, except when using 605 | -- a non-debug build of at least version 5.7.9 of the MySQL library. 606 | -- See . 607 | -- The threads in question are the /OS threads/, so calling this function 608 | -- is likely to be important when using large numbers of bound threads (see 609 | -- "Control.Concurrent"). Unbound threads - those created with 'forkIO' and 610 | -- friends - share a small number of OS threads, so in those it is hard to 611 | -- call this function safely, and there is little benefit in doing so, but in 612 | -- any case using this library in unbound threads is not recommended (see 613 | -- ). 614 | endThread :: IO () 615 | endThread = mysql_thread_end 616 | 617 | withRes :: String -> Result -> (Ptr MYSQL_RES -> IO a) -> IO a 618 | withRes func res act = do 619 | valid <- readIORef (resValid res) 620 | unless valid . throw $ ResultError func 0 "result is no longer usable" 621 | withForeignPtr (resFP res) act 622 | 623 | withString :: String -> (CString -> IO a) -> IO a 624 | withString [] act = act nullPtr 625 | withString xs act = withCString xs act 626 | 627 | withMaybeString :: Maybe String -> (CString -> IO a) -> IO a 628 | withMaybeString Nothing act = act nullPtr 629 | withMaybeString (Just xs) act = withCString xs act 630 | 631 | check :: (Eq a, Num a) => String -> Connection -> a -> IO () 632 | check func conn r = unless (r == 0) $ connectionError func conn 633 | {-# INLINE check #-} 634 | 635 | checkNull :: String -> Connection -> Ptr a -> IO () 636 | checkNull func conn p = when (p == nullPtr) $ connectionError func conn 637 | {-# INLINE checkNull #-} 638 | 639 | withPtr :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) 640 | withPtr act p | p == nullPtr = return Nothing 641 | | otherwise = Just <$> act p 642 | 643 | connectionError :: String -> Connection -> IO a 644 | connectionError func conn = withConn conn $ connectionError_ func 645 | 646 | connectionError_ :: String -> Ptr MYSQL -> IO a 647 | connectionError_ func ptr =do 648 | errno <- mysql_errno ptr 649 | msg <- peekCString =<< mysql_error ptr 650 | throw $ ConnectionError func (fromIntegral errno) msg 651 | -------------------------------------------------------------------------------- /Database/MySQL/Base/C.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, EmptyDataDecls, ForeignFunctionInterface #-} 2 | 3 | -- | 4 | -- Module: Database.MySQL.Base.C 5 | -- Copyright: (c) 2011 MailRank, Inc. 6 | -- License: BSD3 7 | -- Maintainer: Paul Rouse 8 | -- Stability: experimental 9 | -- Portability: portable 10 | -- 11 | -- Direct bindings to the C @mysqlclient@ API. 12 | module Database.MySQL.Base.C 13 | ( 14 | -- * Connection management 15 | mysql_init 16 | , mysql_options 17 | , mysql_ssl_set 18 | , mysql_real_connect 19 | , mysql_close 20 | , mysql_ping 21 | , mysql_autocommit 22 | , mysql_change_user 23 | , mysql_select_db 24 | , mysql_set_character_set 25 | -- ** Connection information 26 | , mysql_thread_id 27 | , mysql_get_server_info 28 | , mysql_get_server_version 29 | , mysql_get_host_info 30 | , mysql_get_proto_info 31 | , mysql_character_set_name 32 | , mysql_get_ssl_cipher 33 | , mysql_stat 34 | -- * Querying 35 | , mysql_real_query 36 | , mysql_insert_id 37 | -- ** Escaping 38 | , mysql_real_escape_string 39 | -- ** Results 40 | , mysql_field_count 41 | , mysql_affected_rows 42 | , mysql_store_result 43 | , mysql_use_result 44 | , mysql_fetch_lengths 45 | , mysql_fetch_lengths_nonblock 46 | , mysql_fetch_row 47 | , mysql_fetch_row_nonblock 48 | -- * Working with results 49 | , mysql_free_result 50 | , mysql_free_result_nonblock 51 | , mysql_fetch_fields 52 | , mysql_fetch_fields_nonblock 53 | , mysql_data_seek 54 | , mysql_row_seek 55 | , mysql_row_tell 56 | -- ** Multiple results 57 | , mysql_next_result 58 | -- * Transactions 59 | , mysql_commit 60 | , mysql_rollback 61 | -- * General information 62 | , mysql_get_client_info 63 | , mysql_get_client_version 64 | -- * Error handling 65 | , mysql_errno 66 | , mysql_error 67 | -- * Concurrency 68 | , mysql_library_init 69 | , mysql_thread_init 70 | , mysql_thread_end 71 | ) where 72 | 73 | #include "mysql_signals.h" 74 | #include "mysql.h" 75 | 76 | import Data.ByteString (useAsCString) 77 | import Database.MySQL.Base.Types 78 | import Foreign.C.String (CString, withCString) 79 | ##if __GLASGOW_HASKELL__ >= 704 80 | import Foreign.C.Types (CChar(..), CInt(..), CUInt(..), CULLong(..), CULong(..)) 81 | ##else 82 | import Foreign.C.Types (CInt, CUInt, CULLong, CULong) 83 | ##endif 84 | import Foreign.Marshal.Utils (with) 85 | import Foreign.Ptr (Ptr, nullPtr) 86 | 87 | foreign import ccall safe mysql_init 88 | :: Ptr MYSQL -- ^ should usually be 'nullPtr' 89 | -> IO (Ptr MYSQL) 90 | 91 | mysql_options :: Ptr MYSQL -> Option -> IO CInt 92 | mysql_options ptr opt = 93 | case opt of 94 | ConnectTimeout secs -> 95 | withIntegral secs $ go (#const MYSQL_OPT_CONNECT_TIMEOUT) 96 | Compress -> 97 | go (#const MYSQL_OPT_COMPRESS) nullPtr 98 | NamedPipe -> 99 | go (#const MYSQL_OPT_NAMED_PIPE) nullPtr 100 | InitCommand cmd -> 101 | useAsCString cmd $ go (#const MYSQL_INIT_COMMAND) 102 | ReadDefaultFile path -> 103 | withCString path $ go (#const MYSQL_READ_DEFAULT_FILE) 104 | ReadDefaultGroup group -> 105 | useAsCString group $ go (#const MYSQL_READ_DEFAULT_GROUP) 106 | CharsetDir path -> 107 | withCString path $ go (#const MYSQL_SET_CHARSET_DIR) 108 | CharsetName cs -> 109 | withCString cs $ go (#const MYSQL_SET_CHARSET_NAME) 110 | LocalInFile b -> 111 | withBool b $ go (#const MYSQL_OPT_LOCAL_INFILE) 112 | Protocol proto -> 113 | withIntegral (fromEnum proto) $ go (#const MYSQL_OPT_PROTOCOL) 114 | SharedMemoryBaseName name -> 115 | useAsCString name $ go (#const MYSQL_SHARED_MEMORY_BASE_NAME) 116 | ReadTimeout secs -> 117 | withIntegral secs $ go (#const MYSQL_OPT_READ_TIMEOUT) 118 | WriteTimeout secs -> 119 | withIntegral secs $ go (#const MYSQL_OPT_WRITE_TIMEOUT) 120 | #if !defined(MARIADB_BASE_VERSION) && MYSQL_VERSION_ID >= 80000 121 | #else 122 | UseRemoteConnection -> 123 | go (#const MYSQL_OPT_USE_REMOTE_CONNECTION) nullPtr 124 | UseEmbeddedConnection -> 125 | go (#const MYSQL_OPT_USE_EMBEDDED_CONNECTION) nullPtr 126 | GuessConnection -> 127 | go (#const MYSQL_OPT_GUESS_CONNECTION) nullPtr 128 | ClientIP ip -> 129 | useAsCString ip $ go (#const MYSQL_SET_CLIENT_IP) 130 | SecureAuth b -> 131 | withBool b $ go (#const MYSQL_SECURE_AUTH) 132 | #endif 133 | ReportDataTruncation b -> 134 | withBool b $ go (#const MYSQL_REPORT_DATA_TRUNCATION) 135 | Reconnect b -> 136 | withBool b $ go (#const MYSQL_OPT_RECONNECT) 137 | #if !defined(MARIADB_BASE_VERSION) && MYSQL_VERSION_ID >= 80000 138 | #else 139 | SSLVerifyServerCert b -> 140 | withBool b $ go (#const MYSQL_OPT_SSL_VERIFY_SERVER_CERT) 141 | #endif 142 | -- Other options are accepted by mysql_real_connect, so ignore them. 143 | _ -> return 0 144 | where 145 | go = mysql_options_ ptr 146 | withBool b = with (if b then 1 else 0 :: CUInt) 147 | withIntegral i = with (fromIntegral i :: CUInt) 148 | 149 | foreign import ccall safe "mysql.h mysql_options" mysql_options_ 150 | :: Ptr MYSQL -> CInt -> Ptr a -> IO CInt 151 | 152 | foreign import ccall safe "mysql_signals.h _hs_mysql_real_connect" 153 | mysql_real_connect 154 | :: Ptr MYSQL -- ^ Context (from 'mysql_init'). 155 | -> CString -- ^ Host name. 156 | -> CString -- ^ User name. 157 | -> CString -- ^ Password. 158 | -> CString -- ^ Database. 159 | -> CInt -- ^ Port. 160 | -> CString -- ^ Unix socket. 161 | -> CULong -- ^ Flags. 162 | -> IO (Ptr MYSQL) 163 | 164 | foreign import ccall safe mysql_ssl_set 165 | :: Ptr MYSQL 166 | -> CString -- ^ Key. 167 | -> CString -- ^ Cert. 168 | -> CString -- ^ CA. 169 | -> CString -- ^ CA path. 170 | -> CString -- ^ Ciphers. 171 | -> IO MyBool 172 | 173 | foreign import ccall safe "mysql_signals.h _hs_mysql_close" mysql_close 174 | :: Ptr MYSQL -> IO () 175 | 176 | foreign import ccall safe "mysql_signals.h _hs_mysql_ping" mysql_ping 177 | :: Ptr MYSQL -> IO CInt 178 | 179 | foreign import ccall safe mysql_thread_id 180 | :: Ptr MYSQL -> IO CULong 181 | 182 | foreign import ccall safe "mysql_signals.h _hs_mysql_autocommit" mysql_autocommit 183 | :: Ptr MYSQL -> MyBool -> IO MyBool 184 | 185 | foreign import ccall safe "mysql_signals.h _hs_mysql_change_user" mysql_change_user 186 | :: Ptr MYSQL 187 | -> CString -- ^ user 188 | -> CString -- ^ password 189 | -> CString -- ^ database 190 | -> IO MyBool 191 | 192 | foreign import ccall safe "mysql_signals.h _hs_mysql_select_db" mysql_select_db 193 | :: Ptr MYSQL 194 | -> CString 195 | -> IO CInt 196 | 197 | foreign import ccall safe mysql_get_server_info 198 | :: Ptr MYSQL -> IO CString 199 | 200 | foreign import ccall safe mysql_get_server_version 201 | :: Ptr MYSQL -> IO CULong 202 | 203 | foreign import ccall safe mysql_get_host_info 204 | :: Ptr MYSQL -> IO CString 205 | 206 | foreign import ccall safe mysql_get_proto_info 207 | :: Ptr MYSQL -> IO CUInt 208 | 209 | foreign import ccall safe mysql_character_set_name 210 | :: Ptr MYSQL -> IO CString 211 | 212 | foreign import ccall safe mysql_set_character_set 213 | :: Ptr MYSQL -> CString -> IO CInt 214 | 215 | foreign import ccall safe mysql_get_ssl_cipher 216 | :: Ptr MYSQL -> IO CString 217 | 218 | foreign import ccall safe "mysql_signals.h _hs_mysql_stat" mysql_stat 219 | :: Ptr MYSQL -> IO CString 220 | 221 | foreign import ccall safe "mysql_signals.h _hs_mysql_real_query" mysql_real_query 222 | :: Ptr MYSQL -> CString -> CULong -> IO CInt 223 | 224 | foreign import ccall safe mysql_insert_id 225 | :: Ptr MYSQL -> IO CULLong 226 | 227 | foreign import ccall safe mysql_field_count 228 | :: Ptr MYSQL -> IO CUInt 229 | 230 | foreign import ccall safe mysql_affected_rows 231 | :: Ptr MYSQL -> IO CULLong 232 | 233 | foreign import ccall safe "mysql_signals.h _hs_mysql_store_result" mysql_store_result 234 | :: Ptr MYSQL -> IO (Ptr MYSQL_RES) 235 | 236 | foreign import ccall safe "mysql_signals.h _hs_mysql_use_result" mysql_use_result 237 | :: Ptr MYSQL -> IO (Ptr MYSQL_RES) 238 | 239 | foreign import ccall safe "mysql_signals.h _hs_mysql_free_result" mysql_free_result 240 | :: Ptr MYSQL_RES -> IO () 241 | 242 | foreign import ccall safe "mysql.h mysql_free_result" mysql_free_result_nonblock 243 | :: Ptr MYSQL_RES -> IO () 244 | 245 | foreign import ccall safe mysql_fetch_fields 246 | :: Ptr MYSQL_RES -> IO (Ptr Field) 247 | 248 | foreign import ccall safe "mysql.h mysql_fetch_fields" mysql_fetch_fields_nonblock 249 | :: Ptr MYSQL_RES -> IO (Ptr Field) 250 | 251 | foreign import ccall safe mysql_data_seek 252 | :: Ptr MYSQL_RES -> CULLong -> IO () 253 | 254 | foreign import ccall safe mysql_row_seek 255 | :: Ptr MYSQL_RES -> MYSQL_ROW_OFFSET -> IO MYSQL_ROW_OFFSET 256 | 257 | foreign import ccall safe mysql_row_tell 258 | :: Ptr MYSQL_RES -> IO MYSQL_ROW_OFFSET 259 | 260 | foreign import ccall safe "mysql_signals.h _hs_mysql_next_result" mysql_next_result 261 | :: Ptr MYSQL -> IO CInt 262 | 263 | foreign import ccall safe "mysql_signals.h _hs_mysql_commit" mysql_commit 264 | :: Ptr MYSQL -> IO MyBool 265 | 266 | foreign import ccall safe "mysql_signals.h _hs_mysql_rollback" mysql_rollback 267 | :: Ptr MYSQL -> IO MyBool 268 | 269 | foreign import ccall safe "mysql_signals.h _hs_mysql_fetch_row" mysql_fetch_row 270 | :: Ptr MYSQL_RES -> IO MYSQL_ROW 271 | 272 | foreign import ccall safe "mysql.h mysql_fetch_row" mysql_fetch_row_nonblock 273 | :: Ptr MYSQL_RES -> IO MYSQL_ROW 274 | 275 | foreign import ccall safe mysql_fetch_lengths 276 | :: Ptr MYSQL_RES -> IO (Ptr CULong) 277 | 278 | foreign import ccall safe "mysql.h mysql_fetch_lengths" mysql_fetch_lengths_nonblock 279 | :: Ptr MYSQL_RES -> IO (Ptr CULong) 280 | 281 | foreign import ccall safe mysql_real_escape_string 282 | :: Ptr MYSQL -> CString -> CString -> CULong -> IO CULong 283 | 284 | foreign import ccall safe mysql_get_client_info :: CString 285 | 286 | foreign import ccall safe mysql_get_client_version :: CULong 287 | 288 | foreign import ccall safe mysql_errno 289 | :: Ptr MYSQL -> IO CInt 290 | 291 | foreign import ccall safe mysql_error 292 | :: Ptr MYSQL -> IO CString 293 | 294 | foreign import ccall safe "mysql.h mysql_server_init" mysql_library_init 295 | :: CInt -> Ptr (Ptr Char) -> Ptr (Ptr Char) -> IO CInt 296 | 297 | foreign import ccall safe "mysql.h" mysql_thread_init 298 | :: IO MyBool 299 | 300 | foreign import ccall safe "mysql.h" mysql_thread_end 301 | :: IO () 302 | -------------------------------------------------------------------------------- /Database/MySQL/Base/Types.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, ForeignFunctionInterface #-} 2 | 3 | -- | 4 | -- Module: Database.MySQL.Base.C 5 | -- Copyright: (c) 2011 MailRank, Inc. 6 | -- License: BSD3 7 | -- Maintainer: Paul Rouse 8 | -- Stability: experimental 9 | -- Portability: portable 10 | -- 11 | -- Types for working with the direct bindings to the C @mysqlclient@ 12 | -- API. 13 | 14 | module Database.MySQL.Base.Types 15 | ( 16 | -- * Types 17 | -- * High-level types 18 | Type(..) 19 | , Seconds 20 | , Protocol(..) 21 | , Option(..) 22 | , Field(..) 23 | , FieldFlag 24 | , FieldFlags 25 | -- * Low-level types 26 | , MYSQL 27 | , MYSQL_RES 28 | , MYSQL_ROW 29 | , MYSQL_ROWS 30 | , MYSQL_ROW_OFFSET 31 | , MyBool 32 | -- * Field flags 33 | , hasAllFlags 34 | , flagNotNull 35 | , flagPrimaryKey 36 | , flagUniqueKey 37 | , flagMultipleKey 38 | , flagUnsigned 39 | , flagZeroFill 40 | , flagBinary 41 | , flagAutoIncrement 42 | , flagNumeric 43 | , flagNoDefaultValue 44 | -- * Connect flags 45 | , toConnectFlag 46 | ) where 47 | 48 | #include "mysql.h" 49 | 50 | import Control.Applicative ((<$>), (<*>), pure) 51 | import Data.Bits ((.|.), (.&.)) 52 | import Data.ByteString hiding (intercalate) 53 | import Data.ByteString.Internal (create, memcpy) 54 | import Data.List (intercalate) 55 | import Data.Maybe (catMaybes) 56 | import Data.Monoid (Monoid(..)) 57 | import Data.Semigroup (Semigroup(..)) 58 | import Data.Typeable (Typeable) 59 | import Data.Word (Word, Word8) 60 | import Foreign.C.Types (CChar, CInt, CUInt, CULong) 61 | import Foreign.Ptr (Ptr) 62 | import Foreign.Storable (Storable(..), peekByteOff) 63 | import qualified Data.IntMap as IntMap 64 | 65 | data MYSQL 66 | data MYSQL_RES 67 | data MYSQL_ROWS 68 | type MYSQL_ROW = Ptr (Ptr CChar) 69 | type MYSQL_ROW_OFFSET = Ptr MYSQL_ROWS 70 | type MyBool = CChar 71 | 72 | -- "mysql.h" defines the `MYSQL_TYPE_...` symbols as values of an enumeration, 73 | -- not as preprocessor symbols. Therefore we can't test for the presence of 74 | -- `MYSQL_TYPE_JSON` using `#ifdef` or `#if defined()`, yet it is not available 75 | -- in all versions of MySQL and MariaDB. Although this is very unsatisfactory, 76 | -- we have little alternative but to define it here. 77 | -- 78 | mysql_type_json :: Int 79 | mysql_type_json = 245 80 | 81 | -- | Column types supported by MySQL. 82 | data Type = Decimal 83 | | Tiny 84 | | Short 85 | | Long 86 | | Float 87 | | Double 88 | | Null 89 | | Timestamp 90 | | LongLong 91 | | Int24 92 | | Date 93 | | Time 94 | | DateTime 95 | | Year 96 | | NewDate 97 | | VarChar 98 | | Bit 99 | | NewDecimal 100 | | Enum 101 | | Set 102 | | TinyBlob 103 | | MediumBlob 104 | | LongBlob 105 | | Blob 106 | | VarString 107 | | String 108 | | Geometry 109 | | Json 110 | deriving (Enum, Eq, Show, Typeable) 111 | 112 | toType :: CInt -> Type 113 | toType v = IntMap.findWithDefault oops (fromIntegral v) typeMap 114 | where 115 | oops = error $ "Database.MySQL: unknown field type " ++ show v 116 | typeMap = IntMap.fromList 117 | [ ((#const MYSQL_TYPE_DECIMAL), Decimal) 118 | , ((#const MYSQL_TYPE_TINY), Tiny) 119 | , ((#const MYSQL_TYPE_SHORT), Short) 120 | , ((#const MYSQL_TYPE_INT24), Int24) 121 | , ((#const MYSQL_TYPE_LONG), Long) 122 | , ((#const MYSQL_TYPE_FLOAT), Float) 123 | , ((#const MYSQL_TYPE_DOUBLE), Double) 124 | , ((#const MYSQL_TYPE_NULL), Null) 125 | , ((#const MYSQL_TYPE_TIMESTAMP), Timestamp) 126 | , ((#const MYSQL_TYPE_LONGLONG), LongLong) 127 | , ((#const MYSQL_TYPE_DATE), Date) 128 | , ((#const MYSQL_TYPE_TIME), Time) 129 | , ((#const MYSQL_TYPE_DATETIME), DateTime) 130 | , ((#const MYSQL_TYPE_YEAR), Year) 131 | , ((#const MYSQL_TYPE_NEWDATE), NewDate) 132 | , ((#const MYSQL_TYPE_VARCHAR), VarChar) 133 | , ((#const MYSQL_TYPE_BIT), Bit) 134 | , ((#const MYSQL_TYPE_NEWDECIMAL), NewDecimal) 135 | , ((#const MYSQL_TYPE_ENUM), Enum) 136 | , ((#const MYSQL_TYPE_SET), Set) 137 | , ((#const MYSQL_TYPE_TINY_BLOB), TinyBlob) 138 | , ((#const MYSQL_TYPE_MEDIUM_BLOB), MediumBlob) 139 | , ((#const MYSQL_TYPE_LONG_BLOB), LongBlob) 140 | , ((#const MYSQL_TYPE_BLOB), Blob) 141 | , ((#const MYSQL_TYPE_VAR_STRING), VarString) 142 | , ((#const MYSQL_TYPE_STRING), String) 143 | , ((#const MYSQL_TYPE_GEOMETRY), Geometry) 144 | , (mysql_type_json, Json) 145 | ] 146 | 147 | -- | A description of a field (column) of a table. 148 | data Field = Field { 149 | fieldName :: ByteString -- ^ Name of column. 150 | , fieldOrigName :: ByteString -- ^ Original column name, if an alias. 151 | , fieldTable :: ByteString -- ^ Table of column, if column was a field. 152 | , fieldOrigTable :: ByteString -- ^ Original table name, if table was an alias. 153 | , fieldDB :: ByteString -- ^ Database for table. 154 | , fieldCatalog :: ByteString -- ^ Catalog for table. 155 | , fieldLength :: Word -- ^ Width of column (create length). 156 | , fieldMaxLength :: Word -- ^ Maximum width for selected set. 157 | , fieldFlags :: FieldFlags -- ^ Div flags. 158 | , fieldDecimals :: Word -- ^ Number of decimals in field. 159 | , fieldCharSet :: Word -- ^ Character set number. 160 | , fieldType :: Type 161 | } deriving (Eq, Show, Typeable) 162 | 163 | newtype FieldFlags = FieldFlags CUInt 164 | deriving (Eq, Typeable) 165 | 166 | instance Show FieldFlags where 167 | show f = '[' : z ++ "]" 168 | where z = intercalate "," . catMaybes $ [ 169 | flagNotNull ??? "flagNotNull" 170 | , flagPrimaryKey ??? "flagPrimaryKey" 171 | , flagUniqueKey ??? "flagUniqueKey" 172 | , flagMultipleKey ??? "flagMultipleKey" 173 | , flagUnsigned ??? "flagUnsigned" 174 | , flagZeroFill ??? "flagZeroFill" 175 | , flagBinary ??? "flagBinary" 176 | , flagAutoIncrement ??? "flagAutoIncrement" 177 | , flagNumeric ??? "flagNumeric" 178 | , flagNoDefaultValue ??? "flagNoDefaultValue" 179 | ] 180 | flag ??? name | f `hasAllFlags` flag = Just name 181 | | otherwise = Nothing 182 | 183 | type FieldFlag = FieldFlags 184 | 185 | instance Semigroup FieldFlags where 186 | (<>) (FieldFlags a) (FieldFlags b) = FieldFlags (a .|. b) 187 | {-# INLINE (<>) #-} 188 | 189 | instance Monoid FieldFlags where 190 | mempty = FieldFlags 0 191 | {-# INLINE mempty #-} 192 | mappend = (<>) 193 | {-# INLINE mappend #-} 194 | 195 | flagNotNull, flagPrimaryKey, flagUniqueKey, flagMultipleKey :: FieldFlag 196 | flagNotNull = FieldFlags #const NOT_NULL_FLAG 197 | flagPrimaryKey = FieldFlags #const PRI_KEY_FLAG 198 | flagUniqueKey = FieldFlags #const UNIQUE_KEY_FLAG 199 | flagMultipleKey = FieldFlags #const MULTIPLE_KEY_FLAG 200 | 201 | flagUnsigned, flagZeroFill, flagBinary, flagAutoIncrement :: FieldFlag 202 | flagUnsigned = FieldFlags #const UNSIGNED_FLAG 203 | flagZeroFill = FieldFlags #const ZEROFILL_FLAG 204 | flagBinary = FieldFlags #const BINARY_FLAG 205 | flagAutoIncrement = FieldFlags #const AUTO_INCREMENT_FLAG 206 | 207 | flagNumeric, flagNoDefaultValue :: FieldFlag 208 | flagNumeric = FieldFlags #const NUM_FLAG 209 | flagNoDefaultValue = FieldFlags #const NO_DEFAULT_VALUE_FLAG 210 | 211 | hasAllFlags :: FieldFlags -> FieldFlags -> Bool 212 | FieldFlags a `hasAllFlags` FieldFlags b = a .&. b == b 213 | {-# INLINE hasAllFlags #-} 214 | 215 | peekField :: Ptr Field -> IO Field 216 | peekField ptr = do 217 | flags <- FieldFlags <$> (#peek MYSQL_FIELD, flags) ptr 218 | Field 219 | <$> peekS ((#peek MYSQL_FIELD, name)) ((#peek MYSQL_FIELD, name_length)) 220 | <*> peekS ((#peek MYSQL_FIELD, org_name)) ((#peek MYSQL_FIELD, org_name_length)) 221 | <*> peekS ((#peek MYSQL_FIELD, table)) ((#peek MYSQL_FIELD, table_length)) 222 | <*> peekS ((#peek MYSQL_FIELD, org_table)) ((#peek MYSQL_FIELD, org_table_length)) 223 | <*> peekS ((#peek MYSQL_FIELD, db)) ((#peek MYSQL_FIELD, db_length)) 224 | <*> peekS ((#peek MYSQL_FIELD, catalog)) ((#peek MYSQL_FIELD, catalog_length)) 225 | <*> (uint <$> (#peek MYSQL_FIELD, length) ptr) 226 | <*> (uint <$> (#peek MYSQL_FIELD, max_length) ptr) 227 | <*> pure flags 228 | <*> (uint <$> (#peek MYSQL_FIELD, decimals) ptr) 229 | <*> (uint <$> (#peek MYSQL_FIELD, charsetnr) ptr) 230 | <*> (toType <$> (#peek MYSQL_FIELD, type) ptr) 231 | where 232 | uint = fromIntegral :: CUInt -> Word 233 | peekS :: (Ptr Field -> IO (Ptr Word8)) -> (Ptr Field -> IO CUInt) 234 | -> IO ByteString 235 | peekS peekPtr peekLen = do 236 | p <- peekPtr ptr 237 | l <- peekLen ptr 238 | create (fromIntegral l) $ \d -> memcpy d p (fromIntegral l) 239 | 240 | instance Storable Field where 241 | sizeOf _ = #{size MYSQL_FIELD} 242 | alignment _ = alignment (undefined :: Ptr CChar) 243 | peek = peekField 244 | poke _ _ = return () -- Unused, but define it to avoid a warning 245 | 246 | type Seconds = Word 247 | 248 | data Protocol = TCP 249 | | Socket 250 | | Pipe 251 | | Memory 252 | deriving (Eq, Read, Show, Enum, Typeable) 253 | 254 | data Option = 255 | -- Options accepted by mysq_options. 256 | ConnectTimeout Seconds 257 | | Compress 258 | | NamedPipe 259 | | InitCommand ByteString 260 | | ReadDefaultFile FilePath 261 | | ReadDefaultGroup ByteString 262 | | CharsetDir FilePath 263 | | CharsetName String 264 | | LocalInFile Bool 265 | | Protocol Protocol 266 | | SharedMemoryBaseName ByteString 267 | | ReadTimeout Seconds 268 | | WriteTimeout Seconds 269 | #if !defined(MARIADB_BASE_VERSION) && MYSQL_VERSION_ID >= 80000 270 | #else 271 | | UseRemoteConnection 272 | | UseEmbeddedConnection 273 | | GuessConnection 274 | | ClientIP ByteString 275 | #endif 276 | | SecureAuth Bool 277 | | ReportDataTruncation Bool 278 | | Reconnect Bool 279 | #if !defined(MARIADB_BASE_VERSION) && MYSQL_VERSION_ID >= 80000 280 | #else 281 | | SSLVerifyServerCert Bool 282 | #endif 283 | -- Flags accepted by mysql_real_connect. 284 | | FoundRows 285 | | IgnoreSIGPIPE 286 | | IgnoreSpace 287 | | Interactive 288 | | LocalFiles 289 | | MultiResults 290 | | MultiStatements 291 | | NoSchema 292 | deriving (Eq, Read, Show, Typeable) 293 | 294 | toConnectFlag :: Option -> CULong 295 | toConnectFlag Compress = #const CLIENT_COMPRESS 296 | toConnectFlag FoundRows = #const CLIENT_FOUND_ROWS 297 | toConnectFlag IgnoreSIGPIPE = #const CLIENT_IGNORE_SIGPIPE 298 | toConnectFlag IgnoreSpace = #const CLIENT_IGNORE_SPACE 299 | toConnectFlag Interactive = #const CLIENT_INTERACTIVE 300 | toConnectFlag LocalFiles = #const CLIENT_LOCAL_FILES 301 | toConnectFlag MultiResults = #const CLIENT_MULTI_RESULTS 302 | toConnectFlag MultiStatements = #const CLIENT_MULTI_STATEMENTS 303 | toConnectFlag NoSchema = #const CLIENT_NO_SCHEMA 304 | toConnectFlag _ = 0 305 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, MailRank, Inc. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # mysql: bindings to the mysqlclient library 2 | 3 | This library is a Haskell binding to the MySQL `mysqlclient` client 4 | library. It is a fairly faithful, low level library that implements 5 | most of the MySQL client API. The major departure from the C API is 6 | that in Haskell, resource management is mostly automatic and safe. 7 | 8 | This library deliberately avoids the question of providing a "good" 9 | API. Its purpose is to serve as a base upon which higher-level 10 | libraries can be built. 11 | 12 | # Licensing 13 | 14 | This library is BSD-licensed under the terms of the 15 | [MySQL FOSS License Exception](http://www.mysql.com/about/legal/licensing/foss-exception/). 16 | 17 | Since this library links against the GPL-licensed `mysqlclient` 18 | library, a non-open-source application that uses it *may* be subject 19 | to the terms of the GPL. 20 | 21 | # To do 22 | 23 | * Add support for prepared statements. The prepared statement API is 24 | huge and of dubious performance value, so it's not currently a 25 | priority for us. Patches welcome! 26 | 27 | # Get involved! 28 | 29 | We are happy to receive bug reports, fixes, documentation enhancements, 30 | and other improvements. 31 | 32 | Please report bugs via the 33 | [github issue tracker](http://github.com/paul-rouse/mysql/issues). 34 | 35 | Master [git repository](http://github.com/paul-rouse/mysql): 36 | 37 | * `git clone git://github.com/paul-rouse/mysql.git` 38 | 39 | # Authors 40 | 41 | This library was written by Bryan O'Sullivan, , 42 | to whom all of the credit is due. 43 | It is now being maintained by Paul Rouse, . 44 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE CPP #-} 5 | {- OPTIONS_GHC -Wall #-} 6 | 7 | #ifndef MIN_VERSION_Cabal 8 | #define MIN_VERSION_Cabal(x,y,z) 0 9 | #endif 10 | 11 | import Control.Exception (IOException, catch) 12 | import Control.Monad (liftM, msum, sequence) 13 | import Data.List (isPrefixOf, isInfixOf, nub) 14 | import Distribution.PackageDescription 15 | import Distribution.Simple 16 | import Distribution.Simple.LocalBuildInfo 17 | import Distribution.Simple.Program 18 | import Distribution.Verbosity 19 | 20 | -- A Cabal 1.16 vs 1.18 compatibility hack, as in 1.18 21 | -- findProgramLocation has a new (unused in this case) parameter. 22 | -- ConstOrId adds this parameter when types say it is mandatory. 23 | class ConstOrId a b where 24 | constOrId :: a -> b 25 | 26 | instance ConstOrId a a where 27 | constOrId = id 28 | 29 | instance ConstOrId a (b -> a) where 30 | constOrId = const 31 | 32 | 33 | main = defaultMainWithHooks simpleUserHooks { 34 | hookedPrograms = [mysqlConfigProgram], 35 | 36 | confHook = \pkg flags -> do 37 | lbi <- confHook simpleUserHooks pkg flags 38 | bi <- mysqlBuildInfo lbi 39 | return lbi { 40 | localPkgDescr = updatePackageDescription (Just bi, []) (localPkgDescr lbi) 41 | } 42 | } 43 | 44 | mysqlConfigProgram = (simpleProgram "mysql_config") { 45 | programFindLocation = \verbosity -> constOrId $ liftM msum $ sequence 46 | #if MIN_VERSION_Cabal(1,24,0) 47 | [ (findProgramOnSearchPath verbosity [ProgramSearchPathDefault] "mysql_config") 48 | , (findProgramOnSearchPath verbosity [ProgramSearchPathDefault] "mysql_config5") 49 | , (findProgramOnSearchPath verbosity [ProgramSearchPathDefault] "mariadb_config") 50 | ] 51 | #else 52 | [ (findProgramLocation verbosity "mysql_config") 53 | , (findProgramLocation verbosity "mysql_config5") 54 | , (findProgramLocation verbosity "mariadb_config") 55 | ] 56 | #endif 57 | } 58 | 59 | mysqlBuildInfo :: LocalBuildInfo -> IO BuildInfo 60 | mysqlBuildInfo lbi = do 61 | #if MIN_VERSION_Cabal(2,0,0) 62 | let mysqlConfig = fmap words . getDbProgramOutput normal 63 | mysqlConfigProgram (withPrograms lbi) 64 | #else 65 | let mysqlConfig = fmap words . rawSystemProgramStdoutConf normal 66 | mysqlConfigProgram (withPrograms lbi) 67 | #endif 68 | 69 | include <- mysqlConfig ["--include"] 70 | libs <- mysqlConfig ["--libs"] 71 | libsR <- mysqlConfig ["--libs_r"] 72 | libsSys' <- mysqlConfig ["--libs_sys"] `catch` libsFromError 73 | 74 | -- On some systems, `mysql_config` fails to give an error status even though 75 | -- it cannot handle `--libs_sys`. The "Usage:" message lists libraries we do 76 | -- do not want to include, so recognise it for what it is! 77 | -- 78 | let libsSys = if null $ filter ("Usage:" `isInfixOf`) libsSys' then libsSys' 79 | else [] 80 | 81 | return emptyBuildInfo { 82 | extraLibDirs = map (drop 2) . filter ("-L" `isPrefixOf`) $ 83 | nub (libsSys ++ libs) 84 | , extraLibs = map (drop 2) . filter ("-l" `isPrefixOf`) . 85 | filter (/= "-lmygcc") $ 86 | filter (/= "-lmysqlclient_r") $ 87 | nub (libsSys ++ libs ++ libsR) 88 | , includeDirs = map (drop 2) include 89 | } 90 | where 91 | -- Recover from an error by returning an empty list. 92 | libsFromError :: IOException -> IO [String] 93 | libsFromError _ = return [] 94 | -------------------------------------------------------------------------------- /cbits/mysql_signals.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Wrap MySQL API calls that are known to block and to be vulnerable 3 | * to interruption by GHC's RTS signals. 4 | */ 5 | 6 | #include "mysql_signals.h" 7 | #include 8 | #include 9 | #include 10 | 11 | static sigset_t sigs[1]; 12 | static int sigs_inited; 13 | 14 | static void init_rts_sigset(void) 15 | { 16 | static pthread_mutex_t sigs_mutex = PTHREAD_MUTEX_INITIALIZER; 17 | 18 | pthread_mutex_lock(&sigs_mutex); 19 | if (!sigs_inited) { 20 | sigemptyset(sigs); 21 | sigaddset(sigs, SIGALRM); 22 | sigaddset(sigs, SIGVTALRM); 23 | sigs_inited = 1; 24 | } 25 | pthread_mutex_unlock(&sigs_mutex); 26 | } 27 | 28 | #define block_rts_signals() \ 29 | do { \ 30 | if (!sigs_inited) init_rts_sigset(); \ 31 | pthread_sigmask(SIG_BLOCK, sigs, NULL); \ 32 | } while (0) 33 | 34 | #define unblock_rts_signals() pthread_sigmask(SIG_UNBLOCK, sigs, NULL) 35 | 36 | MYSQL *STDCALL _hs_mysql_real_connect(MYSQL *mysql, const char *host, 37 | const char *user, 38 | const char *passwd, 39 | const char *db, 40 | unsigned int port, 41 | const char *unix_socket, 42 | unsigned long clientflag) 43 | { 44 | MYSQL *ret; 45 | block_rts_signals(); 46 | ret = mysql_real_connect(mysql, host, user, passwd, db, port, unix_socket, 47 | clientflag); 48 | unblock_rts_signals(); 49 | 50 | return ret; 51 | } 52 | 53 | void STDCALL _hs_mysql_close(MYSQL *sock) 54 | { 55 | block_rts_signals(); 56 | mysql_close(sock); 57 | unblock_rts_signals(); 58 | } 59 | 60 | int STDCALL _hs_mysql_ping(MYSQL *mysql) 61 | { 62 | int ret; 63 | block_rts_signals(); 64 | ret = mysql_ping(mysql); 65 | unblock_rts_signals(); 66 | return ret; 67 | } 68 | 69 | int STDCALL _hs_mysql_real_query(MYSQL *mysql, const char *q, 70 | unsigned long length) 71 | { 72 | int ret; 73 | block_rts_signals(); 74 | ret = mysql_real_query(mysql, q, length); 75 | unblock_rts_signals(); 76 | return ret; 77 | } 78 | 79 | const char *STDCALL _hs_mysql_stat(MYSQL *mysql) 80 | { 81 | const char *ret; 82 | block_rts_signals(); 83 | ret = mysql_stat(mysql); 84 | unblock_rts_signals(); 85 | return ret; 86 | } 87 | 88 | my_bool STDCALL _hs_mysql_commit(MYSQL * mysql) 89 | { 90 | my_bool ret; 91 | block_rts_signals(); 92 | ret = mysql_commit(mysql); 93 | unblock_rts_signals(); 94 | return ret; 95 | } 96 | 97 | my_bool STDCALL _hs_mysql_rollback(MYSQL * mysql) 98 | { 99 | my_bool ret; 100 | block_rts_signals(); 101 | ret = mysql_rollback(mysql); 102 | unblock_rts_signals(); 103 | return ret; 104 | } 105 | 106 | my_bool STDCALL _hs_mysql_autocommit(MYSQL *mysql, my_bool auto_mode) 107 | { 108 | my_bool ret; 109 | block_rts_signals(); 110 | ret = mysql_autocommit(mysql, auto_mode); 111 | unblock_rts_signals(); 112 | return ret; 113 | } 114 | 115 | my_bool STDCALL _hs_mysql_change_user(MYSQL *mysql, const char *user, 116 | const char *passwd, const char *db) 117 | { 118 | my_bool ret; 119 | block_rts_signals(); 120 | ret = mysql_change_user(mysql, user, passwd, db); 121 | unblock_rts_signals(); 122 | return ret; 123 | } 124 | 125 | int STDCALL _hs_mysql_select_db(MYSQL *mysql, const char *db) 126 | { 127 | int ret; 128 | block_rts_signals(); 129 | ret = mysql_select_db(mysql, db); 130 | unblock_rts_signals(); 131 | return ret; 132 | } 133 | 134 | MYSQL_FIELD *STDCALL _hs_mysql_fetch_field(MYSQL_RES *result) 135 | { 136 | MYSQL_FIELD *ret; 137 | block_rts_signals(); 138 | ret = mysql_fetch_field(result); 139 | unblock_rts_signals(); 140 | return ret; 141 | } 142 | 143 | MYSQL_ROW STDCALL _hs_mysql_fetch_row(MYSQL_RES *result) 144 | { 145 | MYSQL_ROW ret; 146 | block_rts_signals(); 147 | ret = mysql_fetch_row(result); 148 | unblock_rts_signals(); 149 | return ret; 150 | } 151 | 152 | unsigned long *STDCALL _hs_mysql_fetch_lengths(MYSQL_RES *result) 153 | { 154 | unsigned long *ret; 155 | block_rts_signals(); 156 | ret = mysql_fetch_lengths(result); 157 | unblock_rts_signals(); 158 | return ret; 159 | } 160 | 161 | MYSQL_RES *STDCALL _hs_mysql_store_result(MYSQL *mysql) 162 | { 163 | MYSQL_RES *ret; 164 | block_rts_signals(); 165 | ret = mysql_store_result(mysql); 166 | unblock_rts_signals(); 167 | return ret; 168 | } 169 | 170 | MYSQL_RES *STDCALL _hs_mysql_use_result(MYSQL *mysql) 171 | { 172 | MYSQL_RES *ret; 173 | block_rts_signals(); 174 | ret = mysql_use_result(mysql); 175 | unblock_rts_signals(); 176 | return ret; 177 | } 178 | 179 | void STDCALL _hs_mysql_free_result(MYSQL_RES *result) 180 | { 181 | block_rts_signals(); 182 | mysql_free_result(result); 183 | unblock_rts_signals(); 184 | } 185 | 186 | int STDCALL _hs_mysql_next_result(MYSQL *mysql) 187 | { 188 | int ret; 189 | block_rts_signals(); 190 | ret = mysql_next_result(mysql); 191 | unblock_rts_signals(); 192 | return ret; 193 | } 194 | -------------------------------------------------------------------------------- /include/mysql_signals.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Wrappers for MySQL API calls that are known to block and to be 3 | * vulnerable to interruption by GHC's RTS signals. 4 | */ 5 | 6 | #ifndef _mysql_signals_h 7 | #define _mysql_signals_h 8 | 9 | #include "mysql.h" 10 | 11 | #if !defined(MARIADB_BASE_VERSION) && MYSQL_VERSION_ID >= 80000 12 | typedef char my_bool; 13 | #endif 14 | 15 | MYSQL *STDCALL _hs_mysql_real_connect(MYSQL *mysql, const char *host, 16 | const char *user, 17 | const char *passwd, 18 | const char *db, 19 | unsigned int port, 20 | const char *unix_socket, 21 | unsigned long clientflag); 22 | void STDCALL _hs_mysql_close(MYSQL *sock); 23 | int STDCALL _hs_mysql_ping(MYSQL *mysql); 24 | int STDCALL _hs_mysql_real_query(MYSQL *mysql, const char *q, 25 | unsigned long length); 26 | const char *STDCALL _hs_mysql_stat(MYSQL *mysql); 27 | my_bool STDCALL _hs_mysql_commit(MYSQL * mysql); 28 | my_bool STDCALL _hs_mysql_rollback(MYSQL * mysql); 29 | my_bool STDCALL _hs_mysql_autocommit(MYSQL * mysql, my_bool auto_mode); 30 | my_bool STDCALL _hs_mysql_change_user(MYSQL *mysql, const char *user, 31 | const char *passwd, const char *db); 32 | int STDCALL _hs_mysql_select_db(MYSQL *mysql, const char *db); 33 | MYSQL_FIELD *STDCALL _hs_mysql_fetch_field(MYSQL_RES *result); 34 | MYSQL_ROW STDCALL _hs_mysql_fetch_row(MYSQL_RES *result); 35 | unsigned long *STDCALL _hs_mysql_fetch_lengths(MYSQL_RES *result); 36 | MYSQL_RES *STDCALL _hs_mysql_store_result(MYSQL *mysql); 37 | MYSQL_RES *STDCALL _hs_mysql_use_result(MYSQL *mysql); 38 | void STDCALL _hs_mysql_free_result(MYSQL_RES *result); 39 | int STDCALL _hs_mysql_next_result(MYSQL *mysql); 40 | void STDCALL _hs_mysql_close(MYSQL *sock); 41 | 42 | #endif /* _mysql_signals_h */ 43 | -------------------------------------------------------------------------------- /mysql.cabal: -------------------------------------------------------------------------------- 1 | name: mysql 2 | version: 0.2.1 3 | homepage: https://github.com/paul-rouse/mysql 4 | bug-reports: https://github.com/paul-rouse/mysql/issues 5 | synopsis: A low-level MySQL client library. 6 | description: 7 | A low-level client library for the MySQL database, implemented as 8 | bindings to the C @mysqlclient@ API. 9 | . 10 | /Important licensing note/: This library is BSD-licensed under the 11 | terms of the MySQL FOSS License Exception 12 | . 13 | . 14 | Since this library links against the GPL-licensed @mysqlclient@ 15 | library, a non-open-source application that uses it /may/ be 16 | subject to the terms of the GPL. 17 | license: BSD3 18 | license-file: LICENSE 19 | author: Bryan O'Sullivan 20 | maintainer: Paul Rouse 21 | copyright: Copyright 2011 MailRank, Inc. 22 | Copyright 2013 Bryan O'Sullivan 23 | category: Database 24 | build-type: Custom 25 | cabal-version: >= 1.10 26 | extra-source-files: 27 | include/mysql_signals.h 28 | ChangeLog.md 29 | README.markdown 30 | 31 | 32 | custom-setup 33 | setup-depends: base, Cabal 34 | 35 | flag developer 36 | description: operate in developer mode 37 | default: False 38 | manual: True 39 | 40 | library 41 | c-sources: cbits/mysql_signals.c 42 | 43 | include-dirs: include 44 | 45 | exposed-modules: 46 | Database.MySQL.Base 47 | Database.MySQL.Base.C 48 | Database.MySQL.Base.Types 49 | 50 | build-depends: 51 | base < 5, 52 | bytestring >= 0.9 && < 1.0, 53 | containers 54 | if !impl(ghc >= 8.0) 55 | build-depends: 56 | semigroups >= 0.11 && < 0.19 57 | 58 | ghc-options: -Wall 59 | if impl(ghc >= 6.8) 60 | ghc-options: -fwarn-tabs 61 | if flag(developer) 62 | ghc-prof-options: -auto-all 63 | ghc-options: -Werror 64 | cpp-options: -DASSERTS 65 | default-language: Haskell2010 66 | 67 | test-suite test 68 | type: exitcode-stdio-1.0 69 | main-is: main.hs 70 | hs-source-dirs: test 71 | ghc-options: -Wall 72 | default-language: Haskell2010 73 | build-depends: base >= 4 && < 5 74 | , bytestring 75 | , hspec 76 | , mysql 77 | 78 | source-repository head 79 | type: git 80 | location: http://github.com/paul-rouse/mysql 81 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | packages: 3 | - . 4 | extra-deps: [] 5 | system-ghc: true 6 | compiler-check: newer-minor 7 | -------------------------------------------------------------------------------- /test/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Applicative ((<|>)) 4 | import Control.Exception (bracket) 5 | import Database.MySQL.Base (ConnectInfo (..), defaultConnectInfo, Option (..), 6 | connect, close, 7 | query, useResult, fetchRow) 8 | import System.Environment (getEnvironment) 9 | import Test.Hspec 10 | 11 | isCI :: IO Bool 12 | isCI = do 13 | env <- getEnvironment 14 | return $ case lookup "TRAVIS" env <|> lookup "CI" env of 15 | Just "true" -> True 16 | _ -> False 17 | 18 | -- This is how to connect to our test database 19 | -- Options with bytestring values are given to partially test #17 and #23 20 | testConn :: Bool -> ConnectInfo 21 | testConn ci = defaultConnectInfo { 22 | connectHost = "127.0.0.1" 23 | , connectUser = "test" 24 | , connectPassword = "test" 25 | , connectDatabase = "test" 26 | , connectPort = if ci then 33306 else 3306 27 | , connectOptions = [ 28 | InitCommand "SET SESSION sql_mode = 'STRICT_ALL_TABLES';" 29 | , ReadDefaultGroup "client" 30 | ] 31 | } 32 | 33 | -- Only the most cursory test is done at the moment, simply showing that 34 | -- things hang together sufficiently well that we can talk to the database 35 | -- server. 36 | -- 37 | main :: IO () 38 | main = do 39 | ci <- isCI 40 | bracket (connect $ testConn ci) close $ \conn -> hspec $ do 41 | describe "Database" $ do 42 | it "seems to be connected" $ do 43 | query conn "select 1 + 1" 44 | result <- useResult conn 45 | row <- fetchRow result 46 | row `shouldBe` [Just "2"] 47 | --------------------------------------------------------------------------------