From 4d187d58eea91cc9bd4c00364264ab46dccf9169 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sat, 23 Apr 2022 22:14:26 +0200
Subject: [PATCH] Change NetworkObject and NetworkReference types
Splits value- and reference type behavior; reference types can now be
initialized without sending data.
---
src/Quasar/Network/Runtime.hs | 33 +++++-----
src/Quasar/Network/Runtime/Observable.hs | 81 ++++++++++++++++++------
2 files changed, 77 insertions(+), 37 deletions(-)
diff --git a/src/Quasar/Network/Runtime.hs b/src/Quasar/Network/Runtime.hs
index 887c15d..9c4f91e 100644
--- a/src/Quasar/Network/Runtime.hs
+++ b/src/Quasar/Network/Runtime.hs
@@ -80,41 +80,36 @@ instance IsChannel (Stream up down) where
-- | Describes how a typeclass is used to send- and receive `NetworkObject`s.
-class IsNetworkStrategy (s :: (Type -> Constraint)) where
+type IsNetworkStrategy :: (Type -> Constraint) -> Constraint
+class IsNetworkStrategy s where
type ChannelIsRequired s :: Bool
- sendObject :: forall a. (NetworkObject a, NetworkStrategy a ~ s) => a -> (Put, Maybe (Channel -> QuasarIO ()))
- receiveObject :: forall a. (NetworkObject a, NetworkStrategy a ~ s) => Get (Either a (Channel -> QuasarIO a))
+ sendObject :: forall a. (NetworkObject a, NetworkStrategy a ~ s) => a -> Either Put (Channel -> QuasarIO ())
+ receiveObject :: forall a. (NetworkObject a, NetworkStrategy a ~ s) => Either (Get a) (Future Channel -> QuasarIO a)
instance IsNetworkStrategy Binary where
-- Copy by value by using `Binary`
type ChannelIsRequired Binary = 'False
- sendObject x = (put x, Nothing)
- receiveObject = Left <$> get
+ sendObject x = Left (put x)
+ receiveObject = Left get
instance IsNetworkStrategy NetworkReference where
-- Send an object by reference with the `NetworkReference` class
type ChannelIsRequired NetworkReference = 'True
- sendObject :: forall a. (NetworkObject a, NetworkStrategy a ~ NetworkReference) => a -> (Put, Maybe (Channel -> QuasarIO ()))
- sendObject x = (put cdata, Just (\channel -> fn (castChannel channel)))
- where
- (cdata, fn) = sendReference x
+ sendObject :: forall a. (NetworkObject a, NetworkStrategy a ~ NetworkReference) => a -> Either Put (Channel -> QuasarIO ())
+ sendObject x = Right (\channel -> sendReference x (castChannel channel))
- receiveObject :: forall a. (NetworkObject a, NetworkStrategy a ~ NetworkReference) => Get (Either a (Channel -> QuasarIO a))
- receiveObject = Right . fn <$> get
- where
- fn :: ConstructorData a -> Channel -> QuasarIO a
- fn cdata channel = receiveReference cdata (castChannel channel)
+ receiveObject :: forall a. (NetworkObject a, NetworkStrategy a ~ NetworkReference) => Either (Get a) (Future Channel -> QuasarIO a)
+ receiveObject = Right (\channel -> receiveReference (castChannel <$> channel))
class (IsNetworkStrategy (NetworkStrategy a), (NetworkStrategy a) a) => NetworkObject a where
type NetworkStrategy a :: (Type -> Constraint)
-class (Binary (ConstructorData a), IsChannel (NetworkReferenceChannel a)) => NetworkReference a where
- type ConstructorData a
+class IsChannel (NetworkReferenceChannel a) => NetworkReference a where
type NetworkReferenceChannel a
- sendReference :: a -> (ConstructorData a, NetworkReferenceChannel a -> QuasarIO ())
- receiveReference :: (ConstructorData a -> ReverseChannelType (NetworkReferenceChannel a) -> QuasarIO a)
+ sendReference :: a -> (NetworkReferenceChannel a -> QuasarIO ())
+ receiveReference :: (Future (ReverseChannelType (NetworkReferenceChannel a)) -> QuasarIO a)
instance NetworkObject Bool where
@@ -132,6 +127,8 @@ instance NetworkObject Double where
instance NetworkObject String where
type NetworkStrategy String = Binary
+
+
-- * Old internal RPC types
class (Binary (ProtocolRequest p), Binary (ProtocolResponse p)) => RpcProtocol p where
diff --git a/src/Quasar/Network/Runtime/Observable.hs b/src/Quasar/Network/Runtime/Observable.hs
index 46217e4..805fe9c 100644
--- a/src/Quasar/Network/Runtime/Observable.hs
+++ b/src/Quasar/Network/Runtime/Observable.hs
@@ -1,3 +1,4 @@
+-- Contains the network instances for `Observable` (from the same family of libraries)
{-# OPTIONS_GHC -Wno-orphans #-}
module Quasar.Network.Runtime.Observable (
@@ -12,43 +13,85 @@ import Quasar.Network.Runtime
import Quasar.Prelude
-instance NetworkObject a => NetworkReference (Observable a) where
- type ConstructorData (Observable a) = ()
- type NetworkReferenceChannel (Observable a) = Stream a Bool
- sendReference :: Observable a -> ((), Stream a Bool -> QuasarIO ())
- sendReference observable = ((), undefined)
- receiveReference :: ConstructorData (Observable a) -> Stream Bool a -> QuasarIO (Observable a)
- receiveReference () channel = undefined
-
-instance NetworkObject a => NetworkObject (Observable a) where
- type NetworkStrategy (Observable a) = NetworkReference
+data ObservableRequest
+ = Start
+ | Stop
-
-data PackedObservableState a
+data ObservableResponse a
= PackedObservableValue a
| PackedObservableLoading
| PackedObservableNotAvailable PackedException
deriving stock (Eq, Show, Generic)
deriving anyclass (Binary)
-packObservableState :: ObservableState r -> PackedObservableState r
+packObservableState :: ObservableState r -> ObservableResponse r
packObservableState (ObservableValue x) = PackedObservableValue x
packObservableState ObservableLoading = PackedObservableLoading
packObservableState (ObservableNotAvailable ex) = PackedObservableNotAvailable (packException ex)
-unpackObservableState :: PackedObservableState r -> ObservableState r
+unpackObservableState :: ObservableResponse r -> ObservableState r
unpackObservableState (PackedObservableValue x) = ObservableValue x
unpackObservableState PackedObservableLoading = ObservableLoading
unpackObservableState (PackedObservableNotAvailable ex) = ObservableNotAvailable (unpackException ex)
+instance NetworkObject a => NetworkReference (Observable a) where
+ type NetworkReferenceChannel (Observable a) = Stream (ObservableResponse a) ObservableRequest
+ sendReference = sendObservableReference
+ receiveReference = receiveObservableReference
+
+instance NetworkObject a => NetworkObject (Observable a) where
+ type NetworkStrategy (Observable a) = NetworkReference
+
+
+data ProxyState
+ = Stopped
+ | Started
+ | StartRequestedWaitingForChannel
+
+data ObservableProxy a =
+ ObservableProxy {
+ channelFuture :: Future (Stream ObservableRequest (ObservableResponse a)),
+ proxyState :: TVar ProxyState,
+ prim :: ObservablePrim a
+ }
+
+sendObservableReference :: NetworkObject a => Observable a -> Stream (ObservableResponse a) ObservableRequest -> QuasarIO ()
+sendObservableReference observable = undefined
+
+receiveObservableReference :: NetworkObject a => Future (Stream ObservableRequest (ObservableResponse a)) -> QuasarIO (Observable a)
+receiveObservableReference channelFuture = liftIO do
+ proxyState <- newTVarIO Stopped
+ prim <- newObservablePrimIO ObservableLoading
+ pure $ toObservable $
+ ObservableProxy {
+ channelFuture,
+ proxyState,
+ prim
+ }
+
+instance NetworkObject a => IsRetrievable a (ObservableProxy a) where
+ retrieve proxy = undefined
+
+
+instance NetworkObject a => IsObservable a (ObservableProxy a) where
+ observe proxy = undefined
+ pingObservable proxy = undefined
+
+
+
+
+
+
+-- * Old code
+
data ObservableClient a =
ObservableClient {
quasar :: Quasar,
beginRetrieve :: IO (Future a),
- createObservableStream :: IO (Stream Void (PackedObservableState a)),
+ createObservableStream :: IO (Stream Void (ObservableResponse a)),
observablePrim :: ObservablePrim a,
- activeStreamVar :: TVar (Maybe (Stream Void (PackedObservableState a)))
+ activeStreamVar :: TVar (Maybe (Stream Void (ObservableResponse a)))
}
instance IsRetrievable a (ObservableClient a) where
@@ -68,7 +111,7 @@ instance IsObservable a (ObservableClient a) where
newObservableClient
:: forall a. Binary a
=> IO (Future a)
- -> IO (Stream Void (PackedObservableState a))
+ -> IO (Stream Void (ObservableResponse a))
-> QuasarIO (Observable a)
newObservableClient beginRetrieve createObservableStream = do
quasar <- askQuasar
@@ -104,7 +147,7 @@ callRetrieve :: Observable a -> QuasarIO (Future a)
callRetrieve x = toFuture <$> async (retrieve x)
-- | Used in generated code to call `observe`.
-observeToStream :: forall a. Binary a => Observable a -> Stream (PackedObservableState a) Void -> QuasarIO ()
+observeToStream :: forall a. Binary a => Observable a -> Stream (ObservableResponse a) Void -> QuasarIO ()
observeToStream observable stream = do
runQuasarIO (streamQuasar stream) do
-- Initial state is defined as loading, no extra message has to be sent
@@ -128,7 +171,7 @@ observeToStream observable stream = do
(streamSendDeferred stream payloadHook)
\ChannelNotConnected -> pure ()
where
- payloadHook :: STM (PackedObservableState a)
+ payloadHook :: STM (ObservableResponse a)
payloadHook = do
writeTVar isLoading False
swapTVar outbox Nothing >>= \case
--
GitLab