--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/OfficialServer/checker.hs	Sat Feb 02 00:33:27 2013 +0400
@@ -0,0 +1,114 @@
+{-# 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
+#if !defined(mingw32_HOST_OS)
+import System.Posix
+#endif
+
+data Message = Packet [B.ByteString]
+    deriving Show
+
+protocolNumber = "43"
+
+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 p
+    where
+    answer :: [B.ByteString] -> IO ()
+    answer p = do
+        debugM "Network" $ "Send: " ++ show p
+        sendAll s $ B.unlines p `B.snoc` '\n'
+    onPacket :: [B.ByteString] -> IO ()
+    onPacket ("CONNECTED":_) = answer ["CHECKER", protocolNumber, l, p]
+    onPacket ["PING"] = answer ["PONG"]
+    onPacket ("BYE" : xs) = error $ show xs
+    onPacket _ = return ()
+
+
+main :: IO ()
+main = withSocketsDo $ do
+#if !defined(mingw32_HOST_OS)
+    installHandler sigPIPE Ignore Nothing;
+#endif
+
+    updateGlobalLogger "Core" (setLevel DEBUG)
+    updateGlobalLogger "Network" (setLevel DEBUG)
+
+    Right (login, password) <- runErrorT $ do
+        d <- liftIO $ getHomeDirectory
+        conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/hedgewars.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
+
+        serverAddress = "netserver.hedgewars.org"