Fix metadata marshalling bug, add QuickCheck properties (#63)

* make metadatamap a newtype of multimap

* update tests for new MetadataMap

* remove multimap dependency, reproduce needed functionality instead

* add repeated key to payload test

* QuickCheck properties for C bindings, fix bug in metadata FFI wrappers

* add quickcheck bound

* fix merge

cbits/grpc_haskell.c

@@ -166,11 +166,12 @@ void metadata_free(grpc_metadata* m){
   grpc_haskell_free("metadata_free", m);
 }
 
-void set_metadata_key_val(char *key, char *val, grpc_metadata *arr, size_t i){
+void set_metadata_key_val(char *key, char *val, size_t val_len,
+                          grpc_metadata *arr, size_t i){
   grpc_metadata *p = arr + i;
   p->key = key;
   p->value = val;
-  p->value_length = strlen(val);
+  p->value_length = val_len;
 }
 
 const char* get_metadata_key(grpc_metadata *arr, size_t i){
@@ -183,6 +184,11 @@ const char* get_metadata_val(grpc_metadata *arr, size_t i){
   return p->value;
 }
 
+size_t get_metadata_val_len(grpc_metadata *arr, size_t i){
+  grpc_metadata *p = arr + i;
+  return p->value_length;
+}
+
 grpc_op* op_array_create(size_t n){
   grpc_op* ops = malloc(n*sizeof(grpc_op));
   memset(ops, 0, n*sizeof(grpc_op));

grpc-haskell.cabal

@@ -187,6 +187,7 @@ test-suite test
     , clock >=0.6.0 && <0.8.0
     , turtle >= 1.2.0
     , text
+    , QuickCheck ==2.8.*
   other-modules:
     LowLevelTests,
     LowLevelTests.Op,

include/grpc_haskell.h

@@ -64,12 +64,15 @@ grpc_metadata* metadata_alloc(size_t n);
 
 void metadata_free(grpc_metadata* m);
 
-void set_metadata_key_val(char *key, char *val, grpc_metadata *arr, size_t i);
+void set_metadata_key_val(char *key, char *val, size_t val_len,
+                          grpc_metadata *arr, size_t i);
 
 const char* get_metadata_key(grpc_metadata *arr, size_t i);
 
 const char* get_metadata_val(grpc_metadata *arr, size_t i);
 
+size_t get_metadata_val_len(grpc_metadata *arr, size_t i);
+
 grpc_op* op_array_create(size_t n);
 
 void op_array_destroy(grpc_op* op_array, size_t n);

src/Network/GRPC/Unsafe/Metadata.chs

@@ -8,6 +8,9 @@ import Control.Exception
 import Control.Monad
 import Data.ByteString (ByteString, useAsCString, packCString)
 import Data.Function (on)
+import Data.List (sortBy, groupBy, (\\))
+import Data.ByteString (ByteString, useAsCString,
+                        useAsCStringLen, packCString, packCStringLen)
 import Data.List (sortBy, groupBy)
 import qualified Data.SortedList as SL
 import qualified Data.Map.Strict as M
@@ -29,7 +32,6 @@ import GHC.Exts
 newtype MetadataMap = MetadataMap {unMap :: M.Map ByteString (SL.SortedList ByteString)}
   deriving Eq
 
-
 instance Show MetadataMap where
   show m = "fromList " ++ show (M.toList (unMap m))
 
@@ -98,17 +100,27 @@ instance Storable MetadataArray where
 -- | Sets a metadata key/value pair at the given index in the
 -- 'MetadataKeyValPtr'. No error checking is performed to ensure the index is
 -- in bounds!
-{#fun unsafe set_metadata_key_val as setMetadataKeyVal
+{#fun unsafe set_metadata_key_val as setMetadataKeyVal'
-  {useAsCString* `ByteString', useAsCString* `ByteString',
+  {useAsCString* `ByteString', `CString', `Int',
    `MetadataKeyValPtr', `Int'} -> `()'#}
 
+setMetadataKeyVal :: ByteString
+                     -> ByteString
+                     -> MetadataKeyValPtr
+                     -> Int
+                     -> IO ()
+setMetadataKeyVal k v m i =
+  useAsCStringLen v $ \(vStr, vLen) -> setMetadataKeyVal' k vStr vLen m i
+
 {#fun unsafe get_metadata_key as getMetadataKey'
   {`MetadataKeyValPtr', `Int'} -> `CString'#}
 
 {#fun unsafe get_metadata_val as getMetadataVal'
   {`MetadataKeyValPtr', `Int'} -> `CString'#}
 
---TODO: The test suggests this is leaking.
+{#fun unsafe get_metadata_val_len as getMetadataValLen
+  {`MetadataKeyValPtr', `Int'} -> `Int'#}
+
 withMetadataArrayPtr :: (Ptr MetadataArray -> IO a) -> IO a
 withMetadataArrayPtr = bracket metadataArrayCreate metadataArrayDestroy
 
@@ -119,7 +131,9 @@ getMetadataKey :: MetadataKeyValPtr -> Int -> IO ByteString
 getMetadataKey m = getMetadataKey' m >=> packCString
 
 getMetadataVal :: MetadataKeyValPtr -> Int -> IO ByteString
-getMetadataVal m = getMetadataVal' m >=> packCString
+getMetadataVal m i = do vStr <- getMetadataVal' m i
+                        vLen <- getMetadataValLen m i
+                        packCStringLen (vStr, vLen)
 
 createMetadata :: MetadataMap -> IO MetadataKeyValPtr
 createMetadata m = do

tests/UnsafeTests.hs

@@ -23,14 +23,14 @@ import           Test.Tasty.HUnit               as HU (testCase, (@?=),
                                                        assertBool)
 import           Test.Tasty.QuickCheck          as QC
 import           Test.Tasty.HUnit               as HU (testCase, (@?=))
+import           Test.QuickCheck.Gen            as QC
+import           Test.QuickCheck.Property       as QC
 
 unsafeTests :: TestTree
 unsafeTests = testGroup "Unit tests for unsafe C bindings"
-  [ roundtripSlice "Hello, world!"
+  [ roundtripSliceUnit "\NULabc\NUL"
-  , roundtripSlice "\NULabc\NUL"
+  , roundtripSliceUnit largeByteString
-  , roundtripByteBuffer "Hwaet! We gardena in geardagum..."
+  , roundtripByteBufferUnit largeByteString
-  , roundtripSlice largeByteString
-  , roundtripByteBuffer largeByteString
   , roundtripTimeSpec (TimeSpec 123 123)
   , testMetadata
   , testNow
@@ -42,13 +42,34 @@ unsafeTests = testGroup "Unit tests for unsafe C bindings"
 
 unsafeProperties :: TestTree
 unsafeProperties = testGroup "QuickCheck properties for unsafe C bindings"
-  [ metadataIsList ]
+  [ roundtripSliceQC
+  , roundtripByteBufferQC
+  , roundtripMetadataQC
+  , metadataIsList
+  ]
 
 instance Arbitrary B.ByteString where
   arbitrary = B.pack <$> arbitrary
 
 instance Arbitrary MetadataMap where
-  arbitrary = fromList <$> arbitrary
+  arbitrary = do
+    --keys are not allowed to contain \NUL, but values are.
+    ks <- arbitrary `suchThat` all (B.notElem 0)
+    let l = length ks
+    vs <- vector l
+    return $ fromList (zip ks vs)
+
+roundtripMetadataKeyVals :: MetadataMap -> IO MetadataMap
+roundtripMetadataKeyVals m = do
+  kvPtr <- createMetadata m
+  m' <- getAllMetadata kvPtr (length $ toList m)
+  metadataFree kvPtr
+  return m'
+
+roundtripMetadataQC :: TestTree
+roundtripMetadataQC = QC.testProperty "Metadata roundtrip" $
+                      \m -> QC.ioProperty $ do m' <- roundtripMetadataKeyVals m
+                                               return $ m === m'
 
 metadataIsList :: TestTree
 metadataIsList = QC.testProperty "Metadata IsList instance" $
@@ -57,26 +78,45 @@ metadataIsList = QC.testProperty "Metadata IsList instance" $
 largeByteString :: B.ByteString
 largeByteString = B.pack $ take (32*1024*1024) $ cycle [97..99]
 
-roundtripSlice :: B.ByteString -> TestTree
+roundtripSlice :: B.ByteString -> IO B.ByteString
-roundtripSlice bs = testCase "ByteString slice roundtrip" $ do
+roundtripSlice bs = do
   slice <- byteStringToSlice bs
   unslice <- sliceToByteString slice
-  unslice HU.@?= bs
   freeSlice slice
+  return unslice
 
-roundtripByteBuffer :: B.ByteString -> TestTree
+roundtripSliceQC :: TestTree
-roundtripByteBuffer bs = testCase "ByteBuffer roundtrip" $ do
+roundtripSliceQC = QC.testProperty "Slice roundtrip: QuickCheck" $
+                   \bs -> QC.ioProperty $ do bs' <- roundtripSlice bs
+                                             return $ bs == bs'
+
+roundtripSliceUnit :: B.ByteString -> TestTree
+roundtripSliceUnit bs = testCase "ByteString slice roundtrip" $ do
+  unslice <- roundtripSlice bs
+  unslice HU.@?= bs
+
+roundtripByteBuffer :: B.ByteString -> IO B.ByteString
+roundtripByteBuffer bs = do
   slice <- byteStringToSlice bs
   buffer <- grpcRawByteBufferCreate slice 1
   reader <- byteBufferReaderCreate buffer
   readSlice <- grpcByteBufferReaderReadall reader
   bs' <- sliceToByteString readSlice
-  bs' HU.@?= bs
-  -- clean up
   freeSlice slice
   byteBufferReaderDestroy reader
   grpcByteBufferDestroy buffer
   freeSlice readSlice
+  return bs'
+
+roundtripByteBufferQC :: TestTree
+roundtripByteBufferQC = QC.testProperty "ByteBuffer roundtrip: QuickCheck" $
+                        \bs -> QC.ioProperty $ do bs' <- roundtripByteBuffer bs
+                                                  return $ bs == bs'
+
+roundtripByteBufferUnit :: B.ByteString -> TestTree
+roundtripByteBufferUnit bs = testCase "ByteBuffer roundtrip" $ do
+  bs' <- roundtripByteBuffer bs
+  bs' HU.@?= bs
 
 roundtripTimeSpec :: TimeSpec -> TestTree
 roundtripTimeSpec t = testCase "CTimeSpec roundtrip" $ do