{-# LANGUAGE OverloadedStrings #-}

module WebSocketApp (newServerState, ServerState, application) where

import Environment
import Control.Monad.IO.Class
import Control.Arrow (first, second)
import UnliftIO.MVar
import UnliftIO.Exception
import Control.Monad.IO.Unlift
import Control.Monad (foldM)
import Control.Monad.Reader.Class(ask)
import Data.Aeson
import qualified Data.Aeson.TickLeiste as TL
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL(toStrict)
import qualified Data.Map.Strict as M
import Data.Maybe (maybe) -- should be replaced by either
import Data.Either (either)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.TickLeiste as TL
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import qualified Network.WebSockets as WS
import Colog.Message

----------------------------------------------------------------------------------
------------------------ NEVER USE putMVar OR takeMVar ---------------------------
----------------------------------------------------------------------------------

-- if use ask yourself why this warning above me exists, this code relies upon the
-- atomicity of modifyMVar, which is only the case if no one produces MVar. It is
-- realy easy to archive this using putMVar. So not using it will make reasoning
-- about the code much simpler. takeMVar on the other hand may produce deadlocks
-- as an MVar is gone and nobody will produce a new one.
-- putMVar and takeMVar are not evil in general, but it contradicts the way this
-- code uses MVar to synchronize.
-- In theory you could write fine code using them, but then you need to make sure
-- to use them as a pair and mask yourself from asynchronous exceptions. But
-- that is basically a reimplementation of modifyMVar

-- maybe this should be T.Text instead, but right now I try
-- to get away without the need of parsing the request Path
-- in any way. If we need, then we should probably change this to T.Text
type SessionId = B.ByteString

-- we only use the uuids here, because 'WS.WS.Connection' has no Eq, and we need
-- to delete clients
type Client = (U.UUID, WS.Connection)

type SessionState = (TL.TickLeiste, M.Map U.UUID T.Text, [Client], Integer)

type ServerState = M.Map SessionId (MVar SessionState)

clientToText :: Client -> T.Text
clientToText = U.toText . fst
{-# INLINE clientToText #-}

newServerState :: ServerState
newServerState = M.empty

-- shift the PendingConnection parameter outside of EnvM
application :: MVar ServerState ->  EnvM WS.ServerApp
application mvar = do
  r <- ask
  return (runEnvM r . application' mvar)


-- Unlifted WS.withPingThread
withPingThread :: WS.Connection -> Int -> EnvM () -> EnvM a -> EnvM a
withPingThread conn int rep action = withRunInIO $ \run -> WS.withPingThread conn int (run rep) (run action)

application' :: MVar ServerState -> WS.PendingConnection -> EnvM ()
application' ssMV pending = do
  -- maybe we want to check that the Path has a maximum length or something
  let requestPath = WS.requestPath $ WS.pendingRequest pending
  if B.null requestPath
    then do
      -- TODO reject Body should probably not empty...
      -- this may need a better logic
      liftIO $ WS.rejectRequestWith pending WS.defaultRejectRequest
      logWarning "Rejected Client connection"
    else do
      conn <- liftIO $ WS.acceptRequest pending
      withPingThread conn 30 (return ()) $ do
        clientUUID <- liftIO U.nextRandom
        let client = (clientUUID, conn)
        bracket
          (addClient requestPath client ssMV)
          (const $ removeClient requestPath (clientUUID, conn) ssMV)
          (\mvar -> clientLogic client mvar `catch` connectionExceptionHandler client)

connectionExceptionHandler :: Client -> WS.ConnectionException -> EnvM ()
connectionExceptionHandler client WS.ConnectionClosed = logWarning $ "Client(" <> clientToText client <> ") connection died unexpectedly"
connectionExceptionHandler client (WS.CloseRequest w bs) = logInfo $ "Client(" <> clientToText client <> ") requsted to close the Connection with code: " <> T.pack (show w) <> " and reason: " <> T.decodeUtf8 (BL.toStrict bs)
connectionExceptionHandler client (WS.ParseException s)  = logWarning $ "Client(" <> clientToText client <> ") send Garbage: " <> T.pack s
connectionExceptionHandler client (WS.UnicodeException s) = logWarning $ "Client(" <> clientToText client <> ") send invalid unicode: " <> T.pack s

clientLogic :: Client -> MVar SessionState -> EnvM ()
clientLogic client sessionStateMVar = do
  msg <- (liftIO $ WS.receiveData (snd client) :: EnvM B.ByteString)
  maybe
    (logWarning $ "Client(" <> clientToText client <> ") send invalid JSON: " <> T.decodeUtf8 msg)
    -- the next line is a bit ugly, maybe there is a better way?
    -- maybe refactor, so that the request Handler can choose to lock or not. -- TODO
    (\request -> modifyMVar_ sessionStateMVar (\sessionState -> requestHandler client sessionState request))
    -- TODO maybe (hihi) a decodeEithor for better logging?
    (decodeStrict msg :: Maybe TL.JSONRequest)
  clientLogic client sessionStateMVar

requestHandler :: Client -> SessionState -> TL.JSONRequest -> EnvM SessionState
requestHandler conn (tl, pl, cls, sem) (TL.SetPlayerTickR playerUUID tick) = do
  let tl' = TL.setPlayerTick playerUUID tick tl
  broadcastEvent (TL.SetPlayerTickE playerUUID tick) cls
  return (tl', pl, cls, sem)
requestHandler conn (tl, pl, cls, sem) (TL.AddPlayerTickR playerName tick) = do
  playerUUID <- liftIO U.nextRandom
  let tl' = TL.setPlayerTick playerUUID tick tl
      pl' = M.insert playerUUID playerName pl
  broadcastEvent (TL.AddPlayerTickE playerUUID playerName tick) cls
  return (tl', pl', cls, sem)
-- Mayeb this is more efficient if we don't convert back and forth, but the UUID must be
-- added regardless
requestHandler conn (tl, pl, cls, sem) (TL.InitializeTickLeisteR preTickLeiste) = do
  (tl', pl') <- playerNameListToTickLeisteList preTickLeiste
  let tll = tickLeisteListToPlayerList pl tl'
  broadcastEvent (TL.InitializeTickLeisteE tll) cls
  return (TL.fromList tl', pl', cls, sem)

-- TODO
-- Also TickLeisteR must be inside the modifyMVar, because we use the MVar also as a lock, and we can't
-- have changes between reading the TickLeiste and sending the information.
requestHandler conn ss@(tl, pl, cls, sem) TL.TickLeisteR = do
  sendClientEvent (TL.InitializeTickLeisteE $ tickLeisteToPlayerList pl tl) conn
  return ss
requestHandler conn (tl, pl, cls, sem) (TL.ChangeNameR playerUUID playerName) = do
  let pl' = M.insert playerUUID playerName pl
  broadcastEvent (TL.ChangeNameE playerUUID playerName) cls
  return (tl, pl', cls, sem)
requestHandler conn (tl, pl, cls, sem) (TL.RemovePlayerR playerUUID) = do
  let tl' = TL.removePlayer playerUUID tl
      pl' = M.delete playerUUID pl
  broadcastEvent (TL.RemovePlayerE playerUUID) cls
  return (tl', pl', cls, sem)

broadcastEvent :: TL.JSONEvent -> [Client] -> EnvM ()
broadcastEvent event = mapM_ $ sendClientEvent event

sendClientEvent :: TL.JSONEvent -> Client -> EnvM ()
sendClientEvent event client = do
  liftIO $  WS.sendTextData (snd client) ( encode event)
  logDebug $ "Send client: " <> clientToText client <> " Event: " <> (T.pack . show $ event)

-- if you find something better than this ugly stuff ... feel free
tickLeisteListToPlayerList :: M.Map U.UUID T.Text -> [(TL.Tick, [U.UUID])] -> [(TL.Tick, [(U.UUID, T.Text)])]
tickLeisteListToPlayerList pl = fmap (second (fmap (\uuid -> maybe (uuid, unknownPlayerName) (\name -> (uuid, name)) (pl M.!? uuid))))

tickLeisteToPlayerList :: M.Map U.UUID T.Text -> TL.TickLeiste -> [(TL.Tick, [(U.UUID, T.Text)])]
tickLeisteToPlayerList pl = tickLeisteListToPlayerList pl . TL.toList

-- uff good luck reading that
-- maybe it would be better to collect the UUID to Text map in a list and call M.fromList in the end?
playerNameListToTickLeisteList :: [(TL.Tick, [T.Text])] -> EnvM ([(TL.Tick, [U.UUID])], M.Map U.UUID T.Text)
playerNameListToTickLeisteList =
  foldM
    ( \(tl, pl) (tick, plns) -> do
        (tl', pl') <-
          foldM
            ( \(tl, pl) playerName -> do
                playerUUID <- liftIO U.nextRandom
                let tl' = playerUUID : tl
                    pl' = M.insert playerUUID playerName pl
                return (tl', pl')
            )
            ([] :: [U.UUID], pl)
            (reverse plns)
        return ((tick, tl') : tl, pl')
    )
    ([] :: [(TL.Tick, [U.UUID])], M.empty)
    . reverse

unknownPlayerName :: T.Text
unknownPlayerName = "Unknown Player"

-- TODO restructer such that we don't have the logic to add a player twice in this function
addClient :: SessionId -> Client -> MVar ServerState -> EnvM (MVar SessionState)
addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serverState ->
  maybe
    ( do
        let sessionState = (TL.newTickLeiste, M.empty, [client], 1)
        sessionStateMVar <- newMVar sessionState
        let serverState' = M.insert sessionId sessionStateMVar serverState
        logDebug $ "Added TickLeiste: " <> (T.pack . show $  sessionId)
        logInfo $ "Added Client: " <> clientToText client <> " to TickLeiste: " <> (T.pack . show) sessionId
        return (serverState', sessionStateMVar)
    )
    ( \sessionStateMVar -> do
        modifyMVar_ sessionStateMVar (\(tl, p, cls, sem) -> return (tl, p, client : cls, sem + 1))
        logInfo $ "Added Client: " <> clientToText client <> " to TickLeiste " <> (T.pack . show) sessionId
        return (serverState, sessionStateMVar)
    )
    (serverState M.!? sessionId)

removeClient :: SessionId -> Client -> MVar ServerState -> EnvM ()
removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \serverState ->
  maybe
    ( do
        logError "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG"
        return serverState
    )
    ( \sessionStateMVar -> do
        modifyMVar sessionStateMVar $ \(tl, p, cls, sem) -> do
          let sem' = sem - 1
              removedClient = (tl, p, filter ((/= fst client) . fst) cls, sem')
          logDebug $ "Removed Client: " <> clientToText client <> " from TickLeist " <> (T.pack . show) sessionId
          if sem' == 0
            then do
              logDebug $ "Removed TickLeiste: " <> (T.pack . show) sessionId
              return (removedClient, sessionId `M.delete` serverState)

          else return (removedClient, serverState)
    )
    (serverState M.!? sessionId)