-
Notifications
You must be signed in to change notification settings - Fork 9
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
9 changed files
with
174 additions
and
101 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,16 @@ | ||
| { | ||
| "node": "PingServerNode", | ||
| "nodeScenario": "PingServer", | ||
| "nodeConfig": { | ||
| "tag": "PingServerNodeConfig", | ||
| "stopOnPing": 200, | ||
| "servingPort": 3000 | ||
| }, | ||
| "loggerConfig": { | ||
| "logFilePath": "", | ||
| "format": "$prio $loggername: $msg", | ||
| "logToFile": false, | ||
| "logToConsole": true, | ||
| "level": "Debug" | ||
| } | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,17 @@ | ||
| { | ||
| "node": "PongClientNode", | ||
| "nodeScenario": "PongClient", | ||
| "nodeConfig": { | ||
| "tag": "PongClientNodeConfig", | ||
| "clientName": "Pong client #1", | ||
| "pingDelay": 1000000, | ||
| "pingServerAddress": {"host":"127.0.0.1","port":3000} | ||
| }, | ||
| "loggerConfig": { | ||
| "logFilePath": "", | ||
| "format": "$prio $loggername: $msg", | ||
| "logToFile": false, | ||
| "logToConsole": true, | ||
| "level": "Debug" | ||
| } | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,17 @@ | ||
| { | ||
| "node": "PongClientNode", | ||
| "nodeScenario": "PongClient", | ||
| "nodeConfig": { | ||
| "tag": "PongClientNodeConfig", | ||
| "clientName": "Pong client #2", | ||
| "pingDelay": 1000000, | ||
| "pingServerAddress": {"host":"127.0.0.1","port":3000} | ||
| }, | ||
| "loggerConfig": { | ||
| "logFilePath": "", | ||
| "format": "$prio $loggername: $msg", | ||
| "logToFile": false, | ||
| "logToConsole": true, | ||
| "level": "Debug" | ||
| } | ||
| } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,9 +1,11 @@ | ||
| {-# LANGUAGE DeriveAnyClass #-} | ||
|
|
||
| module Enecuum.Assets.Nodes.TstNodes.PingPong.Messages where | ||
|
|
||
| import Enecuum.Prelude | ||
| import Enecuum.Prelude | ||
|
|
||
| data Ping = Ping Text | ||
| newtype Ping = Ping Text | ||
| deriving (Show, Eq, Generic, ToJSON, FromJSON) | ||
|
|
||
| data Pong = Pong Int | ||
| newtype Pong = Pong Int | ||
| deriving (Show, Eq, Generic, ToJSON, FromJSON) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,62 +1,55 @@ | ||
| {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
| {-# LANGUAGE DeriveAnyClass #-} | ||
| {-# LANGUAGE DuplicateRecordFields #-} | ||
| {-# LANGUAGE FunctionalDependencies #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
| {-# LANGUAGE DuplicateRecordFields #-} | ||
|
|
||
| module Enecuum.Assets.Nodes.TstNodes.PingPong.PingServer where | ||
|
|
||
| import qualified Data.Aeson as A | ||
| import Enecuum.Assets.Nodes.TstNodes.PingPong.Messages | ||
| import Enecuum.Config | ||
| import qualified Enecuum.Domain as D | ||
| import qualified Enecuum.Language as L | ||
| import qualified Enecuum.Domain as D | ||
| import qualified Enecuum.Language as L | ||
| import Enecuum.Prelude | ||
| import Enecuum.Assets.Nodes.TstNodes.PingPong.Messages | ||
|
|
||
| data PingServerData = PingServerData | ||
| { _pingsCount :: D.StateVar Int | ||
| } | ||
|
|
||
| makeFieldsNoPrefix ''PingServerData | ||
| data PingServerNode = PingServerNode | ||
| deriving (Show, Generic) | ||
|
|
||
| data instance NodeConfig PingServerNode = PingServerNode | ||
| { _stopOnPing :: Int | ||
| data instance NodeConfig PingServerNode = PingServerNodeConfig | ||
| { _stopOnPing :: Int | ||
| , _servingPort :: D.PortNumber | ||
| } | ||
| deriving (Show, Generic) | ||
|
|
||
| instance Node PingServerNode where | ||
| data NodeScenario PingServerNode = PingServer | ||
| deriving (Show, Generic) | ||
| getNodeScript _ = pingServerNode | ||
| getNodeScript _ = pingServerNode' | ||
| getNodeTag _ = PingServerNode | ||
|
|
||
| instance ToJSON (NodeScenario PingServerNode) where toJSON = J.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON (NodeScenario PingServerNode) where parseJSON = J.genericParseJSON nodeConfigJsonOptions | ||
| instance ToJSON PingServerNode where toJSON = A.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON PingServerNode where parseJSON = A.genericParseJSON nodeConfigJsonOptions | ||
| instance ToJSON (NodeConfig PingServerNode) where toJSON = A.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON (NodeConfig PingServerNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions | ||
| instance ToJSON (NodeScenario PingServerNode) where toJSON = A.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON (NodeScenario PingServerNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions | ||
|
|
||
| acceptPing :: PingServerNodeData -> Ping -> connection -> L.NodeL () | ||
| acceptPing nodeData (Ping clientName) conn = do | ||
| acceptPing :: D.StateVar Int -> Ping -> D.Connection D.Udp -> L.NodeL () | ||
| acceptPing pingsCount (Ping clientName) conn = do | ||
| pings <- L.atomically $ do | ||
| pings <- L.readVar $ nodeData ^. pingsCount | ||
| let newPings = pings + 1 | ||
| L.writeVar (nodeData ^. pingsCount) newPings | ||
| pure newPings | ||
| L.modifyVar pingsCount (+1) | ||
| L.readVar pingsCount | ||
| L.send conn (Pong pings) | ||
| L.close conn | ||
| L.logInfo $ "Ping #" +|| pings ||+ " accepted from " <> clientName <> "." | ||
| L.logInfo $ "Ping #" +|| pings ||+ " accepted from " +|| clientName ||+ "." | ||
|
|
||
| pingServerNode :: NodeConfig PingServerNode -> L.NodeDefinitionL () | ||
| pingServerNode cfg = do | ||
| nodeData <- initializePingServerNode | ||
| pingServerNode :: Int -> D.PortNumber -> L.NodeDefinitionL () | ||
| pingServerNode threshold port = do | ||
| pingsCount <- L.newVarIO 0 | ||
|
|
||
| L.serving D.Udp 3000 $ do | ||
| L.method $ acceptPing nodeData | ||
| L.serving D.Udp port $ | ||
| L.handler $ acceptPing pingsCount | ||
|
|
||
| L.atomically $ do | ||
| pings <- readVar $ nodeData ^. pingsCount | ||
| when (pings < _stopOnPing cfg) L.retry | ||
| pings <- L.readVar pingsCount | ||
| when (pings < threshold) L.retry | ||
|
|
||
| initializePingServerNode :: NodeConfig PingServerNode -> L.NodeL PingServerNodeData | ||
| initializePingServerNode cfg = do | ||
| pingsCount <- L.newVarIO 0 | ||
| pure PingServerNodeData | ||
| { _pingsCount = pingsCount | ||
| } | ||
| pingServerNode' :: NodeConfig PingServerNode -> L.NodeDefinitionL () | ||
| pingServerNode' cfg = pingServerNode (_stopOnPing cfg) (_servingPort cfg) |
113 changes: 66 additions & 47 deletions
113
src/Enecuum/Assets/Nodes/TstNodes/PingPong/PongClient.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,63 +1,82 @@ | ||
| {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
| {-# LANGUAGE DeriveAnyClass #-} | ||
| {-# LANGUAGE DuplicateRecordFields #-} | ||
| {-# LANGUAGE FunctionalDependencies #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
| {-# LANGUAGE DuplicateRecordFields #-} | ||
|
|
||
| module Enecuum.Assets.Nodes.TstNodes.PingPong.PongClient where | ||
|
|
||
| import qualified Data.Aeson as A | ||
| import Enecuum.Assets.Nodes.TstNodes.PingPong.Messages | ||
| import Enecuum.Config | ||
| import qualified Enecuum.Domain as D | ||
| import Enecuum.Framework.Language.Extra (HasStatus) | ||
| import qualified Enecuum.Language as L | ||
| import qualified Enecuum.Domain as D | ||
| import Enecuum.Framework.Language.Extra (HasStatus) | ||
| import qualified Enecuum.Language as L | ||
| import Enecuum.Prelude | ||
| import Enecuum.Assets.Nodes.TstNodes.PingPong.Messages | ||
|
|
||
| data PongClientData = PongClientData | ||
| { _pingsCount :: D.StateVar Int | ||
| } | ||
|
|
||
| makeFieldsNoPrefix ''PongClientData | ||
| data PongClientNode = PongClientNode | ||
| deriving (Show, Generic) | ||
|
|
||
| data instance NodeConfig PongClientNode = PongClientNode | ||
| { _clientName :: Text | ||
| data instance NodeConfig PongClientNode = PongClientNodeConfig | ||
| { _clientName :: Text | ||
| , _pingDelay :: Int | ||
| , _pingServerAddress :: D.Address | ||
| } | ||
| deriving (Show, Generic) | ||
|
|
||
| instance Node PongClientNode where | ||
| data NodeScenario PongClientNode = PongClient | ||
| deriving (Show, Generic) | ||
| getNodeScript _ = PongClientNode | ||
| getNodeScript _ = pongClientNode' | ||
| getNodeTag _ = PongClientNode | ||
|
|
||
| instance ToJSON (NodeScenario PongClientNode) where toJSON = J.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON (NodeScenario PongClientNode) where parseJSON = J.genericParseJSON nodeConfigJsonOptions | ||
|
|
||
| acceptPing :: PongClientNodeData -> Ping -> connection -> L.NodeL () | ||
| acceptPing nodeData (Ping clientName) conn = do | ||
| pings <- L.atomically $ do | ||
| pings <- L.readVar $ nodeData ^. pingsCount | ||
| let newPings = pings + 1 | ||
| L.writeVar (nodeData ^. pingsCount) newPings | ||
| pure newPings | ||
| L.send conn (Pong pings) | ||
| L.close conn | ||
| L.logInfo $ "Ping #" +|| pings ||+ " accepted from " <> clientName <> "." | ||
|
|
||
| PongClientNode :: NodeConfig PongClientNode -> L.NodeDefinitionL () | ||
| PongClientNode cfg = do | ||
| nodeData <- initializePongClientNode | ||
|
|
||
| L.serving D.Udp 3000 $ do | ||
| L.method $ acceptPing nodeData | ||
|
|
||
| L.atomically $ do | ||
| pings <- readVar $ nodeData ^. pingsCount | ||
| when (pings < _stopOnPing cfg) L.retry | ||
|
|
||
| initializePongClientNode :: NodeConfig PongClientNode -> L.NodeL PongClientNodeData | ||
| initializePongClientNode cfg = do | ||
| pingsCount <- L.newVarIO 0 | ||
| pure PongClientNodeData | ||
| { _pingsCount = pingsCount | ||
| } | ||
| instance ToJSON PongClientNode where toJSON = A.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON PongClientNode where parseJSON = A.genericParseJSON nodeConfigJsonOptions | ||
| instance ToJSON (NodeConfig PongClientNode) where toJSON = A.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON (NodeConfig PongClientNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions | ||
| instance ToJSON (NodeScenario PongClientNode) where toJSON = A.genericToJSON nodeConfigJsonOptions | ||
| instance FromJSON (NodeScenario PongClientNode) where parseJSON = A.genericParseJSON nodeConfigJsonOptions | ||
|
|
||
| acceptPong :: Pong -> connection -> L.NodeL () | ||
| acceptPong (Pong pingsCount) _ = | ||
| L.logInfo $ "Pong accepted from server. Pings count: " <> show pingsCount | ||
|
|
||
| pingSending' :: NodeConfig PongClientNode -> D.Connection D.Udp -> L.NodeL () | ||
| pingSending' cfg conn = do | ||
| L.delay $ _pingDelay cfg | ||
| L.logInfo "Sending Ping to the server." | ||
| eSent <- L.send conn (Ping $ _clientName cfg) | ||
| case eSent of | ||
| Right () -> pingSending' cfg conn | ||
| Left _ -> do | ||
| L.logInfo "Server is gone." | ||
| L.close conn | ||
|
|
||
|
|
||
| pongClientNode' :: NodeConfig PongClientNode -> L.NodeDefinitionL () | ||
| pongClientNode' cfg = do | ||
|
|
||
| mbConn <- L.open D.Udp (_pingServerAddress cfg) $ | ||
| L.handler acceptPong | ||
|
|
||
| case mbConn of | ||
| Nothing -> L.logError "Ping Server not found" | ||
| Just conn -> do | ||
| L.process (pingSending' cfg conn) | ||
| L.awaitNodeForever | ||
|
|
||
| pingSending :: Text -> D.Connection D.Udp -> L.NodeL () | ||
| pingSending clientName conn = do | ||
| L.delay 1000000 | ||
| L.logInfo "Sending Ping to the server." | ||
| eSent <- L.send conn (Ping clientName) | ||
| when (isLeft eSent) $ L.close conn | ||
| when (isRight eSent) $ pingSending clientName conn | ||
|
|
||
| pongClientNode :: Text -> D.Address -> L.NodeDefinitionL () | ||
| pongClientNode clientName serverAddress = do | ||
|
|
||
| mbConn <- L.open D.Udp serverAddress $ | ||
| L.handler acceptPong | ||
|
|
||
| when (isNothing mbConn) $ L.logError "Ping Server not found" | ||
| whenJust mbConn $ \conn -> do | ||
| L.process $ pingSending clientName conn | ||
| L.awaitNodeForever |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters