wizard-wipeout/src-server/Server/Communication.hs

{-# LANGUAGE OverloadedStrings #-}
module Server.Communication
  ( module Server.Communication
  , module S
  ) where

import Control.Concurrent

import qualified Control.Concurrent.STM as STM

import Control.Exception

import Control.Monad

import Control.Monad.IO.Class

import Control.Monad.RWS.Strict

import Network.Socket as Net

import System.Posix.Signals

-- internal imports

import Library.Types

import Server.Communication.Handler as S
import Server.Communication.Receive as S
import Server.Communication.Send as S
import Server.Types

-- | Function which determines whether the given filePath is a supported socket path and
--   subsequently creates a socket in said location.
bindSocket
  :: FilePath  -- ^ File Path for socket to be created (e.g.: "/tmp/wizard.sock")
  -> IO Socket -- ^ resulting Socket
bindSocket path = do
  let sockAddr = SockAddrUnix path
  unless (isSupportedSockAddr sockAddr)
    (error $ "invalid socket path " <> path)
  -- removeIfExists path
  sock <- socket AF_UNIX Stream 0
  bind sock sockAddr
  Net.listen sock 5
  pure sock

-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
  :: Game ()
terminateGameOnSigint = do
  sock <- asks rcMainSocket
  serverState <- gets scServerState
  clientList <- gets scClientSockets
  void $ liftIO $ installHandler
    sigINT
    (CatchOnce $ do
      putStrLn "SIGINT caught, terminating…"
      clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
      disconnectClients clientList clients
      threadDelay (10 ^ 6)
      close sock
      st <- STM.atomically $ STM.readTMVar serverState
      void $ STM.atomically $ STM.swapTMVar serverState $ st
        { serverStop = True
        }
    )
    Nothing

-- | Disconnect all connected clients gracefully by announcing the server quitting
disconnectClients
  :: STM.TMVar [ClientComms]
  -> [ClientComms]
  -> IO ()
disconnectClients clientList clients = do
  putStrLn "server shutting down. Notifying all clients…"
  mapM_
    (\client -> do
      maybe
        (pure ())
        (\uuid -> do
          queueMessage ServerQuit uuid clientList
          dropClient clientList (ccSocket client)
        )
        (ccUUID client)
    )
    clients


-- | Process incoming connection requests
processRequests :: Game ()
processRequests = do
  mainSocket <- asks rcMainSocket
  queue <- gets scMessageQueue
  socketList <- gets scClientSockets
  st <- gets scServerState
  void $ liftIO $ forkIO $ acceptConnection mainSocket socketList queue st
  where
    acceptConnection mainSocket socketList queue st = do
      putStrLn "Ready for new connection requests…"
      eSock <- try $ accept mainSocket
      case eSock of
        Left (_ :: SomeException) ->
          putStrLn "Main socket vanished!"
        Right (clientSock, _) -> do
          messageQueue <- STM.newTQueueIO
          sockCOntainer <- STM.newTMVarIO clientSock
          clientWriteThreadId <- liftIO $ forkIO $ forever $ do
            receiveMessage sockCOntainer queue socketList
          clientListenThreadId <- liftIO $ forkIO $ forever $ do
            sendMessageQueue sockCOntainer messageQueue
          print clientSock
          liftIO $ STM.atomically $ do
            list <- STM.takeTMVar socketList
            STM.putTMVar
              socketList
              (ClientComms
                Nothing
                clientSock
                messageQueue
                clientWriteThreadId
                clientListenThreadId
                : list
              )
          putStrLn "accepted new connection"
          abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
          unless abortCondition $
            acceptConnection mainSocket socketList queue st