Control.Protocol (#35)

* polysemy effects

* exctract Protocol abstraction

* refactor: use Control.Protocol

* better type errors

definitions/src/Simplex/Messaging/Broker.hs

@@ -1,19 +1,23 @@
 {-# 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 Control.Protocol (PartyCmd (..))
+import Polysemy.Internal
 import Simplex.Messaging.Protocol
 
 instance Monad m => PartyProtocol m Broker where
   api ::
-    Command from '(Broker, s, s') a ->
+    SimplexCommand from (Cmd Broker s s') a ->
     Connection Broker s ->
     ExceptT String m (a, Connection Broker s')
   api (CreateConn _) = apiStub
@@ -25,9 +29,26 @@ instance Monad m => PartyProtocol m Broker where
   api (DeleteMsg _ _) = apiStub
 
   action ::
-    Command '(Broker, s, s') to a ->
+    SimplexCommand (Cmd Broker s s') to a ->
     Connection Broker s ->
     ExceptT String m a ->
     ExceptT String m (Connection Broker s')
   action (PushConfirm _ _) = actionStub
   action (PushMsg _ _) = actionStub
+
+type SimplexBroker = SimplexParty Broker
+
+api' ::
+  Member SimplexBroker r =>
+  SimplexCommand from (Cmd 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 =>
+  SimplexCommand (Cmd 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

definitions/src/Simplex/Messaging/Client.hs

@@ -1,26 +1,30 @@
 {-# 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 Control.Protocol (PartyCmd (..))
+import Polysemy.Internal
 import Simplex.Messaging.Protocol
 
 instance Monad m => PartyProtocol m Recipient where
   api ::
-    Command from '(Recipient, s, s') a ->
+    SimplexCommand from (Cmd Recipient s s') a ->
     Connection Recipient s ->
     ExceptT String m (a, Connection Recipient s')
   api (PushConfirm _ _) = apiStub
   api (PushMsg _ _) = apiStub
 
   action ::
-    Command '(Recipient, s, s') to a ->
+    SimplexCommand (Cmd Recipient s s') to a ->
     Connection Recipient s ->
     ExceptT String m a ->
     ExceptT String m (Connection Recipient s')
@@ -33,15 +37,49 @@ instance Monad m => PartyProtocol m Recipient where
 
 instance Monad m => PartyProtocol m Sender where
   api ::
-    Command from '(Sender, s, s') a ->
+    SimplexCommand from (Cmd Sender s s') a ->
     Connection Sender s ->
     ExceptT String m (a, Connection Sender s')
   api (SendInvite _) = apiStub
 
   action ::
-    Command '(Sender, s, s') to a ->
+    SimplexCommand (Cmd Sender s s') to a ->
     Connection Sender s ->
     ExceptT String m a ->
     ExceptT String m (Connection Sender s')
   action (ConfirmConn _ _) = actionStub
   action (SendMsg _ _) = actionStub
+
+type SimplexRecipient = SimplexParty Recipient
+
+type SimplexSender = SimplexParty Sender
+
+rApi ::
+  Member SimplexRecipient r =>
+  SimplexCommand from (Cmd 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 =>
+  SimplexCommand (Cmd 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 =>
+  SimplexCommand from (Cmd 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 =>
+  SimplexCommand (Cmd 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

definitions/src/Simplex/Messaging/Core.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
+module Simplex.Messaging.Core where
+
+import Data.Kind
+import Data.Singletons.TH
+
+$( singletons
+     [d|
+       data Party = Recipient | Broker | Sender
+         deriving (Show, Eq)
+
+       data ConnState
+         = None -- (all) not available or removed from the broker
+         | New -- (recipient, broker) connection created (or received from sender)
+         | Pending -- (recipient, sender) sent to sender out-of-band
+         | Confirmed -- (recipient) confirmed by sender with the broker
+         | Secured -- (all) secured with the broker
+         | Disabled -- (broker, recipient) disabled with the broker by recipient
+         deriving (Show, Eq)
+       |]
+ )
+
+type family HasState (p :: Party) (s :: ConnState) :: Constraint where
+  HasState Recipient _ = ()
+  HasState Broker None = ()
+  HasState Broker New = ()
+  HasState Broker Secured = ()
+  HasState Broker Disabled = ()
+  HasState Sender None = ()
+  HasState Sender New = ()
+  HasState Sender Confirmed = ()
+  HasState Sender Secured = ()
+
+type family Enabled (rs :: ConnState) (bs :: ConnState) :: Constraint where
+  Enabled New New = ()
+  Enabled Pending New = ()
+  Enabled Confirmed New = ()
+  Enabled Secured Secured = ()

definitions/src/Simplex/Messaging/PrintScenario.hs

@@ -1,17 +1,20 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
 module Simplex.Messaging.PrintScenario where
 
 import Control.Monad.Writer
+import Control.Protocol
 import Control.XFreer
 import Data.Singletons
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Types
 
-printScenario :: Protocol s s' a -> IO ()
+printScenario :: SimplexProtocol s s' a -> IO ()
 printScenario scn = ps 1 "" $ execWriter $ logScenario scn
   where
     ps :: Int -> String -> [(String, String)] -> IO ()
@@ -24,17 +27,17 @@ printScenario scn = ps 1 "" $ execWriter $ logScenario scn
         prt i' s = putStrLn s >> ps i' p' ls
         l' = "   - " <> l
 
-logScenario :: Protocol s s' a -> Writer [(String, String)] a
+logScenario :: SimplexProtocol s s' a -> Writer [(String, String)] a
 logScenario (Pure x) = return x
 logScenario (Bind p f) = logProtocol p >>= \x -> logScenario (f x)
 
-logProtocol :: ProtocolCmd s s' a -> Writer [(String, String)] a
-logProtocol (Start s) = tell [("", s)]
+logProtocol :: ProtocolCmd SimplexCommand '[Recipient, Broker, Sender] s s' a -> Writer [(String, String)] a
+logProtocol (Comment s) = tell [("", s)]
 logProtocol (ProtocolCmd from to cmd) = do
   tell [(party from, commandStr cmd <> " " <> party to)]
   mockCommand cmd
 
-commandStr :: Command from to a -> String
+commandStr :: SimplexCommand from to a -> String
 commandStr (CreateConn _) = "creates connection in"
 commandStr (Subscribe cid) = "subscribes to connection " <> show cid <> " in"
 commandStr (Unsubscribe cid) = "unsubscribes from connection " <> show cid <> " in"
@@ -46,7 +49,7 @@ commandStr (SendMsg cid _) = "sends message to connection " <> show cid <> " in"
 commandStr (PushMsg cid _) = "pushes message from connection " <> show cid <> " to"
 commandStr (DeleteMsg cid _) = "deletes message from connection " <> show cid <> " in"
 
-mockCommand :: Monad m => Command from to a -> m a
+mockCommand :: Monad m => SimplexCommand from to a -> m a
 mockCommand (CreateConn _) =
   return
     CreateConnResponse

definitions/src/Simplex/Messaging/Protocol.hs

@@ -1,108 +1,70 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE EmptyCase #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE NoStarIsType #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 
-module Simplex.Messaging.Protocol where
+module Simplex.Messaging.Protocol
+  ( module Simplex.Messaging.Core,
+    module Simplex.Messaging.Protocol,
+  )
+where
 
 import Control.Monad.Trans.Except
-import Control.XFreer
+import Control.Protocol
 import Data.Kind
-import Data.Singletons
-import Data.Singletons.TH
 import Data.Type.Bool (type (||))
+import Data.Type.Equality (type (==))
+import Simplex.Messaging.Core
 import Simplex.Messaging.Types
 
-$( singletons
-     [d|
-       data Party = Recipient | Broker | Sender
-         deriving (Show, Eq)
+type SimplexProtocol = Protocol SimplexCommand '[Recipient, Broker, Sender]
 
-       data ConnState
-         = None -- (all) not available or removed from the broker
-         | New -- (recipient, broker) connection created (or received from sender)
-         | Pending -- (recipient, sender) sent to sender out-of-band
-         | Confirmed -- (recipient) confirmed by sender with the broker
-         | Secured -- (all) secured with the broker
-         | Disabled -- (broker, recipient) disabled with the broker by recipient
-         deriving (Show, Eq)
-       |]
- )
-
-type family HasState (p :: Party) (s :: ConnState) :: Constraint where
-  HasState Recipient _ = ()
-  HasState Broker None = ()
-  HasState Broker New = ()
-  HasState Broker Secured = ()
-  HasState Broker Disabled = ()
-  HasState Sender None = ()
-  HasState Sender New = ()
-  HasState Sender Confirmed = ()
-  HasState Sender Secured = ()
-
-type family Enabled (rs :: ConnState) (bs :: ConnState) :: Constraint where
-  Enabled New New = ()
-  Enabled Pending New = ()
-  Enabled Confirmed New = ()
-  Enabled Secured Secured = ()
-
-type PartyCmd = (Party, ConnState, ConnState)
-
-data Command (from :: PartyCmd) (to :: PartyCmd) (a :: Type) :: Type where
+data SimplexCommand :: Command Party where
   CreateConn ::
     PublicKey ->
-    Command '(Recipient, None, New) '(Broker, None, New) CreateConnResponse
+    SimplexCommand (Cmd Recipient None New) (Cmd Broker None New) CreateConnResponse
   Subscribe ::
     Enabled rs bs =>
     ConnId ->
-    Command '(Recipient, rs, rs) '(Broker, bs, bs) ()
+    SimplexCommand (Cmd Recipient rs rs) (Cmd Broker bs bs) ()
   Unsubscribe ::
     Enabled rs bs =>
     ConnId ->
-    Command '(Recipient, rs, rs) '(Broker, bs, bs) ()
+    SimplexCommand (Cmd Recipient rs rs) (Cmd Broker bs bs) ()
   SendInvite ::
     Invitation ->
-    Command '(Recipient, New, Pending) '(Sender, None, New) ()
+    SimplexCommand (Cmd Recipient New Pending) (Cmd Sender None New) ()
   ConfirmConn ::
     SenderConnId ->
     Encrypted ->
-    Command '(Sender, New, Confirmed) '(Broker, New, New) ()
+    SimplexCommand (Cmd Sender New Confirmed) (Cmd Broker New New) ()
   PushConfirm ::
     ConnId ->
     Message ->
-    Command '(Broker, New, New) '(Recipient, Pending, Confirmed) ()
+    SimplexCommand (Cmd Broker New New) (Cmd Recipient Pending Confirmed) ()
   SecureConn ::
     ConnId ->
     PublicKey ->
-    Command '(Recipient, Confirmed, Secured) '(Broker, New, Secured) ()
+    SimplexCommand (Cmd Recipient Confirmed Secured) (Cmd Broker New Secured) ()
   SendMsg ::
     (ss == Confirmed || ss == Secured) ~ True =>
     SenderConnId ->
     Encrypted ->
-    Command '(Sender, ss, Secured) '(Broker, Secured, Secured) ()
+    SimplexCommand (Cmd Sender ss Secured) (Cmd Broker Secured Secured) ()
   PushMsg ::
     ConnId ->
     Message ->
-    Command '(Broker, Secured, Secured) '(Recipient, Secured, Secured) ()
+    SimplexCommand (Cmd Broker Secured Secured) (Cmd Recipient Secured Secured) ()
   DeleteMsg ::
     ConnId ->
     MessageId ->
-    Command '(Recipient, Secured, Secured) '(Broker, Secured, Secured) ()
+    SimplexCommand (Cmd Recipient Secured Secured) (Cmd Broker Secured Secured) ()
 
 -- connection type stub for all participants, TODO move from idris
 data
@@ -114,11 +76,11 @@ data
 
 class Monad m => PartyProtocol m (p :: Party) where
   api ::
-    Command from '(p, s, s') a ->
+    SimplexCommand from (Cmd p s s') a ->
     Connection p s ->
     ExceptT String m (a, Connection p s')
   action ::
-    Command '(p, s, s') to a ->
+    SimplexCommand (Cmd p s s') to a ->
     Connection p s ->
     ExceptT String m a ->
     ExceptT String m (Connection p s')
@@ -129,52 +91,13 @@ 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"
 
-type ProtocolState = (ConnState, ConnState, ConnState)
-
-type family HasProtoSt (s :: ProtocolState) :: Constraint where
-  HasProtoSt '(rs, bs, ss) =
-    ( HasState Recipient rs,
-      HasState Broker bs,
-      HasState Sender ss
-    )
-
-type family ConnSt (p :: Party) (s :: ProtocolState) :: ConnState where
-  ConnSt Recipient '(rs, _, _) = rs
-  ConnSt Broker '(_, bs, _) = bs
-  ConnSt Sender '(_, _, ss) = ss
-
-type family ProtoSt (s :: ProtocolState) from fs' to ts' :: ProtocolState where
-  ProtoSt s from fs' to ts' =
-    '( PartySt Recipient s from fs' to ts',
-       PartySt Broker s from fs' to ts',
-       PartySt Sender s from fs' to ts'
-     )
-
-type family PartySt (p :: Party) (s :: ProtocolState) from fs' to ts' :: ConnState where
-  PartySt from _ from fs' _ _ = fs'
-  PartySt to _ _ _ to ts' = ts'
-  PartySt p s _ _ _ _ = ConnSt p s
-
-data ProtocolCmd (s :: ProtocolState) (s' :: ProtocolState) (a :: Type) :: Type where
-  Start :: String -> ProtocolCmd s s ()
-  ProtocolCmd ::
-    (HasProtoSt s, HasState from fs', HasState to ts') =>
-    Sing from ->
-    Sing to ->
-    Command '(from, ConnSt from s, fs') '(to, ConnSt to s, ts') a ->
-    ProtocolCmd s (ProtoSt s from fs' to ts') a
-
-type Protocol = XFree ProtocolCmd
-
-infix 6 ->:
-
-(->:) ::
-  (HasProtoSt s, HasState from fs', HasState to ts') =>
-  Sing from ->
-  Sing to ->
-  Command '(from, ConnSt from s, fs') '(to, ConnSt to s, ts') a ->
-  Protocol s (ProtoSt s from fs' to ts') a
-(->:) f t c = xfree $ ProtocolCmd f t c
-
-start :: String -> Protocol s s ()
-start = xfree . Start
+data SimplexParty (p :: Party) m a where
+  Api ::
+    SimplexCommand from (Cmd p s s') x ->
+    Connection p s ->
+    SimplexParty p m (Either String (x, Connection p s'))
+  Action ::
+    SimplexCommand (Cmd p s s') to x ->
+    Connection p s ->
+    Either String x ->
+    SimplexParty p m (Either String (Connection p s'))

definitions/src/Simplex/Messaging/Scenarios.hs

@@ -2,12 +2,14 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-}
 {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
 {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
 
 module Simplex.Messaging.Scenarios where
 
+import Control.Protocol
 import Control.XMonad.Do
 import Data.Singletons
 import Data.String
@@ -24,9 +26,9 @@ b = SBroker
 s :: Sing Sender
 s = SSender
 
-establishConnection :: Protocol '(None, None, None) '(Secured, Secured, Secured) ()
+establishConnection :: SimplexProtocol (None |: None |: None) (Secured |: Secured |: Secured) ()
 establishConnection = do
-  start "Establish simplex messaging connection and send first message"
+  comment "Establish simplex messaging connection and send first message"
   r ->: b $ CreateConn "BODbZxmtKUUF1l8pj4nVjQ"
   r ->: b $ Subscribe "RU"
   r ->: s $ SendInvite "invitation RU" -- invitation - TODo