restructuring code

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
+      sock <- bindSocket setSocketPath
-      unless (isSupportedSockAddr sockAddr)
+      dropSocketOnSigint sock
-        (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
       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

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

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
+  { rcMap    :: ServerMap
-  , rcFPS :: Int
+  , rcFPS    :: Int
+  , rcSocket :: Socket
   }
   deriving (Eq, Show)
 

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

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