Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add RTS signal blocking support.

  • Loading branch information...
commit b06f922b1da73db18f4db11705fb1da5f7783610 1 parent ed2ddf5
@bos authored
Showing with 53 additions and 0 deletions.
  1. +53 −0 Database/HDBC/MySQL/RTS.hsc
View
53 Database/HDBC/MySQL/RTS.hsc
@@ -0,0 +1,53 @@
+{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}
+
+module Database.HDBC.MySQL.RTS (withRTSSignalsBlocked) where
+
+import Control.Concurrent (runInBoundThread)
+import Control.Exception (finally)
+import Foreign.C.Types (CInt)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (Ptr, nullPtr)
+import Foreign.Storable (Storable(..))
+
+#include <signal.h>
+
+-- | 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 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.
+--
+-- 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 = runInBoundThread . alloca $ \set -> do
+ sigemptyset set
+ sigaddset set (#const SIGALRM)
+ sigaddset set (#const SIGVTALRM)
+ pthread_sigmask (#const SIG_BLOCK) set nullPtr
+ act `finally` pthread_sigmask (#const SIG_UNBLOCK) set nullPtr
+
+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 ()
Please sign in to comment.
Something went wrong with that request. Please try again.