{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}

module Main where

import Network
import IO
import System.IO
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (handle, finally, Exception, IOException)
import Control.Monad
import Maybe (fromMaybe, isJust, fromJust)
import Data.List
import Miscutils
import HWProto
import Opts
import Data.Time

#if !defined(mingw32_HOST_OS)
import System.Posix
#endif


data Messages =
	Accept ClientInfo
	| ClientMessage ([String], ClientInfo)
	| CoreMessage [String]
	| TimerTick

messagesLoop :: TChan [String] -> IO()
messagesLoop messagesChan = forever $ do
	threadDelay (25 * 10^6) -- 25 seconds
	atomically $ writeTChan messagesChan ["PING"]

timerLoop :: TChan [String] -> IO()
timerLoop messagesChan = forever $ do
	threadDelay (60 * 10^6) -- 60 seconds
	atomically $ writeTChan messagesChan ["MINUTELY"]

acceptLoop :: Socket -> TChan ClientInfo -> IO ()
acceptLoop servSock acceptChan =
	Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $
	do
	(cHandle, host, _) <- accept servSock
	
	currentTime <- getCurrentTime
	putStrLn $ (show currentTime) ++ " new client: " ++ host
	
	cChan <- atomically newTChan
	sendChan <- atomically newTChan
	forkIO $ clientRecvLoop cHandle cChan
	forkIO $ clientSendLoop cHandle cChan sendChan
	
	atomically $ writeTChan acceptChan (ClientInfo cChan sendChan cHandle host currentTime "" 0 "" False False False)
	atomically $ writeTChan cChan ["ASKME"]
	acceptLoop servSock acceptChan


listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
listenLoop handle buf chan = do
	str <- hGetLine handle
	if str == "" then do
		atomically $ writeTChan chan buf
		listenLoop handle [] chan
		else
		listenLoop handle (buf ++ [str]) chan


clientRecvLoop :: Handle -> TChan [String] -> IO ()
clientRecvLoop handle chan =
	listenLoop handle [] chan
		`catch` (\e -> (clientOff $ show e) >> return ())
	where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message

clientSendLoop :: Handle -> TChan[String] -> TChan[String] -> IO()
clientSendLoop handle clChan chan = do
	answer <- atomically $ readTChan chan
	doClose <- Control.Exception.handle
		(\(e :: Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do
		forM_ answer (\str -> hPutStrLn handle str)
		hPutStrLn handle ""
		hFlush handle
		return $ isQuit answer

	if doClose then
		Control.Exception.handle (\(_ :: Exception) -> putStrLn "error on hClose") $ hClose handle
		else
		clientSendLoop handle clChan chan

	where
		sendQuit e = atomically $ writeTChan clChan ["QUIT", show e]
		isQuit answer = head answer == "BYE"

sendAnswers  [] _ clients _ = return clients
sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
	let recipients = handlesFunc client clients rooms
	--unless (null recipients) $ putStrLn ("< " ++ (show answer))
	when (head answer == "NICK") $ putStrLn (show answer)

	clHandles' <- forM recipients $
		\ch ->
			do
			atomically $ writeTChan (sendChan ch) answer
			if head answer == "BYE" then return [ch] else return []

	let outHandles = concat clHandles'
	unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer))

	let mclients = deleteFirstsBy (==) clients outHandles

	sendAnswers answers client mclients rooms


reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
reactCmd serverInfo cmd client clients rooms = do
	--putStrLn ("> " ++ show cmd)

	let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd
	let mrooms = roomsFunc rooms
	let mclients = (clientsFunc clients)
	let mclient = fromMaybe client $ find (== client) mclients
	let answers = map (\x -> x serverInfo) answerFuncs

	clientsIn <- sendAnswers answers mclient mclients mrooms
	mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn
	
	return (clientsIn, mrooms)


mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
mainLoop serverInfo acceptChan messagesChan clients rooms = do
	r <- atomically $
		(Accept `fmap` readTChan acceptChan) `orElse`
		(ClientMessage `fmap` tselect clients) `orElse`
		(CoreMessage `fmap` readTChan messagesChan)
	
	case r of
		Accept ci -> do
			let sameHostClients = filter (\cl -> host ci == host cl) clients
			let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients
			
			when haveJustConnected $ do
				atomically $ do
					writeTChan (chan ci) ["QUIT", "Reconnected too fast"]

			currentTime <- getCurrentTime
			let newServerInfo = serverInfo{
					loginsNumber = loginsNumber serverInfo + 1,
					lastHourUsers = currentTime : lastHourUsers serverInfo
					}
			mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms
			
		ClientMessage (cmd, client) -> do
			(clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms
			
			let hadRooms = (not $ null rooms) && (null mrooms)
				in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
		
		CoreMessage msg -> case msg of
			["PING"] ->
				if not $ null $ clients then
					do
					let client = head clients -- don't care
					(clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
					mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
				else
					mainLoop serverInfo acceptChan messagesChan clients rooms
			["MINUTELY"] -> do
				currentTime <- getCurrentTime
				let newServerInfo = serverInfo{
						lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo
						}
				mainLoop newServerInfo acceptChan messagesChan clients rooms

startServer :: ServerInfo -> Socket -> IO()
startServer serverInfo serverSocket = do
	acceptChan <- atomically newTChan
	forkIO $ acceptLoop serverSocket acceptChan
	
	messagesChan <- atomically newTChan
	forkIO $ messagesLoop messagesChan
	forkIO $ timerLoop messagesChan

	mainLoop serverInfo acceptChan messagesChan [] []


main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
	installHandler sigPIPE Ignore Nothing;
#endif
	serverInfo <- getOpts $ newServerInfo
	
	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
	serverSocket <- listenOn $ PortNumber (listenPort serverInfo)
	
	startServer serverInfo serverSocket `finally` sClose serverSocket