dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-24 15:15:35 +00:00
Code Issues Packages Projects Releases Wiki Activity

refactor: make Protocol a freer parameterized monad

Browse Source
This commit is contained in:
Evgeny Poberezkin
2020-07-10 11:54:09 +01:00
parent cffb8bd11a
commit 063b7286e2
5 changed files with 49 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files
definitions/src/Simplex/Messaging/PrintScenario.hs
+7 -4
View File
@@ -6,6 +6,7 @@
module Simplex.Messaging.PrintScenario where
import Control.Monad.Writer
import Control.XFreer
import Data.Singletons
import Simplex.Messaging.Protocol
import Simplex.Messaging.Types
@@ -24,12 +25,14 @@ printScenario scn = ps 1 "" $ execWriter $ logScenario scn
l' = " - " <> l
logScenario :: Protocol s s' a -> Writer [(String, String)] a
logScenario (Start s) = tell [("", s)]
logScenario ((:->) from to cmd) = do
logScenario (Pure x) = return x
logScenario (Bind p f) = logProtocol p >>= \x -> logScenario (f x)
logProtocol :: ProtocolEff s s' a -> Writer [(String, String)] a
logProtocol (Start s) = tell [("", s)]
logProtocol (ProtocolCmd from to cmd) = do
tell [(party from, commandStr cmd <> " " <> party to)]
mockCommand cmd
logScenario (p :>> c) = logScenario p >> logScenario c
logScenario (p :>>= f) = logScenario p >>= \x -> logScenario (f x)
commandStr :: Command from fs fs' to ts ts' a -> String
commandStr (CreateConn _) = "creates connection in"
definitions/src/Simplex/Messaging/Protocol.hs
+23 -19
View File
@@ -21,6 +21,7 @@
module Simplex.Messaging.Protocol where
import Control.Monad.Trans.Except
import Control.XFreer
import Data.Kind
import Data.Singletons
import Data.Singletons.TH
@@ -134,8 +135,8 @@ apiStub _ = throwE "api not implemented"
actionStub :: Monad m => Connection p ps -> ExceptT String m res -> ExceptT String m (Connection p ps')
actionStub _ _ = throwE "action not implemented"
type family AllowedStates' s from fs' to ts' :: Constraint where
AllowedStates' '(rs, bs, ss) from fs' to ts' =
type family AllowedStates s from fs' to ts' :: Constraint where
AllowedStates '(rs, bs, ss) from fs' to ts' =
( HasState Recipient rs,
HasState Broker bs,
HasState Sender ss,
@@ -143,8 +144,6 @@ type family AllowedStates' s from fs' to ts' :: Constraint where
HasState to ts'
)
infix 6 :->
type ProtocolState = (ConnState, ConnState, ConnState)
type family ConnSt (p :: Party) (s :: ProtocolState) :: ConnState where
@@ -164,24 +163,29 @@ type family PartySt (p :: Party) (s :: ProtocolState) from fs' to ts' where
PartySt to _ _ _ to ts' = ts'
PartySt p s _ _ _ _ = ConnSt p s
infixl 4 :>>
data Protocol (s :: ProtocolState) (s' :: ProtocolState) (a :: Type) :: Type where
Start :: String -> Protocol s s ()
(:->) ::
AllowedStates' s from fs' to ts' =>
data ProtocolEff (s :: ProtocolState) (s' :: ProtocolState) (a :: Type) :: Type where
Start :: String -> ProtocolEff s s ()
ProtocolCmd ::
AllowedStates s from fs' 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
(:>>) ::
Protocol s s' a ->
Protocol s' s'' b ->
Protocol s s'' b
(:>>=) ::
Protocol s s' a ->
(a -> Protocol s' s'' b) ->
Protocol s s'' b
ProtocolEff s (ProtoSt s from fs' to ts') a
type Protocol = XFree ProtocolEff
infix 6 ->:
(->:) ::
AllowedStates s from fs' 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
infix 5 |$
definitions/src/Simplex/Messaging/Scenarios.hs
+16 -15
View File
@@ -6,6 +6,7 @@
module Simplex.Messaging.Scenarios where
import Control.XMonad
import Data.Singletons
import Simplex.Messaging.Protocol
import Simplex.Messaging.Types
@@ -21,18 +22,18 @@ s = SSender
establishConnection :: Protocol '(None, None, None) '(Secured, Secured, Secured) ()
establishConnection =
Start "Establish simplex messaging connection and send first message"
:>> r :-> b |$ CreateConn "BODbZxmtKUUF1l8pj4nVjQ"
:>> r :-> b |$ Subscribe "RU"
:>> r :-> s |$ SendInvite "invitation RU" -- invitation - TODo
:>> s :-> b |$ ConfirmConn "SU" "encrypted"
:>> b :-> r |$ PushConfirm "RU" Message {msgId = "abc", msg = "XPaVEVNunkYKqqK0dnAT5Q"}
:>> r :-> b |$ SecureConn "RU" "XPaVEVNunkYKqqK0dnAT5Q"
:>> r :-> b |$ DeleteMsg "RU" "abc"
:>> s :-> b |$ SendMsg "SU" "welcome" -- welcome message
:>> b :-> r |$ PushMsg "RU" Message {msgId = "def", msg = "welcome"}
:>> r :-> b |$ DeleteMsg "RU" "def"
:>> s :-> b |$ SendMsg "SU" "hello there"
:>> b :-> r |$ PushMsg "RU" Message {msgId = "ghi", msg = "hello there"}
:>> r :-> b |$ DeleteMsg "RU" "ghi"
:>> r :-> b |$ Unsubscribe "RU"
start "Establish simplex messaging connection and send first message"
>>: r ->: b |$ CreateConn "BODbZxmtKUUF1l8pj4nVjQ"
>>: r ->: b |$ Subscribe "RU"
>>: r ->: s |$ SendInvite "invitation RU" -- invitation - TODo
>>: s ->: b |$ ConfirmConn "SU" "encrypted"
>>: b ->: r |$ PushConfirm "RU" Message {msgId = "abc", msg = "XPaVEVNunkYKqqK0dnAT5Q"}
>>: r ->: b |$ SecureConn "RU" "XPaVEVNunkYKqqK0dnAT5Q"
>>: r ->: b |$ DeleteMsg "RU" "abc"
>>: s ->: b |$ SendMsg "SU" "welcome" -- welcome message
>>: b ->: r |$ PushMsg "RU" Message {msgId = "def", msg = "welcome"}
>>: r ->: b |$ DeleteMsg "RU" "def"
>>: s ->: b |$ SendMsg "SU" "hello there"
>>: b ->: r |$ PushMsg "RU" Message {msgId = "ghi", msg = "hello there"}
>>: r ->: b |$ DeleteMsg "RU" "ghi"
>>: r ->: b |$ Unsubscribe "RU"