{-# LANGUAGE OverloadedStrings #-}

module Quoridor.Cmdline.Network.Server
  ( hostServer
  ) where

import           Control.Concurrent              (forkFinally, forkIO,
                                                  threadDelay)
import           Control.Exception               (bracket)
import           Control.Monad                   (filterM, forM_, forever,
                                                  unless, when, zipWithM)
import           Control.Monad.Reader            (ask)
import           Control.Monad.State             (MonadIO, get, liftIO)
import qualified Data.ByteString                 as B
import           Data.Functor                    (void)
import           Data.List                       (find)
import           Data.Maybe                      (fromJust, isNothing)
import           System.Directory                (getCurrentDirectory)
import           System.IO                       (Handle, hClose, hFlush)
import           System.Process                  (runInteractiveCommand,
                                                  terminateProcess)

import           Control.Concurrent.Async        (race)
import           Control.Concurrent.MVar         (MVar, newEmptyMVar, putMVar,
                                                  takeMVar)
import           Control.Concurrent.STM          (STM, TChan, TVar, atomically,
                                                  modifyTVar, newTChanIO,
                                                  newTVarIO, readTChan,
                                                  readTVar, writeTChan)
import           Network.Simple.TCP              (HostPreference (Host),
                                                  Socket, accept, listen)
import qualified Network.WebSockets              as WS
import qualified Network.WebSockets.Snap         as WS
import qualified Snap.Core                       as Snap
import qualified Snap.Http.Server                as Snap
import qualified Snap.Util.FileServe             as Snap
import           System.FilePath                 ((</>))
import           Text.Printf                     (printf)

import           Paths_quoridor_hs               (getDataDir)
import           Quoridor
import           Quoridor.Cmdline.Messages
import           Quoridor.Cmdline.Network.Common

type PChans = TVar [TChan Message]
type GameChan = TChan (Color, Turn)

-- | Given a port, hosts a game server that listens
-- on the given port.
-- This isn't optimal. If a player keeps on connecting and
-- disconnecting, there's no limit to the depth of the stack that is
-- possible here.
hostServer :: Int -> Int -> Game IO ()
hostServer quoriHostPort httpPort = do
  liftIO $ forkIO $ httpListen quoriHostPort httpPort
  listen (Host "127.0.0.1") (show quoriHostPort) $
    \(lstnSock, _) -> do
      gc <- ask
      gameChan <- liftIO newTChanIO
      playerChans <- liftIO $ newTVarIO []

      let
        getPlayers 0 socks = do
          coSocks <- filterM isAliveSock socks
          if length coSocks /= length socks
            then do
              let playersLeft = length socks - length coSocks
                  msg = printf "Some players were disconnected. \
                                   \Waiting for %d more. "
                    playersLeft
              liftIO $ putStrLn msg
              liftIO $ forM_ coSocks $ sendMsg $ WaitMsg msg
              getPlayers playersLeft coSocks
            else do
              let colors = map toEnum [0..]
              doneConnPs <- liftIO $
                zipWithM (handleClient gameChan playerChans) socks colors
              let connPs = map snd doneConnPs
              let dones = map fst doneConnPs
              forM_ connPs $ \p ->
                sendToPlayer (FstGameMsg gc (coplColor p)) p

              handleGame gameChan connPs
              -- Allow 10 seconds for the clients to shutdown
              void $ liftIO $ race (threadDelay $ 10 * 1000 * 1000)
                                   (mapM_ takeMVar dones)

        getPlayers n socks = accept lstnSock $ \(connSock, _) -> do
          let msg = if n - 1 > 0
                then printf "Waiting for %d more player(s)." $ n - 1
                else "Everyone connected. Rechecking connections..."
          liftIO $ putStrLn msg
          sendMsg (WaitMsg msg) connSock
          getPlayers (n-1) $ connSock : socks

      getPlayers (numOfPlayers gc) []

handleClient :: GameChan -> PChans -> Socket ->
                Color -> IO (MVar (), ConnPlayer)
handleClient gameChan playerChans sock col = do
  chan <- newTChanIO
  atomically $ modifyTVar playerChans (chan :)
  done <- newEmptyMVar
  let action = race (handleMsgSend chan sock)
                    (handleClientInput gameChan playerChans col sock)
      finally _ = putMVar done ()
  forkFinally action finally
  return (done, ConnPlayer chan col)

handleGame :: GameChan -> [ConnPlayer] -> Game IO ()
handleGame gameChan connPs = go msgInitialTurn
 where
  go msg = do
    gs <- get
    vm <- getCurrentValidMoves
    liftIO $ atomically $
      broadcast (GameMsg gs vm msg) $ map coplChan connPs
    when (isNothing $ winner gs) $ do
      let currColor = color $ currP gs
          currConnP = fromJust $ find ((currColor ==) . coplColor) connPs
          getTurnOfCurrP = do
            (col, turn) <- atomically $ readTChan gameChan
            if col == currColor then return turn
                                  else getTurnOfCurrP
          execValidTurn = do
            turn <- liftIO getTurnOfCurrP
            let reAskForInput msg' = do sendToPlayer (GameMsg gs vm msg')
                                                     currConnP
                                        execValidTurn
            makeTurn turn >>= maybe (reAskForInput msgInvalidTurn)
                                    return
      turn <- execValidTurn
      go $ msgValidTurn currColor turn

