gRPC-haskell/core/tests/UnsafeTests.hs

{-# 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 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"
  [ roundtripSliceUnit "\NULabc\NUL"
  , roundtripSliceUnit largeByteString
  , roundtripByteBufferUnit largeByteString
  , roundtripTimeSpec (TimeSpec 123 123)
  , testMetadata
  , testMetadataOrdering
  , testMetadataOrderingProp
  , testNow
  , testCreateDestroyMetadata
  , testCreateDestroyMetadataKeyVals
  , testCreateDestroyDeadline
  , testCreateDestroyChannelArgs
  , testCreateDestroyClientCreds
  , testCreateDestroyServerCreds
  ]

unsafeProperties :: TestTree
unsafeProperties = testGroup "QuickCheck properties for unsafe C bindings"
  [ roundtripSliceQC
  , roundtripByteBufferQC
  , roundtripMetadataQC
  , metadataIsList
  , roundtripMetadataOrdering
  ]

instance Arbitrary B.ByteString where
  arbitrary = B.pack <$> arbitrary

instance Arbitrary MetadataMap where
  arbitrary = do
    -- 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
  (kvPtr, l) <- createMetadata m
  m' <- getAllMetadata kvPtr l
  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" $
                   \(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]

roundtripSlice :: B.ByteString -> IO B.ByteString
roundtripSlice bs = do
  slice <- byteStringToSlice bs
  unslice <- sliceToByteString slice
  freeSlice slice
  return unslice

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 @?= 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
  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' @?= bs

roundtripTimeSpec :: TimeSpec -> TestTree
roundtripTimeSpec t = testCase "CTimeSpec roundtrip" $ do
  p <- malloc
  let c = CTimeSpec t
  poke p c
  c' <- peek p
  c' @?= c
  free p

testMetadata :: TestTree
testMetadata = testCase "Metadata setter/getter roundtrip" $ do
  m <- metadataAlloc 3
  setMetadataKeyVal "hello" "world" m 0
  setMetadataKeyVal "foo" "bar" m 1
  setMetadataKeyVal "Haskell" "Curry" m 2
  k0 <- getMetadataKey m 0
  v0 <- getMetadataVal m 0
  k1 <- getMetadataKey m 1
  v1 <- getMetadataVal m 1
  k2 <- getMetadataKey m 2
  v2 <- getMetadataVal m 2
  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
  tMillis <- gprTimeToMillis gprT
  timespecDestroy gprT
  return tMillis

testNow :: TestTree
testNow = testCase "Create/destroy various clock types" $ do
  _ <- currTimeMillis GprClockMonotonic
  _ <- currTimeMillis GprClockRealtime
  _ <- currTimeMillis GprClockPrecise
  return ()

testCreateDestroyMetadata :: TestTree
testCreateDestroyMetadata = testCase "Create/destroy metadataArrayPtr" $ do
  grpc $ withMetadataArrayPtr $ const $ return ()

testCreateDestroyMetadataKeyVals :: TestTree
testCreateDestroyMetadataKeyVals = testCase "Create/destroy metadata key/values" $ do
  grpc $ withMetadataKeyValPtr 10 $ const $ return ()

testCreateDestroyDeadline :: TestTree
testCreateDestroyDeadline = testCase "Create/destroy deadline" $ do
  grpc $ withDeadlineSeconds 10 $ const $ return ()

testCreateDestroyChannelArgs :: TestTree
testCreateDestroyChannelArgs = testCase "Create/destroy channel args" $
  grpc $ withChannelArgs [CompressionAlgArg GrpcCompressDeflate] $
  const $ return ()

testCreateDestroyClientCreds :: TestTree
testCreateDestroyClientCreds = testCase "Create/destroy client credentials" $
  grpc $ withChannelCredentials Nothing Nothing Nothing $ const $ return ()

testCreateDestroyServerCreds :: TestTree
testCreateDestroyServerCreds = testCase "Create/destroy server credentials" $
  grpc $ withServerCredentials Nothing
                               "tests/ssl/testServerKey.pem"
                               "tests/ssl/testServerCert.pem"
                               SslDontRequestClientCertificate
                               $ const $ return ()

assertCqEventComplete :: Event -> IO ()
assertCqEventComplete e = do
  eventCompletionType e @?= OpComplete
  eventSuccess e @?= True

grpc :: IO a -> IO ()
grpc = bracket_ grpcInit grpcShutdownBlocking . void

_nowarnUnused :: a
_nowarnUnused = assertCqEventComplete `undefined` threadDelaySecs