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

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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.RWS.Strict

import qualified Data.Aeson as A

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as B8

import Data.List

import qualified Data.Matrix as M

import Data.Maybe

import Data.UUID hiding (null)
import Data.UUID.V4

import qualified Data.Vector.Storable as VS

import Foreign hiding (void)

import Linear

import Network.Socket as Net

import System.Posix.Signals

-- internal imports

import Library.Types

import Server.Types
import Server.Util

-- | 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)
  -- aremoveIfExists path
  sock <- socket AF_UNIX Stream defaultProtocol
  bind sock sockAddr
  Net.listen sock 5
  pure sock

-- | Function that installs a handler on SIGINT to terminate game
terminateGameOnSigint
  :: FilePath
  -> Game ()
terminateGameOnSigint path = do
  sock <- asks rcMainSocket
  clients <- liftIO . STM.atomically . STM.readTMVar =<< gets scClientSockets
  serverState <- gets scServerState
  void $ liftIO $ installHandler
    sigINT
    (CatchOnce $ do
      putStrLn "SIGINT caught, terminating…"
      disconnectClients clients
      close sock
      removeIfExists path
      void $ STM.atomically $ STM.swapTMVar serverState (ServerState False True)
      -- Raise SIGINT again so it does not get blocked
      -- raiseSignal sigINT
    )
    Nothing
  where
    disconnectClients = mapM_
      (\(_, clientSocket) -> do
        sendMessage ServerQuit clientSocket
        close clientSocket
      )

-- | Process incoming connection requests
processRequests :: Game ()
processRequests = do
  mainSocket <- asks rcMainSocket
  socketList <- gets scClientSockets
  void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
  where
    acceptConnection mainSocket socketList = do
      putStrLn "accepting new connections…"
      (clientSock, _) <- accept mainSocket
      liftIO $ STM.atomically $ do
        list <- STM.takeTMVar socketList
        STM.putTMVar socketList ((Nothing, clientSock) : list)
      putStrLn "accepted new connection"
      acceptConnection mainSocket socketList

-- | Sends a specified message through given socket to the client
sendMessage
  :: ServerMessage
  -> Socket
  -> IO ()
sendMessage msg sock = do
  let msgJson = A.encode msg
      msgVector = VS.fromList $ B.unpack $ B.toStrict $ ('<' `B8.cons` (msgJson `B8.snoc` '>'))
  -- putStrLn $ "sending: " <> B8.unpack msgJson
  VS.unsafeWith
    msgVector
    (\ptr -> void $ sendBuf sock ptr (VS.length msgVector))

-- | receive incoming messages from clients
receiveMessages
  :: STM.TMVar [(Maybe UUID, Socket)]
  -> STM.TQueue ClientMessage
  -> IO ()
receiveMessages clientsVar queue = do
  clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
  mapM_
    (\(_, clientSocket) -> do
      receiveMessage clientSocket queue
    )
    clients

-- | handle received messages
handleMessages :: Game ()
handleMessages = do
  queue <- gets scMessageQueue
  serverState <- get
  readerContainer <- ask
  msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
  void $ liftIO $ do
    mapM_
      (handleMessage serverState readerContainer)
      msgs

-- | receive a 'ClientMessage'
receiveMessage
  :: Socket
  -> STM.TQueue ClientMessage
  -> IO ()
receiveMessage sock queue = do
  let maxBufferLength = 4096
  mmsg <- do
    ptr <- mallocArray maxBufferLength
    bufferLength <- recvBuf sock ptr maxBufferLength
    msg <- B.pack <$> peekArray bufferLength ptr
    let mJsonMsg = A.decode' $ B8.fromStrict msg :: Maybe ClientMessage
    free ptr
    if bufferLength > 0
    then
      pure mJsonMsg
    else
      pure Nothing
  maybe
    (pure ())
    (\msg -> do
      liftIO $ STM.atomically $ STM.writeTQueue queue msg
      -- when (msg == IdRequest) (threadDelay $ 10 ^ 3)
    )
    mmsg

-- | function for translating 'ClientMessage's into server actions
handleMessage
  :: StateContainer
  -> ReaderContainer
  -> ClientMessage
  -> IO ()
