Add a few QuickCheck tests of the channel interface

dns/dns.h

@@ -144,7 +144,7 @@ extern int dns_debug;
 
 #define dns_quietinit(...) \
 	DNS_PRAGMA_PUSH DNS_PRAGMA_QUIET __VA_ARGS__ DNS_PRAGMA_POP
-#elif (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ > 4
+#elif (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || (__GNUC__ > 4 && __GNUC__ < 9)
 #define DNS_PRAGMA_PUSH _Pragma("GCC diagnostic push")
 #define DNS_PRAGMA_QUIET _Pragma("GCC diagnostic ignored \"-Woverride-init\"")
 #define DNS_PRAGMA_POP _Pragma("GCC diagnostic pop")

tests/quickcheck/README.md

@@ -0,0 +1,36 @@
+# Testing libdill with QuickCheck
+Demonstrates how to test monadic C-code using [QuickCheck](https://en.wikipedia.org/wiki/QuickCheck) and property-based testing.
+
+## Environment
+In order to run these tests at least the following is needed:
+- A C compiler
+- [Stack](https://haskellstack.org/)
+
+## Building
+Build the library from the top-level of the libdill repo:
+
+```shell
+./autogen.sh
+./configure --enable-debug
+make
+```
+
+## Testing
+Test the library with QuickCheck:
+
+```shell
+cd test/quickcheck
+stack test
+```
+
+Test the library in GHCi:
+```shell
+cd test/quickchek
+stack ghci libdill-quickcheck:libdill-quickcheck-test
+```
+
+and then in the GHCi prompt
+```shell
+> main
++++ OK, passed 10000 tests.
+```

tests/quickcheck/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

tests/quickcheck/libdill-quickcheck.cabal

@@ -0,0 +1,26 @@
+name:                libdill-quickcheck
+version:             0.1.0.0
+build-type:          Simple
+cabal-version:       >=1.10
+
+test-suite libdill-quickcheck-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             QuickCheck.hs
+  other-modules:       ChannelQC
+                     , FFI.Channels
+                     , FFI.Handles
+                     , FFI.Helpers
+                     , FFI.TestCaseFFI
+  build-depends:       base
+                     , containers
+                     , test-framework
+                     , test-framework-quickcheck2
+                     , QuickCheck
+                     , array
+  includes:            libdill.h
+                     , test-ffi.h
+  c-sources:           test/FFI/lib/test-ffi.c
+  extra-libraries:     dill
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -dynamic
+  default-language:    Haskell2010

tests/quickcheck/stack.yaml

@@ -0,0 +1,68 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-13.14
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.9"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+extra-include-dirs:
+- ../..
+- ../../dns
+- test/FFI/lib
+extra-lib-dirs:
+- ../../.libs
+
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

tests/quickcheck/test/ChannelQC.hs

@@ -0,0 +1,157 @@
+{-
+ Copyright 2019, Mokshasoft AB (mokshasoft.com)
+
+ This software may be distributed and modified according to the terms of
+ the GNU General Public License version 3. Note that NO WARRANTY is provided.
+ See "LICENSE.txt" for details.
+ -}
+{-
+ Test the libdill channel interface using QuickCheck
+ -}
+module ChannelQC
+  ( quickcheckChannel
+  ) where
+
+import qualified Control.Exception as CE
+import Control.Monad
+import Data.Maybe
+import Foreign.C.Types
+import Foreign.Storable
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+
+import FFI.Channels
+import FFI.Handles
+import FFI.Helpers
+import FFI.TestCaseFFI
+
+-- |Top-level function that runs all libdill channel QuickCheck tests.
+quickcheckChannel :: IO ()
+quickcheckChannel = do
+  quickCheck (withMaxSuccess 10000 prop_GetChannel)
+  quickCheck (withMaxSuccess 10000 prop_ReceiverWaitsForSender)
+  quickCheck (withMaxSuccess 1000 prop_SimultaneousSenders)
+  quickCheck (withMaxSuccess 1000 prop_SimultaneousReceivers)
+  quickCheck (withMaxSuccess 100 prop_chdoneUnblocksSenders)
+
+-- |Print a string and trigger an assert
+triggerAssert :: String -> IO ()
+triggerAssert str = do
+  putStrLn str
+  CE.assert False $ return ()
+
+-- |Get a channel
+getChannel :: IO (CInt, CInt)
+getChannel = do
+  ch <- dill_chmake
+  unless (isJust ch) $ triggerAssert "Failed to get channel"
+  return $ fromMaybe (0, 0) ch
+
+-- |Close a channel
+closeChannel :: (CInt, CInt) -> IO ()
+closeChannel channel = do
+  rc1 <- dill_hclose (snd channel)
+  unless (rc1 == 0) $ triggerAssert "Failed to close receiver end-point"
+  rc2 <- dill_hclose (fst channel)
+  unless (rc2 == 0) $ triggerAssert "Failed to close sender end-point"
+
+-- |Close all handles
+closeAllHandles :: [CInt] -> IO ()
+closeAllHandles handles = do
+  rcs <- mapM dill_hclose handles
+  unless (all (== 0) rcs) $ triggerAssert "Failed to close all handles"
+
+-- |Test that dill_chmake returns a channel (not really a property test)
+prop_GetChannel :: Property
+prop_GetChannel =
+  monadicIO $ run testProp
+  where
+    testProp :: IO ()
+    testProp = do
+      channel <- getChannel
+      closeChannel channel
+
+-- |Test that a receiver waits for the sender
+prop_ReceiverWaitsForSender :: CInt -> Property
+prop_ReceiverWaitsForSender val =
+  monadicIO $ do
+    res <- run testProp
+    assert res
+  where
+    testProp :: IO Bool
+    testProp = do
+      channel <- getChannel
+      hdl <- ffi_go_sender (fst channel) val
+      unless (isJust hdl) $ triggerAssert "Failed to get sender handle"
+      let handle = fromMaybe 0 hdl
+      rv <- dill_chrecv_int (snd channel)
+      unless (isJust rv) $ triggerAssert "Failed to receive value"
+      let retVal = fromMaybe 0 rv
+      closeChannel channel
+      rc <- dill_hclose handle
+      unless (rc == 0) $ triggerAssert "Failed to close sender handle"
+      return $ val == retVal
+
+-- |Test multiple simultaneous senders, each sender sends one value
+prop_SimultaneousSenders :: NonEmptyList CInt -> Property
+prop_SimultaneousSenders (NonEmpty vs) =
+  monadicIO $ do
+    res <- run testProp
+    assert res
+  where
+    testProp :: IO Bool
+    testProp = do
+      channel <- getChannel
+      hdls <- mapM (ffi_go_sender (fst channel)) vs
+      unless (all isJust hdls) $
+        triggerAssert "Failed to get all sender handles"
+      let handles = map (fromMaybe 0) hdls
+      rvs <- mapM (\_ -> dill_chrecv_int (snd channel)) handles
+      unless (all isJust rvs) $ triggerAssert "Failed to receive all values"
+      let retVals = map (fromMaybe 0) rvs
+      closeChannel channel
+      closeAllHandles handles
+      return $ vs == retVals
+
+-- |Test multiple simultaneous receivers, each sender sends one value
+prop_SimultaneousReceivers :: NonEmptyList CInt -> Property
+prop_SimultaneousReceivers (NonEmpty vs) =
+  monadicIO $ do
+    res <- run testProp
+    assert res
+  where
+    testProp :: IO Bool
+    testProp = do
+      channel <- getChannel
+      hdls <- mapM (ffi_go_receiver (fst channel)) vs
+      unless (all isJust hdls) $
+        triggerAssert "Failed to get all receiver handles"
+      let handles = map (fromMaybe 0) hdls
+      rcs <- mapM (dill_chsend_int (snd channel)) vs
+      unless (all (== 0) rcs) $ triggerAssert "Failed to send all values"
+      closeChannel channel
+      closeAllHandles handles
+      return True -- ffi_go_receiver checks that the received values are correct
+
+-- |Test that chdone unblocks all senders
+prop_chdoneUnblocksSenders :: NonEmptyList CInt -> Property
+prop_chdoneUnblocksSenders (NonEmpty vs) =
+  monadicIO $ do
+    res <- run testProp
+    assert res
+  where
+    testProp :: IO Bool
+    testProp = do
+      channel <- getChannel
+      hdls <- mapM (ffi_go_sender_unblocked (fst channel)) vs
+      unless (all isJust hdls) $
+        triggerAssert "Failed to get all sender handles"
+      let handles = map (fromMaybe 0) hdls
+      now <- dill_now
+      rc1 <- dill_msleep $ now + 50
+      unless (rc1 == 0) $ triggerAssert "Failed to sleep"
+      rc2 <- dill_chdone (snd channel)
+      unless (rc2 == 0) $ triggerAssert "Failed to close channel"
+      closeChannel channel
+      closeAllHandles handles
+      return True

tests/quickcheck/test/FFI/Channels.hs

@@ -0,0 +1,75 @@
+{-
+ Copyright 2019, Mokshasoft AB (mokshasoft.com)
+
+ This software may be distributed and modified according to the terms of
+ the GNU General Public License version 3. Note that NO WARRANTY is provided.
+ See "LICENSE.txt" for details.
+ -}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+{-
+ FFI for the channels part of libdill.h
+ -}
+module FFI.Channels
+  ( dill_chmake
+  , dill_chsend_int
+  , dill_chrecv_int
+  , dill_chdone
+  ) where
+
+import Control.Monad
+import Foreign.C
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
+
+-- int dill_chmake(int chv[2]);
+dill_chmake :: IO (Maybe (CInt, CInt))
+dill_chmake = do
+  ch <- newArray [0, 0]
+  pokeElemOff ch 0 0
+  pokeElemOff ch 1 0
+  -- Create channel endpoint handles and check that it worked
+  res <- internal_dill_chmake ch
+  if res /= 0
+    then return Nothing
+    else do
+      ep1 <- peekElemOff ch 0
+      ep2 <- peekElemOff ch 1
+      if ep1 >= 0 && ep2 >= 0
+        then return $ Just (ep1, ep2)
+        else return Nothing
+
+foreign import ccall "dill_chmake" internal_dill_chmake :: Ptr CInt -> IO CInt
+
+dill_chsend_int :: CInt -> CInt -> IO CInt
+dill_chsend_int ch value = do
+  val <- malloc
+  pokeElemOff val 0 value
+  let valSize = fromIntegral (sizeOf value)
+  res <- internal_dill_chsend_int ch val valSize (-1)
+  free val
+  return res
+
+foreign import ccall "dill_chsend" internal_dill_chsend_int
+  :: CInt -> Ptr CInt -> CInt -> CInt -> IO CInt
+
+dill_chrecv_int :: CInt -> IO (Maybe CInt)
+dill_chrecv_int ch = do
+  val <- malloc
+  let valSize = fromIntegral (sizeOf (0 :: CInt))
+  res <- internal_dill_chrecv_int ch val valSize (-1)
+  ret <-
+    if res /= 0
+      then return Nothing
+      else do
+        v <- peekElemOff val 0
+        return $ Just v
+  free val
+  return ret
+
+foreign import ccall "dill_chrecv" internal_dill_chrecv_int
+  :: CInt -> Ptr CInt -> CInt -> CInt -> IO CInt
+
+foreign import ccall "dill_chdone" dill_chdone :: CInt -> IO CInt

tests/quickcheck/test/FFI/Handles.hs

@@ -0,0 +1,19 @@
+{-
+ Copyright 2019, Mokshasoft AB (mokshasoft.com)
+
+ This software may be distributed and modified according to the terms of
+ the GNU General Public License version 3. Note that NO WARRANTY is provided.
+ See "LICENSE.txt" for details.
+ -}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+{-
+ FFI for the handles part of libdill.h
+ -}
+module FFI.Handles
+  ( dill_hclose
+  ) where
+
+import Foreign.C
+
+foreign import ccall "dill_hclose" dill_hclose :: CInt -> IO CInt