From 54fadc205b4b369e9611c1ab5557231779531e8c Mon Sep 17 00:00:00 2001 From: Hao Lian Date: Sat, 6 Sep 2014 01:29:40 +0200 Subject: [PATCH] Server now understands pinging, ponging, GCing, registration, and moves --- server/Main.hs | 167 ++++++++++++++++++++++++++++++++---------- server/staunton.cabal | 18 ++--- 2 files changed, 138 insertions(+), 47 deletions(-) diff --git a/server/Main.hs b/server/Main.hs index e3a7077..4958012 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -1,50 +1,141 @@ -{-# LANGUAGE OverloadedStrings #-} -import BasePrelude -import Control.Concurrent -import Control.Monad.IO.Class (liftIO) +{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, NamedFieldPuns #-} + +import BasePrelude hiding ((\\), finally) +import Control.Concurrent (MVar) +import qualified Control.Concurrent as C +import Control.Concurrent.Suspend (sDelay) +import Control.Concurrent.Timer (repeatedTimer, stopTimer) +import Control.Monad.Catch (finally) +import Control.Monad.Trans +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as A import Data.Map (Map) import qualified Data.Map as M import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.UnixTime (UnixTime, getUnixTime, secondsToUnixDiffTime, diffUnixTime) import qualified Network.WebSockets as WS +import System.IO +import System.IO.Streams.Attoparsec (ParseException) + +type Email = Text +type Location = (Float, Float) +data Player = Player Email deriving (Eq, Ord, Show) +data Move = Move Location deriving (Show) +data Pong = Pong Bool +type DB = Map Player (Location, UnixTime, WS.Connection) + +instance A.FromJSON Player where + parseJSON (A.Object o) = Player <$> o A..: "email" + +instance A.FromJSON Move where + parseJSON (A.Object o) = Move <$> ((,) <$> o A..: "x" <*> o A..: "y") -broadcast :: Text -> Text -> Map k WS.Connection -> IO () -broadcast user msg toUsers = do - let line = user <> ": " <> msg - T.putStrLn line - forM_ (M.elems toUsers) (\conn -> WS.sendTextData conn line) +instance A.FromJSON Pong where + parseJSON (A.Object o) = Pong <$> o A..: "pong" -newDB :: Map Text WS.Connection -newDB = M.empty +ping :: WS.Connection -> IO () +ping conn = WS.sendTextData conn ("{\"ping\": true}" :: Text) -application - :: Text -> WS.Connection -> MVar (Map Text WS.Connection) -> IO () -application email conn db = do - liftIO setup - finally talk disconnect +heartbeatIntervalSeconds :: Int64 +heartbeatIntervalSeconds = 1 + +heartbeat :: DB -> IO DB +heartbeat db = + M.fromList <$> heartbeatFilterM (M.toList db) where - setup = do - T.putStrLn ("+ Setup: " <> email) - modifyMVar_ db $ \users -> - return (M.insert email conn users) - disconnect = do - T.putStrLn ("+ Disconnect: " <> email) - modifyMVar_ db $ \users -> - return (M.delete email users) - talk = forever $ do - T.putStrLn ("+ Broadcast: " <> email) - msg <- WS.receiveData conn - liftIO (readMVar db >>= broadcast email msg) + delta = + secondsToUnixDiffTime (heartbeatIntervalSeconds * 2) + heartbeatFilterM = + filterM $ \(player, (_, lastPongTime, conn)) -> do + now <- getUnixTime + case (diffUnixTime now lastPongTime > delta) of + True -> do + putStrLn ("+ GCing " <> show player) + WS.sendClose conn ("pong better" :: Text) + return False + False -> do + ping conn + return True -main :: IO () -main = do - db <- newMVar newDB - T.putStrLn ("+ Listening to " <> ip <> ":" <> (T.pack $ show port)) - WS.runServer (T.unpack ip) port $ \pending -> do - conn <- WS.acceptRequest pending - email <- WS.receiveData conn - application email conn db +dataflow :: (Player + -> WS.Connection + -> IO (Move -> IO (), Pong -> IO (), IO ())) + -> WS.PendingConnection -> IO () +dataflow onConnect pending = do + conn <- WS.acceptRequest pending + initial <- WS.receiveData conn + case A.decode initial of + Nothing -> do + putStrLn ("Invalid registration: " <> show initial) + Just player -> do + (onMove, onPong, onDisconnect) <- onConnect player conn + ((`finally` onDisconnect) . runMaybeT . forever) $ do + message <- lift $ WS.receiveData conn + case A.decode message of + Just move -> + lift $ onMove move + Nothing -> do + case A.decode message of + Just pong -> + lift $ onPong pong + Nothing -> do + lift $ putStrLn ("Unrecognized: " <> show message) + unforever + putStrLn "+ Finally over" + return () + where + -- forever in the IO monad loops forever, as you might suspect, + -- without giving us a way to break out. forever in the + -- MaybeT IO monad, however, is quite delightful. + unforever = mzero + +mainWithState :: MVar DB -> IO () +mainWithState state = do + putStrLn "+ Heartbeat up" + timer <- repeatedTimer (withDB $ heartbeat) (sDelay heartbeatIntervalSeconds) + (`finally` (stopTimer timer)) $ runServer (dataflow application) + where + withDB = + C.modifyMVar_ state + application player conn = do + putStrLn ("+ Connecting " <> show player) + renew + return (onMove, onPong, onDisconnect) + where + renew = withDB $ \db -> do + now <- getUnixTime + return (M.insert player ((0, 0), now, conn) db) + onMove (Move to) = withDB $ \db -> do + putStrLn ("+ Move from " <> show player <> ": " <> show to) + now <- getUnixTime + return (M.insert player (to, now, conn) db) + onDisconnect = withDB $ \db -> do + putStrLn ("+ Disconnecting " <> show player) + return (M.delete player db) + onPong _ = do + renew + +runServer :: (WS.PendingConnection -> IO ()) -> IO () +runServer server = do + putStrLn ("+ Server up @" <> ip <> ":" <> show port) + WS.runServer ip port (handle connectionExceptions . + handle parseExceptions . + server) where ip = "0.0.0.0" port = 9160 + + connectionExceptions :: WS.ConnectionException -> IO () + connectionExceptions _ = + -- Our finally handler is sufficient. + return () + + parseExceptions :: ParseException -> IO () + parseExceptions _ = do + throw WS.ConnectionClosed + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + state <- C.newMVar (M.empty) + mainWithState state diff --git a/server/staunton.cabal b/server/staunton.cabal index e4a21bc..64a044f 100644 --- a/server/staunton.cabal +++ b/server/staunton.cabal @@ -4,27 +4,27 @@ name: staunton version: 1.0.0.0 synopsis: "Chess" server --- description: homepage: https://github.com/trello/staunton --- license: license-file: LICENSE author: Trello, Inc. maintainer: hao@trello.com --- copyright: --- category: build-type: Simple --- extra-source-files: cabal-version: >=1.10 executable staunton main-is: Main.hs - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <4.8 + build-depends: aeson >= 0.8.0.0 + , base >=4.7 && <4.8 , base-prelude >= 0.1.3 + , bytestring >= 0.10.4.0 , containers >= 0.5.5.1 + , exceptions >= 0.6.1 + , io-streams >= 1.1.4.6 + , mtl >= 2.2.1 + , suspend >= 0.2.0.0 , text >= 1.1.1.3 + , timers >= 0.2.0.2 , transformers >= 0.4.1.0 + , unix-time >= 0.3.3 , websockets >= 0.8.2.6 - -- hs-source-dirs: default-language: Haskell2010