From b21f71ffc8fd83e7ca76d6fb6fd653d445e4ba78 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 9 Dec 2023 13:58:59 +0100 Subject: [PATCH] restructuring code --- src-server/Main.hs | 33 ++++-------------------------- src-server/Server/Communication.hs | 33 ++++++++++++++++++++++++++++++ src-server/Server/Types.hs | 7 +++++-- src-server/Server/Util.hs | 13 ++++++++++++ wizard-wipeout.cabal | 4 +++- 5 files changed, 58 insertions(+), 32 deletions(-) create mode 100644 src-server/Server/Communication.hs create mode 100644 src-server/Server/Util.hs diff --git a/src-server/Main.hs b/src-server/Main.hs index 1207027..cc4a522 100644 --- a/src-server/Main.hs +++ b/src-server/Main.hs @@ -2,8 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Exception (catch, throwIO) - import Control.Monad.RWS.Strict import qualified Data.ByteString.Char8 as B8 @@ -18,16 +16,12 @@ import Network.Socket as Net import Options.Applicative -import System.Posix.Signals - -import System.Directory - -import System.IO.Error -- internal imports import Library.Types +import Server.Communication import Server.Game import Server.Map (generateArena) import Server.Types @@ -44,21 +38,8 @@ main = do fromString (prettyPrintParseException msg) ) Right (Settings {..}) -> do - let sockAddr = SockAddrUnix setSocketPath - unless (isSupportedSockAddr sockAddr) - (error $ "invalid socket path " <> setSocketPath) - removeIfExists setSocketPath - sock <- socket AF_UNIX Stream 0 - bind sock sockAddr - touchSocket sock - void $ installHandler - keyboardSignal - (CatchOnce $ do - close' sock - removeIfExists setSocketPath - raiseSignal keyboardSignal - ) - Nothing + sock <- bindSocket setSocketPath + dropSocketOnSigint sock Net.listen sock 1024 putStrLn "Bound and listening to socket:" print =<< getSocketName sock @@ -69,7 +50,7 @@ main = do putStrLn "-----------------------------------------------------------------------------------" putStrLn "starting gameā€¦" now <- getCurrentTime - let initRead = ReaderContainer (arenaMap arena) setFPS + let initRead = ReaderContainer (arenaMap arena) setFPS sock initState = StateContainer (arenaSpawners arena) [] (ServerState False False) now (finalState, finalWrite) <- execRWST runGame initRead initState print finalWrite @@ -79,9 +60,3 @@ main = do <> progDesc "Run the \"wizard-wipeout\" Server." <> header "wizard-wipeout - Last Mage standing" ) - -removeIfExists :: FilePath -> IO () -removeIfExists fileName = removeFile fileName `catch` handleExists - where handleExists e - | isDoesNotExistError e = return () - | otherwise = throwIO e diff --git a/src-server/Server/Communication.hs b/src-server/Server/Communication.hs new file mode 100644 index 0000000..811857e --- /dev/null +++ b/src-server/Server/Communication.hs @@ -0,0 +1,33 @@ +module Server.Communication where + +import Control.Monad + +import Network.Socket + +import System.Posix.Signals + +-- internal imports + +import Server.Util + +bindSocket :: FilePath -> IO 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 + pure sock + +dropSocketOnSigint :: Socket -> IO () +dropSocketOnSigint sock = + void $ installHandler + keyboardSignal + (CatchOnce $ do + (SockAddrUnix path) <- getSocketName sock + close' sock + removeIfExists path + raiseSignal keyboardSignal + ) + Nothing diff --git a/src-server/Server/Types.hs b/src-server/Server/Types.hs index 79e5b2a..58095e8 100644 --- a/src-server/Server/Types.hs +++ b/src-server/Server/Types.hs @@ -9,6 +9,8 @@ import Data.Time.Clock import GHC.Generics +import Network.Socket + import Options.Applicative as O import Library.Types @@ -38,8 +40,9 @@ options = Options ) data ReaderContainer = ReaderContainer - { rcMap :: ServerMap - , rcFPS :: Int + { rcMap :: ServerMap + , rcFPS :: Int + , rcSocket :: Socket } deriving (Eq, Show) diff --git a/src-server/Server/Util.hs b/src-server/Server/Util.hs new file mode 100644 index 0000000..57577ce --- /dev/null +++ b/src-server/Server/Util.hs @@ -0,0 +1,13 @@ +module Server.Util where + +import Control.Exception + +import System.Directory + +import System.IO.Error + +removeIfExists :: FilePath -> IO () +removeIfExists fileName = removeFile fileName `catch` handleExists + where handleExists e + | isDoesNotExistError e = return () + | otherwise = throwIO e diff --git a/wizard-wipeout.cabal b/wizard-wipeout.cabal index 29247e9..b3227d9 100644 --- a/wizard-wipeout.cabal +++ b/wizard-wipeout.cabal @@ -44,9 +44,11 @@ executable wizard-wipeout-client executable wizard-wipeout-server import: warnings main-is: Main.hs - other-modules: Server.Game + other-modules: Server.Communication + Server.Game Server.Map Server.Types + Server.Util -- other-extensions: build-depends: base ^>=4.17.2.1 , aeson