1 {-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}

     2 module Main where

     3 

     4 import qualified Control.Exception as Exception

     5 import System.IO

     6 import System.Log.Logger

     7 import qualified Data.ConfigFile as CF

     8 import Control.Monad.Error

     9 import System.Directory

    10 import Control.Monad.State

    11 import Control.Concurrent.Chan

    12 import Control.Concurrent

    13 import Network

    14 import Network.BSD

    15 import Network.Socket hiding (recv)

    16 import Network.Socket.ByteString

    17 import qualified Data.ByteString.Char8 as B

    18 #if !defined(mingw32_HOST_OS)

    19 import System.Posix

    20 #endif

    21 

    22 data Message = Packet [B.ByteString]

    23     deriving Show

    24 

    25 protocolNumber = "43"

    26 

    27 takePacks :: State B.ByteString [[B.ByteString]]

    28 takePacks = do

    29     modify (until (not . B.isPrefixOf pDelim) (B.drop 2))

    30     packet <- state $ B.breakSubstring pDelim

    31     buf <- get

    32     if B.null buf then put packet >> return [] else

    33         if B.null packet then return [] else do

    34             packets <- takePacks

    35             return (B.splitWith (== '\n') packet : packets)

    36     where

    37     pDelim = "\n\n"

    38 

    39 

    40 recvLoop :: Socket -> Chan Message -> IO ()

    41 recvLoop s chan =

    42         ((receiveWithBufferLoop B.empty >> return "Connection closed")

    43             `Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e)

    44         )

    45         >>= disconnected

    46     where

    47         disconnected msg = writeChan chan $ Packet ["BYE", msg]

    48         receiveWithBufferLoop recvBuf = do

    49             recvBS <- recv s 4096

    50             unless (B.null recvBS) $ do

    51                 let (packets, newrecvBuf) = runState takePacks $ B.append recvBuf recvBS

    52                 forM_ packets sendPacket

    53                 receiveWithBufferLoop $ B.copy newrecvBuf

    54 

    55         sendPacket packet = writeChan chan $ Packet packet

    56 

    57 

    58 session :: B.ByteString -> B.ByteString -> Socket -> IO ()

    59 session l p s = do

    60     noticeM "Core" "Connected"

    61     coreChan <- newChan

    62     forkIO $ recvLoop s coreChan

    63     forever $ do

    64         p <- readChan coreChan

    65         case p of

    66             Packet p -> do

    67                 debugM "Network" $ "Recv: " ++ show p

    68                 onPacket p

    69     where

    70     answer :: [B.ByteString] -> IO ()

    71     answer p = do

    72         debugM "Network" $ "Send: " ++ show p

    73         sendAll s $ B.unlines p `B.snoc` '\n'

    74     onPacket :: [B.ByteString] -> IO ()

    75     onPacket ("CONNECTED":_) = answer ["CHECKER", protocolNumber, l, p]

    76     onPacket ["PING"] = answer ["PONG"]

    77     onPacket ("BYE" : xs) = error $ show xs

    78     onPacket _ = return ()

    79 

    80 

    81 main :: IO ()

    82 main = withSocketsDo $ do

    83 #if !defined(mingw32_HOST_OS)

    84     installHandler sigPIPE Ignore Nothing;

    85 #endif

    86 

    87     updateGlobalLogger "Core" (setLevel DEBUG)

    88     updateGlobalLogger "Network" (setLevel DEBUG)

    89 

    90     Right (login, password) <- runErrorT $ do

    91         d <- liftIO $ getHomeDirectory

    92         conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/hedgewars.ini"

    93         l <- CF.get conf "net" "nick"

    94         p <- CF.get conf "net" "passwordhash"

    95         return (B.pack l, B.pack p)

    96 

    97 

    98     Exception.bracket

    99         setupConnection

   100         (\s -> noticeM "Core" "Shutting down" >> sClose s)

   101         (session login password)

   102     where

   103         setupConnection = do

   104             noticeM "Core" "Connecting to the server..."

   105 

   106             proto <- getProtocolNumber "tcp"

   107             let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }

   108             (addr:_) <- getAddrInfo (Just hints) (Just serverAddress) Nothing

   109             let (SockAddrInet _ host) = addrAddress addr

   110             sock <- socket AF_INET Stream proto

   111             connect sock (SockAddrInet 46631 host)

   112             return sock

   113 

   114         serverAddress = "netserver.hedgewars.org"