From b9b548d8eb1352a3a2f73a0cce6fdae73de7b8f8 Mon Sep 17 00:00:00 2001 From: Connor Clark Date: Wed, 17 Aug 2016 09:54:46 -0700 Subject: [PATCH] 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 | 10 +++- grpc-haskell.cabal | 1 + include/grpc_haskell.h | 5 +- src/Network/GRPC/Unsafe/Metadata.chs | 30 ++++++++---- tests/UnsafeTests.hs | 68 ++++++++++++++++++++++------ 5 files changed, 89 insertions(+), 25 deletions(-) diff --git a/cbits/grpc_haskell.c b/cbits/grpc_haskell.c index 36a3f71..d3a6ddb 100644 --- a/cbits/grpc_haskell.c +++ b/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)); diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 3f1470f..d5ba88a 100644 --- a/grpc-haskell.cabal +++ b/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, diff --git a/include/grpc_haskell.h b/include/grpc_haskell.h index 083678b..6773189 100644 --- a/include/grpc_haskell.h +++ b/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); diff --git a/src/Network/GRPC/Unsafe/Metadata.chs b/src/Network/GRPC/Unsafe/Metadata.chs index 40bc7ad..6d3e70d 100644 --- a/src/Network/GRPC/Unsafe/Metadata.chs +++ b/src/Network/GRPC/Unsafe/Metadata.chs @@ -1,6 +1,6 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Network.GRPC.Unsafe.Metadata where @@ -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 - {useAsCString* `ByteString', useAsCString* `ByteString', +{#fun unsafe set_metadata_key_val as setMetadataKeyVal' + {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 diff --git a/tests/UnsafeTests.hs b/tests/UnsafeTests.hs index a693528..e36d554 100644 --- a/tests/UnsafeTests.hs +++ b/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!" - , roundtripSlice "\NULabc\NUL" - , roundtripByteBuffer "Hwaet! We gardena in geardagum..." - , roundtripSlice largeByteString - , roundtripByteBuffer largeByteString + [ roundtripSliceUnit "\NULabc\NUL" + , roundtripSliceUnit largeByteString + , roundtripByteBufferUnit 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 bs = testCase "ByteString slice roundtrip" $ do +roundtripSlice :: B.ByteString -> IO B.ByteString +roundtripSlice bs = do slice <- byteStringToSlice bs unslice <- sliceToByteString slice - unslice HU.@?= bs freeSlice slice + return unslice -roundtripByteBuffer :: B.ByteString -> TestTree -roundtripByteBuffer bs = testCase "ByteBuffer roundtrip" $ do +roundtripSliceQC :: TestTree +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