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 Data.List (find)

import Data.Maybe (fromJust)

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.Log (logPrintIO)
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
  curLevel <- asks rcLogLevel
  serverState <- gets scServerState
  clientList <- gets scClientSockets
  queueList <- gets scClientQueues
  void $ liftIO $ installHandler
    sigINT
    (CatchOnce $ do
      logPrintIO curLevel Info "SIGINT caught, terminating…"
      disconnectClients curLevel clientList queueList
      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
  :: LogLevel
  -> STM.TMVar [ClientSocket]
  -> STM.TMVar [ClientQueue]
  -> IO ()
disconnectClients curLevel clientSockets queueList = do
  logPrintIO curLevel Info "server shutting down. Notifying all clients…"
  queues <- STM.atomically $ STM.readTMVar queueList
  mapM_
    (\queue -> do
      maybe
        (pure ())
        (\uuid -> do
          logPrintIO curLevel Info $ "notifying client: " <> show uuid
          queueMessage curLevel ServerQuit uuid queueList
          threadDelay 1000 -- wait for the message to be actually sent
          sock <- do
            socketList <- STM.atomically $ STM.readTMVar clientSockets
            pure $ fromJust $ find (\s -> csUUID s == Just uuid) socketList
          dropClient curLevel clientSockets queueList (csSocket sock)
        )
        (cqUUID queue)
    )
    queues


-- | Process incoming connection requests
processRequests :: Game ()
processRequests = do
  mainSocket <- asks rcMainSocket
  curLevel <- asks rcLogLevel
  serverQueue <- gets scMessageQueue
  socketList <- gets scClientSockets
  queueList <- gets scClientQueues
  st <- gets scServerState
  void $ liftIO $ forkIO $ acceptConnection curLevel mainSocket socketList queueList serverQueue st
  where
    acceptConnection curLevel mainSocket socketList queueList serverQueue st = do
      logPrintIO curLevel Info "Ready for new connection requests…"
      eSock <- try $ accept mainSocket
      case eSock of
        Left (_ :: SomeException) ->
          logPrintIO curLevel Warning "Main socket vanished!"
        Right (clientSock, _) -> do
          clientQueue <- STM.newTQueueIO
          sockContainer <- STM.newTMVarIO clientSock
          receiverThreadId <- liftIO $ do
            t <- forkIO $ do
              threadDelay $ 10 ^ 6
              forever $ receiveMessage curLevel socketList queueList sockContainer serverQueue
            logPrintIO curLevel Verbose "enabled listener thread"
            pure t
          senderThreadId <- liftIO $ do
            t <- forkIO $ do
              threadDelay $ 10 ^ 6
              forever $ sendMessageQueue curLevel sockContainer clientQueue
            logPrintIO curLevel Verbose "enabled sender thread"
            pure t
          logPrintIO curLevel Verbose $ show clientSock
          liftIO $ STM.atomically $ do
            slist <- STM.takeTMVar socketList
            STM.putTMVar
              socketList
              (ClientSocket
                Nothing
                clientSock
                receiverThreadId
                senderThreadId
              : slist
              )
            qlist <- STM.takeTMVar queueList
            STM.putTMVar queueList
              (ClientQueue
                Nothing
                clientQueue
              : qlist
              )
          logPrintIO curLevel Info "accepted new connection"
          -- abortCondition <- serverStop <$> STM.atomically (STM.readTMVar st)
          -- unless abortCondition $
          --   acceptConnection mainSocket socketList queue st
          acceptConnection curLevel mainSocket socketList queueList serverQueue st