diff --git a/grpc-haskell.cabal b/grpc-haskell.cabal index 30a4cf7..3f1470f 100644 --- a/grpc-haskell.cabal +++ b/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.* diff --git a/src/Network/GRPC/LowLevel.hs b/src/Network/GRPC/LowLevel.hs index d8b88fb..0b6c1fc 100644 --- a/src/Network/GRPC/LowLevel.hs +++ b/src/Network/GRPC/LowLevel.hs @@ -22,7 +22,7 @@ GRPC , GRPCMethodType(..) , RegisteredMethod , NormalRequestResult(..) -, MetadataMap +, MetadataMap(..) , MethodName(..) , StatusDetails(..) diff --git a/src/Network/GRPC/LowLevel/GRPC.hs b/src/Network/GRPC/LowLevel/GRPC.hs index c15dbfe..24457b6 100644 --- a/src/Network/GRPC/LowLevel/GRPC.hs +++ b/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 B.ByteString +newtype StatusDetails = StatusDetails 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 --} diff --git a/src/Network/GRPC/LowLevel/Op.hs b/src/Network/GRPC/LowLevel/Op.hs index 9afd1fc..9711c59 100644 --- a/src/Network/GRPC/LowLevel/Op.hs +++ b/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 diff --git a/src/Network/GRPC/Unsafe/Metadata.chs b/src/Network/GRPC/Unsafe/Metadata.chs index 42a7edd..40bc7ad 100644 --- a/src/Network/GRPC/Unsafe/Metadata.chs +++ b/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 #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 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..] $ M.toList m + let indexedKeyVals = zip [0..] $ 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) diff --git a/stack.yaml b/stack.yaml index 0e56867..f2e1440 100644 --- a/stack.yaml +++ b/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: diff --git a/tests/LowLevelTests.hs b/tests/LowLevelTests.hs index 44f50ac..a419238 100644 --- a/tests/LowLevelTests.hs +++ b/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 `M.intersection` expected) + assertEqual desc expected' (actual' `S.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 diff --git a/tests/Properties.hs b/tests/Properties.hs index 1e8a977..ce84244 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -7,6 +7,7 @@ import GeneratedTests main :: IO () main = defaultMain $ testGroup "GRPC Unit Tests" [ unsafeTests + , unsafeProperties , lowLevelOpTests , lowLevelTests , generatedTests diff --git a/tests/UnsafeTests.hs b/tests/UnsafeTests.hs index b051ca4..a693528 100644 --- a/tests/UnsafeTests.hs +++ b/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]