Skip to content
This repository was archived by the owner on Feb 15, 2025. It is now read-only.

Commit 7415fc8

Browse files
hyperthunkhyperthunk
committed
Tweaks, test cases, and travis config
1 parent 76ed6f0 commit 7415fc8

File tree

10 files changed

+176
-72
lines changed

10 files changed

+176
-72
lines changed

‎.travis.yml

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
language: c
2+
3+
sudo: false
4+
5+
matrix:
6+
include:
7+
- env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml" COVER="" GHCVER=7.10.3
8+
addons: {apt: {packages: [libgmp-dev]}}
9+
- env: ARGS="--stack-yaml stack-ghc-8.0.1.yaml" COVER="" GHCVER=8.0.1
10+
addons: {apt: {packages: [libgmp-dev]}}
11+
- env: ARGS="--resolver nightly" COVER="" GHCVER=latest
12+
addons: {apt: {packages: [libgmp-dev]}}
13+
14+
cache:
15+
directories:
16+
- $HOME/.stack
17+
- $HOME/.local
18+
19+
before_install:
20+
- export PATH=$HOME/.local/bin:$HOME/.cabal/bin:$PATH
21+
- mkdir -p ~/.local/bin
22+
- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
23+
- stack --version
24+
25+
install:
26+
- stack ${ARGS} setup --no-terminal
27+
28+
script:
29+
- case "$COVER" in
30+
true)
31+
stack ${ARGS} test --coverage --no-terminal;
32+
./coverage.sh;
33+
;;
34+
*)
35+
stack ${ARGS} test --test-arguments='--plain'
36+
;;
37+
esac
38+
39+
notifications:
40+
slack:
41+
secure: g0NP1tkOe3+kI6O0Q1mgT/jPaLjxQ31J26MWouicu2F1Y3p73qTvv/QsOkafRMZDn07HlzgviCP25r7Ytg32pUAFvOh4U4MT2MpO0jUVVGPi4ZiwB+W5AH+HlDtJSickeSZ0AjXZSaGv8nQNegWkeaLQgLBIzrTHU8s0Y9K+whQ=

‎LICENCE

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
Copyright Tim Watson, 2012-2013.
1+
Copyright Tim Watson, 2017.
22

33
All rights reserved.
44

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

Lines changed: 1 addition & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -13,13 +13,9 @@
1313

1414
module Control.Distributed.Process.FSM where
1515

16-
import Control.Distributed.Process (Process)
17-
import Control.Distributed.Process.Extras
18-
( ExitReason(ExitShutdown)
19-
)
16+
import Control.Distributed.Process.Extras (ExitReason)
2017
import Control.Distributed.Process.Extras.Time
2118
( TimeInterval
22-
, seconds
2319
)
2420
import Control.Distributed.Process.ManagedProcess
2521
( processState
@@ -28,16 +24,7 @@ import Control.Distributed.Process.ManagedProcess
2824
)
2925
import qualified Control.Distributed.Process.ManagedProcess.Internal.Types as MP (liftIO)
3026
import Control.Distributed.Process.FSM.Internal.Types
31-
import Control.Distributed.Process.FSM.Internal.Process
32-
( start
33-
)
3427
import Control.Distributed.Process.Serializable (Serializable)
35-
import Control.Monad (void)
36-
import Data.Binary (Binary)
37-
import Data.Typeable (Typeable)
38-
import GHC.Generics
39-
40-
type Pipeline = forall s d . Step s d
4128

4229
initState :: forall s d . s -> d -> Step s d
4330
initState = Yield

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

Lines changed: 43 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -20,34 +20,70 @@ import Control.Distributed.Process
2020
, newChan
2121
, unwrapMessage
2222
, receiveWait
23-
, receiveChan
23+
, receiveTimeout
2424
, monitor
2525
, unmonitor
2626
, die
2727
, matchChan
2828
, matchIf
29+
, catchesExit
30+
, handleMessageIf
31+
, getSelfPid
2932
, Message
3033
, Process
3134
, SendPort
3235
, ReceivePort
3336
, ProcessId
3437
, ProcessMonitorNotification(..)
35-
, MonitorRef
3638
)
3739
import Control.Distributed.Process.Extras (ExitReason(ExitOther))
40+
import Control.Distributed.Process.Extras.Time (TimeInterval, asTimeout)
3841
import Control.Distributed.Process.FSM.Internal.Types (baseErr)
3942
import Control.Distributed.Process.Serializable (Serializable)
4043
import Control.Monad.Catch (bracket)
4144

