Properties.hs

{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE GADTs                #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module System.ZMQ4.Test.Properties where

import Test.QuickCheck
import Test.QuickCheck.Monadic
import Test.Tools

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 qualified Data.ByteString as SB
import qualified Data.ByteString.Char8 as CB

tests :: IO ()
tests = do
      quickBatch' ("0MQ Socket Properties"
        , [ ("get socket option (Pair)",       property $ prop_get_socket_option Pair)
          , ("get socket option (Pub)",        property $ prop_get_socket_option Pub)
          , ("get socket option (Sub)",        property $ prop_get_socket_option Sub)
          , ("get socket option (XPub)",       property $ prop_get_socket_option XPub)
          , ("get socket option (XSub)",       property $ prop_get_socket_option XSub)
          , ("get socket option (Req)",        property $ prop_get_socket_option Req)
          , ("get socket option (Rep)",        property $ prop_get_socket_option Rep)
          , ("get socket option (Dealer)",     property $ prop_get_socket_option Dealer)
          , ("get socket option (Router)",     property $ prop_get_socket_option Router)
          , ("get socket option (Pull)",       property $ prop_get_socket_option Pull)
          , ("get socket option (Push)",       property $ prop_get_socket_option Push)
          , ("set;get socket option (Pair)",   property $ prop_set_get_socket_option Pair)
          , ("set;get socket option (Pub)",    property $ prop_set_get_socket_option Pub)
          , ("set;get socket option (Sub)",    property $ prop_set_get_socket_option Sub)
          , ("set;get socket option (XPub)",   property $ prop_set_get_socket_option XPub)
          , ("set;get socket option (XSub)",   property $ prop_set_get_socket_option XSub)
          , ("set;get socket option (Req)",    property $ prop_set_get_socket_option Req)
          , ("set;get socket option (Rep)",    property $ prop_set_get_socket_option Rep)
          , ("set;get socket option (Dealer)", property $ prop_set_get_socket_option Dealer)
          , ("set;get socket option (Router)", property $ prop_set_get_socket_option Router)
          , ("set;get socket option (Pull)",   property $ prop_set_get_socket_option Pull)
          , ("set;get socket option (Push)",   property $ prop_set_get_socket_option Push)
          , ("(un-)subscribe",                 property $ prop_subscribe Sub)
          ] ++
          [ ("connect disconnect ", property $ prop_connect_disconnect x) |
            x <- [ (AnySocket Rep, AnySocket Req)
                 , (AnySocket Router, AnySocket Req)
                 , (AnySocket Pull, AnySocket Push)]]
          )

      quickBatch' ("0MQ Messages"
        , [ ("msg send == msg received (Req/Rep)",   property $ prop_send_receive Req Rep)
          , ("msg send == msg received (Push/Pull)", property $ prop_send_receive Push Pull)
          , ("msg send == msg received (Pair/Pair)", property $ prop_send_receive Pair Pair)

          -- , ("publish/subscribe", property $ 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)
    assert r
  where
    ieq :: (Integral i, Integral k) => i -> k -> Bool
    ieq i k  = (fromIntegral i :: Int) == (fromIntegral k :: Int)

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
    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
    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