diff --git a/definitions/package.yaml b/definitions/package.yaml index bebd528553..17be97b54a 100644 --- a/definitions/package.yaml +++ b/definitions/package.yaml @@ -11,6 +11,8 @@ extra-source-files: - readme.md ghc-options: + # - -fplugin=Polysemy.Plugin + - -O2 - -Wall - -Wcompat - -Werror=incomplete-patterns @@ -23,6 +25,8 @@ dependencies: - aeson - base >= 4.7 && < 5 - freer-indexed + - polysemy + # - polysemy-plugin - lens - mtl - singletons diff --git a/definitions/src/Simplex/Messaging/Broker.hs b/definitions/src/Simplex/Messaging/Broker.hs index eacc340ed6..f1091c5154 100644 --- a/definitions/src/Simplex/Messaging/Broker.hs +++ b/definitions/src/Simplex/Messaging/Broker.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module Simplex.Messaging.Broker where import Control.Monad.Trans.Except +import Polysemy.Internal import Simplex.Messaging.Protocol instance Monad m => PartyProtocol m Broker where @@ -31,3 +34,20 @@ instance Monad m => PartyProtocol m Broker where ExceptT String m (Connection Broker s') action (PushConfirm _ _) = actionStub action (PushMsg _ _) = actionStub + +type SimplexBroker = SimplexParty Broker + +api' :: + Member SimplexBroker r => + Command from '(Broker, s, s') a -> + Connection Broker s -> + Sem r (Either String (a, Connection Broker s')) +api' cmd conn = send $ Api cmd conn + +action' :: + Member SimplexBroker r => + Command '(Broker, s, s') to a -> + Connection Broker s -> + Either String a -> + Sem r (Either String (Connection Broker s')) +action' cmd conn res = send $ Action cmd conn res diff --git a/definitions/src/Simplex/Messaging/Client.hs b/definitions/src/Simplex/Messaging/Client.hs index 4364cb82f2..8a6537191f 100644 --- a/definitions/src/Simplex/Messaging/Client.hs +++ b/definitions/src/Simplex/Messaging/Client.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module Simplex.Messaging.Client where import Control.Monad.Trans.Except +import Polysemy.Internal import Simplex.Messaging.Protocol instance Monad m => PartyProtocol m Recipient where @@ -45,3 +48,37 @@ instance Monad m => PartyProtocol m Sender where ExceptT String m (Connection Sender s') action (ConfirmConn _ _) = actionStub action (SendMsg _ _) = actionStub + +type SimplexRecipient = SimplexParty Recipient + +type SimplexSender = SimplexParty Sender + +rApi :: + Member SimplexRecipient r => + Command from '(Recipient, s, s') a -> + Connection Recipient s -> + Sem r (Either String (a, Connection Recipient s')) +rApi cmd conn = send $ Api cmd conn + +rAction :: + Member SimplexRecipient r => + Command '(Recipient, s, s') to a -> + Connection Recipient s -> + Either String a -> + Sem r (Either String (Connection Recipient s')) +rAction cmd conn res = send $ Action cmd conn res + +sApi :: + Member SimplexSender r => + Command from '(Sender, s, s') a -> + Connection Sender s -> + Sem r (Either String (a, Connection Sender s')) +sApi cmd conn = send $ Api cmd conn + +sAction :: + Member SimplexSender r => + Command '(Sender, s, s') to a -> + Connection Sender s -> + Either String a -> + Sem r (Either String (Connection Sender s')) +sAction cmd conn res = send $ Action cmd conn res diff --git a/definitions/src/Simplex/Messaging/Protocol.hs b/definitions/src/Simplex/Messaging/Protocol.hs index a6a25c8a1b..c08189b23c 100644 --- a/definitions/src/Simplex/Messaging/Protocol.hs +++ b/definitions/src/Simplex/Messaging/Protocol.hs @@ -129,6 +129,17 @@ apiStub _ = throwE "api not implemented" actionStub :: Monad m => Connection p s -> ExceptT String m a -> ExceptT String m (Connection p s') actionStub _ _ = throwE "action not implemented" +data SimplexParty (p :: Party) m a where + Api :: + Command from '(p, s, s') x -> + Connection p s -> + SimplexParty p m (Either String (x, Connection p s')) + Action :: + Command '(p, s, s') to x -> + Connection p s -> + Either String x -> + SimplexParty p m (Either String (Connection p s')) + type ProtocolState = (ConnState, ConnState, ConnState) type family HasProtoSt (s :: ProtocolState) :: Constraint where