implement proper non-blocking socket handling

src-server/Main.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 
+import qualified Control.Concurrent.STM as STM
+
 import Control.Monad.RWS.Strict
 
 import qualified Data.ByteString.Char8 as B8
@@ -16,7 +18,6 @@ import Network.Socket as Net
 
 import Options.Applicative
 
-
 -- internal imports
 
 import Library.Types
@@ -39,8 +40,6 @@ main = do
         )
     Right (Settings {..}) -> do
       sock <- bindSocket setSocketPath
-      terminateSocketOnSigint sock
-      -- Net.listen sock 1024
       putStrLn "Bound and listening to socket:"
       print =<< getSocketName sock
       putStrLn "-----------------------------------------------------------------------------------"
@@ -50,9 +49,17 @@ main = do
       putStrLn "-----------------------------------------------------------------------------------"
       putStrLn "starting game…"
       now <- getCurrentTime
+      sockList <- STM.newTMVarIO []
+      serverState <- STM.newTMVarIO (ServerState False False)
       let initRead  = ReaderContainer (arenaMap arena) setFPS sock
-          initState = StateContainer (arenaSpawners arena) [] (ServerState False False) now []
-      (finalState, finalWrite) <- execRWST runGame initRead initState
+          initState = StateContainer (arenaSpawners arena) [] serverState now sockList
+      (finalState, finalWrite) <- execRWST
+        (do
+          terminateGameOnSigint
+          runGame
+        )
+        initRead
+        initState
       print finalWrite
   where
     opts = info (options <**> helper)

src-server/Server/Communication.hs

@@ -1,12 +1,20 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Server.Communication where
 
+import Control.Concurrent
+
+import qualified Control.Concurrent.STM as STM
+
 import Control.Monad
 
 import Control.Monad.IO.Class
 
+import Control.Monad.Loops
+
 import Control.Monad.RWS.Strict
 
+import Data.Maybe (maybe)
+
 import Network.Socket as Net
 
 import System.IO
@@ -17,6 +25,7 @@ import System.Posix.Signals
 
 import Server.Types
 import Server.Util
+import Data.Maybe (isNothing)
 
 -- | Function which determines whether the given filePath is a supported socket path and
 --   subsequently creates a socket in said location.
@@ -33,14 +42,19 @@ bindSocket path = do
   Net.listen sock 5
   pure sock
 
--- | Function that installs a handler on SIGINT to close and remove the given socket
-terminateSocketOnSigint
-  :: Socket -- ^ Socket to terminate on termination
-  -> IO ()
-terminateSocketOnSigint sock =
-  void $ installHandler
+-- | Function that installs a handler on SIGINT to terminate game
+terminateGameOnSigint
+  :: Game ()
+terminateGameOnSigint = do
+  sock <- asks rcMainSocket
+  clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
+  serverState <- gets scServerState
+  void $ liftIO $ installHandler
     keyboardSignal
     (CatchOnce $ do
+      void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
+      disconnectClients clients
+      threadDelay (10 ^ 6)
       (SockAddrUnix path) <- getSocketName sock
       close' sock
       removeIfExists path
@@ -48,29 +62,52 @@ terminateSocketOnSigint sock =
       raiseSignal keyboardSignal
     )
     Nothing
+  where
+    disconnectClients = mapM_
+      (\(clientSocket, mThread) -> do
+        maybe (pure ()) killThread mThread
+        close' clientSocket
+      )
 
 -- | Process incoming connection requests
-processRequests :: Game
+processRequests :: Game ()
 processRequests = do
   mainSocket <- asks rcMainSocket
-  clientSock <- liftIO $ do
-    (clientSock, _) <- accept mainSocket
-    putStrLn $ "accepted new connection"
-    pure clientSock
-  modify' (\st ->
-    st
-      {scClientSockets = clientSock : scClientSockets st}
-    )
+  socketList <- gets scClientSockets
+  serverState <- gets scServerState
+  void $ liftIO $ forkIO $ acceptConnection mainSocket socketList serverState
+  where
+    acceptConnection mainSocket socketList serverState = whileM_
+      (not . serverStop <$> liftIO (STM.atomically $ STM.readTMVar serverState))
+      (do
+        (clientSock, _) <- accept mainSocket
+        putStrLn "accepted new connection"
+        liftIO $ STM.atomically $ do
+          list <- STM.takeTMVar socketList
+          STM.putTMVar socketList ((clientSock, Nothing) : list)
+      )
 
--- | process incomeing messages from clients
-processMessages :: Game
+-- | process incoming messages from clients
+processMessages :: Game ()
 processMessages = do
