Connor/metadata improvements (#52)

* make metadatamap a newtype of multimap

* update tests for new MetadataMap

* remove multimap dependency, reproduce needed functionality instead

* add repeated key to payload test

* bump LTS version for sorted-list, use SortedList for MetadataMap

* remove unneeded conversion

* MetadataMap documentation

* minor fixes

grpc-haskell.cabal

@@ -41,6 +41,7 @@ library
     , tasty-hunit >= 0.9 && <0.10
     , safe ==0.3.*
     , vector
+    , sorted-list >=0.1.6.1 && <=0.3
 
   c-sources:
     cbits/grpc_haskell.c
@@ -176,6 +177,7 @@ test-suite test
     , async
     , tasty >= 0.11 && <0.12
     , tasty-hunit >= 0.9 && <0.10
+    , tasty-quickcheck ==0.8.*
     , containers ==0.5.*
     , managed >= 1.0.0 && < 1.1
     , pipes ==4.1.*

src/Network/GRPC/LowLevel.hs

@@ -22,7 +22,7 @@ GRPC
 , GRPCMethodType(..)
 , RegisteredMethod
 , NormalRequestResult(..)
-, MetadataMap
+, MetadataMap(..)
 , MethodName(..)
 , StatusDetails(..)
 

src/Network/GRPC/LowLevel/GRPC.hs

@@ -2,21 +2,30 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 
-module Network.GRPC.LowLevel.GRPC where
+module Network.GRPC.LowLevel.GRPC(
+GRPC
+, withGRPC
+, GRPCIOError(..)
+, throwIfCallError
+, grpcDebug
+, threadDelaySecs
+, C.MetadataMap(..)
+, StatusDetails(..)
+) where
 
 import           Control.Concurrent     (threadDelay, myThreadId)
 import           Control.Exception
 import           Data.String            (IsString)
+import           Data.ByteString        (ByteString)
 import qualified Data.ByteString        as B
 import qualified Data.Map               as M
 import           Data.Typeable
 import qualified Network.GRPC.Unsafe    as C
 import qualified Network.GRPC.Unsafe.Op as C
+import qualified Network.GRPC.Unsafe.Metadata as C
 import           Proto3.Wire.Decode     (ParseError)
 
-type MetadataMap = M.Map B.ByteString B.ByteString
+newtype StatusDetails = StatusDetails ByteString
-
-newtype StatusDetails = StatusDetails B.ByteString
   deriving (Eq, IsString, Monoid, Show)
 
 -- | Functions as a proof that the gRPC core has been started. The gRPC core
@@ -72,33 +81,3 @@ grpcDebug' str = do
 
 threadDelaySecs :: Int -> IO ()
 threadDelaySecs = threadDelay . (* 10^(6::Int))
-
-{-
--- TODO: remove this once finally decided on whether to use it.
--- | Monad for running gRPC operations.
-newtype GRPCIO a = GRPCIO {unGRPCIO :: ExceptT GRPCIOError IO a}
-  deriving (Functor, Applicative, Monad, MonadIO)
-
-deriving instance MonadError GRPCIOError GRPCIO
-
-runGRPCIO :: GRPCIO a -> IO (Either GRPCIOError a)
-runGRPCIO = runExceptT . unGRPCIO
-
-unrunGRPCIO :: IO (Either GRPCIOError a) -> GRPCIO a
-unrunGRPCIO = GRPCIO . ExceptT
-
-continueFrom :: (a -> GRPCIO b) -> (Either GRPCIOError a) -> GRPCIO b
-continueFrom f (Left x) = throwError x
-continueFrom f (Right x) = f x
-
-wrapGRPC :: Either GRPCIOError a -> GRPCIO a
-wrapGRPC (Left x) = throwError x
-wrapGRPC (Right x) = return x
-
-grpcBracket :: GRPCIO a -> (a -> GRPCIO b) -> (a -> GRPCIO c) -> GRPCIO c
-grpcBracket create destroy f = unrunGRPCIO $ do
-  let createAction = runGRPCIO create
-  let fAction = runGRPCIO . continueFrom f
-  let destroyAction = runGRPCIO . continueFrom destroy
-  bracket createAction destroyAction fAction
--}

src/Network/GRPC/LowLevel/Op.hs

@@ -12,7 +12,6 @@ import           Control.Monad.Trans.Class             (MonadTrans(lift))
 import           Control.Monad.Trans.Except
 import           Data.ByteString                       (ByteString)
 import qualified Data.ByteString                       as B
-import qualified Data.Map.Strict                       as M
 import           Data.Maybe                            (catMaybes)
 import           Foreign.C.String                      (CString)
 import           Foreign.C.Types                       (CInt)
@@ -20,6 +19,7 @@ import           Foreign.Marshal.Alloc                 (free, malloc,
                                                         mallocBytes)
 import           Foreign.Ptr                           (Ptr, nullPtr)
 import           Foreign.Storable                      (peek, poke)
+import           GHC.Exts                              (IsList(..))
 import           Network.GRPC.LowLevel.CompletionQueue
 import           Network.GRPC.LowLevel.GRPC
 import qualified Network.GRPC.Unsafe                   as C (Call)
@@ -41,7 +41,7 @@ data Op = OpSendInitialMetadata MetadataMap
           | OpRecvMessage
           | OpRecvStatusOnClient
           | OpRecvCloseOnServer
-          deriving (Eq, Show)
+          deriving (Show)
 
 -- | Container holding the pointers to the C and gRPC data needed to execute the
 -- corresponding 'Op'. These are obviously unsafe, and should only be used with
@@ -70,14 +70,14 @@ createOpContext :: Op -> IO OpContext
 createOpContext (OpSendInitialMetadata m) =
   OpSendInitialMetadataContext
   <$> C.createMetadata m
-  <*> return (M.size m)
+  <*> return (length $ toList m)
 createOpContext (OpSendMessage bs) =
   fmap OpSendMessageContext (C.createByteBuffer bs)
 createOpContext (OpSendCloseFromClient) = return OpSendCloseFromClientContext
 createOpContext (OpSendStatusFromServer m code (StatusDetails str)) =
   OpSendStatusFromServerContext
   <$> C.createMetadata m
-  <*> return (M.size m)
+  <*> return (length $ toList m)
   <*> return code
   <*> return str
 createOpContext OpRecvInitialMetadata =
@@ -158,7 +158,7 @@ data OpRecvResult =
     -- which case this will be 'Nothing'.
   | OpRecvStatusOnClientResult MetadataMap C.StatusCode B.ByteString
   | OpRecvCloseOnServerResult Bool -- ^ True if call was cancelled.
-  deriving (Eq, Show)
+  deriving (Show)
 
 -- | For the given 'OpContext', if the 'Op' receives data, copies the data out
 -- of the 'OpContext' and into GC-managed Haskell types. After this, it is safe

src/Network/GRPC/Unsafe/Metadata.chs

@@ -1,21 +1,55 @@
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeFamilies               #-}
 
 module Network.GRPC.Unsafe.Metadata where
 
 import Control.Exception
 import Control.Monad
 import Data.ByteString (ByteString, useAsCString, packCString)
-import Data.Map.Strict as M
+import Data.Function (on)
+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
 
 #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 Monoid MetadataMap where
+  mempty = MetadataMap $ M.empty
+  mappend (MetadataMap m1) (MetadataMap m2) =
+    MetadataMap $ M.unionWith mappend m1 m2
+
+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#}
@@ -87,22 +121,22 @@ getMetadataKey m = getMetadataKey' m >=> packCString
 getMetadataVal :: MetadataKeyValPtr -> Int -> IO ByteString
 getMetadataVal m = getMetadataVal' m >=> packCString
 
-createMetadata :: M.Map ByteString ByteString -> IO MetadataKeyValPtr
+createMetadata :: MetadataMap -> IO MetadataKeyValPtr
 createMetadata m = do
-  let l = M.size m
+  let indexedKeyVals = zip [0..] $ toList m
-  let indexedKeyVals = zip [0..] $ M.toList m
+      l = length indexedKeyVals
   metadata <- metadataAlloc l
   forM_ indexedKeyVals $ \(i,(k,v)) -> setMetadataKeyVal k v metadata i
   return metadata
 
-getAllMetadataArray :: MetadataArray -> IO (M.Map ByteString ByteString)
+getAllMetadataArray :: MetadataArray -> IO MetadataMap
 getAllMetadataArray m = do
   kvs <- metadataArrayGetMetadata m
   l <- metadataArrayGetCount m
   getAllMetadata kvs l
 
-getAllMetadata :: MetadataKeyValPtr -> Int -> IO (M.Map ByteString ByteString)
+getAllMetadata :: MetadataKeyValPtr -> Int -> IO MetadataMap
 getAllMetadata m count = do
   let indices = [0..count-1]
-  fmap M.fromList $ forM indices $
+  fmap fromList $ forM indices $
     \i -> liftM2 (,) (getMetadataKey m i) (getMetadataVal m i)

stack.yaml

@@ -2,7 +2,7 @@
 # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
 
 # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
-resolver: lts-5.10
+resolver: lts-6.9
 
 # Local packages, usually specified by relative directory name
 packages:

tests/LowLevelTests.hs

@@ -19,7 +19,9 @@ import           Control.Monad.Managed
 import           Data.ByteString                           (ByteString,
                                                             isPrefixOf,
                                                             isSuffixOf)
-import qualified Data.Map                                  as M
+import qualified Data.Map.Strict                           as M
+import qualified Data.Set                                  as S
+import           GHC.Exts                                  (fromList, toList)
 import           Network.GRPC.LowLevel
 import           Network.GRPC.LowLevel.GRPC (threadDelaySecs)
 import qualified Network.GRPC.LowLevel.Call.Unregistered   as U
@@ -130,7 +132,9 @@ testPayload :: TestTree
 testPayload =
   csTest "registered normal request/response" client server (["/foo"],[],[],[])
   where
-    clientMD = [("foo_key", "foo_val"), ("bar_key", "bar_val")]
+    clientMD = [ ("foo_key", "foo_val")
+               , ("bar_key", "bar_val")
+               , ("bar_key", "bar_repeated_val")]
     client c = do
       rm <- clientRegisterMethodNormal c "/foo"
       clientRequest c rm 10 "Hello!" clientMD >>= do
@@ -452,7 +456,10 @@ testCustomUserAgent =
     server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do
       let rm = head (normalMethods s)
       serverHandleNormalCall s rm mempty $ \c -> do
-        let ua = metadata c M.! "user-agent"
+        ua <- case toList $ (unMap $ metadata c) M.! "user-agent" of
+                []   -> fail "user-agent missing from metadata."
+                [ua] -> return ua
+                _    -> fail "multiple user-agent keys."
         assertBool "User agent prefix is present" $ isPrefixOf "prefix!" ua
         assertBool "User agent suffix is present" $ isSuffixOf "suffix!" ua
         return dummyResp
@@ -510,7 +517,7 @@ testClientServerCompression =
 is :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()
 is act x = act >>= liftIO . (@?= x)
 
-dummyMeta :: M.Map ByteString ByteString
+dummyMeta :: MetadataMap
 dummyMeta = [("foo","bar")]
 
 dummyResp :: (ByteString, MetadataMap, StatusCode, StatusDetails)
@@ -565,10 +572,10 @@ csTest' nm tc ts =
 -- @actual@, or when values differ for matching keys.
 checkMD :: String -> MetadataMap -> MetadataMap -> Assertion
 checkMD desc expected actual =
-  unless (M.null $ expected `diff` actual) $
+    assertEqual desc expected' (actual' `S.intersection` expected')
-    assertEqual desc expected (actual `M.intersection` expected)
   where
-    diff = M.differenceWith $ \a b -> if a == b then Nothing else Just b
+    expected' = fromList . toList $ expected
+    actual' = fromList . toList $ actual
 
 checkReqRslt :: Show a => (b -> Assertion) -> Either a b -> Assertion
 checkReqRslt = either clientFail

tests/Properties.hs

@@ -7,6 +7,7 @@ import           GeneratedTests
 main :: IO ()
 main = defaultMain $ testGroup "GRPC Unit Tests"
   [ unsafeTests
+  , unsafeProperties
   , lowLevelOpTests
   , lowLevelTests
   , generatedTests

tests/UnsafeTests.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
-module UnsafeTests (unsafeTests) where
+module UnsafeTests (unsafeTests, unsafeProperties) where
 
 import           Control.Concurrent                        (threadDelay)
 import           Control.Exception (bracket_)
@@ -8,6 +9,7 @@ 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
@@ -17,6 +19,9 @@ import           Network.GRPC.Unsafe.Time
 import           Network.GRPC.Unsafe.ChannelArgs
 import           System.Clock
 import           Test.Tasty
+import           Test.Tasty.HUnit               as HU (testCase, (@?=),
+                                                       assertBool)
+import           Test.Tasty.QuickCheck          as QC
 import           Test.Tasty.HUnit               as HU (testCase, (@?=))
 
 unsafeTests :: TestTree
@@ -35,6 +40,20 @@ unsafeTests = testGroup "Unit tests for unsafe C bindings"
   , testCreateDestroyChannelArgs
   ]
 
+unsafeProperties :: TestTree
+unsafeProperties = testGroup "QuickCheck properties for unsafe C bindings"
+  [ metadataIsList ]
+
+instance Arbitrary B.ByteString where
+  arbitrary = B.pack <$> arbitrary
+
+instance Arbitrary MetadataMap where
+  arbitrary = fromList <$> arbitrary
+
+metadataIsList :: TestTree
+metadataIsList = QC.testProperty "Metadata IsList instance" $
+                   \(md :: MetadataMap) -> md == (fromList $ toList md)
+
 largeByteString :: B.ByteString
 largeByteString = B.pack $ take (32*1024*1024) $ cycle [97..99]