From caf1de4baef34061dad6bd2173285e6df45cf0dd Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 12 Aug 2021 02:10:29 +0200
Subject: [PATCH] Add stub generator and tests for Observable
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
src/Quasar/Network/TH.hs | 12 +++++++++---
test/Quasar/NetworkSpec.hs | 40 +++++++++++++++++++++++++++++++++++---
2 files changed, 46 insertions(+), 6 deletions(-)
diff --git a/src/Quasar/Network/TH.hs b/src/Quasar/Network/TH.hs
index ca042a5..42a83d7 100644
--- a/src/Quasar/Network/TH.hs
+++ b/src/Quasar/Network/TH.hs
@@ -363,7 +363,7 @@ data RequestHandlerContext = RequestHandlerContext {
generateObservable :: RpcApi -> RpcObservable -> Q Code
generateObservable api observable = pure Code {
- clientStubDecs = [],
+ clientStubDecs = observableStubDec,
requests = [observeRequest, retrieveRequest],
serverImplFields = [varDefaultBangType serverImplFieldName serverImplFieldSig]
}
@@ -390,14 +390,20 @@ generateObservable api observable = pure Code {
fields = [Field "result" observable.ty]
}
serverImplFieldName :: Name
- serverImplFieldName = mkName observable.name
+ serverImplFieldName = mkName (observable.name <> "Impl")
serverImplFieldSig :: Q Type
serverImplFieldSig = [t|Observable $(observable.ty)|]
observableE :: RequestHandlerContext -> Q Exp
observableE ctx = [|$(varE serverImplFieldName) $(ctx.implRecordE)|]
observableStubDec :: [Q Dec]
observableStubDec = [
- sigD (mkName observable.name) [t|$(clientType api) -> Observable $(observable.ty)|]
+ sigD (mkName observable.name) [t|$(clientType api) -> IO (Observable $(observable.ty))|],
+ do
+ clientName <- newName "client"
+ let clientE = varE clientName
+ funD (mkName observable.name) [
+ clause [varP clientName] (normalB [|newObservableStub ($(clientRequestStubE api retrieveRequest) $clientE) ($(clientRequestStubE api observeRequest) $clientE)|]) []
+ ]
]
observeE :: Q Exp
observeE = clientRequestStubE api observeRequest
diff --git a/test/Quasar/NetworkSpec.hs b/test/Quasar/NetworkSpec.hs
index 3b8c887..4b836c9 100644
--- a/test/Quasar/NetworkSpec.hs
+++ b/test/Quasar/NetworkSpec.hs
@@ -11,19 +11,22 @@
module Quasar.NetworkSpec where
import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Control.Exception (toException)
import Control.Monad.IO.Class (MonadIO, liftIO)
-import Prelude
+import Quasar.Prelude
import Quasar.Awaitable
import Quasar.Core
import Quasar.Network
import Quasar.Network.Runtime (withStandaloneClient)
import Quasar.Network.TH (makeRpc)
+import Quasar.Observable
import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck.Monadic
-shouldReturnAsync :: (HasCallStack, Show a, Eq a) => AsyncIO a -> a -> AsyncIO ()
-action `shouldReturnAsync` expected = action >>= liftIO . (`shouldBe` expected)
+shouldReturnAsync :: (HasCallStack, IsAwaitable r a, Show r, Eq r) => AsyncIO a -> r -> AsyncIO ()
+action `shouldReturnAsync` expected = action >>= await >>= liftIO . (`shouldBe` expected)
$(makeRpc $ rpcApi "Example" $ do
@@ -87,6 +90,7 @@ streamExampleProtocolImpl = StreamExampleProtocolImpl {
streamSetHandler stream1 $ streamSend stream1
streamSetHandler stream2 $ streamSend stream2
+
spec :: Spec
spec = parallel $ do
describe "Example" $ do
@@ -119,3 +123,33 @@ spec = parallel $ do
liftIO $ streamSend stream (x, y)
liftIO $ takeMVar resultMVar `shouldReturn` x * y
+ describe "ObservableExample" $ do
+ it "can retrieve values" $ do
+ var <- newObservableVar 42
+ withStandaloneClient @ObservableExampleProtocol (ObservableExampleProtocolImpl (toObservable var)) $ \client -> do
+ observable <- intObservable client
+ retrieveIO observable `shouldReturn` 42
+ setObservableVar var 13
+ retrieveIO observable `shouldReturn` 13
+
+ it "foobar" $ do
+ var <- newObservableVar 42
+ withStandaloneClient @ObservableExampleProtocol (ObservableExampleProtocolImpl (toObservable var)) $ \client -> do
+ resultVar <- newTVarIO ObservableLoading
+ observable <- intObservable client
+ void $ observe observable $ atomically . writeTVar resultVar
+ let latestShouldBe = \expected -> join $ atomically $ readTVar resultVar >>=
+ \case
+ -- Network might be slow, so this retries until the expected value is received.
+ -- Blocks forever if the wrong or no value is received.
+ ObservableUpdate x -> if (x == expected) then pure (pure ()) else retry
+ ObservableLoading -> retry
+ ObservableNotAvailable ex -> pure $ throwIO ex
+
+ latestShouldBe 42
+ setObservableVar var 13
+ latestShouldBe 13
+ setObservableVar var (-1)
+ latestShouldBe (-1)
+ setObservableVar var 42
+ latestShouldBe 42
--
GitLab