diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +0.6.3 +----------------------------------------------------------------------------- +- Make internal modules available. +- Typeable instance for `Context`. +- Update dependencies. + 0.6.2 ----------------------------------------------------------------------------- - Bug fixes: #56 (we no longer call zmq_msg_close after successfull sends) diff --git a/src/System/ZMQ4.hs b/src/System/ZMQ4.hs --- a/src/System/ZMQ4.hs +++ b/src/System/ZMQ4.hs @@ -220,15 +220,15 @@ import Foreign.C.String import Foreign.C.Types (CInt, CShort) import System.Posix.Types (Fd(..)) -import System.ZMQ4.Base import System.ZMQ4.Internal -import System.ZMQ4.Error +import System.ZMQ4.Internal.Base +import System.ZMQ4.Internal.Error -import qualified Data.ByteString as SB -import qualified Data.ByteString.Lazy as LB -import qualified Data.List.NonEmpty as S -import qualified Prelude as P -import qualified System.ZMQ4.Base as B +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import qualified Data.List.NonEmpty as S +import qualified Prelude as P +import qualified System.ZMQ4.Internal.Base as B import GHC.Conc (threadWaitRead) import GHC.Generics(Generic) @@ -898,8 +898,7 @@ #else c_zmq_recvmsg s (msgPtr m) (flagVal dontWait) #endif - ptr <- c_zmq_msg_data (msgPtr m) - evt <- peek ptr + evt <- peekZMQEvent (msgPtr m) str <- receive soc return . Just $ eventMessage str evt diff --git a/src/System/ZMQ4/Base.hsc b/src/System/ZMQ4/Base.hsc deleted file mode 100644 --- a/src/System/ZMQ4/Base.hsc +++ /dev/null @@ -1,371 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} - -module System.ZMQ4.Base where - -import Foreign -import Foreign.C.Types -import Foreign.C.String -import Control.Applicative - -#include - -#if ZMQ_VERSION_MAJOR != 4 - #error *** INVALID 0MQ VERSION (must be 4.x) *** -#endif - ------------------------------------------------------------------------------ --- Message - -newtype ZMQMsg = ZMQMsg - { content :: Ptr () - } deriving (Eq, Ord) - -instance Storable ZMQMsg where - alignment _ = #{alignment zmq_msg_t} - sizeOf _ = #{size zmq_msg_t} - peek p = ZMQMsg <$> #{peek zmq_msg_t, _} p - poke p (ZMQMsg c) = #{poke zmq_msg_t, _} p c - ------------------------------------------------------------------------------ --- Poll - -data ZMQPoll = ZMQPoll - { pSocket :: {-# UNPACK #-} !ZMQSocket - , pFd :: {-# UNPACK #-} !CInt - , pEvents :: {-# UNPACK #-} !CShort - , pRevents :: {-# UNPACK #-} !CShort - } - -instance Storable ZMQPoll where - alignment _ = #{alignment zmq_pollitem_t} - sizeOf _ = #{size zmq_pollitem_t} - peek p = do - s <- #{peek zmq_pollitem_t, socket} p - f <- #{peek zmq_pollitem_t, fd} p - e <- #{peek zmq_pollitem_t, events} p - re <- #{peek zmq_pollitem_t, revents} p - return $ ZMQPoll s f e re - poke p (ZMQPoll s f e re) = do - #{poke zmq_pollitem_t, socket} p s - #{poke zmq_pollitem_t, fd} p f - #{poke zmq_pollitem_t, events} p e - #{poke zmq_pollitem_t, revents} p re - -type ZMQMsgPtr = Ptr ZMQMsg -type ZMQCtx = Ptr () -type ZMQSocket = Ptr () -type ZMQPollPtr = Ptr ZMQPoll - -#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) - ------------------------------------------------------------------------------ --- Socket Types - -newtype ZMQSocketType = ZMQSocketType - { typeVal :: CInt - } deriving (Eq, Ord) - -#{enum ZMQSocketType, ZMQSocketType - , pair = ZMQ_PAIR - , pub = ZMQ_PUB - , sub = ZMQ_SUB - , xpub = ZMQ_XPUB - , xsub = ZMQ_XSUB - , request = ZMQ_REQ - , response = ZMQ_REP - , dealer = ZMQ_DEALER - , router = ZMQ_ROUTER - , pull = ZMQ_PULL - , push = ZMQ_PUSH - , stream = ZMQ_STREAM -} - ------------------------------------------------------------------------------ --- Socket Options - -newtype ZMQOption = ZMQOption - { optVal :: CInt - } deriving (Eq, Ord) - -#{enum ZMQOption, ZMQOption - , affinity = ZMQ_AFFINITY - , backlog = ZMQ_BACKLOG - , conflate = ZMQ_CONFLATE - , curve = ZMQ_CURVE - , curvePublicKey = ZMQ_CURVE_PUBLICKEY - , curveSecretKey = ZMQ_CURVE_SECRETKEY - , curveServer = ZMQ_CURVE_SERVER - , curveServerKey = ZMQ_CURVE_SERVERKEY - , delayAttachOnConnect = ZMQ_DELAY_ATTACH_ON_CONNECT - , events = ZMQ_EVENTS - , filedesc = ZMQ_FD - , identity = ZMQ_IDENTITY - , immediate = ZMQ_IMMEDIATE - , ipv4Only = ZMQ_IPV4ONLY - , ipv6 = ZMQ_IPV6 - , lastEndpoint = ZMQ_LAST_ENDPOINT - , linger = ZMQ_LINGER - , maxMessageSize = ZMQ_MAXMSGSIZE - , mcastHops = ZMQ_MULTICAST_HOPS - , mechanism = ZMQ_MECHANISM - , null = ZMQ_NULL - , plain = ZMQ_PLAIN - , plainPassword = ZMQ_PLAIN_PASSWORD - , plainServer = ZMQ_PLAIN_SERVER - , plainUserName = ZMQ_PLAIN_USERNAME - , probeRouter = ZMQ_PROBE_ROUTER - , rate = ZMQ_RATE - , receiveBuf = ZMQ_RCVBUF - , receiveHighWM = ZMQ_RCVHWM - , receiveMore = ZMQ_RCVMORE - , receiveTimeout = ZMQ_RCVTIMEO - , reconnectIVL = ZMQ_RECONNECT_IVL - , reconnectIVLMax = ZMQ_RECONNECT_IVL_MAX - , recoveryIVL = ZMQ_RECOVERY_IVL - , reqCorrelate = ZMQ_REQ_CORRELATE - , reqRelaxed = ZMQ_REQ_RELAXED - , routerMandatory = ZMQ_ROUTER_MANDATORY - , sendBuf = ZMQ_SNDBUF - , sendHighWM = ZMQ_SNDHWM - , sendTimeout = ZMQ_SNDTIMEO - , subscribe = ZMQ_SUBSCRIBE - , tcpAcceptFilter = ZMQ_TCP_ACCEPT_FILTER - , tcpKeepAlive = ZMQ_TCP_KEEPALIVE - , tcpKeepAliveCount = ZMQ_TCP_KEEPALIVE_CNT - , tcpKeepAliveIdle = ZMQ_TCP_KEEPALIVE_IDLE - , tcpKeepAliveInterval = ZMQ_TCP_KEEPALIVE_INTVL - , unsubscribe = ZMQ_UNSUBSCRIBE - , xpubVerbose = ZMQ_XPUB_VERBOSE - , zapDomain = ZMQ_ZAP_DOMAIN -} - ------------------------------------------------------------------------------ --- Context Options - -newtype ZMQCtxOption = ZMQCtxOption - { ctxOptVal :: CInt - } deriving (Eq, Ord) - -#{enum ZMQCtxOption, ZMQCtxOption - , _ioThreads = ZMQ_IO_THREADS - , _maxSockets = ZMQ_MAX_SOCKETS -} - ------------------------------------------------------------------------------ --- Event Type - -newtype ZMQEventType = ZMQEventType - { eventTypeVal :: Word16 - } deriving (Eq, Ord, Show) - -#{enum ZMQEventType, ZMQEventType - , connected = ZMQ_EVENT_CONNECTED - , connectDelayed = ZMQ_EVENT_CONNECT_DELAYED - , connectRetried = ZMQ_EVENT_CONNECT_RETRIED - , listening = ZMQ_EVENT_LISTENING - , bindFailed = ZMQ_EVENT_BIND_FAILED - , accepted = ZMQ_EVENT_ACCEPTED - , acceptFailed = ZMQ_EVENT_ACCEPT_FAILED - , closed = ZMQ_EVENT_CLOSED - , closeFailed = ZMQ_EVENT_CLOSE_FAILED - , disconnected = ZMQ_EVENT_DISCONNECTED - , allEvents = ZMQ_EVENT_ALL - , monitorStopped = ZMQ_EVENT_MONITOR_STOPPED -} - ------------------------------------------------------------------------------ --- Event - -data ZMQEvent = ZMQEvent - { zeEvent :: {-# UNPACK #-} !ZMQEventType - , zeValue :: {-# UNPACK #-} !Int32 - } - -instance Storable ZMQEvent where - alignment _ = #{alignment zmq_event_t} - sizeOf _ = #{size zmq_event_t} - peek e = ZMQEvent - <$> (ZMQEventType <$> #{peek zmq_event_t, event} e) - <*> #{peek zmq_event_t, value} e - poke e (ZMQEvent (ZMQEventType a) b) = do - #{poke zmq_event_t, event} e a - #{poke zmq_event_t, value} e b - ------------------------------------------------------------------------------ --- Security Mechanism - -newtype ZMQSecMechanism = ZMQSecMechanism - { secMechanism :: Int - } deriving (Eq, Ord, Show) - -#{enum ZMQSecMechanism, ZMQSecMechanism - , secNull = ZMQ_NULL - , secPlain = ZMQ_PLAIN - , secCurve = ZMQ_CURVE -} - ------------------------------------------------------------------------------ --- Message Options - -newtype ZMQMsgOption = ZMQMsgOption - { msgOptVal :: CInt - } deriving (Eq, Ord) - -#{enum ZMQMsgOption, ZMQMsgOption - , more = ZMQ_MORE -} - ------------------------------------------------------------------------------ --- Flags - -newtype ZMQFlag = ZMQFlag - { flagVal :: CInt - } deriving (Eq, Ord) - -#{enum ZMQFlag, ZMQFlag - , dontWait = ZMQ_DONTWAIT - , sndMore = ZMQ_SNDMORE -} - ------------------------------------------------------------------------------ --- Poll Events - -newtype ZMQPollEvent = ZMQPollEvent - { pollVal :: CShort - } deriving (Eq, Ord) - -#{enum ZMQPollEvent, ZMQPollEvent, - pollIn = ZMQ_POLLIN, - pollOut = ZMQ_POLLOUT, - pollerr = ZMQ_POLLERR -} - ------------------------------------------------------------------------------ --- function declarations - --- general initialization - -foreign import ccall unsafe "zmq.h zmq_version" - c_zmq_version :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () - -foreign import ccall unsafe "zmq.h zmq_ctx_new" - c_zmq_ctx_new :: IO ZMQCtx - -foreign import ccall unsafe "zmq.h zmq_ctx_shutdown" - c_zmq_ctx_shutdown :: ZMQCtx -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_ctx_term" - c_zmq_ctx_term :: ZMQCtx -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_ctx_get" - c_zmq_ctx_get :: ZMQCtx -> CInt -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_ctx_set" - c_zmq_ctx_set :: ZMQCtx -> CInt -> CInt -> IO CInt - --- zmq_msg_t related - -foreign import ccall unsafe "zmq.h zmq_msg_init" - c_zmq_msg_init :: ZMQMsgPtr -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_msg_init_size" - c_zmq_msg_init_size :: ZMQMsgPtr -> CSize -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_msg_close" - c_zmq_msg_close :: ZMQMsgPtr -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_msg_data" - c_zmq_msg_data :: ZMQMsgPtr -> IO (Ptr a) - -foreign import ccall unsafe "zmq.h zmq_msg_size" - c_zmq_msg_size :: ZMQMsgPtr -> IO CSize - -foreign import ccall unsafe "zmq.h zmq_msg_get" - c_zmq_msg_get :: ZMQMsgPtr -> CInt -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_msg_set" - c_zmq_msg_set :: ZMQMsgPtr -> CInt -> CInt -> IO CInt - --- socket - -foreign import ccall unsafe "zmq.h zmq_socket" - c_zmq_socket :: ZMQCtx -> CInt -> IO ZMQSocket - -foreign import ccall unsafe "zmq.h zmq_close" - c_zmq_close :: ZMQSocket -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_setsockopt" - c_zmq_setsockopt :: ZMQSocket - -> CInt -- option - -> Ptr () -- option value - -> CSize -- option value size - -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_getsockopt" - c_zmq_getsockopt :: ZMQSocket - -> CInt -- option - -> Ptr () -- option value - -> Ptr CSize -- option value size ptr - -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_bind" - c_zmq_bind :: ZMQSocket -> CString -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_unbind" - c_zmq_unbind :: ZMQSocket -> CString -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_connect" - c_zmq_connect :: ZMQSocket -> CString -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_disconnect" - c_zmq_disconnect :: ZMQSocket -> CString -> IO CInt - -#ifdef mingw32_HOST_OS -foreign import ccall safe "zmq.h zmq_sendmsg" - c_zmq_sendmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt - -foreign import ccall safe "zmq.h zmq_recvmsg" - c_zmq_recvmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt -#else -foreign import ccall unsafe "zmq.h zmq_sendmsg" - c_zmq_sendmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt - -foreign import ccall unsafe "zmq.h zmq_recvmsg" - c_zmq_recvmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt -#endif - -foreign import ccall unsafe "zmq.h zmq_socket_monitor" - c_zmq_socket_monitor :: ZMQSocket -> CString -> CInt -> IO CInt - --- errors - -foreign import ccall unsafe "zmq.h zmq_errno" - c_zmq_errno :: IO CInt - -foreign import ccall unsafe "zmq.h zmq_strerror" - c_zmq_strerror :: CInt -> IO CString - --- proxy - -foreign import ccall safe "zmq.h zmq_proxy" - c_zmq_proxy :: ZMQSocket -> ZMQSocket -> ZMQSocket -> IO CInt - --- poll - -foreign import ccall safe "zmq.h zmq_poll" - c_zmq_poll :: ZMQPollPtr -> CInt -> CLong -> IO CInt - --- Z85 encode/decode - -foreign import ccall unsafe "zmq.h zmq_z85_encode" - c_zmq_z85_encode :: CString -> Ptr Word8 -> CSize -> IO CString - -foreign import ccall unsafe "zmq.h zmq_z85_decode" - c_zmq_z85_decode :: Ptr Word8 -> CString -> IO (Ptr Word8) - --- curve crypto - -foreign import ccall unsafe "zmq.h zmq_curve_keypair" - c_zmq_curve_keypair :: CString -> CString -> IO CInt - diff --git a/src/System/ZMQ4/Error.hs b/src/System/ZMQ4/Error.hs deleted file mode 100644 --- a/src/System/ZMQ4/Error.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- We use our own functions for throwing exceptions in order to get --- the actual error message via 'zmq_strerror'. 0MQ defines additional --- error numbers besides those defined by the operating system, so --- 'zmq_strerror' should be used in preference to 'strerror' which is --- used by the standard throw* functions in 'Foreign.C.Error'. -module System.ZMQ4.Error where - -import Control.Applicative -import Control.Monad -import Control.Exception -import Text.Printf -import Data.Typeable (Typeable) - -import Foreign hiding (throwIf, throwIf_, void) -import Foreign.C.Error -import Foreign.C.String -import Foreign.C.Types (CInt) - -import System.ZMQ4.Base - --- | ZMQError encapsulates information about errors, which occur --- when using the native 0MQ API, such as error number and message. -data ZMQError = ZMQError - { errno :: Int -- ^ Error number value. - , source :: String -- ^ Source where this error originates from. - , message :: String -- ^ Actual error message. - } deriving (Eq, Ord, Typeable) - -instance Show ZMQError where - show e = printf "ZMQError { errno = %d, source = \"%s\", message = \"%s\" }" - (errno e) (source e) (message e) - -instance Exception ZMQError - -throwError :: String -> IO a -throwError src = do - (Errno e) <- zmqErrno - msg <- zmqErrnoMessage e - throwIO $ ZMQError (fromIntegral e) src msg - -throwIf :: (a -> Bool) -> String -> IO a -> IO a -throwIf p src act = do - r <- act - if p r then throwError src else return r - -throwIf_ :: (a -> Bool) -> String -> IO a -> IO () -throwIf_ p src act = void $ throwIf p src act - -throwIfRetry :: (a -> Bool) -> String -> IO a -> IO a -throwIfRetry p src act = do - r <- act - if p r then zmqErrno >>= k else return r - where - k e | e == eINTR = throwIfRetry p src act - | otherwise = throwError src - -throwIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () -throwIfRetry_ p src act = void $ throwIfRetry p src act - -throwIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a -throwIfMinus1 = throwIf (== -1) - -throwIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO () -throwIfMinus1_ = throwIf_ (== -1) - -throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a) -throwIfNull = throwIf (== nullPtr) - -throwIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a -throwIfMinus1Retry = throwIfRetry (== -1) - -throwIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO () -throwIfMinus1Retry_ = throwIfRetry_ (== -1) - -throwIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a -throwIfRetryMayBlock p src f on_block = do - r <- f - if p r then zmqErrno >>= k else return r - where - k e | e == eINTR = throwIfRetryMayBlock p src f on_block - | e == eWOULDBLOCK || e == eAGAIN = on_block >> throwIfRetryMayBlock p src f on_block - | otherwise = throwError src - -throwIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO () -throwIfRetryMayBlock_ p src f on_block = void $ throwIfRetryMayBlock p src f on_block - -throwIfMinus1RetryMayBlock :: (Eq a, Num a) => String -> IO a -> IO b -> IO a -throwIfMinus1RetryMayBlock = throwIfRetryMayBlock (== -1) - -throwIfMinus1RetryMayBlock_ :: (Eq a, Num a) => String -> IO a -> IO b -> IO () -throwIfMinus1RetryMayBlock_ = throwIfRetryMayBlock_ (== -1) - -zmqErrnoMessage :: CInt -> IO String -zmqErrnoMessage e = c_zmq_strerror e >>= peekCString - -zmqErrno :: IO Errno -zmqErrno = Errno <$> c_zmq_errno diff --git a/src/System/ZMQ4/Internal.hs b/src/System/ZMQ4/Internal.hs --- a/src/System/ZMQ4/Internal.hs +++ b/src/System/ZMQ4/Internal.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} +-- | /Warning/: This is an internal module and subject +-- to change without notice. module System.ZMQ4.Internal ( Context (..) , Socket (..) @@ -68,10 +71,11 @@ import Data.IORef (newIORef) import Data.Restricted +import Data.Typeable import System.Posix.Types (Fd(..)) -import System.ZMQ4.Base -import System.ZMQ4.Error +import System.ZMQ4.Internal.Base +import System.ZMQ4.Internal.Error import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB @@ -139,6 +143,8 @@ -- | A 0MQ context representation. newtype Context = Context { _ctx :: ZMQCtx } + +deriving instance Typeable Context -- | A 0MQ Socket. newtype Socket a = Socket diff --git a/src/System/ZMQ4/Internal/Base.hsc b/src/System/ZMQ4/Internal/Base.hsc new file mode 100644 --- /dev/null +++ b/src/System/ZMQ4/Internal/Base.hsc @@ -0,0 +1,387 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | /Warning/: This is an internal module and subject +-- to change without notice. +module System.ZMQ4.Internal.Base where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Control.Applicative + +#include + +#if ZMQ_VERSION_MAJOR != 4 + #error *** INVALID 0MQ VERSION (must be 4.x) *** +#endif + +----------------------------------------------------------------------------- +-- Message + +newtype ZMQMsg = ZMQMsg + { content :: Ptr () + } deriving (Eq, Ord) + +instance Storable ZMQMsg where + alignment _ = #{alignment zmq_msg_t} + sizeOf _ = #{size zmq_msg_t} + peek p = ZMQMsg <$> #{peek zmq_msg_t, _} p + poke p (ZMQMsg c) = #{poke zmq_msg_t, _} p c + +----------------------------------------------------------------------------- +-- Poll + +data ZMQPoll = ZMQPoll + { pSocket :: {-# UNPACK #-} !ZMQSocket + , pFd :: {-# UNPACK #-} !CInt + , pEvents :: {-# UNPACK #-} !CShort + , pRevents :: {-# UNPACK #-} !CShort + } + +instance Storable ZMQPoll where + alignment _ = #{alignment zmq_pollitem_t} + sizeOf _ = #{size zmq_pollitem_t} + peek p = do + s <- #{peek zmq_pollitem_t, socket} p + f <- #{peek zmq_pollitem_t, fd} p + e <- #{peek zmq_pollitem_t, events} p + re <- #{peek zmq_pollitem_t, revents} p + return $ ZMQPoll s f e re + poke p (ZMQPoll s f e re) = do + #{poke zmq_pollitem_t, socket} p s + #{poke zmq_pollitem_t, fd} p f + #{poke zmq_pollitem_t, events} p e + #{poke zmq_pollitem_t, revents} p re + +type ZMQMsgPtr = Ptr ZMQMsg +type ZMQCtx = Ptr () +type ZMQSocket = Ptr () +type ZMQPollPtr = Ptr ZMQPoll + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +----------------------------------------------------------------------------- +-- Socket Types + +newtype ZMQSocketType = ZMQSocketType + { typeVal :: CInt + } deriving (Eq, Ord) + +#{enum ZMQSocketType, ZMQSocketType + , pair = ZMQ_PAIR + , pub = ZMQ_PUB + , sub = ZMQ_SUB + , xpub = ZMQ_XPUB + , xsub = ZMQ_XSUB + , request = ZMQ_REQ + , response = ZMQ_REP + , dealer = ZMQ_DEALER + , router = ZMQ_ROUTER + , pull = ZMQ_PULL + , push = ZMQ_PUSH + , stream = ZMQ_STREAM +} + +----------------------------------------------------------------------------- +-- Socket Options + +newtype ZMQOption = ZMQOption + { optVal :: CInt + } deriving (Eq, Ord) + +#{enum ZMQOption, ZMQOption + , affinity = ZMQ_AFFINITY + , backlog = ZMQ_BACKLOG + , conflate = ZMQ_CONFLATE + , curve = ZMQ_CURVE + , curvePublicKey = ZMQ_CURVE_PUBLICKEY + , curveSecretKey = ZMQ_CURVE_SECRETKEY + , curveServer = ZMQ_CURVE_SERVER + , curveServerKey = ZMQ_CURVE_SERVERKEY + , delayAttachOnConnect = ZMQ_DELAY_ATTACH_ON_CONNECT + , events = ZMQ_EVENTS + , filedesc = ZMQ_FD + , identity = ZMQ_IDENTITY + , immediate = ZMQ_IMMEDIATE + , ipv4Only = ZMQ_IPV4ONLY + , ipv6 = ZMQ_IPV6 + , lastEndpoint = ZMQ_LAST_ENDPOINT + , linger = ZMQ_LINGER + , maxMessageSize = ZMQ_MAXMSGSIZE + , mcastHops = ZMQ_MULTICAST_HOPS + , mechanism = ZMQ_MECHANISM + , null = ZMQ_NULL + , plain = ZMQ_PLAIN + , plainPassword = ZMQ_PLAIN_PASSWORD + , plainServer = ZMQ_PLAIN_SERVER + , plainUserName = ZMQ_PLAIN_USERNAME + , probeRouter = ZMQ_PROBE_ROUTER + , rate = ZMQ_RATE + , receiveBuf = ZMQ_RCVBUF + , receiveHighWM = ZMQ_RCVHWM + , receiveMore = ZMQ_RCVMORE + , receiveTimeout = ZMQ_RCVTIMEO + , reconnectIVL = ZMQ_RECONNECT_IVL + , reconnectIVLMax = ZMQ_RECONNECT_IVL_MAX + , recoveryIVL = ZMQ_RECOVERY_IVL + , reqCorrelate = ZMQ_REQ_CORRELATE + , reqRelaxed = ZMQ_REQ_RELAXED + , routerMandatory = ZMQ_ROUTER_MANDATORY + , sendBuf = ZMQ_SNDBUF + , sendHighWM = ZMQ_SNDHWM + , sendTimeout = ZMQ_SNDTIMEO + , subscribe = ZMQ_SUBSCRIBE + , tcpAcceptFilter = ZMQ_TCP_ACCEPT_FILTER + , tcpKeepAlive = ZMQ_TCP_KEEPALIVE + , tcpKeepAliveCount = ZMQ_TCP_KEEPALIVE_CNT + , tcpKeepAliveIdle = ZMQ_TCP_KEEPALIVE_IDLE + , tcpKeepAliveInterval = ZMQ_TCP_KEEPALIVE_INTVL + , unsubscribe = ZMQ_UNSUBSCRIBE + , xpubVerbose = ZMQ_XPUB_VERBOSE + , zapDomain = ZMQ_ZAP_DOMAIN +} + +----------------------------------------------------------------------------- +-- Context Options + +newtype ZMQCtxOption = ZMQCtxOption + { ctxOptVal :: CInt + } deriving (Eq, Ord) + +#{enum ZMQCtxOption, ZMQCtxOption + , _ioThreads = ZMQ_IO_THREADS + , _maxSockets = ZMQ_MAX_SOCKETS +} + +----------------------------------------------------------------------------- +-- Event Type + +newtype ZMQEventType = ZMQEventType + { eventTypeVal :: Word16 + } deriving (Eq, Ord, Show, Storable) + +#{enum ZMQEventType, ZMQEventType + , connected = ZMQ_EVENT_CONNECTED + , connectDelayed = ZMQ_EVENT_CONNECT_DELAYED + , connectRetried = ZMQ_EVENT_CONNECT_RETRIED + , listening = ZMQ_EVENT_LISTENING + , bindFailed = ZMQ_EVENT_BIND_FAILED + , accepted = ZMQ_EVENT_ACCEPTED + , acceptFailed = ZMQ_EVENT_ACCEPT_FAILED + , closed = ZMQ_EVENT_CLOSED + , closeFailed = ZMQ_EVENT_CLOSE_FAILED + , disconnected = ZMQ_EVENT_DISCONNECTED + , allEvents = ZMQ_EVENT_ALL + , monitorStopped = ZMQ_EVENT_MONITOR_STOPPED +} + +----------------------------------------------------------------------------- +-- Event + +data ZMQEvent = ZMQEvent + { zeEvent :: {-# UNPACK #-} !ZMQEventType + , zeValue :: {-# UNPACK #-} !Int32 + } + +#if ZMQ_VERSION < 40100 +instance Storable ZMQEvent where + alignment _ = #{alignment zmq_event_t} + sizeOf _ = #{size zmq_event_t} + peek e = ZMQEvent + <$> (ZMQEventType <$> #{peek zmq_event_t, event} e) + <*> #{peek zmq_event_t, value} e + poke e (ZMQEvent (ZMQEventType a) b) = do + #{poke zmq_event_t, event} e a + #{poke zmq_event_t, value} e b +#endif + +peekZMQEvent :: ZMQMsgPtr -> IO ZMQEvent +peekZMQEvent m = do + p <- c_zmq_msg_data m +#if ZMQ_VERSION < 40100 + peek p +#else + e <- peek p + v <- peek (p `plusPtr` 2) + return (ZMQEvent e v) +#endif + +----------------------------------------------------------------------------- +-- Security Mechanism + +newtype ZMQSecMechanism = ZMQSecMechanism + { secMechanism :: Int + } deriving (Eq, Ord, Show) + +#{enum ZMQSecMechanism, ZMQSecMechanism + , secNull = ZMQ_NULL + , secPlain = ZMQ_PLAIN + , secCurve = ZMQ_CURVE +} + +----------------------------------------------------------------------------- +-- Message Options + +newtype ZMQMsgOption = ZMQMsgOption + { msgOptVal :: CInt + } deriving (Eq, Ord) + +#{enum ZMQMsgOption, ZMQMsgOption + , more = ZMQ_MORE +} + +----------------------------------------------------------------------------- +-- Flags + +newtype ZMQFlag = ZMQFlag + { flagVal :: CInt + } deriving (Eq, Ord) + +#{enum ZMQFlag, ZMQFlag + , dontWait = ZMQ_DONTWAIT + , sndMore = ZMQ_SNDMORE +} + +----------------------------------------------------------------------------- +-- Poll Events + +newtype ZMQPollEvent = ZMQPollEvent + { pollVal :: CShort + } deriving (Eq, Ord) + +#{enum ZMQPollEvent, ZMQPollEvent, + pollIn = ZMQ_POLLIN, + pollOut = ZMQ_POLLOUT, + pollerr = ZMQ_POLLERR +} + +----------------------------------------------------------------------------- +-- function declarations + +-- general initialization + +foreign import ccall unsafe "zmq.h zmq_version" + c_zmq_version :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () + +foreign import ccall unsafe "zmq.h zmq_ctx_new" + c_zmq_ctx_new :: IO ZMQCtx + +foreign import ccall unsafe "zmq.h zmq_ctx_shutdown" + c_zmq_ctx_shutdown :: ZMQCtx -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_ctx_term" + c_zmq_ctx_term :: ZMQCtx -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_ctx_get" + c_zmq_ctx_get :: ZMQCtx -> CInt -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_ctx_set" + c_zmq_ctx_set :: ZMQCtx -> CInt -> CInt -> IO CInt + +-- zmq_msg_t related + +foreign import ccall unsafe "zmq.h zmq_msg_init" + c_zmq_msg_init :: ZMQMsgPtr -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_msg_init_size" + c_zmq_msg_init_size :: ZMQMsgPtr -> CSize -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_msg_close" + c_zmq_msg_close :: ZMQMsgPtr -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_msg_data" + c_zmq_msg_data :: ZMQMsgPtr -> IO (Ptr a) + +foreign import ccall unsafe "zmq.h zmq_msg_size" + c_zmq_msg_size :: ZMQMsgPtr -> IO CSize + +foreign import ccall unsafe "zmq.h zmq_msg_get" + c_zmq_msg_get :: ZMQMsgPtr -> CInt -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_msg_set" + c_zmq_msg_set :: ZMQMsgPtr -> CInt -> CInt -> IO CInt + +-- socket + +foreign import ccall unsafe "zmq.h zmq_socket" + c_zmq_socket :: ZMQCtx -> CInt -> IO ZMQSocket + +foreign import ccall unsafe "zmq.h zmq_close" + c_zmq_close :: ZMQSocket -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_setsockopt" + c_zmq_setsockopt :: ZMQSocket + -> CInt -- option + -> Ptr () -- option value + -> CSize -- option value size + -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_getsockopt" + c_zmq_getsockopt :: ZMQSocket + -> CInt -- option + -> Ptr () -- option value + -> Ptr CSize -- option value size ptr + -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_bind" + c_zmq_bind :: ZMQSocket -> CString -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_unbind" + c_zmq_unbind :: ZMQSocket -> CString -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_connect" + c_zmq_connect :: ZMQSocket -> CString -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_disconnect" + c_zmq_disconnect :: ZMQSocket -> CString -> IO CInt + +#ifdef mingw32_HOST_OS +foreign import ccall safe "zmq.h zmq_sendmsg" + c_zmq_sendmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt + +foreign import ccall safe "zmq.h zmq_recvmsg" + c_zmq_recvmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt +#else +foreign import ccall unsafe "zmq.h zmq_sendmsg" + c_zmq_sendmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt + +foreign import ccall unsafe "zmq.h zmq_recvmsg" + c_zmq_recvmsg :: ZMQSocket -> ZMQMsgPtr -> CInt -> IO CInt +#endif + +foreign import ccall unsafe "zmq.h zmq_socket_monitor" + c_zmq_socket_monitor :: ZMQSocket -> CString -> CInt -> IO CInt + +-- errors + +foreign import ccall unsafe "zmq.h zmq_errno" + c_zmq_errno :: IO CInt + +foreign import ccall unsafe "zmq.h zmq_strerror" + c_zmq_strerror :: CInt -> IO CString + +-- proxy + +foreign import ccall safe "zmq.h zmq_proxy" + c_zmq_proxy :: ZMQSocket -> ZMQSocket -> ZMQSocket -> IO CInt + +-- poll + +foreign import ccall safe "zmq.h zmq_poll" + c_zmq_poll :: ZMQPollPtr -> CInt -> CLong -> IO CInt + +-- Z85 encode/decode + +foreign import ccall unsafe "zmq.h zmq_z85_encode" + c_zmq_z85_encode :: CString -> Ptr Word8 -> CSize -> IO CString + +foreign import ccall unsafe "zmq.h zmq_z85_decode" + c_zmq_z85_decode :: Ptr Word8 -> CString -> IO (Ptr Word8) + +-- curve crypto + +foreign import ccall unsafe "zmq.h zmq_curve_keypair" + c_zmq_curve_keypair :: CString -> CString -> IO CInt + diff --git a/src/System/ZMQ4/Internal/Error.hs b/src/System/ZMQ4/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/src/System/ZMQ4/Internal/Error.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | We use our own functions for throwing exceptions in order to get +-- the actual error message via 'zmq_strerror'. 0MQ defines additional +-- error numbers besides those defined by the operating system, so +-- 'zmq_strerror' should be used in preference to 'strerror' which is +-- used by the standard throw* functions in 'Foreign.C.Error'. +-- +-- /Warning/: This is an internal module and subject +-- to change without notice. +module System.ZMQ4.Internal.Error where + +import Control.Applicative +import Control.Monad +import Control.Exception +import Text.Printf +import Data.Typeable (Typeable) + +import Foreign hiding (throwIf, throwIf_, void) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types (CInt) + +import System.ZMQ4.Internal.Base + +-- | ZMQError encapsulates information about errors, which occur +-- when using the native 0MQ API, such as error number and message. +data ZMQError = ZMQError + { errno :: Int -- ^ Error number value. + , source :: String -- ^ Source where this error originates from. + , message :: String -- ^ Actual error message. + } deriving (Eq, Ord, Typeable) + +instance Show ZMQError where + show e = printf "ZMQError { errno = %d, source = \"%s\", message = \"%s\" }" + (errno e) (source e) (message e) + +instance Exception ZMQError + +throwError :: String -> IO a +throwError src = do + (Errno e) <- zmqErrno + msg <- zmqErrnoMessage e + throwIO $ ZMQError (fromIntegral e) src msg + +throwIf :: (a -> Bool) -> String -> IO a -> IO a +throwIf p src act = do + r <- act + if p r then throwError src else return r + +throwIf_ :: (a -> Bool) -> String -> IO a -> IO () +throwIf_ p src act = void $ throwIf p src act + +throwIfRetry :: (a -> Bool) -> String -> IO a -> IO a +throwIfRetry p src act = do + r <- act + if p r then zmqErrno >>= k else return r + where + k e | e == eINTR = throwIfRetry p src act + | otherwise = throwError src + +throwIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () +throwIfRetry_ p src act = void $ throwIfRetry p src act + +throwIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a +throwIfMinus1 = throwIf (== -1) + +throwIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO () +throwIfMinus1_ = throwIf_ (== -1) + +throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +throwIfNull = throwIf (== nullPtr) + +throwIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a +throwIfMinus1Retry = throwIfRetry (== -1) + +throwIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO () +throwIfMinus1Retry_ = throwIfRetry_ (== -1) + +throwIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a +throwIfRetryMayBlock p src f on_block = do + r <- f + if p r then zmqErrno >>= k else return r + where + k e | e == eINTR = throwIfRetryMayBlock p src f on_block + | e == eWOULDBLOCK || e == eAGAIN = on_block >> throwIfRetryMayBlock p src f on_block + | otherwise = throwError src + +throwIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO () +throwIfRetryMayBlock_ p src f on_block = void $ throwIfRetryMayBlock p src f on_block + +throwIfMinus1RetryMayBlock :: (Eq a, Num a) => String -> IO a -> IO b -> IO a +throwIfMinus1RetryMayBlock = throwIfRetryMayBlock (== -1) + +throwIfMinus1RetryMayBlock_ :: (Eq a, Num a) => String -> IO a -> IO b -> IO () +throwIfMinus1RetryMayBlock_ = throwIfRetryMayBlock_ (== -1) + +zmqErrnoMessage :: CInt -> IO String +zmqErrnoMessage e = c_zmq_strerror e >>= peekCString + +zmqErrno :: IO Errno +zmqErrno = Errno <$> c_zmq_errno diff --git a/zeromq4-haskell.cabal b/zeromq4-haskell.cabal --- a/zeromq4-haskell.cabal +++ b/zeromq4-haskell.cabal @@ -1,12 +1,12 @@ name: zeromq4-haskell -version: 0.6.2 +version: 0.6.3 synopsis: Bindings to ZeroMQ 4.x category: System, FFI license: MIT license-file: LICENSE author: Toralf Wittner maintainer: Toralf Wittner -copyright: (c) 2010 - 2014 zeromq-haskell authors +copyright: (c) 2010 - 2015 zeromq-haskell authors homepage: http://github.com/twittner/zeromq-haskell/ stability: experimental tested-With: GHC == 7.6.3 @@ -40,24 +40,22 @@ library hs-source-dirs: src + ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields + exposed-modules: + Data.Restricted System.ZMQ4 System.ZMQ4.Monadic - Data.Restricted - - other-modules: - System.ZMQ4.Base System.ZMQ4.Internal - System.ZMQ4.Error - - ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields + System.ZMQ4.Internal.Base + System.ZMQ4.Internal.Error build-depends: base >= 3 && < 5 , async == 2.0.* , bytestring , containers - , exceptions == 0.6.* + , exceptions >= 0.6 && < 1.0 , semigroups >= 0.8 , transformers >= 0.3