{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.ZMQ4.Test.Properties where import Test.QuickCheck import Test.QuickCheck.Monadic (monadicIO, run) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Control.Applicative import Control.Concurrent.Async (wait) import Data.Int import Data.Word import Data.Restricted import Data.Maybe (fromJust) import Data.ByteString (ByteString) import System.ZMQ4.Monadic import System.Posix.Types (Fd(..)) import Prelude import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as CB import qualified Test.QuickCheck.Monadic as QM tests :: TestTree tests = testGroup "0MQ Socket Properties" [ testProperty "get socket option (Pair)" (prop_get_socket_option Pair) , testProperty "get socket option (Pub)" (prop_get_socket_option Pub) , testProperty "get socket option (Sub)" (prop_get_socket_option Sub) , testProperty "get socket option (XPub)" (prop_get_socket_option XPub) , testProperty "get socket option (XSub)" (prop_get_socket_option XSub) , testProperty "get socket option (Req)" (prop_get_socket_option Req) , testProperty "get socket option (Rep)" (prop_get_socket_option Rep) , testProperty "get socket option (Dealer)" (prop_get_socket_option Dealer) , testProperty "get socket option (Router)" (prop_get_socket_option Router) , testProperty "get socket option (Pull)" (prop_get_socket_option Pull) , testProperty "get socket option (Push)" (prop_get_socket_option Push) , testProperty "set;get socket option (Pair)" (prop_set_get_socket_option Pair) , testProperty "set;get socket option (Pub)" (prop_set_get_socket_option Pub) , testProperty "set;get socket option (Sub)" (prop_set_get_socket_option Sub) , testProperty "set;get socket option (XPub)" (prop_set_get_socket_option XPub) , testProperty "set;get socket option (XSub)" (prop_set_get_socket_option XSub) , testProperty "set;get socket option (Req)" (prop_set_get_socket_option Req) , testProperty "set;get socket option (Rep)" (prop_set_get_socket_option Rep) , testProperty "set;get socket option (Dealer)" (prop_set_get_socket_option Dealer) , testProperty "set;get socket option (Router)" (prop_set_get_socket_option Router) , testProperty "set;get socket option (Pull)" (prop_set_get_socket_option Pull) , testProperty "set;get socket option (Push)" (prop_set_get_socket_option Push) , testProperty "(un-)subscribe" (prop_subscribe Sub) , testCase "last_enpoint" (last_endpoint) , testGroup "connect disconnect" [ testProperty "" (prop_connect_disconnect x) | x <- [ (AnySocket Rep, AnySocket Req) , (AnySocket Router, AnySocket Req) , (AnySocket Pull, AnySocket Push) ] ] , testGroup "0MQ Messages" [ testProperty "msg send == msg received (Req/Rep)" (prop_send_receive Req Rep) , testProperty "msg send == msg received (Push/Pull)" (prop_send_receive Push Pull) , testProperty "msg send == msg received (Pair/Pair)" (prop_send_receive Pair Pair) -- , testProperty "publish/subscribe" (prop_pub_sub Pub Sub) -- (disabled due to LIBZMQ-270 [https://zeromq.jira.com/browse/LIBZMQ-270]) ] ] prop_get_socket_option :: SocketType t => t -> GetOpt -> Property prop_get_socket_option t opt = monadicIO $ run $ do runZMQ $ do s <- socket t case opt of Events _ -> events s >> return () Filedesc _ -> fileDescriptor s >> return () ReceiveMore _ -> moreToReceive s >> return () prop_set_get_socket_option :: SocketType t => t -> SetOpt -> Property prop_set_get_socket_option t opt = monadicIO $ do r <- run $ runZMQ $ do s <- socket t case opt of Identity val -> (== (rvalue val)) <$> (setIdentity val s >> identity s) Ipv4Only val -> (== val) <$> (setIpv4Only val s >> ipv4Only s) Affinity val -> (ieq val) <$> (setAffinity val s >> affinity s) Backlog val -> (ieq (rvalue val)) <$> (setBacklog val s >> backlog s) Linger val -> (ieq (rvalue val)) <$> (setLinger val s >> linger s) Rate val -> (ieq (rvalue val)) <$> (setRate val s >> rate s) ReceiveBuf val -> (ieq (rvalue val)) <$> (setReceiveBuffer val s >> receiveBuffer s) ReconnectIVL val -> (ieq (rvalue val)) <$> (setReconnectInterval val s >> reconnectInterval s) ReconnectIVLMax val -> (ieq (rvalue val)) <$> (setReconnectIntervalMax val s >> reconnectIntervalMax s) RecoveryIVL val -> (ieq (rvalue val)) <$> (setRecoveryInterval val s >> recoveryInterval s) SendBuf val -> (ieq (rvalue val)) <$> (setSendBuffer val s >> sendBuffer s) MaxMessageSize val -> (ieq (rvalue val)) <$> (setMaxMessageSize val s >> maxMessageSize s) McastHops val -> (ieq (rvalue val)) <$> (setMcastHops val s >> mcastHops s) ReceiveHighWM val -> (ieq (rvalue val)) <$> (setReceiveHighWM val s >> receiveHighWM s) 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) QM.assert r where ieq :: (Integral i, Integral k) => i -> k -> Bool ieq i k = (fromIntegral i :: Int) == (fromIntegral k :: Int) last_endpoint :: IO () last_endpoint = do let a = "tcp://127.0.0.1:43821" a' <- runZMQ $ do s <- socket Rep bind s a lastEndpoint s a @=? a' prop_subscribe :: (Subscriber a, SocketType a) => a -> ByteString -> Property prop_subscribe t 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 msg' <- run $ runZMQ $ do sender <- socket a receiver <- socket b bind receiver "inproc://endpoint" x <- async $ receive receiver connect sender "inproc://endpoint" send sender [] msg 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 msg' <- run $ runZMQ $ do pub <- socket a sub <- socket b subscribe sub "" bind sub "inproc://endpoint" connect pub "inproc://endpoint" send pub [] msg receive sub QM.assert (msg == msg') prop_connect_disconnect :: (AnySocket, AnySocket) -> Property prop_connect_disconnect (AnySocket t0, AnySocket t) = monadicIO $ run $ runZMQ $ do s0 <- socket t0 bind s0 "inproc://endpoint" s <- socket t connect s "inproc://endpoint" disconnect s "inproc://endpoint" instance Arbitrary ByteString where arbitrary = CB.pack . filter (/= '\0') <$> arbitrary data GetOpt = Events Int | Filedesc Fd | ReceiveMore Bool deriving Show data SetOpt = Affinity Word64 | Backlog (Restricted (N0, Int32) Int) | Identity (Restricted (N1, N254) ByteString) | Ipv4Only Bool | Linger (Restricted (Nneg1, Int32) Int) | MaxMessageSize (Restricted (Nneg1, Int64) Int64) | McastHops (Restricted (N1, Int32) Int) | Rate (Restricted (N1, Int32) Int) | ReceiveBuf (Restricted (N0, Int32) Int) | ReceiveHighWM (Restricted (N0, Int32) Int) | ReceiveTimeout (Restricted (Nneg1, Int32) Int) | ReconnectIVL (Restricted (N0, Int32) Int) | ReconnectIVLMax (Restricted (N0, Int32) Int) | RecoveryIVL (Restricted (N0, Int32) Int) | SendBuf (Restricted (N0, Int32) Int) | SendHighWM (Restricted (N0, Int32) Int) | SendTimeout (Restricted (Nneg1, Int32) Int) deriving Show instance Arbitrary GetOpt where arbitrary = oneof [ Events <$> arbitrary , Filedesc . Fd . fromIntegral <$> (arbitrary :: Gen Int32) , ReceiveMore <$> arbitrary ] instance Arbitrary SetOpt where arbitrary = oneof [ Affinity <$> (arbitrary :: Gen Word64) , Ipv4Only <$> (arbitrary :: Gen Bool) , Backlog . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , Linger . toRneg1 <$> (arbitrary :: Gen Int32) `suchThat` (>= -1) , Rate . toR1 <$> (arbitrary :: Gen Int32) `suchThat` (> 0) , ReceiveBuf . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , ReconnectIVL . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , ReconnectIVLMax . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , RecoveryIVL . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , SendBuf . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , McastHops . toR1 <$> (arbitrary :: Gen Int32) `suchThat` (> 0) , ReceiveHighWM . toR0 <$> (arbitrary :: Gen Int32) `suchThat` (>= 0) , ReceiveTimeout . toRneg1 <$> (arbitrary :: Gen Int32) `suchThat` (>= -1) , 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) ] toR1 :: Int32 -> Restricted (N1, Int32) Int toR1 = fromJust . toRestricted . fromIntegral toR0 :: Int32 -> Restricted (N0, Int32) Int toR0 = fromJust . toRestricted . fromIntegral toRneg1 :: Int32 -> Restricted (Nneg1, Int32) Int toRneg1 = fromJust . toRestricted . fromIntegral toRneg1' :: Int64 -> Restricted (Nneg1, Int64) Int64 toRneg1' = fromJust . toRestricted . fromIntegral data AnySocket where AnySocket :: SocketType a => a -> AnySocket