Server now understands pinging, ponging, GCing, registration, and moves

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

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:          [email protected]
--- 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