open a socket properly

This commit is contained in:
nek0 2023-12-09 13:24:33 +01:00
parent d109583d66
commit 7a01a2a601
2 changed files with 30 additions and 10 deletions

View file

@ -2,6 +2,8 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Exception (catch, throwIO)
import Control.Monad.RWS.Strict
import qualified Data.ByteString.Char8 as B8
@ -12,10 +14,16 @@ import Data.Time
import Data.Yaml
import Network.Socket
import Network.Socket as Net
import Options.Applicative
import System.Posix.Signals
import System.Directory
import System.IO.Error
-- internal imports
import Library.Types
@ -39,15 +47,19 @@ main = do
let sockAddr = SockAddrUnix setSocketPath
unless (isSupportedSockAddr sockAddr)
(error $ "invalid socket path " <> setSocketPath)
let hints = defaultHints
{ addrFamily = AF_UNIX
, addrSocketType = Stream
, addrAddress = sockAddr
}
addr <- head <$> getAddrInfo (Just hints) Nothing Nothing
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
bind sock (addrAddress addr)
putStrLn "Bound to socket:"
removeIfExists setSocketPath
sock <- socket AF_UNIX Stream 0
bind sock sockAddr
touchSocket sock
void $ installHandler
keyboardSignal
(CatchOnce $ do
close' sock
removeIfExists setSocketPath
)
Nothing
Net.listen sock 1024
putStrLn "Bound and listening to socket:"
print =<< getSocketName sock
putStrLn "-----------------------------------------------------------------------------------"
arena <- generateArena setMapRows setMapColumns setSpawnerProbability
@ -66,3 +78,9 @@ 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

View file

@ -51,6 +51,7 @@ executable wizard-wipeout-server
build-depends: base ^>=4.17.2.1
, aeson
, bytestring
, directory
, linear
, matrix
, monad-loops
@ -60,6 +61,7 @@ executable wizard-wipeout-server
, text
, time
, random
, unix
, wizard-wipeout
, yaml
hs-source-dirs: src-server