Carry the input message correctly

Author: hyperthunk

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

@@ -81,7 +81,7 @@ call pid msg = bracket (monitor pid) unmonitor $ \mRef -> do
   send pid (wrapMessage msg, sp)
   msg' <- receiveWait [ matchChan rp return
                       , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)
-                                (\_ -> die $ ExitOther "ServerUnreachable")
+                                (\(ProcessMonitorNotification _ _ r) -> die $ ExitOther (show r))
                       ] :: Process Message
   mR <- unwrapMessage msg'
   case mR of

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

@@ -91,13 +91,13 @@ handleRpcRawInputs :: forall s d . (Show s) => State s d
                    -> (P.Message, SendPort P.Message)
                    -> Action (State s d)
 handleRpcRawInputs st@State{..} (msg, port) =
-  handleInput msg $ st { stReply = (sendChan port), stTrans = Q.empty }
+  handleInput msg $ st { stReply = (sendChan port), stTrans = Q.empty, stInput = Just msg }
 
 handleAllRawInputs :: forall s d. (Show s) => State s d
                    -> P.Message
                    -> Action (State s d)
 handleAllRawInputs st@State{..} msg =
-  handleInput msg $ st { stReply = noOp, stTrans = Q.empty }
+  handleInput msg $ st { stReply = noOp, stTrans = Q.empty, stInput = Just msg }
 
 noOp :: P.Message -> Process ()
 noOp = const $ return ()

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

@@ -154,6 +154,12 @@ currentState = ST.get >>= return . stName
 stateData :: FSM s d d
 stateData = ST.get >>= return . stData
 
+currentMessage :: forall s d . FSM s d P.Message
+currentMessage = ST.get >>= return . fromJust . stInput
+
+currentInput :: forall s d m . (Serializable m) => FSM s d (Maybe m)
+currentInput = currentMessage >>= \m -> lift (unwrapMessage m :: Process (Maybe m))
+
 addTransition :: Transition s d -> FSM s d ()
 addTransition t = ST.modify (\s -> fromJust $ enqueue s (Just t) )
 

tests/TestFSM.hs

@@ -15,7 +15,7 @@ import qualified Control.Distributed.Process.Extras (__remoteTable)
 import Control.Distributed.Process.Extras.Time hiding (timeout)
 import Control.Distributed.Process.Extras.Timer
 import Control.Distributed.Process.FSM
-import Control.Distributed.Process.FSM.Client (call)
+import Control.Distributed.Process.FSM.Client (call, callTimeout)
 import Control.Distributed.Process.FSM.Internal.Process
 import Control.Distributed.Process.FSM.Internal.Types hiding (State, liftIO)
 import Control.Distributed.Process.SysTest.Utils
@@ -37,6 +37,7 @@ import qualified Network.Transport as NT
 -- import Control.Distributed.Process.Serializable (Serializable)
 -- import Control.Monad (void)
 import Data.Binary (Binary)
+import Data.Maybe (fromJust)
 import Data.Typeable (Typeable)
 import GHC.Generics
 
@@ -104,8 +105,11 @@ deepFSM :: SendPort () -> SendPort () -> Step State ()
 deepFSM on off = initState Off ()
        ^. ((event :: Event State) ~> (allState $ \s -> enter s))
        .| ( (Off ~@ resume)
-            |> ((event :: Event ())
-                ~> (allState $ \s -> (lift $ sendChan off s) >> resume))
+            |> (  ((event :: Event ())
+                    ~> (allState $ \s -> (lift $ sendChan off s) >> resume))
+               .| (((event :: Event String) ~> (always $ \(_ :: String) -> resume))
+                    |> (reply (currentInput >>= return . fromJust :: FSM State () String)))
+               )
           )
        .| ( (On ~@ resume)
             |> ((event :: Event ())
@@ -129,11 +133,17 @@ verifyOuterStateHandler = do
   Nothing <- receiveChanTimeout (asTimeout $ seconds 3) rpOff
   () <- receiveChan rpOn
 
+  resp <- callTimeout pid "hello there" (seconds 3):: Process (Maybe String)
+  resp `shouldBe` equalTo (Nothing :: Maybe String)
+
   send pid Off
   send pid ()
   Nothing <- receiveChanTimeout (asTimeout $ seconds 3) rpOn
   () <- receiveChan rpOff
 
+  res <- call pid "hello" :: Process String
+  res `shouldBe` equalTo "hello"
+
   kill pid "bye bye"
 
 verifyMailboxHandling :: Process ()