Skip to content

Commit 76ed6f0

Browse files
hyperthunkhyperthunk
committed
Provide a simple client API
1 parent 55d62b2 commit 76ed6f0

File tree

4 files changed

+95
-28
lines changed

4 files changed

+95
-28
lines changed

‎distributed-process-fsm.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ library
4343
ghc-options: -Wall
4444
exposed-modules:
4545
Control.Distributed.Process.FSM,
46+
Control.Distributed.Process.FSM.Client,
4647
Control.Distributed.Process.FSM.Internal.Types,
4748
Control.Distributed.Process.FSM.Internal.Process
4849

‎src/Control/Distributed/Process/FSM.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -77,8 +77,8 @@ pick = Alternate
7777
(^.) = Init
7878
infixr 9 ^.
7979

80-
init :: Step s d -> Step s d -> Step s d
81-
init = Init
80+
begin :: Step s d -> Step s d -> Step s d
81+
begin = Init
8282

8383
(|>) :: Step s d -> Step s d -> Step s d
8484
(|>) = Sequence
@@ -111,6 +111,9 @@ atState = Perhaps
111111
allState :: forall s d m . (Serializable m) => (m -> FSM s d (Transition s d)) -> Step s d
112112
allState = Always
113113

114+
always :: forall s d m . (Serializable m) => (m -> FSM s d (Transition s d)) -> Step s d
115+
always = Always
116+
114117
(~?) :: forall s d m . (Serializable m) => (m -> Bool) -> (m -> FSM s d (Transition s d)) -> Step s d
115118
(~?) = Matching
116119

