diff --git a/core/grpc-haskell-core.cabal b/core/grpc-haskell-core.cabal index f88a634..e134200 100644 --- a/core/grpc-haskell-core.cabal +++ b/core/grpc-haskell-core.cabal @@ -1,5 +1,5 @@ name: grpc-haskell-core -version: 0.1.0 +version: 0.2.0 synopsis: Haskell implementation of gRPC layered on shared C library. homepage: https://github.com/awakenetworks/gRPC-haskell license: Apache-2.0 @@ -28,7 +28,6 @@ library , containers >=0.5 && <0.7 , managed >= 1.0.0 && < 1.1 , transformers - , sorted-list >=0.1.6.1 && <=0.3 c-sources: cbits/grpc_haskell.c @@ -50,6 +49,7 @@ library Network.GRPC.LowLevel.CompletionQueue.Internal Network.GRPC.LowLevel.CompletionQueue.Unregistered Network.GRPC.LowLevel.GRPC + Network.GRPC.LowLevel.GRPC.MetadataMap Network.GRPC.LowLevel.Op Network.GRPC.LowLevel.Server Network.GRPC.LowLevel.Call diff --git a/core/src/Network/GRPC/LowLevel/GRPC.hs b/core/src/Network/GRPC/LowLevel/GRPC.hs index 397665d..5152e91 100644 --- a/core/src/Network/GRPC/LowLevel/GRPC.hs +++ b/core/src/Network/GRPC/LowLevel/GRPC.hs @@ -11,16 +11,16 @@ GRPC , grpcDebug , grpcDebug' , threadDelaySecs -, C.MetadataMap(..) +, MetadataMap(..) , C.StatusDetails(..) ) where import Control.Concurrent (threadDelay, myThreadId) import Control.Exception import Data.Typeable +import Network.GRPC.LowLevel.GRPC.MetadataMap (MetadataMap(..)) import qualified Network.GRPC.Unsafe as C import qualified Network.GRPC.Unsafe.Op as C -import qualified Network.GRPC.Unsafe.Metadata as C -- | Functions as a proof that the gRPC core has been started. The gRPC core -- must be initialized to create any gRPC state, so this is a requirement for diff --git a/core/src/Network/GRPC/LowLevel/GRPC/MetadataMap.hs b/core/src/Network/GRPC/LowLevel/GRPC/MetadataMap.hs new file mode 100644 index 0000000..d62bb25 --- /dev/null +++ b/core/src/Network/GRPC/LowLevel/GRPC/MetadataMap.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Network.GRPC.LowLevel.GRPC.MetadataMap where + +import Data.ByteString (ByteString) +import Data.Function (on) +import GHC.Exts (IsList(..)) +import Data.List (sortBy, groupBy) +import Data.Ord (comparing) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M + +{- | Represents metadata for a given RPC, consisting of key-value pairs (often + referred to as "GRPC custom metadata headers"). + + Keys are allowed to be repeated, with the 'last' value element (i.e., the + last-presented) usually taken as the value for that key (see 'lookupLast' and + 'lookupAll'). + + Since repeated keys are unlikely in practice, the 'IsList' instance for + 'MetadataMap' uses key-value pairs as items, and treats duplicates + appropriately. + + >>> lookupAll "k1" (fromList [("k1","x"), ("k2", "z"), ("k1", "y")]) + Just ("x" :| ["y"]) + + >>> lookupLast "k1" (fromList [("k1","x"), ("k2", "z"), ("k1", "y")]) + Just "y" +-} + +newtype MetadataMap = MetadataMap {unMap :: M.Map ByteString [ByteString]} + deriving Eq + +instance Show MetadataMap where + show m = "fromList " ++ show (M.toList (unMap m)) + +instance Semigroup MetadataMap where + MetadataMap m1 <> MetadataMap m2 = + MetadataMap $ M.unionWith (<>) m1 m2 + +instance Monoid MetadataMap where + mempty = MetadataMap M.empty + +instance IsList MetadataMap where + type Item MetadataMap = (ByteString, ByteString) + fromList = MetadataMap + . M.fromList + . map (\xs -> ((fst . head) xs, map snd xs)) + . groupBy ((==) `on` fst) + . sortBy (comparing fst) + toList = concatMap (\(k,vs) -> map (k,) vs) + . map (fmap toList) + . M.toList + . unMap + +-- | Obtain all header values for a given header key, in presentation order. +lookupAll :: ByteString -> MetadataMap -> Maybe (NE.NonEmpty ByteString) +lookupAll k (MetadataMap md) = NE.nonEmpty =<< M.lookup k md + +-- | Obtain the last-presented header value for a given header key. +lookupLast :: ByteString -> MetadataMap -> Maybe ByteString +lookupLast k = fmap NE.last . lookupAll k diff --git a/core/src/Network/GRPC/Unsafe/Metadata.chs b/core/src/Network/GRPC/Unsafe/Metadata.chs index 57db2ae..bbb4889 100644 --- a/core/src/Network/GRPC/Unsafe/Metadata.chs +++ b/core/src/Network/GRPC/Unsafe/Metadata.chs @@ -1,6 +1,4 @@ {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} module Network.GRPC.Unsafe.Metadata where @@ -8,53 +6,18 @@ module Network.GRPC.Unsafe.Metadata where import Control.Exception import Control.Monad -import Data.Function (on) -import Data.ByteString (ByteString, useAsCString, - useAsCStringLen) -import Data.List (sortBy, groupBy) -import qualified Data.SortedList as SL -import qualified Data.Map.Strict as M -import Data.Ord (comparing) +import Data.ByteString (ByteString, useAsCString, useAsCStringLen) import Foreign.C.String import Foreign.Ptr import Foreign.Storable import GHC.Exts +import Network.GRPC.LowLevel.GRPC.MetadataMap (MetadataMap) #include #include #include #include --- | Represents metadata for a given RPC, consisting of key-value pairs. Keys --- are allowed to be repeated. Since repeated keys are unlikely in practice, --- the 'IsList' instance uses key-value pairs as items. For example, --- @fromList [("key1","val1"),("key2","val2"),("key1","val3")]@. -newtype MetadataMap = MetadataMap {unMap :: M.Map ByteString (SL.SortedList ByteString)} - deriving Eq - -instance Show MetadataMap where - show m = "fromList " ++ show (M.toList (unMap m)) - -instance Semigroup MetadataMap where - (MetadataMap m1) <> (MetadataMap m2) = - MetadataMap $ M.unionWith mappend m1 m2 - -instance Monoid MetadataMap where - mempty = MetadataMap $ M.empty - mappend = (<>) - -instance IsList MetadataMap where - type Item MetadataMap = (ByteString, ByteString) - fromList = MetadataMap - . M.fromList - . map (\xs -> ((fst . head) xs, fromList $ map snd xs)) - . groupBy ((==) `on` fst) - . sortBy (comparing fst) - toList = concatMap (\(k,vs) -> map (k,) vs) - . map (fmap toList) - . M.toList - . unMap - -- | Represents a pointer to one or more metadata key/value pairs. This type -- is intended to be used when sending metadata. {#pointer *grpc_metadata as MetadataKeyValPtr newtype#} diff --git a/core/src/Network/GRPC/Unsafe/Security.chs b/core/src/Network/GRPC/Unsafe/Security.chs index 1153816..7de77f1 100644 --- a/core/src/Network/GRPC/Unsafe/Security.chs +++ b/core/src/Network/GRPC/Unsafe/Security.chs @@ -13,6 +13,7 @@ import Foreign.C.Types import Foreign.Storable import Foreign.Marshal.Alloc (free) import Foreign.Ptr (nullPtr, FunPtr, Ptr, castPtr) +import Network.GRPC.LowLevel.GRPC.MetadataMap (MetadataMap) #include #include diff --git a/core/tests/UnsafeTests.hs b/core/tests/UnsafeTests.hs index b009e9c..5a24cb8 100644 --- a/core/tests/UnsafeTests.hs +++ b/core/tests/UnsafeTests.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnsafeTests (unsafeTests, unsafeProperties) where -import Control.Exception (bracket_) -import Control.Monad -import qualified Data.ByteString as B -import Foreign.Marshal.Alloc -import Foreign.Storable -import GHC.Exts -import Network.GRPC.LowLevel.GRPC (threadDelaySecs) -import Network.GRPC.Unsafe -import Network.GRPC.Unsafe.ByteBuffer -import Network.GRPC.Unsafe.ChannelArgs -import Network.GRPC.Unsafe.Metadata -import Network.GRPC.Unsafe.Security -import Network.GRPC.Unsafe.Slice -import Network.GRPC.Unsafe.Time -import System.Clock -import Test.QuickCheck.Gen -import Test.Tasty -import Test.Tasty.HUnit as HU (testCase, (@?=)) -import Test.Tasty.QuickCheck as QC +import Control.Exception (bracket_) +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.Map as M +import Data.List.NonEmpty (NonEmpty((:|))) +import Foreign.Marshal.Alloc +import Foreign.Storable +import GHC.Exts +import Network.GRPC.LowLevel.GRPC (MetadataMap (..), threadDelaySecs) +import qualified Network.GRPC.LowLevel.GRPC.MetadataMap as MD +import Network.GRPC.Unsafe +import Network.GRPC.Unsafe.ByteBuffer +import Network.GRPC.Unsafe.ChannelArgs +import Network.GRPC.Unsafe.Metadata +import Network.GRPC.Unsafe.Security +import Network.GRPC.Unsafe.Slice +import Network.GRPC.Unsafe.Time +import System.Clock +import Test.QuickCheck.Gen +import Test.Tasty +import Test.Tasty.HUnit as HU (Assertion, testCase, (@?=)) +import Test.Tasty.QuickCheck as QC unsafeTests :: TestTree unsafeTests = testGroup "Unit tests for unsafe C bindings" @@ -31,6 +35,8 @@ unsafeTests = testGroup "Unit tests for unsafe C bindings" , roundtripByteBufferUnit largeByteString , roundtripTimeSpec (TimeSpec 123 123) , testMetadata + , testMetadataOrdering + , testMetadataOrderingProp , testNow , testCreateDestroyMetadata , testCreateDestroyMetadataKeyVals @@ -46,6 +52,7 @@ unsafeProperties = testGroup "QuickCheck properties for unsafe C bindings" , roundtripByteBufferQC , roundtripMetadataQC , metadataIsList + , roundtripMetadataOrdering ] instance Arbitrary B.ByteString where @@ -53,11 +60,14 @@ instance Arbitrary B.ByteString where instance Arbitrary MetadataMap where 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) + -- keys are not allowed to contain \NUL, but values are. + let key = arbitrary `suchThat` B.notElem 0 + ks0 <- listOf key + duplicateKeys <- arbitrary + ks <- if duplicateKeys + then (ks0 <>) . concat . replicate 2 <$> listOf1 key + else pure ks0 + fromList . zip ks <$> vector (length ks) roundtripMetadataKeyVals :: MetadataMap -> IO MetadataMap roundtripMetadataKeyVals m = do @@ -75,6 +85,10 @@ metadataIsList :: TestTree metadataIsList = QC.testProperty "Metadata IsList instance" $ \(md :: MetadataMap) -> md == (fromList $ toList md) +roundtripMetadataOrdering :: TestTree +roundtripMetadataOrdering = QC.testProperty "Metadata map ordering" $ + QC.ioProperty . checkMetadataOrdering + largeByteString :: B.ByteString largeByteString = B.pack $ take (32*1024*1024) $ cycle [97..99] @@ -93,7 +107,7 @@ roundtripSliceQC = QC.testProperty "Slice roundtrip: QuickCheck" $ roundtripSliceUnit :: B.ByteString -> TestTree roundtripSliceUnit bs = testCase "ByteString slice roundtrip" $ do unslice <- roundtripSlice bs - unslice HU.@?= bs + unslice @?= bs roundtripByteBuffer :: B.ByteString -> IO B.ByteString roundtripByteBuffer bs = do @@ -116,7 +130,7 @@ roundtripByteBufferQC = QC.testProperty "ByteBuffer roundtrip: QuickCheck" $ roundtripByteBufferUnit :: B.ByteString -> TestTree roundtripByteBufferUnit bs = testCase "ByteBuffer roundtrip" $ do bs' <- roundtripByteBuffer bs - bs' HU.@?= bs + bs' @?= bs roundtripTimeSpec :: TimeSpec -> TestTree roundtripTimeSpec t = testCase "CTimeSpec roundtrip" $ do @@ -139,14 +153,53 @@ testMetadata = testCase "Metadata setter/getter roundtrip" $ do v1 <- getMetadataVal m 1 k2 <- getMetadataKey m 2 v2 <- getMetadataVal m 2 - k0 HU.@?= "hello" - v0 HU.@?= "world" - k1 HU.@?= "foo" - v1 HU.@?= "bar" - k2 HU.@?= "Haskell" - v2 HU.@?= "Curry" + k0 @?= "hello" + v0 @?= "world" + k1 @?= "foo" + v1 @?= "bar" + k2 @?= "Haskell" + v2 @?= "Curry" metadataFree m +testMetadataOrdering :: TestTree +testMetadataOrdering = testCase "Metadata map ordering (simple)" $ do + let m0 = fromList @MetadataMap [("foo", "bar"), ("fnord", "FNORD")] + let m1 = fromList @MetadataMap [("foo", "baz")] + let lr = m0 <> m1 + let rl = m1 <> m0 + M.lookup "foo" (unMap lr) @?= Just ["bar", "baz"] + M.lookup "foo" (unMap rl) @?= Just ["baz", "bar"] + toList lr @?= [("fnord", "FNORD"), ("foo", "bar"), ("foo", "baz")] + toList rl @?= [("fnord", "FNORD"), ("foo", "baz"), ("foo", "bar")] + M.lookup "foo" (unMap (lr <> rl)) @?= Just ["bar", "baz", "baz", "bar"] + MD.lookupAll "foo" lr @?= Just ("bar" :| ["baz"]) + MD.lookupLast "foo" lr @?= Just "baz" + MD.lookupAll "foo" rl @?= Just ("baz" :| ["bar"]) + MD.lookupLast "foo" rl @?= Just "bar" + +testMetadataOrderingProp :: TestTree +testMetadataOrderingProp = testCase "Metadata map ordering prop w/ trivial inputs" $ + mapM_ (checkMetadataOrdering . fromList) + [ [("foo", "bar"), ("fnord", "FNORD"), ("foo", "baz")] + , [("foo", "baz"), ("fnord", "FNORD"), ("foo", "bar")] + ] + +checkMetadataOrdering :: MetadataMap -> Assertion +checkMetadataOrdering md0 = do + let ikvps = toList md0 `zip` [0..] + let ok md = unMap md @?= M.unionsWith (<>) [M.singleton k [v] | ((k, v), _i) <- ikvps] + ok md0 + md1 <- do + let n = length ikvps + withMetadataKeyValPtr n $ \m -> do + let deref i = (,) <$> getMetadataKey m i <*> getMetadataVal m i + mapM_ (\((k, v), i) -> setMetadataKeyVal k v m i) ikvps + mapM_ (\(kvp, i) -> deref i >>= (@?= kvp)) ikvps + getAllMetadata m n + ok md1 + -- Check Eq instance + mapM_ (uncurry (@?=)) [(x, y) | x <- [md0, md1], y <- [md0, md1]] + currTimeMillis :: ClockType -> IO Int currTimeMillis t = do gprT <- gprNow t @@ -192,8 +245,8 @@ testCreateDestroyServerCreds = testCase "Create/destroy server credentials" $ assertCqEventComplete :: Event -> IO () assertCqEventComplete e = do - eventCompletionType e HU.@?= OpComplete - eventSuccess e HU.@?= True + eventCompletionType e @?= OpComplete + eventSuccess e @?= True grpc :: IO a -> IO () grpc = bracket_ grpcInit grpcShutdownBlocking . void diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 5bdd245..4a5a8bd 100644 --- a/grpc-haskell.cabal +++ b/grpc-haskell.cabal @@ -1,5 +1,5 @@ name: grpc-haskell -version: 0.1.0 +version: 0.2.0 synopsis: Haskell implementation of gRPC layered on shared C library. homepage: https://github.com/awakenetworks/gRPC-haskell license: Apache-2.0 @@ -31,7 +31,7 @@ library , bytestring ==0.10.* , proto3-suite >=0.4.1 , proto3-wire >=1.2.0 - , grpc-haskell-core + , grpc-haskell-core >=0.2.0 , async >=2.1 && <2.3 , managed >= 1.0.5 @@ -58,7 +58,7 @@ executable hellos-server , bytestring == 0.10.* , containers >=0.5 && <0.7 , grpc-haskell - , grpc-haskell-core + , grpc-haskell-core >=0.2.0 , proto3-suite , proto3-wire , text @@ -78,7 +78,7 @@ executable hellos-client , bytestring == 0.10.* , containers >=0.5 && <0.7 , grpc-haskell - , grpc-haskell-core + , grpc-haskell-core >=0.2.0 , proto3-suite , proto3-wire , text @@ -99,7 +99,7 @@ executable echo-server , containers >=0.5 && <0.7 , deepseq , grpc-haskell - , grpc-haskell-core + , grpc-haskell-core >=0.2.0 , optparse-generic , proto3-suite , proto3-wire @@ -124,7 +124,7 @@ executable arithmetic-server , containers >=0.5 && <0.7 , deepseq , grpc-haskell - , grpc-haskell-core + , grpc-haskell-core >=0.2.0 , optparse-generic , proto3-suite , proto3-wire @@ -148,7 +148,7 @@ executable arithmetic-client , containers >=0.5 && <0.7 , deepseq , grpc-haskell - , grpc-haskell-core + , grpc-haskell-core >=0.2.0 , optparse-generic , proto3-suite , proto3-wire @@ -172,7 +172,7 @@ executable echo-client , containers >=0.5 && <0.7 , deepseq , grpc-haskell - , grpc-haskell-core + , grpc-haskell-core >=0.2.0 , optparse-generic , proto3-suite , proto3-wire diff --git a/release.nix b/release.nix index 4b0ffc0..40df463 100644 --- a/release.nix +++ b/release.nix @@ -184,15 +184,26 @@ let }; usesGRPC = haskellPackage: - # TODO: Try using pkgsNew.fixDarwinDylibNames (see PR#129). + # On Linux, LD_LIBRARY_PATH needs to be set for loading + # grpc-haskell{-,core} code into `ghci` from within `nix-shell` + # environments. + # + # TODO: We might try using pkgsNew.fixDarwinDylibNames (see PR#129) + # instead of setting DYLD_LIBRARY_PATH, but we might still need them + # around for `ghci` as on Linux. + pkgsNew.haskell.lib.overrideCabal haskellPackage (oldAttributes: { preBuild = (oldAttributes.preBuild or "") + pkgsNew.lib.optionalString pkgsNew.stdenv.isDarwin '' export DYLD_LIBRARY_PATH=${pkgsNew.grpc}/lib''${DYLD_LIBRARY_PATH:+:}$DYLD_LIBRARY_PATH ''; + shellHook = (oldAttributes.shellHook or "") + pkgsNew.lib.optionalString pkgsNew.stdenv.isDarwin '' export DYLD_LIBRARY_PATH=${pkgsNew.grpc}/lib''${DYLD_LIBRARY_PATH:+:}$DYLD_LIBRARY_PATH + '' + + pkgsNew.lib.optionalString pkgsNew.stdenv.isLinux '' + export LD_LIBRARY_PATH=${pkgsNew.grpc}/lib''${LD_LIBRARY_PATH:+:}$LD_LIBRARY_PATH ''; } );