handleMessage stateContainer readerContainer msg = do
  let clientList = scClientSockets stateContainer
  clients <- liftIO $ STM.atomically $ STM.readTMVar clientList
  putStrLn $ "Handling following: " <> show msg
  case msg of
    IdRequest                      -> do
      clientId <- nextRandom
      let clientIdx = findIndex (\a -> fst a == Nothing) clients
      let clientSock = snd $ clients !! fromJust clientIdx
      let newClients = map
            (\old@(muuid, oldClientSock) ->
              if oldClientSock == clientSock && muuid == Nothing
              then
                (Just clientId, clientSock)
              else
                old
            )
            clients
      void $ liftIO $ STM.atomically $ STM.swapTMVar clientList newClients
      putStrLn $ "Accepted Client with UUID " <> show clientId
      sendMessage (AcceptClient clientId) clientSock
    ClientMessage clientId payload ->
      case payload of
        ClientQuit -> do
          putStrLn $ "removing client " <> show clientId
          let newClients = filter (\a -> fst a /= Just clientId) clients
          STM.atomically $ do
            currentPlayers <- STM.readTMVar (scPlayers stateContainer)
            let newPlayers = filter (\p -> playerId p /= clientId) currentPlayers
            void $ STM.swapTMVar (scPlayers stateContainer) newPlayers
            void $ STM.swapTMVar clientList newClients
        ClientRequestWizard -> do
          putStrLn "initializing new wizard"
          let arena = rcMap readerContainer
          initPos <- rollInitPosition arena
          let freshWizard = newWizard initPos
          STM.atomically $ do
            currentPlayers <- STM.readTMVar (scPlayers stateContainer)
            void $ STM.swapTMVar (scPlayers stateContainer) $
              Player clientId freshWizard False : currentPlayers
          let clientSock = fromJust $ lookup (Just clientId) clients
          sendMessage (ProvideInitialWizard freshWizard) clientSock
        ClientReady -> do
          putStrLn $ "client " <> show clientId <> " is ready!"
          STM.atomically $ do
            currentPlayers <- STM.readTMVar (scPlayers stateContainer)
            let (thisPlayers, otherPlayers) =
                  partition (\p -> playerId p == clientId) currentPlayers
            unless (null thisPlayers) $
              void $ STM.swapTMVar (scPlayers stateContainer) $
                (head thisPlayers) {playerReady = True} : otherPlayers
        _          -> pure ()

sendUpdates :: Game ()
sendUpdates = do
  tileMap <- asks rcMap
  stateContainer <- get
  players <- liftIO $ STM.atomically $ STM.readTMVar (scPlayers stateContainer)
  sockets <- liftIO $ STM.atomically $ STM.readTMVar (scClientSockets stateContainer)
  mapM_
    (\(Player playerId wizard@(Wizard {..}) readiness) -> do
      when readiness $ do
        let V2 wr wc = wizardPos
            subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
            leftBound = wizardRot + (pi / 4)
            rightBound = wizardRot - (pi / 4)
            leftLine row = cos leftBound * row
            rightLine row = sin rightBound * row
            correctionLeft = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
              then floor
              else ceiling
            correctionRight = if wizardRot < pi / 2 || wizardRot > 4 * pi / 2
              then ceiling
              else floor
            viewMatrix = M.fromList 9 9 $ map
              (\(qr, qc) ->
                if qc - floor wc <= correctionLeft (leftLine (wr - fromIntegral qr))
                    && qc - floor wc >= correctionRight (rightLine (wr - fromIntegral qr))
                then
                  M.safeGet qr qc tileMap
                else
                  Nothing
              )
              subCoords
            clientSock = fromJust $ lookup (Just playerId) sockets
        -- liftIO $ print $ leftLine . (\x -> x - wr) . fromIntegral .fst <$> subCoords
        -- liftIO $ print initViewMatrix
        liftIO $ sendMessage
          (TickUpdate
            { tuWizard   = wizard
            , tuMapSlice = MapSlice
              { msViewMap  = viewMatrix
              , msContents = []
              }
            }
          )
          clientSock
    )
    players