‎src/Control/Distributed/Process/FSM/Client.hs‎

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
1+
{-# LANGUAGE ExistentialQuantification #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE PatternGuards #-}
4+
{-# LANGUAGE BangPatterns #-}
5+
{-# LANGUAGE RecordWildCards #-}
6+
{-# LANGUAGE TupleSections #-}
7+
{-# LANGUAGE DeriveDataTypeable #-}
8+
{-# LANGUAGE DeriveGeneric #-}
9+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+
{-# LANGUAGE MultiParamTypeClasses #-}
11+
{-# LANGUAGE GADTs #-}
12+
{-# LANGUAGE RankNTypes #-}
13+
14+
module Control.Distributed.Process.FSM.Client
15+
where
16+
17+
import Control.Distributed.Process
18+
( send
19+
, wrapMessage
20+
, newChan
21+
, unwrapMessage
22+
, receiveWait
23+
, receiveChan
24+
, monitor
25+
, unmonitor
26+
, die
27+
, matchChan
28+
, matchIf
29+
, Message
30+
, Process
31+
, SendPort
32+
, ReceivePort
33+
, ProcessId
34+
, ProcessMonitorNotification(..)
35+
, MonitorRef
36+
)
37+
import Control.Distributed.Process.Extras (ExitReason(ExitOther))
38+
import Control.Distributed.Process.FSM.Internal.Types (baseErr)
39+
import Control.Distributed.Process.Serializable (Serializable)
40+
import Control.Monad.Catch (bracket)
41+
42+
call :: (Serializable m, Serializable r) => ProcessId -> m -> Process r
43+
call pid msg = bracket (monitor pid) unmonitor $ \mRef -> do
44+
(sp, rp) <- newChan :: Process (SendPort Message, ReceivePort Message)
45+
send pid (wrapMessage msg, sp)
46+
msg <- receiveWait [ matchChan rp return
47+
, matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
48+
(\_ -> die $ ExitOther "ServerUnreachable")
49+
] :: Process Message
50+
mR <- unwrapMessage msg
51+
case mR of
52+
Just r -> return r
53+
_ -> die $ ExitOther $ baseErr ++ ".Client:InvalidResponseType"

‎tests/TestFSM.hs‎

Lines changed: 36 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55

66
module Main where
77

8-
import Control.Distributed.Process
8+
import Control.Distributed.Process hiding (call)
99
import Control.Distributed.Process.Node
1010
import Control.Distributed.Process.Extras
1111
( ExitReason(..)
@@ -15,6 +15,7 @@ import qualified Control.Distributed.Process.Extras (__remoteTable)
1515
import Control.Distributed.Process.Extras.Time hiding (timeout)
1616
import Control.Distributed.Process.Extras.Timer
1717
import Control.Distributed.Process.FSM
18+
import Control.Distributed.Process.FSM.Client (call)
1819
import Control.Distributed.Process.FSM.Internal.Process
1920
import Control.Distributed.Process.FSM.Internal.Types hiding (State, liftIO)
2021
import qualified Control.Distributed.Process.FSM.Internal.Types as FSM
@@ -79,42 +80,49 @@ switchFsm = startState
7980
.| (event :: Event Reset)
8081
~> (allState $ \Reset -> put initCount >> enter Off)
8182

82-
walkingAnFsmTree :: Process ()
83-
walkingAnFsmTree = do
84-
pid <- start Off initCount switchFsm
83+
switchFsmAlt :: Step State StateData
84+
switchFsmAlt =
85+
begin startState $
86+
pick (await (event :: Event ButtonPush) ((pick (atState On (set (+1) >> enter Off))
87+
(atState Off (set (+1) >> enter On))) `join` (reply currentState)))
88+
(pick (await (event :: Event Stop) (pick (matching (== ExitShutdown) (\_ -> timeout (seconds 3) Reset))
89+
(matching (const True) stop)))
90+
(pick (await (event :: Event Check) (reply stateData))
91+
(await (event :: Event Reset) (always $ \Reset -> put initCount >> enter Off))))
92+
93+
notSoQuirkyDefinitions :: Process ()
94+
notSoQuirkyDefinitions = do
95+
start Off initCount switchFsmAlt >>= walkingAnFsmTree
96+
97+
quirkyOperators :: Process ()
98+
quirkyOperators = do
99+
start Off initCount switchFsm >>= walkingAnFsmTree
100+
101+
walkingAnFsmTree :: ProcessId -> Process ()
102+
walkingAnFsmTree pid = do
85103

86104
(sp, rp) <- newChan :: Process (SendPort Message, ReceivePort Message)
87105

88-
send pid (wrapMessage (() :: ButtonPush), sp)
89-
msg <- receiveChan rp :: Process Message
90-
mSt <- unwrapMessage msg :: Process (Maybe State)
91-
mSt `shouldBe` equalTo (Just On)
106+
mSt <- call pid (() :: ButtonPush) :: Process State
107+
mSt `shouldBe` equalTo On
92108

93-
send pid (wrapMessage (() :: ButtonPush), sp)
94-
msg' <- receiveChan rp :: Process Message
95-
mSt' <- unwrapMessage msg' :: Process (Maybe State)
96-
mSt' `shouldBe` equalTo (Just Off)
109+
mSt' <- call pid (() :: ButtonPush) :: Process State
110+
mSt' `shouldBe` equalTo Off
97111

98-
send pid (wrapMessage Check, sp)
99-
chk <- receiveChan rp :: Process Message
100-
mCk <- unwrapMessage chk :: Process (Maybe StateData)
101-
mCk `shouldBe` equalTo (Just $ (2 :: StateData))
112+
mCk <- call pid Check :: Process StateData
113+
mCk `shouldBe` equalTo (2 :: StateData)
102114

103115
send pid ExitShutdown
104116
sleep $ seconds 6
105117
alive <- isProcessAlive pid
106118
liftIO $ putStrLn $ "alive == " ++ (show alive)
107119
alive `shouldBe` equalTo True
108120

109-
send pid (wrapMessage Check, sp)
110-
chk2 <- receiveChan rp :: Process Message
111-
mCk2 <- unwrapMessage chk2 :: Process (Maybe StateData)
112-
mCk2 `shouldBe` equalTo (Just $ (0 :: StateData))
121+
mCk2 <- call pid Check :: Process StateData
122+
mCk2 `shouldBe` equalTo (0 :: StateData)
113123

114-
send pid (wrapMessage (() :: ButtonPush), sp)
115-
rst' <- receiveChan rp :: Process Message
116-
mrst' <- unwrapMessage rst' :: Process (Maybe State)
117-
mrst' `shouldBe` equalTo (Just On)
124+
mrst' <- call pid (() :: ButtonPush) :: Process State
125+
mrst' `shouldBe` equalTo On
118126

119127
send pid ExitNormal
120128
sleep $ seconds 5
@@ -133,8 +141,10 @@ tests transport = do
133141
return [
134142
testGroup "Language/DSL"
135143
[
136-
testCase "Traversing an FSM definition"
137-
(runProcess localNode walkingAnFsmTree)
144+
testCase "Traversing an FSM definition (operators)"
145+
(runProcess localNode quirkyOperators)
146+
, testCase "Traversing an FSM definition (functions)"
147+
(runProcess localNode notSoQuirkyDefinitions)
138148
]
139149
]
140150

0 commit comments

Comments
 (0)