45+
safeCall :: (Serializable m, Serializable r)
46+
=> ProcessId
47+
-> m
48+
-> Process (Either ExitReason r)
49+
safeCall pid msg = do
50+
us <- getSelfPid
51+
(call pid msg >>= return . Right)
52+
`catchesExit` [(\sid rsn -> handleMessageIf rsn (weFailed sid us)
53+
(return . Left))]
54+
where
55+
weFailed a b (ExitOther _) = a == b
56+
weFailed _ _ _ = False
57+
58+
callTimeout :: (Serializable m, Serializable r)
59+
=> ProcessId
60+
-> m
61+
-> TimeInterval
62+
-> Process (Maybe r)
63+
callTimeout pid msg ti = bracket (monitor pid) unmonitor $ \mRef -> do
64+
(sp, rp) <- newChan :: Process (SendPort Message, ReceivePort Message)
65+
send pid (wrapMessage msg, sp)
66+
msg' <- receiveTimeout (asTimeout ti)
67+
[ matchChan rp return
68+
, matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
69+
(\_ -> die $ ExitOther "ServerUnreachable")
70+
] :: Process (Maybe Message)
71+
case msg' of
72+
Nothing -> return Nothing
73+
Just m -> do mR <- unwrapMessage m
74+
case mR of
75+
Just r -> return $ Just r
76+
_ -> die $ ExitOther $ baseErr ++ ".Client:InvalidResponseType"
77+
4278
call :: (Serializable m, Serializable r) => ProcessId -> m -> Process r
4379
call pid msg = bracket (monitor pid) unmonitor $ \mRef -> do
4480
(sp, rp) <- newChan :: Process (SendPort Message, ReceivePort Message)
4581
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
82+
msg' <- receiveWait [ matchChan rp return
83+
, matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
84+
(\_ -> die $ ExitOther "ServerUnreachable")
85+
] :: Process Message
86+
mR <- unwrapMessage msg'
5187
case mR of
5288
Just r -> return r
5389
_ -> die $ ExitOther $ baseErr ++ ".Client:InvalidResponseType"

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

Lines changed: 14 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -25,29 +25,27 @@ import Control.Distributed.Process
2525
import qualified Control.Distributed.Process as P
2626
( Message
2727
)
28-
import Control.Distributed.Process.Extras (ExitReason(..))
2928
import Control.Distributed.Process.Extras.Time (Delay(Infinity))
3029
import Control.Distributed.Process.FSM.Internal.Types hiding (liftIO)
3130
import Control.Distributed.Process.ManagedProcess
3231
( ProcessDefinition(..)
33-
, PrioritisedProcessDefinition
34-
, ProcessAction()
32+
, PrioritisedProcessDefinition(filters)
3533
, Action
3634
, InitHandler
3735
, InitResult(..)
3836
, defaultProcess
3937
, prioritised
40-
, GenProcess
41-
, setProcessState
42-
, push
4338
)
4439
import qualified Control.Distributed.Process.ManagedProcess as MP (pserve)
40+
import Control.Distributed.Process.ManagedProcess.Server.Priority (safely)
4541
import Control.Distributed.Process.ManagedProcess.Server
4642
( handleRaw
4743
, handleInfo
4844
, continue
4945
)
50-
import Data.Maybe (fromJust)
46+
import Control.Distributed.Process.ManagedProcess.Internal.Types
47+
( ExitSignalDispatcher(..)
48+
)
5149
import qualified Data.Sequence as Q (empty)
5250
-- import Control.Distributed.Process.Serializable (Serializable)
5351
-- import Control.Monad (void)
@@ -67,12 +65,15 @@ fsmInit (st, sd, prog) =
6765

6866
processDefinition :: forall s d . (Show s) => PrioritisedProcessDefinition (State s d)
6967
processDefinition =
70-
defaultProcess
71-
{
72-
infoHandlers = [ handleInfo handleRpcRawInputs
73-
, handleRaw handleAllRawInputs
74-
]
75-
} `prioritised` []
68+
(prioritised
69+
defaultProcess
70+
{
71+
infoHandlers = [ handleInfo handleRpcRawInputs
72+
, handleRaw handleAllRawInputs
73+
]
74+
, exitHandlers = [ ExitSignalDispatcher (\s _ m -> handleAllRawInputs s m >>= return . Just)
75+
]
76+
} []) { filters = [safely] }
7677

7778
handleRpcRawInputs :: forall s d . (Show s) => State s d
7879
-> (P.Message, SendPort P.Message)

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

