{-# LANGUAGE OverloadedStrings #-}

module WebSocketApp (newServerState, ServerState) where

-- Maybe strict MVar?? but then we need NFData instenaces for TickLeiste
import Control.Concurrent.MVar
import Control.Exception
import Data.Aeson.TickLeiste
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Text 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 System.IO

----------------------------------------------------------------------------------
------------------------ 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, [Client], Integer)

type ServerState = M.Map SessionId (MVar SessionState)

newServerState :: ServerState
newServerState = M.empty

application :: MVar ServerState -> WS.ServerApp
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
      WS.rejectRequestWith pending WS.defaultRejectRequest
    else do
      conn <- WS.acceptRequest pending
      WS.withPingThread conn 30 (return ()) $ do
        clientUUID <- U.nextRandom
        bracket
          (addClient requestPath (clientUUID, conn) ssMV)
          (const $ removeClient requestPath (clientUUID, conn) ssMV)
          (eventHandler conn)

eventHandler :: WS.Connection -> MVar SessionState -> IO ()
eventHandler = undefined

addClient :: SessionId -> Client -> MVar ServerState -> IO (MVar SessionState)
addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serverState ->
  maybe
    ( do
        let sessionState = (TL.newTickLeiste, [client], 1)
        sessionStateMVar <- newMVar sessionState
        let serverState' = M.insert sessionId sessionStateMVar serverState
        return (serverState', sessionStateMVar)
    )
    ( \sessionStateMVar -> do
        modifyMVar_ sessionStateMVar (\(tl, cls, sem) -> return (tl, client : cls, sem + 1))
        return (serverState, sessionStateMVar)
    )
    (serverState M.!? sessionId)

removeClient :: SessionId -> Client -> MVar ServerState -> IO ()
removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \serverState ->
  maybe
    ( do
        hPutStrLn stderr "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG"
        return serverState
    )
    ( \sessionStateMVar -> do
        modifyMVar sessionStateMVar $ \(tl, cls, sem) -> do
          let sem' = sem - 1
              removedClient = (tl, filter ((/= fst client) . fst) cls, sem')
          if sem - 1 == 0
            then return (removedClient, sessionId `M.delete` serverState)
            else do
              return (removedClient, serverState)
    )
    (serverState M.!? sessionId)