diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +0.8.0 +----------------------------------------------------------------------------- +- Require non-empty `ByteString`s in `setZapDomain` (#63) + +0.7.0 +----------------------------------------------------------------------------- +- Add `setZapDomain` (thanks to Alain O'Dea). +- `ByteString`s returned from the following socket option getters will no + longer include the trailing NUL byte from the original C string: + * `plainUserName` + * `plainPassword` + 0.6.7 ----------------------------------------------------------------------------- - Bugfix release. diff --git a/src/Data/Restricted.hs b/src/Data/Restricted.hs --- a/src/Data/Restricted.hs +++ b/src/Data/Restricted.hs @@ -150,6 +150,12 @@ restrict s | B.length s < 1 = Restricted (B.singleton 0x20) | otherwise = Restricted (B.take 254 s) +instance Restriction (N0, N254) ByteString where + toRestricted s | check (0, 254) (B.length s) = Just $ Restricted s + | otherwise = Nothing + + restrict s = Restricted (B.take 254 s) + -- Other constraints instance Restriction Div4 ByteString where diff --git a/src/System/ZMQ4.hs b/src/System/ZMQ4.hs --- a/src/System/ZMQ4.hs +++ b/src/System/ZMQ4.hs @@ -178,6 +178,7 @@ , setTcpKeepAliveIdle , setTcpKeepAliveInterval , setXPubVerbose + , setZapDomain -- * Restrictions , Data.Restricted.restrict @@ -467,7 +468,7 @@ -- | . identity :: Socket a -> IO SB.ByteString -identity s = getByteStringOpt s B.identity +identity s = getBytesOpt s B.identity -- | . affinity :: Socket a -> IO Word64 @@ -759,6 +760,10 @@ -- | . setXPubVerbose :: Bool -> Socket XPub -> IO () setXPubVerbose x s = setIntOpt s B.xpubVerbose (bool2cint x) + +-- | . +setZapDomain :: Restricted (N1, N254) SB.ByteString -> Socket a -> IO () +setZapDomain x s = setByteStringOpt s B.zapDomain (rvalue x) -- | Bind the socket to the given address -- (cf. ). 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 @@ -34,6 +34,7 @@ , setInt32OptFromRestricted , ctxIntOption , setCtxIntOption + , getBytesOpt , getByteStringOpt , setByteStringOpt @@ -62,12 +63,11 @@ import Control.Applicative import Control.Monad (foldM_, when, void) import Control.Monad.IO.Class -import Control.Exception import Data.IORef (IORef, mkWeakIORef, readIORef, atomicModifyIORef) import Foreign hiding (throwIfNull, void) import Foreign.C.String -import Foreign.C.Types (CInt, CSize) +import Foreign.C.Types (CInt) import Data.IORef (newIORef) import Data.Restricted @@ -252,26 +252,29 @@ throwIfMinus1Retry_ "setStrOpt" . withCStringLen str $ setCStrOpt s opt getIntOpt :: (Storable b, Integral b) => Socket a -> ZMQOption -> b -> IO b -getIntOpt sock (ZMQOption o) i = onSocket "getIntOpt" sock $ \s -> do - bracket (new i) free $ \iptr -> - bracket (new (fromIntegral . sizeOf $ i :: CSize)) free $ \jptr -> do - throwIfMinus1Retry_ "getIntOpt" $ - c_zmq_getsockopt s (fromIntegral o) (castPtr iptr) jptr - peek iptr +getIntOpt sock (ZMQOption o) i = onSocket "getIntOpt" sock $ \s -> + with i $ \iptr -> + with (fromIntegral $ sizeOf i) $ \jptr -> do + throwIfMinus1Retry_ "getIntOpt" $ + c_zmq_getsockopt s (fromIntegral o) (castPtr iptr) jptr + peek iptr getCStrOpt :: (CStringLen -> IO s) -> Socket a -> ZMQOption -> IO s getCStrOpt peekA sock (ZMQOption o) = onSocket "getCStrOpt" sock $ \s -> - bracket (mallocBytes 255) free $ \bPtr -> - bracket (new (255 :: CSize)) free $ \sPtr -> do + with 256 $ \nptr -> + allocaBytes 256 $ \bptr -> do throwIfMinus1Retry_ "getCStrOpt" $ - c_zmq_getsockopt s (fromIntegral o) (castPtr bPtr) sPtr - peek sPtr >>= \len -> peekA (bPtr, fromIntegral len) + c_zmq_getsockopt s (fromIntegral o) (castPtr bptr) nptr + peek nptr >>= \len -> peekA (bptr, fromIntegral len) getStrOpt :: Socket a -> ZMQOption -> IO String getStrOpt = getCStrOpt (peekCString . fst) getByteStringOpt :: Socket a -> ZMQOption -> IO SB.ByteString -getByteStringOpt = getCStrOpt SB.packCStringLen +getByteStringOpt = getCStrOpt (SB.packCString . fst) + +getBytesOpt :: Socket a -> ZMQOption -> IO SB.ByteString +getBytesOpt = getCStrOpt SB.packCStringLen getInt32Option :: ZMQOption -> Socket a -> IO Int getInt32Option o s = fromIntegral <$> getIntOpt s o (0 :: CInt) diff --git a/src/System/ZMQ4/Monadic.hs b/src/System/ZMQ4/Monadic.hs --- a/src/System/ZMQ4/Monadic.hs +++ b/src/System/ZMQ4/Monadic.hs @@ -163,6 +163,7 @@ , setTcpKeepAliveIdle , setTcpKeepAliveInterval , setXPubVerbose + , setZapDomain -- * Error Handling , Z.ZMQError @@ -600,6 +601,9 @@ setXPubVerbose :: Bool -> Socket z Z.XPub -> ZMQ z () setXPubVerbose b = liftIO . Z.setXPubVerbose b . _unsocket + +setZapDomain :: Restricted (N1, N254) ByteString -> Socket z t -> ZMQ z () +setZapDomain s = liftIO . Z.setZapDomain s . _unsocket -- * Low Level Functions diff --git a/tests/System/ZMQ4/Test/Properties.hs b/tests/System/ZMQ4/Test/Properties.hs --- a/tests/System/ZMQ4/Test/Properties.hs +++ b/tests/System/ZMQ4/Test/Properties.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module System.ZMQ4.Test.Properties where @@ -99,6 +98,9 @@ ReceiveTimeout val -> (ieq (rvalue val)) <$> (setReceiveTimeout val s >> receiveTimeout s) SendHighWM val -> (ieq (rvalue val)) <$> (setSendHighWM val s >> sendHighWM s) SendTimeout val -> (ieq (rvalue val)) <$> (setSendTimeout val s >> sendTimeout s) + ZapDomain val -> (== (rvalue val)) <$> (setZapDomain val s >> zapDomain s) + PlainPassword val -> (== (rvalue val)) <$> (setPlainPassword val s >> plainPassword s) + PlainUsername val -> (== (rvalue val)) <$> (setPlainUserName val s >> plainUserName s) QM.assert r where ieq :: (Integral i, Integral k) => i -> k -> Bool @@ -113,15 +115,15 @@ lastEndpoint s a @=? a' -prop_subscribe :: (Subscriber a, SocketType a) => a -> ByteString -> Property -prop_subscribe t subs = monadicIO $ run $ +prop_subscribe :: (Subscriber a, SocketType a) => a -> Bytes -> Property +prop_subscribe t (Bytes subs) = monadicIO $ run $ runZMQ $ do s <- socket t subscribe s subs unsubscribe s subs -prop_send_receive :: (SocketType a, SocketType b, Receiver b, Sender a) => a -> b -> ByteString -> Property -prop_send_receive a b msg = monadicIO $ do +prop_send_receive :: (SocketType a, SocketType b, Receiver b, Sender a) => a -> b -> Bytes -> Property +prop_send_receive a b (Bytes msg) = monadicIO $ do msg' <- run $ runZMQ $ do sender <- socket a receiver <- socket b @@ -132,8 +134,8 @@ liftIO $ wait x QM.assert (msg == msg') -prop_pub_sub :: (SocketType a, Subscriber b, SocketType b, Sender a, Receiver b) => a -> b -> ByteString -> Property -prop_pub_sub a b msg = monadicIO $ do +prop_pub_sub :: (SocketType a, Subscriber b, SocketType b, Sender a, Receiver b) => a -> b -> Bytes -> Property +prop_pub_sub a b (Bytes msg) = monadicIO $ do msg' <- run $ runZMQ $ do pub <- socket a sub <- socket b @@ -154,9 +156,11 @@ connect s "inproc://endpoint" disconnect s "inproc://endpoint" -instance Arbitrary ByteString where - arbitrary = CB.pack . filter (/= '\0') <$> arbitrary +newtype Bytes = Bytes { unbytes :: ByteString } deriving Show +instance Arbitrary Bytes where + arbitrary = Bytes . CB.filter (/= '\NUL') . CB.pack <$> arbitrary + data GetOpt = Events Int | Filedesc Fd @@ -181,6 +185,9 @@ | SendBuf (Restricted (N0, Int32) Int) | SendHighWM (Restricted (N0, Int32) Int) | SendTimeout (Restricted (Nneg1, Int32) Int) + | ZapDomain (Restricted (N1, N254) ByteString) + | PlainPassword (Restricted (N1, N254) ByteString) + | PlainUsername (Restricted (N1, N254) ByteString) deriving Show instance Arbitrary GetOpt where @@ -208,7 +215,10 @@ , SendHighWM . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , SendTimeout . toRneg1 <$> (arbitrary :: Gen Int32) `suchThat` (>= -1) , MaxMessageSize . toRneg1' <$> (arbitrary :: Gen Int64) `suchThat` (>= -1) - , Identity . fromJust . toRestricted <$> arbitrary `suchThat` (\s -> SB.length s > 0 && SB.length s < 255) + , ZapDomain . fromJust . toRestricted <$> (unbytes <$> arbitrary) `suchThat` (\s -> SB.length s > 0 && SB.length s < 255) + , PlainPassword . fromJust . toRestricted <$> (unbytes <$> arbitrary) `suchThat` (\s -> SB.length s > 0 && SB.length s < 255) + , PlainUsername . fromJust . toRestricted <$> (unbytes <$> arbitrary) `suchThat` (\s -> SB.length s > 0 && SB.length s < 255) + , Identity . fromJust . toRestricted <$> (unbytes <$> arbitrary) `suchThat` (\s -> SB.length s > 0 && SB.length s < 255) ] toR1 :: Int32 -> Restricted (N1, Int32) Int diff --git a/zeromq4-haskell.cabal b/zeromq4-haskell.cabal --- a/zeromq4-haskell.cabal +++ b/zeromq4-haskell.cabal @@ -1,5 +1,5 @@ name: zeromq4-haskell -version: 0.6.7 +version: 0.8.0 synopsis: Bindings to ZeroMQ 4.x category: System, FFI license: MIT @@ -9,7 +9,7 @@ copyright: (c) 2010 - 2015 zeromq-haskell authors homepage: https://gitlab.com/twittner/zeromq-haskell/ stability: experimental -tested-With: GHC == 8.0.2 +tested-With: GHC == 8.2.2 cabal-version: >= 1.8 build-type: Simple extra-source-files: @@ -77,6 +77,7 @@ hs-source-dirs: tests main-is: tests.hs ghc-options: -Wall -threaded + other-modules: System.ZMQ4.Test.Properties build-depends: zeromq4-haskell , async