-  clientSocks <- gets scClientSockets
-  mapM_
-    (\clientSocket -> liftIO $ do
-      connectionHandle <- socketToHandle clientSocket ReadMode
-      hSetBuffering connectionHandle LineBuffering
-      messages <- hGetContents' connectionHandle
-      print messages
+  clientsVar <- gets scClientSockets
+  clients <- liftIO $ STM.atomically $ STM.readTMVar $ clientsVar
+  newClients <- mapM
+    (\client@(clientSocket, mThread) ->
+      if isNothing mThread
+      then liftIO $ do
+        connectionHandle <- socketToHandle clientSocket ReadMode
+        thread <- forkIO
+          (listenTo connectionHandle)
+        pure (clientSocket, Just thread)
+      else
+        pure client
     )
-    clientSocks
+    clients
+  liftIO $ STM.atomically $ do
+    void $ STM.swapTMVar clientsVar newClients
+  where
+    listenTo connectionHandle = do
+      hSetBuffering connectionHandle LineBuffering
+      message <- hGetContents' connectionHandle
+      putStr message

src-server/Server/Game.hs

@@ -1,13 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Server.Game where
 
-import Control.Concurrent (threadDelay)
+import Control.Concurrent (threadDelay, killThread)
+
+import qualified Control.Concurrent.STM as STM
 
 import Control.Monad.RWS.Strict
 
 import Control.Monad.Loops
 
+import qualified Data.ByteString.Char8 as B8
+
 import Data.Time
 
+import Data.String (fromString)
+
+import System.IO (stdout)
+
 -- internal imports
 
 import Library.Types
@@ -15,26 +24,31 @@ import Library.Types
 import Server.Communication
 import Server.Types
 
-runGame :: Game
+runGame :: Game ()
 runGame = do
+  processRequests
   whileM_
-    (not . serverStop <$> gets scServerState)
+    (not . serverStop <$> (liftIO . STM.atomically . STM.readTMVar =<< gets scServerState))
     (do
       before <- gets scServerLastTick
       now <- liftIO getCurrentTime
       let delta = realToFrac $ diffUTCTime now before
-
-      processRequests
+      liftIO $ B8.hPutStr stdout $ "tick: " <> fromString (show delta) <> "  \r"
       processMessages
       updateSpawners delta
       updateWizards delta
+      modify'
+        (\s -> s
+          { scServerLastTick = now
+          }
+        )
       fps <- asks rcFPS
       let remainingTime = recip (fromIntegral fps) - delta
       when (remainingTime > 0) $
         liftIO $ threadDelay $ floor $ remainingTime * 10 ^ 6
     )
 
-updateSpawners :: Float -> Game
+updateSpawners :: Float -> Game ()
 updateSpawners dt =
   modify' (\sc@(StateContainer spawners _ _ _ _) ->
     let newSpawners = map
@@ -55,7 +69,7 @@ updateSpawners dt =
       }
     )
 
-updateWizards :: Float -> Game
+updateWizards :: Float -> Game ()
 updateWizards dt =
   modify' (\sc@(StateContainer _ wizards _ _ _) ->
     let newWizards = map

src-server/Server/Types.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE DeriveGeneric #-}
 module Server.Types where
 
+import Control.Concurrent (ThreadId)
+
+import qualified Control.Concurrent.STM as STM
+
 import Control.Monad.RWS.Strict
 
 import qualified Data.Aeson as Aeson
@@ -13,6 +17,8 @@ import Network.Socket
 
 import Options.Applicative as O
 
+--internal imports
+
 import Library.Types
 
 data Settings = Settings
@@ -49,9 +55,9 @@ data ReaderContainer = ReaderContainer
 data StateContainer = StateContainer
   { scSpawners       :: [ Spawner ]
   , scPlayers        :: [ Wizard ]
-  , scServerState    :: ServerState
+  , scServerState    :: STM.TMVar ServerState
   , scServerLastTick :: UTCTime
-  , scClientSockets  :: [ Socket ]
+  , scClientSockets  :: STM.TMVar [ (Socket, Maybe ThreadId) ]
   }
 
 -- | Data object for storing the server's state
@@ -61,4 +67,4 @@ data ServerState = ServerState
   }
   deriving (Show, Eq)
 
-type Game = RWST ReaderContainer String StateContainer IO ()
+type Game = RWST ReaderContainer String StateContainer IO

wizard-wipeout.cabal

@@ -63,6 +63,7 @@ executable wizard-wipeout-server
                     , text
                     , time
                     , random
+                    , stm
                     , unix
                     , wizard-wipeout
                     , yaml