make enums crash-safe. and other fixes
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
module Main where
import qualified Control.Exception as Exception
import System.IO
import System.Log.Logger
import qualified Data.ConfigFile as CF
import Control.Monad.Error
import System.Directory
import Control.Monad.State
import Control.Concurrent.Chan
import Control.Concurrent
import Network
import Network.BSD
import Network.Socket hiding (recv)
import Network.Socket.ByteString
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BW
import qualified Codec.Binary.Base64 as Base64
import System.Process
import Data.Maybe
import qualified Data.List as L
#if !defined(mingw32_HOST_OS)
import System.Posix
#endif
readInt_ :: (Num a) => B.ByteString -> a
readInt_ str =
case B.readInt str of
Just (i, t) | B.null t -> fromIntegral i
_ -> 0
data Message = Packet [B.ByteString]
| CheckFailed B.ByteString
| CheckSuccess [B.ByteString]
deriving Show
serverAddress = "netserver.hedgewars.org"
protocolNumber = "47"
getLines :: Handle -> IO [B.ByteString]
getLines h = g
where
g = do
l <- liftM Just (B.hGetLine h) `Exception.catch` (\(_ :: Exception.IOException) -> return Nothing)
if isNothing l then
return []
else
do
lst <- g
return $ fromJust l : lst
engineListener :: Chan Message -> Handle -> String -> IO ()
engineListener coreChan h fileName = do
stats <- liftM (ps . L.dropWhile (not . start)) $ getLines h
debugM "Engine" $ show stats
if null stats then
writeChan coreChan $ CheckFailed "No stats msg"
else
writeChan coreChan $ CheckSuccess stats
removeFile fileName
where
start = flip L.elem ["WINNERS", "DRAW"]
ps ("DRAW" : bs) = "DRAW" : ps bs
ps ("WINNERS" : n : bs) = let c = readInt_ n in "WINNERS" : n : take c bs ++ (ps $ drop c bs)
ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) =
"ACHIEVEMENT" : typ : teamname : location : value : ps bs
ps _ = []
checkReplay :: Chan Message -> [B.ByteString] -> IO ()
checkReplay coreChan msgs = do
tempDir <- getTemporaryDirectory
(fileName, h) <- openBinaryTempFile tempDir "checker-demo"
B.hPut h . BW.pack . concat . map (fromMaybe [] . Base64.decode . B.unpack) $ msgs
hFlush h
hClose h
(_, _, Just hOut, _) <- createProcess (proc "/usr/home/unC0Rr/Sources/Hedgewars/Releases/0.9.20/bin/hwengine"
[fileName
, "--user-prefix", "/usr/home/unC0Rr/.hedgewars"
, "--prefix", "/usr/home/unC0Rr/Sources/Hedgewars/Releases/0.9.20/share/hedgewars/Data"
, "--nomusic"
, "--nosound"
, "--stats-only"
])
{std_err = CreatePipe}
hSetBuffering hOut LineBuffering
void $ forkIO $ engineListener coreChan hOut fileName
takePacks :: State B.ByteString [[B.ByteString]]
takePacks = do
modify (until (not . B.isPrefixOf pDelim) (B.drop 2))
packet <- state $ B.breakSubstring pDelim
buf <- get
if B.null buf then put packet >> return [] else
if B.null packet then return [] else do
packets <- takePacks
return (B.splitWith (== '\n') packet : packets)
where
pDelim = "\n\n"
recvLoop :: Socket -> Chan Message -> IO ()
recvLoop s chan =
((receiveWithBufferLoop B.empty >> return "Connection closed")
`Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e)
)
>>= disconnected
where
disconnected msg = writeChan chan $ Packet ["BYE", msg]
receiveWithBufferLoop recvBuf = do
recvBS <- recv s 4096
unless (B.null recvBS) $ do
let (packets, newrecvBuf) = runState takePacks $ B.append recvBuf recvBS
forM_ packets sendPacket
receiveWithBufferLoop $ B.copy newrecvBuf
sendPacket packet = writeChan chan $ Packet packet
session :: B.ByteString -> B.ByteString -> Socket -> IO ()
session l p s = do
noticeM "Core" "Connected"
coreChan <- newChan
forkIO $ recvLoop s coreChan
forever $ do
p <- readChan coreChan
case p of
Packet p -> do
debugM "Network" $ "Recv: " ++ show p
onPacket coreChan p
CheckFailed msg -> do
warningM "Check" "Check failed"
answer ["CHECKED", "FAIL", msg]
answer ["READY"]
CheckSuccess msgs -> do
warningM "Check" "Check succeeded"
answer ("CHECKED" : "OK" : msgs)
answer ["READY"]
where
answer :: [B.ByteString] -> IO ()
answer p = do
debugM "Network" $ "Send: " ++ show p
sendAll s $ B.unlines p `B.snoc` '\n'
onPacket :: Chan Message -> [B.ByteString] -> IO ()
onPacket _ ("CONNECTED":_) = do
answer ["CHECKER", protocolNumber, l, p]
onPacket _ ["PING"] = answer ["PONG"]
onPacket _ ["LOGONPASSED"] = answer ["READY"]
onPacket chan ("REPLAY":msgs) = do
checkReplay chan msgs
warningM "Check" "Started check"
onPacket _ ("BYE" : xs) = error $ show xs
onPacket _ _ = return ()
main :: IO ()
main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
installHandler sigPIPE Ignore Nothing
installHandler sigCHLD Ignore Nothing
#endif
updateGlobalLogger "Core" (setLevel DEBUG)
updateGlobalLogger "Network" (setLevel WARNING)
updateGlobalLogger "Check" (setLevel DEBUG)
updateGlobalLogger "Engine" (setLevel DEBUG)
Right (login, password) <- runErrorT $ do
d <- liftIO $ getHomeDirectory
conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/settings.ini"
l <- CF.get conf "net" "nick"
p <- CF.get conf "net" "passwordhash"
return (B.pack l, B.pack p)
Exception.bracket
setupConnection
(\s -> noticeM "Core" "Shutting down" >> sClose s)
(session login password)
where
setupConnection = do
noticeM "Core" "Connecting to the server..."
proto <- getProtocolNumber "tcp"
let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
(addr:_) <- getAddrInfo (Just hints) (Just serverAddress) Nothing
let (SockAddrInet _ host) = addrAddress addr
sock <- socket AF_INET Stream proto
connect sock (SockAddrInet 46631 host)
return sock