{-# LANGUAGE TemplateHaskell, TypeOperators, OverloadedStrings #-}

{- | Rooms
   * Rooms are places where users can chat.
   * Rooms have a name and a title, they also store the conversation log and who is in the room and what their permissions are.
   * A user permission for a room can either be Normal or Admin. A Normal user can send and receive messages written in the room,
     An Admin can invite or accept new users to the room, change their permissions or change the room title.

There are a few default rooms to convey messages to the user, such as "Errors" room.


Type from Types.hs:

data Room = Room
  { _rName  :: T.Text
  , _rTitle :: T.Text
  , _rList  :: [(User, Permission)]
  , _rLog   :: [LogMsg]
  }


-}

module Rooms where


import Data.Monoid ((<>))
import Data.List (delete, deleteBy)
import Data.Function (on)
import qualified Data.Text.IO as T
import qualified Data.Text as T

import qualified Control.Monad.STM as STM
import qualified Control.Concurrent.STM as STM

import Types
import Utils
import qualified Handler as H

import Data.Label as Lens


data MsgIn
  = SendMessage Message
  | AddUser User Permission Name
  | RemUser User Name
  | NewRoom User Name

data MsgOut
  = SendMessage' [User] Message
  deriving Show


data Err
  = RoomNotFound Name
  | RoomExists Room
  | UserExists User Room
  | UserNotFound User Room

printErr :: Err -> T.Text
printErr = \case
  RoomNotFound r -> "Room '" <> r <> "' not found."
  RoomExists r   -> "Room '" <> _rName r <> "' already exists."
  UserExists u r -> "User '" <> _uName u <> "' already exists in room " <> _rName r <> "."
  UserNotFound u r -> "User '" <> _uName u <> "' note found in room " <> _rName r <> "."

type Rooms = [Room]


newRoom :: User -> Name -> Rooms -> Either Err Rooms
newRoom user room rooms =
  case filter ((== room) . _rName) rooms of
    [r] ->
      throwErr (RoomExists r)
    _ ->
      pure (Room room mempty [(user,Admin)] mempty : rooms)


addUser :: User -> Permission -> Name -> Rooms -> Either Err Rooms
addUser user perm room rooms =
  case filter ((== room) . _rName) rooms of
    [r] ->
      case lookup user (_rList r) of
        Just _ -> throwErr (UserExists user r)
        Nothing -> pure $ (Lens.modify rList ((user, perm):) r : delete r rooms)
    _ ->
      throwErr (RoomNotFound room)

remUser :: User -> Name -> Rooms -> Either Err Rooms
remUser user room rooms =
  case filter ((== room) . _rName) rooms of
    [r] ->
      case lookup user (_rList r) of
        Nothing -> throwErr (UserNotFound user r)
        Just _  -> pure $ (Lens.modify rList (deleteBy (on (==) (_uName . fst)) (user, undefined)) r : delete r rooms)
    _ ->
      throwErr (RoomNotFound room)

sendMessage :: Message -> Rooms -> Either Err ([User], Rooms)
sendMessage m@Message{..} rooms =
  case filter ((== _mRoom) . _rName) rooms of
    [r] ->
      pure (map fst $ _rList r, Lens.modify rLog (msgToLogMsg m:) r : delete r rooms)

    _ ->
      throwErr (RoomNotFound _mRoom)

type RoomsHandler = H.Handler MsgIn

new :: STM.TVar Rooms -> STM.TQueue MsgOut -> IO RoomsHandler
new statevar = H.newHandler statevar inHandler outHandler

{- | inHandler

resposible on getting messages from inside the application and handle them
-}

inHandler :: STM.TVar Rooms -> STM.TQueue MsgIn -> IO [MsgOut]
inHandler rooms input = do
  action <- STM.atomically $ do
    action <- STM.readTQueue input
    case action of
      SendMessage msg ->
        sendMessageSTM msg rooms
  
      AddUser user perm room ->
        addUserSTM user perm room rooms
  
      RemUser user room ->
        remUserSTM user room rooms
  
      NewRoom user room ->
        newRoomSTM user room rooms

  action

sendMessageSTM :: Message -> STM.TVar Rooms -> STM.STM (IO [MsgOut])
sendMessageSTM msg rs = do
  rooms <- STM.readTVar rs
  case sendMessage msg rooms of 
    Right (users, rooms') -> do
      STM.writeTVar rs rooms'
      pure $ do
        T.putStrLn ("Message Sent.\n  " <> T.pack (show msg))
        pure [SendMessage' users msg]
    Left err -> do
      pure $ T.putStrLn ("Error when sending message: " <> printErr err) >> pure []

addUserSTM :: User -> Permission -> Name -> STM.TVar Rooms -> STM.STM (IO [MsgOut])
addUserSTM user perm room rs = do
  rooms <- STM.readTVar rs
  case addUser user perm room rooms of
    Right rooms' -> do
      STM.writeTVar rs rooms'
      pure $ T.putStrLn ("User '" <> _uName user <> "' added to " <> room <> ".\n  ") >> pure []
    Left err -> do
      pure $ T.putStrLn ("Error when adding new user: " <> printErr err) >> pure []

remUserSTM :: User -> Name -> STM.TVar Rooms -> STM.STM (IO [MsgOut])
remUserSTM user room rs = do
  rooms <- STM.readTVar rs
  case remUser user room rooms of
    Right rooms' -> do
      STM.writeTVar rs rooms'
      pure $ T.putStrLn ("User '" <> _uName user <> "' removed from " <> room <> ".\n  ") >> pure []
    Left err -> do
      pure $ T.putStrLn ("Error when removing user: " <> printErr err) >> pure []

newRoomSTM :: User -> Name -> STM.TVar Rooms -> STM.STM (IO [MsgOut])
newRoomSTM user room rs = do
  rooms <- STM.readTVar rs
  case newRoom user room rooms of
    Right rooms' -> do
      STM.writeTVar rs rooms'
      pure $ T.putStrLn ("User '" <> _uName user <> "' created room " <> room <> ".\n  ") >> pure []
    Left err -> do
      pure $ T.putStrLn ("Error when removing user: " <> printErr err) >> pure []



{- | outHandler

This part gets the messages that needs to be sent and sends them.

-- MsgOut should be changed to `Either Err MsgOut` to report failures as well

-}

outHandler :: STM.TQueue MsgOut -> STM.TQueue MsgOut -> IO ()
outHandler input output = STM.atomically $ do
  STM.writeTQueue output =<< STM.readTQueue input