From c0fd391e65b835bd1bfda7ca44e888122c55919e Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Mon, 17 Feb 2025 07:54:27 +1100 Subject: [PATCH 1/5] Tidy up unused imports and warnings. --- .../src/Control/Distributed/Process/FSM/Internal/Process.hs | 6 +++--- .../src/Control/Distributed/Process/FSM/Internal/Types.hs | 3 +-- packages/distributed-process-fsm/tests/TestFSM.hs | 4 +--- 3 files changed, 5 insertions(+), 8 deletions(-) diff --git a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Process.hs b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Process.hs index ff0e6af8..193d1edc 100644 --- a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Process.hs +++ b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Process.hs @@ -121,19 +121,19 @@ walkPFSM st acc handleRpcRawInputs :: forall s d . (Show s) => State s d -> (P.Message, SendPort P.Message) -> Action (State s d) -handleRpcRawInputs st@State{..} (msg, port) = +handleRpcRawInputs st (msg, port) = 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 = +handleAllRawInputs st msg = handleInput msg $ st { stReply = noOp, stTrans = Q.empty, stInput = Just msg } handleExitReason :: forall s d. (Show s) => State s d -> P.Message -> Process (Maybe (ProcessAction (State s d))) -handleExitReason st@State{..} msg = +handleExitReason st msg = let st' = st { stReply = noOp, stTrans = Q.empty, stInput = Just msg } in tryHandleInput st' msg diff --git a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Types.hs b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Types.hs index f187265c..ae92da4b 100644 --- a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Types.hs +++ b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Internal/Types.hs @@ -93,7 +93,7 @@ import Data.Sequence ) import qualified Data.Sequence as Q (null) import Data.Typeable (Typeable, typeOf) -import Data.Tuple (swap, uncurry) +import Data.Tuple (swap) import GHC.Generics -- | The internal state of an FSM process. @@ -312,7 +312,6 @@ apply st msg step setProcessState s' -- (_, st') <- runFSM st (addTransition ev) return $ enqueue st (Just ev) - | otherwise = error $ baseErr ++ ".Internal.Types.apply:InvalidStep" where mstash = return . uncurry enqueue . swap stash (o, s) = return $ enqueue s (Just o) diff --git a/packages/distributed-process-fsm/tests/TestFSM.hs b/packages/distributed-process-fsm/tests/TestFSM.hs index 56c7d6cc..1c3ae2dd 100644 --- a/packages/distributed-process-fsm/tests/TestFSM.hs +++ b/packages/distributed-process-fsm/tests/TestFSM.hs @@ -29,8 +29,6 @@ import Test.Tasty.HUnit (testCase, assertEqual, assertBool) import Network.Transport.TCP 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) @@ -157,7 +155,7 @@ republicationOfEvents = do send pid "yo" send pid On - res' <- receiveChanTimeout (asTimeout $ seconds 20) rp :: Process (Maybe ()) + _ <- receiveChanTimeout (asTimeout $ seconds 20) rp :: Process (Maybe ()) liftIO $ assertEqual mempty (Just ()) res kill pid "thankyou byebye" From 68171a2ed01e302833518dff81db382ded178d1d Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Thu, 6 Mar 2025 15:09:13 +1100 Subject: [PATCH 2/5] Typo in FSM example code --- .../src/Control/Distributed/Process/FSM.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM.hs b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM.hs index 505d5b5e..d2f14dd1 100644 --- a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM.hs +++ b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM.hs @@ -127,7 +127,7 @@ -- > ^. ((event :: Event ButtonPush) -- > ~> ( (On ~@ enter Off)) -- > .| (Off ~@ (set_ (+1) >> enter On)) --- > ) |> (reply currentState)) +-- > ) |> (reply currentState) -- -- Our client code will need to use the @call@ function from the Client module, -- although it /is/ possible to interact synchronously with an FSM process (e.g. From b4b07a1f4a2dc8791ef0b5adf623216265730935 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Thu, 6 Mar 2025 15:25:53 +1100 Subject: [PATCH 3/5] Move ChatServer/Client example into network-transport-tcp. --- .../network-transport-tcp.cabal | 24 +++++++++++++++++++ .../tests/chat/ChatClient.hs | 21 ++++++++-------- .../tests/chat/ChatServer.hs | 15 +++++++----- 3 files changed, 44 insertions(+), 16 deletions(-) rename packages/{network-transport => network-transport-tcp}/tests/chat/ChatClient.hs (83%) rename packages/{network-transport => network-transport-tcp}/tests/chat/ChatServer.hs (57%) diff --git a/packages/network-transport-tcp/network-transport-tcp.cabal b/packages/network-transport-tcp/network-transport-tcp.cabal index 1f88335b..5dd9a25f 100644 --- a/packages/network-transport-tcp/network-transport-tcp.cabal +++ b/packages/network-transport-tcp/network-transport-tcp.cabal @@ -105,3 +105,27 @@ Test-Suite TestQC DeriveDataTypeable MultiParamTypeClasses default-language: Haskell2010 + +executable chat-server + import: warnings + main-is: ChatServer.hs + hs-source-dirs: tests/chat + Default-Language: Haskell2010 + build-depends: base >= 4.14 && < 5, + bytestring, + containers, + mtl, + network-transport, + network-transport-tcp + +executable chat-client + import: warnings + main-is: ChatClient.hs + hs-source-dirs: tests/chat + Default-Language: Haskell2010 + build-depends: base >= 4.14 && < 5, + bytestring, + containers, + network-transport, + network-transport-tcp + \ No newline at end of file diff --git a/packages/network-transport/tests/chat/ChatClient.hs b/packages/network-transport-tcp/tests/chat/ChatClient.hs similarity index 83% rename from packages/network-transport/tests/chat/ChatClient.hs rename to packages/network-transport-tcp/tests/chat/ChatClient.hs index 69a97468..192a0896 100644 --- a/packages/network-transport/tests/chat/ChatClient.hs +++ b/packages/network-transport-tcp/tests/chat/ChatClient.hs @@ -1,6 +1,8 @@ +module Main (main) where + import System.Environment (getArgs) import Network.Transport -import Network.Transport.TCP (createTransport) +import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, modifyMVar_, modifyMVar) import Control.Concurrent (forkIO) import Control.Monad (forever, forM, unless, when) @@ -11,12 +13,12 @@ import qualified Data.Map as Map (fromList, elems, insert, member, empty, size, chatClient :: MVar () -> EndPoint -> EndPointAddress -> IO () chatClient done endpoint serverAddr = do - connect endpoint serverAddr ReliableOrdered + _ <- connect endpoint serverAddr ReliableOrdered defaultConnectHints cOut <- getPeers >>= connectToPeers cIn <- newMVar Map.empty -- Listen for incoming messages - forkIO . forever $ do + _ <- forkIO . forever $ do event <- receive endpoint case event of Received _ msg -> @@ -26,7 +28,7 @@ chatClient done endpoint serverAddr = do didAdd <- modifyMVar cOut $ \conns -> if not (Map.member addr conns) then do - Right conn <- connect endpoint addr ReliableOrdered + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints return (Map.insert addr conn conns, True) else return (conns, False) @@ -38,8 +40,7 @@ chatClient done endpoint serverAddr = do close (conns Map.! addr) return (Map.delete addr conns) showNumPeers cOut - - + _ -> pure () -- DO nothing for unrecognised events {- chatState <- newMVar (Map.fromList peerConns) @@ -67,7 +68,7 @@ chatClient done endpoint serverAddr = do let go = do msg <- BSC.getLine unless (BS.null msg) $ do - readMVar cOut >>= \conns -> forM (Map.elems conns) $ \conn -> send conn [msg] + _ <- readMVar cOut >>= \conns -> forM (Map.elems conns) $ \conn -> send conn [msg] go go putMVar done () @@ -83,7 +84,7 @@ chatClient done endpoint serverAddr = do connectToPeers :: [EndPointAddress] -> IO (MVar (Map EndPointAddress Connection)) connectToPeers addrs = do conns <- forM addrs $ \addr -> do - Right conn <- connect endpoint addr ReliableOrdered + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints return (addr, conn) newMVar (Map.fromList conns) @@ -97,11 +98,11 @@ chatClient done endpoint serverAddr = do main :: IO () main = do host:port:server:_ <- getArgs - Right transport <- createTransport host port + Right transport <- createTransport (defaultTCPAddr host port) defaultTCPParameters Right endpoint <- newEndPoint transport clientDone <- newEmptyMVar - forkIO $ chatClient clientDone endpoint (EndPointAddress . BSC.pack $ server) + _ <- forkIO $ chatClient clientDone endpoint (EndPointAddress . BSC.pack $ server) takeMVar clientDone diff --git a/packages/network-transport/tests/chat/ChatServer.hs b/packages/network-transport-tcp/tests/chat/ChatServer.hs similarity index 57% rename from packages/network-transport/tests/chat/ChatServer.hs rename to packages/network-transport-tcp/tests/chat/ChatServer.hs index 7c36df00..526f3de6 100644 --- a/packages/network-transport/tests/chat/ChatServer.hs +++ b/packages/network-transport-tcp/tests/chat/ChatServer.hs @@ -1,6 +1,8 @@ +module Main (main) where + import System.Environment (getArgs) import Network.Transport -import Network.Transport.TCP (createTransport) +import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters) import Control.Monad.State (evalStateT, modify, get) import Control.Monad (forever) import Control.Monad.IO.Class (liftIO) @@ -10,7 +12,7 @@ import qualified Data.ByteString.Char8 as BSC (pack) main :: IO () main = do host:port:_ <- getArgs - Right transport <- createTransport host port + Right transport <- createTransport (defaultTCPAddr host port) defaultTCPParameters Right endpoint <- newEndPoint transport putStrLn $ "Chat server ready at " ++ (show . endPointAddressToByteString . address $ endpoint) @@ -20,9 +22,10 @@ main = do case event of ConnectionOpened cid _ addr -> do get >>= \clients -> liftIO $ do - Right conn <- connect endpoint addr ReliableOrdered - send conn [BSC.pack . show . IntMap.elems $ clients] + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints + _ <- send conn [BSC.pack . show . IntMap.elems $ clients] close conn - modify $ IntMap.insert cid (endPointAddressToByteString addr) + modify $ IntMap.insert (fromIntegral cid) (endPointAddressToByteString addr) ConnectionClosed cid -> - modify $ IntMap.delete cid + modify $ IntMap.delete (fromIntegral cid) + _ -> liftIO . putStrLn $ "Other event received" From 8c100bf57ae59e0a143f11156ae6bc314ea4ed10 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Thu, 6 Mar 2025 15:26:45 +1100 Subject: [PATCH 4/5] Remove unused transfomers dependency --- packages/network-transport-tcp/network-transport-tcp.cabal | 1 - packages/network-transport/network-transport.cabal | 1 - 2 files changed, 2 deletions(-) diff --git a/packages/network-transport-tcp/network-transport-tcp.cabal b/packages/network-transport-tcp/network-transport-tcp.cabal index 5dd9a25f..7106464a 100644 --- a/packages/network-transport-tcp/network-transport-tcp.cabal +++ b/packages/network-transport-tcp/network-transport-tcp.cabal @@ -92,7 +92,6 @@ Test-Suite TestQC data-accessor, data-accessor-transformers, mtl, - transformers, lockfree-queue Else Buildable: False diff --git a/packages/network-transport/network-transport.cabal b/packages/network-transport/network-transport.cabal index e6fa93b6..0a95e8a6 100644 --- a/packages/network-transport/network-transport.cabal +++ b/packages/network-transport/network-transport.cabal @@ -81,7 +81,6 @@ Library binary >= 0.8 && < 0.9, bytestring >= 0.10 && < 0.13, hashable >= 1.2.0.5 && < 1.6, - transformers >= 0.2 && < 0.7, deepseq >= 1.0 && < 1.7 Exposed-Modules: Network.Transport Network.Transport.Util From 3d35221d698ddbe861a787ad764f8b1f3c06a484 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Thu, 6 Mar 2025 15:34:05 +1100 Subject: [PATCH 5/5] Explicitly match on Nothing. --- .../src/Control/Distributed/Process/FSM/Client.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Client.hs b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Client.hs index a0ba33c6..11c401fb 100644 --- a/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Client.hs +++ b/packages/distributed-process-fsm/src/Control/Distributed/Process/FSM/Client.hs @@ -80,7 +80,7 @@ callTimeout pid msg ti = bracket (monitor pid) unmonitor $ \mRef -> do Just m -> do mR <- unwrapMessage m case mR of Just r -> return $ Just r - _ -> die $ ExitOther $ baseErr ++ ".Client:InvalidResponseType" + Nothing -> die $ ExitOther $ baseErr ++ ".Client:InvalidResponseType" -- | Make a synchronous /call/ to the FSM process at "ProcessId". If a -- "Step" exists that upon receiving an event of type @m@ will eventually @@ -98,4 +98,4 @@ call pid msg = bracket (monitor pid) unmonitor $ \mRef -> do mR <- unwrapMessage msg' case mR of Just r -> return r - _ -> die $ ExitOther $ baseErr ++ ".Client:InvalidResponseType" + Nothing -> die $ ExitOther $ baseErr ++ ".Client:InvalidResponseType"