sendToPlayer :: MonadIO m => Message -> ConnPlayer -> m ()
sendToPlayer msg cnp = liftIO $ atomically $ writeTChan (coplChan cnp) msg

-- | The error message will appear only if the current player exits.
-- To handle the case where other players will exit I'll have to rewrite the whole
-- mechanism to be asynchronous between players.
{-recvFromPlayer :: (Functor m, MonadIO m) => ConnPlayer -> m String-}
{-recvFromPlayer cnp = fromMaybe throwErr <$> recvFromSock (coplSock cnp)-}
  {-where throwErr = error $ "Lost connection with " ++ show (coplColor cnp)-}

handleMsgSend :: TChan Message -> Socket -> IO ()
handleMsgSend chan sock = do
  msg <- atomically $ readTChan chan
  sendMsg msg sock
  handleMsgSend chan sock

handleClientInput :: GameChan -> PChans -> Color -> Socket -> IO ()
handleClientInput gameChan playerChans col sock = go
 where
  go = do
    msg <- recvMsg sock
    atomically $ case msg of
      chatMsg@(ChatMsg _ _) -> readTVar playerChans >>= broadcast chatMsg
      TurnMsg turn          -> writeTChan gameChan (col, turn)
      _ -> error "handleClientInput - unexpected Message"
    go

broadcast :: Message -> [TChan Message] -> STM ()
broadcast msg playerChans = forM_ playerChans $ flip writeTChan msg


-- Web interface

httpListen :: Int -> Int -> IO ()
httpListen quoriHostPort httpPort = do
  putStrLn "Http server: "
  Snap.httpServe config $ app quoriHostPort
 where
  config = Snap.setPort httpPort $
           Snap.setErrorLog  Snap.ConfigNoLog $
           Snap.setAccessLog Snap.ConfigNoLog
           Snap.defaultConfig
  app :: Int -> Snap.Snap ()
  app port = do
    dataDir <- liftIO getDataDir
    Snap.route
      [ ("",           Snap.ifTop $ Snap.serveFile $ dataDir </> "console.html")
      , ("console.js", Snap.serveFile $ dataDir </> "console.js")
      , ("style.css",  Snap.serveFile $ dataDir </> "style.css")
      , ("play",       acceptWSPlayer port)
      ]

acceptWSPlayer :: Int -> Snap.Snap ()
acceptWSPlayer port = WS.runWebSocketsSnap $ \pending ->
  do
    dir <- getCurrentDirectory
    let cmd = dir </> "quoridor-exec -p " ++ show port
    putStrLn cmd

    let acqRsrc = do
          (hIn, hOut, _, ph) <- runInteractiveCommand cmd
          conn <- WS.acceptRequest pending
          return (hIn, hOut, ph, conn)
        freeRsrc (hIn, hOut, ph, _) = do
          hClose hIn
          hClose hOut
          terminateProcess ph
    bracket acqRsrc freeRsrc $
      \(hIn,hOut,_,conn) -> race (copyHandleToConn hOut conn) (copyConnToHandle conn hIn)

    return ()

copyHandleToConn :: Handle -> WS.Connection -> IO ()
copyHandleToConn h c = do
  bs <- B.hGetSome h 4096
  unless (B.null bs) $ do
    putStrLn $ previewStr $ "WS > " ++ show bs
    WS.sendTextData c bs
    copyHandleToConn h c
 where

copyConnToHandle :: WS.Connection -> Handle -> IO ()
copyConnToHandle c h = forever $ do
  bs <- WS.receiveData c
  putStrLn $ previewStr $ "WS < " ++ show bs
  B.hPutStr h bs
  hFlush h

previewStr :: String -> String
previewStr str = prvw ++ if not $ null rst then "....."
                                        else ""
 where (prvw, rst) = splitAt 80 str