Lines changed: 25 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -44,23 +44,23 @@ import Control.Distributed.Process.Serializable (Serializable)
4444
import Control.Monad.Fix (MonadFix)
4545
import Control.Monad.IO.Class (MonadIO)
4646
import qualified Control.Monad.State.Strict as ST
47-
( MonadState
48-
, StateT
49-
, get
50-
, modify
51-
, lift
52-
, runStateT
53-
)
47+
( MonadState
48+
, StateT
49+
, get
50+
, modify
51+
, lift
52+
, runStateT
53+
)
5454
-- import Data.Binary (Binary)
5555
import Data.Maybe (fromJust, isJust)
5656
import Data.Sequence
57-
( Seq
58-
, ViewR(..)
59-
, (<|)
60-
, (|>)
61-
, viewr
62-
)
63-
import qualified Data.Sequence as Q (empty, null)
57+
( Seq
58+
, ViewR(..)
59+
, (<|)
60+
, (|>)
61+
, viewr
62+
)
63+
import qualified Data.Sequence as Q (null)
6464
import Data.Typeable (Typeable, typeOf)
6565
import Data.Tuple (swap, uncurry)
6666
-- import GHC.Generics
@@ -194,19 +194,19 @@ apply st msg step
194194
| Yield sn sd <- step = do
195195
P.liftIO $ putStrLn "Yield s d"
196196
return $ Just $ st { stName = sn, stData = sd }
197-
| Await evt act <- step = do
197+
| Await evt act' <- step = do
198198
let ev = decodeToEvent evt msg
199199
P.liftIO $ putStrLn $ (show evt) ++ " decoded: " ++ (show $ isJust ev)
200-
if isJust (ev) then apply st msg act
200+
if isJust (ev) then apply st msg act'
201201
else (P.liftIO $ putStrLn $ "Cannot decode " ++ (show (evt, msg))) >> return Nothing
202-
| Always fsm <- step = do
202+
| Always fsm <- step = do
203203
P.liftIO $ putStrLn "Always..."
204204
runFSM st (handleMessage msg fsm) >>= mstash
205-
| Perhaps eqn act <- step = do
205+
| Perhaps eqn act' <- step = do
206206
P.liftIO $ putStrLn $ "Perhaps " ++ (show eqn) ++ " in " ++ (show $ stName st)
207-
if eqn == (stName st) then runFSM st act >>= stash
207+
if eqn == (stName st) then runFSM st act' >>= stash
208208
else (P.liftIO $ putStrLn "Perhaps Not...") >> return Nothing
209-
| Matching chk fsm <- step = do
209+
| Matching chk fsm <- step = do
210210
P.liftIO $ putStrLn "Matching..."
211211
runFSM st (handleMessageIf msg chk fsm) >>= mstash
212212
| Sequence ac1 ac2 <- step = do s <- apply st msg ac1
@@ -219,10 +219,11 @@ apply st msg step
219219
else (P.liftIO $ putStrLn "try br 2") >> apply st msg al2
220220
| Reply rply <- step = do
221221
let ev = Eval $ do fSt <- processState
222-
MP.lift $ do
223-
P.liftIO $ putStrLn $ "Replying from " ++ (show fSt)
224-
(r, s) <- runFSM fSt rply
225-
(stReply fSt) $ wrapMessage r
222+
s' <- MP.lift $ do P.liftIO $ putStrLn $ "Replying from " ++ (show fSt)
223+
(r, s) <- runFSM fSt rply
224+
(stReply s) $ wrapMessage r
225+
return s
226+
setProcessState s'
226227
-- (_, st') <- runFSM st (addTransition ev)
227228
return $ enqueue st (Just ev)
228229
| otherwise = error $ baseErr ++ ".Internal.Types.apply:InvalidStep"

‎stack-ghc-7.10.3.yaml

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
resolver: nightly-2016-03-08
2+
3+
packages:
4+
- '.'
5+
- location:
6+
git: https://github.com/haskell-distributed/distributed-process-client-server.git
7+
commit: 36b179ec804bfdf380286082255e8b1fae099414
8+
extra-dep: true
9+
10+
extra-deps:
11+
- network-transport-inmemory-0.5.1 # snapshot 0.5.2 in lts-7.18
12+
- distributed-process-0.6.6 # missing snapshot
13+
- distributed-process-extras-0.3.1 # missing snapshot
14+
- distributed-process-async-0.2.4 # missing snapshot
15+
- distributed-process-systest-0.1.1 # missing prior to Jan-2017
16+
- rematch-0.2.0.0

‎stack-ghc-8.0.1.yaml

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
resolver: lts-7.18
2+
3+
packages:
4+
- '.'
5+
- location:
6+
git: https://github.com/haskell-distributed/distributed-process-client-server.git
7+
commit: 36b179ec804bfdf380286082255e8b1fae099414
8+
extra-dep: true
9+
10+
extra-deps:
11+
- network-transport-inmemory-0.5.1 # snapshot 0.5.2 in lts-7.18
12+
- distributed-process-0.6.6 # missing snapshot
13+
- distributed-process-extras-0.3.1 # missing snapshot
14+
- distributed-process-async-0.2.4 # missing snapshot
15+
- distributed-process-systest-0.1.1 # missing prior to Jan-2017
16+
- rematch-0.2.0.0

‎stack.yaml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ packages:
44
- '.'
55
- location:
66
git: https://github.com/haskell-distributed/distributed-process-client-server.git
7-
commit: b88d84e6fb9029781c263685e52c650e9a05970d
7+
commit: 36b179ec804bfdf380286082255e8b1fae099414
88
extra-dep: true
99

1010
extra-deps:

0 commit comments

Comments
 (0)