grpc-haskell{-core} -> 0.2.0: Fix MetadataMap duplicate-key ordering (#132)

* Put LD_LIBRARY_PATH set back into Linux `nix-shell`

...as we need it for `ghci` workflows inside the shell(s).

* Add (failing) test case to check MetadataMap ordering

* Remove SortedList value-component from MetadataMap

...which fixes the failing test case introduced by `85a2d13`.

This is a potentially breaking change that warrants a library rev bump.

I'm not sure what the original reason was for the sorted list component of
`MetadataMap` (i.e., header values), but that implementation choice makes it so
that determining the "last provided" header value associated with a duplicate
key cannot be recovered. That is, it is in violation of this requirement from
the [spec](https://github.com/grpc/grpc/blob/master/doc/PROTOCOL-HTTP2.md):

```
Custom-Metadata header order is not guaranteed to be preserved except for values
with duplicate header names.
```

I'm guessing that the original motivation might have been to ensure that the Eq
instance was not sensitive to ordering of values for duplicate keys.

I think we can drop the existing `Eq` assumption about order-insensitive values
for duplicate keys (there is order sensitivity after all), and if we end up
discovering a common use case for an order-insensitive equality on values, we
should address that via a utility function (instead via the type's `Eq`
instance).

So, this commit changes the value component of the `MetadataMap` type to be a
list of `ByteString` values instead of `SortedList ByteString`, and removes the
`sorted-list` package as a dependency, as it has no other uses in the library.

Note that this commit is not claiming we are now spec-compliant w.r.t. header
treatment after this change. In particular (and at least),

1. We do not yet support base64-encoded binary data via the special `-bin` key
suffix.

2. As far as I am aware, we do not (yet) interpret comma-separated header values
the same as duplicate header keys for each of those values.

3. As far as I am aware, we do not (yet) do any validation of header names nor
whitespace handling as per the request grammar from the spec.

* Extend Arbitrary MetadataMap to explicitly encode key duplication

Duplicate keys were allowed by the previous implementation, but this commit
makes key duplication more explicit and more frequent.

* Add metadata map ordering QC prop

* Drop qualified use of @?= since it's so common in this module

* Extend checkMetadataOrdering to check instance Eq MetadataMap

...and use the appropriate bracketing wrapper.

* Relocate MetadataMap type to its own module

* Add some helper functions for MetadataMap lookup; documentation

* Extend testMetadataOrdering w/ use of lookup{All,Last}

* Bump grpc-haskell{,-core} -> 0.2.0

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

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

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

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.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 Foreign.C.String
 import Foreign.Ptr
 import Foreign.Storable
 import GHC.Exts
+import Network.GRPC.LowLevel.GRPC.MetadataMap (MetadataMap)
 
 #include <grpc/grpc.h>
 #include <grpc/status.h>
 #include <grpc/impl/codegen/grpc_types.h>
 #include <grpc_haskell.h>
 
--- | 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#}

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 <grpc/grpc.h>
 #include <grpc/grpc_security.h>

core/tests/UnsafeTests.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -7,10 +8,13 @@ module UnsafeTests (unsafeTests, unsafeProperties) where
 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      (threadDelaySecs)
+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
@@ -21,7 +25,7 @@ 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.HUnit as HU (Assertion, testCase, (@?=))
 import Test.Tasty.QuickCheck as QC
 
 unsafeTests :: TestTree
@@ -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
@@ -54,10 +61,13 @@ 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 key = arbitrary `suchThat` B.notElem 0
-    let l = length ks
+    ks0 <- listOf key
-    vs <- vector l
+    duplicateKeys <- arbitrary
-    return $ fromList (zip ks vs)
+    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"
+  k0 @?= "hello"
-  v0 HU.@?= "world"
+  v0 @?= "world"
-  k1 HU.@?= "foo"
+  k1 @?= "foo"
-  v1 HU.@?= "bar"
+  v1 @?= "bar"
-  k2 HU.@?= "Haskell"
+  k2 @?= "Haskell"
-  v2 HU.@?= "Curry"
+  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
+  eventCompletionType e @?= OpComplete
-  eventSuccess e HU.@?= True
+  eventSuccess e @?= True
 
 grpc :: IO a -> IO ()
 grpc = bracket_ grpcInit grpcShutdownBlocking . void

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

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
             '';
         }
       );