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

77 lines
2 KiB
Haskell
Raw Normal View History

2023-12-10 01:02:09 +00:00
{-# LANGUAGE OverloadedStrings #-}
2023-12-09 12:58:59 +00:00
module Server.Communication where
import Control.Monad
2023-12-10 01:02:09 +00:00
import Control.Monad.IO.Class
import Control.Monad.RWS.Strict
import Network.Socket as Net
import System.IO
2023-12-09 12:58:59 +00:00
import System.Posix.Signals
-- internal imports
2023-12-10 01:02:09 +00:00
import Server.Types
2023-12-09 12:58:59 +00:00
import Server.Util
2023-12-09 13:18:10 +00:00
-- | 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
2023-12-09 12:58:59 +00:00
bindSocket path = do
let sockAddr = SockAddrUnix path
unless (isSupportedSockAddr sockAddr)
(error $ "invalid socket path " <> path)
2023-12-09 13:18:10 +00:00
-- aremoveIfExists path
2023-12-10 01:02:09 +00:00
sock <- socket AF_UNIX Stream defaultProtocol
2023-12-09 12:58:59 +00:00
bind sock sockAddr
2023-12-10 01:02:09 +00:00
Net.listen sock 5
2023-12-09 12:58:59 +00:00
pure sock
2023-12-09 13:18:10 +00:00
-- | Function that installs a handler on SIGINT to close and remove the given socket
terminateSocketOnSigint
:: Socket -- ^ Socket to terminate on termination
-> IO ()
terminateSocketOnSigint sock =
2023-12-09 12:58:59 +00:00
void $ installHandler
keyboardSignal
(CatchOnce $ do
(SockAddrUnix path) <- getSocketName sock
close' sock
removeIfExists path
2023-12-09 13:11:37 +00:00
-- Raise SIGINT again so it does not get blocked
2023-12-09 12:58:59 +00:00
raiseSignal keyboardSignal
)
Nothing
2023-12-10 01:02:09 +00:00
-- | Process incoming connection requests
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}
)
-- | process incomeing 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
)
clientSocks