-- xxx: set the sizes for the hPane children to something reasonable

import System.Environment ( getArgs )

import Control.Monad ( forever, when, forM, forM_ )
import Control.Monad.Trans ( liftIO )
import Control.Monad.Reader ( ReaderT, runReaderT, asks, ask )
import Control.Concurrent ( forkIO )
import Control.Concurrent.STM ( atomically )
import Control.Concurrent.STM.TVar ( newTVar, readTVar, writeTVar, TVar )

import qualified Data.Map as Map

import Network.Socket
import Network.Chat.Protocol
import Network.Chat.Parse ( parseServerMessage )

import Graphics.UI.Gtk hiding ( Socket, get )
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk.Gdk.Events

-- |A tab in the message interface, containing references to messaging
-- widgets and the name of the user involved.
data UserTab = UserTab { tabMessageView :: TextView
                       , tabMessageInput :: Entry
                       , tabUsername :: Username
                       }

-- |The user-to-tab mapping maintained by the client.
type UserTabMap = Map.Map Username UserTab

-- |The graphical interface, and the parts of it that need to be
-- accessed.
data Interface = Interface { mainWindow :: Window
                           , messageTabs :: Notebook
                           , userTabs :: TVar UserTabMap
                           , userListStore :: ListStore Username
                           , userListView :: TreeView
                           }

-- |The application state, including the graphical interface, the
-- network socket that is connected to the chat server, and the
-- name of the user in chat.
data AppState = AppState { appInterface :: Interface
                         , clientSock :: Socket
                         , localUsername :: Username
                         }

-- |Given a user tab, send a message to the user represented by the
-- tab by reading from the entry widget in the tab and serializing a
-- message to that user onto the network socket.
sendMessage :: UserTab -> ReaderT AppState IO ()
sendMessage tab = do
  self <- asks localUsername

  let entry = tabMessageInput tab
      tabUser = tabUsername tab
      view = tabMessageView tab

  sock <- asks clientSock
  msg <- liftIO $ Gtk.get entry entryText

  liftIO $ do
    set entry [ entryText := "" ]
    postGUIAsync (updateMessageView view (formatMessage self msg))
    sendProtocolMessage sock (MessageTo tabUser msg)

  return ()

-- |Given a username, add a tab to the messaging interface for that
-- user, including a message viewing widget and input box.  Return the
-- new UserTab.
addUserTab :: Username -> ReaderT AppState IO UserTab
addUserTab u = do
  gui <- asks appInterface
  let notebook = messageTabs gui

  st <- ask
  tab <- liftIO $ do
    messagingArea <- vBoxNew False 5

    messageView <- textViewNew
    set messageView [ textViewEditable := False
                    , textViewCursorVisible := False ]

    messageInput <- entryNew
    boxPackStart messagingArea messageView PackGrow 0
    boxPackStart messagingArea messageInput PackNatural 0

    let theTab = UserTab { tabMessageView = messageView
                         , tabMessageInput = messageInput
                         , tabUsername = u
                         }

    onEntryActivate messageInput (runReaderT (sendMessage theTab) st)

    pageNum <- notebookAppendPage notebook messagingArea u
    notebookSetCurrentPage notebook pageNum

    -- is this show-all necessary?
    widgetShowAll notebook
    return theTab

  -- Now that the tab interface has been set up, we need to update the
  -- application state
  let mapping = userTabs gui

  liftIO $ atomically $ do
                 oldMap <- readTVar mapping
                 let newMap = Map.insert u tab oldMap
                 writeTVar mapping newMap

  return tab

-- |Build the client interface and return it, along with the main
-- window.
buildInterface :: IO (Interface, Window)
buildInterface = do
  notebook <- notebookNew

  -- set up the user list and store
  theUserListStore <- listStoreNew []
  theUserListView <- treeViewNewWithModel theUserListStore
  col <- treeViewColumnNew
  renderer <- cellRendererTextNew

  -- Add the username column to the user list
  treeViewColumnPackStart col renderer True
  treeViewColumnSetTitle col "Users"
  treeViewAppendColumn theUserListView col
  cellLayoutSetAttributes col renderer theUserListStore $ \row -> [ cellText := row ]

  -- main layout: left: messsaging area, right: user list
  mainLayout <- hPanedNew
  containerAdd mainLayout notebook
  containerAdd mainLayout theUserListView

  -- add the main layout to a window
  window <- windowNew
  windowResize window 500 300
  containerAdd window mainLayout

  userTabMapping <- atomically $ newTVar $ Map.empty

  let gui = Interface { mainWindow = window
                      , messageTabs = notebook
                      , userListStore = theUserListStore
                      , userListView = theUserListView
                      , userTabs = userTabMapping
                      }

  return (gui, window)

-- |Given a socket and protocol message, serialize the message onto
-- the socket.
sendProtocolMessage :: Socket -> ClientMessage -> IO ()
sendProtocolMessage sock msg = do
  send sock (show msg)
  return ()

-- |Given a socket, wait for the next valid message and return the
-- parsed form.
nextMessage :: Socket -> IO ServerMessage
nextMessage sock = do
  message <- recv sock 1024
  case parseServerMessage message of
    Nothing -> nextMessage sock
    Just msg -> return msg

-- |Given a text view and a string, add the string (with a newline) to
-- the end of the text view.
updateMessageView :: TextView -> String -> IO ()
updateMessageView tv msg = do
  buf <- textViewGetBuffer tv
  pos <- textBufferGetEndIter buf
  textBufferInsert buf pos (msg ++ "\n")

-- |Given a username and message, return a formatted version suitable
-- for display in a text view.
formatMessage :: Username -> String -> String
formatMessage u msg = u ++ ": " ++ msg

-- |Given a username, look up the username in the client's UserTabMap
-- and return it or Nothing if it could not be found.
getTab :: Username -> ReaderT AppState IO (Maybe UserTab)
getTab u = do
  gui <- asks appInterface
  return =<< liftIO $ atomically $ do
               theMap <- readTVar (userTabs gui)
               return $ Map.lookup u theMap

-- |Given a username, return a UserTab for that user; create one if
-- one and add it to the graphical interface if it does not already
-- exist.
getOrCreateUserTab :: Username -> ReaderT AppState IO UserTab
getOrCreateUserTab u = do
  theTab <- getTab u
  maybe (addUserTab u) (return) theTab

-- |Given an originating username and message, post it to the message
-- view (in the appropriate UserTab) for that user.  Create a new
-- UserTab if necessary.
postToMessageView :: Username -> String -> ReaderT AppState IO ()
postToMessageView src content = do
  st <- ask
  liftIO $ postGUIAsync (runReaderT act st)
    where
      act = do
        tab <- getOrCreateUserTab src
        liftIO $ updateMessageView (tabMessageView tab) (formatMessage src content)

-- |Listen on the client socket and parse incoming messages, taking
-- appropriate action for each kind of message by updating the
-- interface.
socketListener :: ReaderT AppState IO ()
socketListener = do
  sock <- asks clientSock
  forever $ do
    mMsg <- liftIO $ nextMessage sock
    case mMsg of
      MessageFrom src content -> postToMessageView src content
      UserList users -> forM_ users evUserConnected
      AnnounceConnect u -> evUserConnected u
      AnnounceDisconnect u -> evUserDisconnected u
      -- xxx these messages are noise after initialization; should we
      -- further split up client and server messages into pre- and
      -- post-initialization messages?  how far should that really go?
      IdentifyResult _ _ -> return ()
      Error _ -> return ()

-- |Connect to the chat server on the specified hostname and port and
-- return the resulting socket.
chatConnect :: String -> String -> IO Socket
chatConnect hostname port = do
    addrInfo <- getAddrInfo Nothing (Just hostname) (Just port)
    sock <- socket AF_INET Stream defaultProtocol
    let addr = addrAddress (head addrInfo)
    connect sock addr
    return sock

-- |Given a socket and username, authenticate with the server and wait
-- for an identification response.
doAuth :: Socket -> Username -> IO Bool
doAuth sock username = do
  send sock (show $ Identify username)
  waitForIdentifyResult sock

-- |Given a socket, parse incoming messages until an identification
-- response is received, then return whether the identification
-- succeeded.
waitForIdentifyResult :: Socket -> IO Bool
waitForIdentifyResult sock = do
  msg <- nextMessage sock
  case msg of
    IdentifyResult Success _ -> return True
    IdentifyResult Failure _ -> return False
    _ -> waitForIdentifyResult sock

-- |Handle an identification-completed event for the specified
-- username by setting the window title.
evIdentificationComplete :: Username -> ReaderT AppState IO ()
evIdentificationComplete u = do
  gui <- asks appInterface
  liftIO $ set (mainWindow gui) [ windowTitle := u ]

-- |Handle a user-connected event by adding that user to the user list
-- in the graphical interface.
evUserConnected :: Username -> ReaderT AppState IO ()
evUserConnected u = do
  self <- asks localUsername
  when (u /= self) $ do
                      gui <- asks appInterface
                      liftIO $ listStoreAppend (userListStore gui) u
                      return ()

-- |Handle a user-disconnected event by removing that user from the
-- user list in the graphical interface.
evUserDisconnected :: Username -> ReaderT AppState IO ()
evUserDisconnected u = do
  gui <- asks appInterface
  let store = userListStore gui
  pos <- liftIO $ listStoreFind store u
  case pos of
    Nothing -> return ()
    Just i -> liftIO $ listStoreRemove store i

-- |Given a ListStore and an element, return the index of that element
-- or Nothing if it does not exist in the store.
listStoreFind :: Eq a => ListStore a -> a -> IO (Maybe Int)
listStoreFind store e = do
  size <- listStoreGetSize store
  found <- forM [0..(size - 1)] $ \i -> do
                          v <- listStoreGetValue store i
                          if (v == e) then (return i) else (return (-1))
  case dropWhile (== (-1)) found of
    [] -> return Nothing
    h:_ -> return $ Just h

-- |Handle a mouse-click event in the user list by creating (or
-- switching to) the UserTab for the clicked username.
handleUserListClick :: Event -> ReaderT AppState IO Bool
handleUserListClick e = do
  -- If the mouse release was for button three, find out which
  -- username was clicked and either switch to an existing tab for
  -- that user or create a new tab (and switch to it).
  if (elem Button1 (eventModifier e)) then (process e) else (return False)
      where
        process event = do
          gui <- asks appInterface
          let userList = userListView gui
              eventPos = (truncate $ eventX event,
                          truncate $ eventY event)
          path <- liftIO $ treeViewGetPathAtPos userList eventPos
          case path of
            Nothing -> return False
            Just (pth, _, _) -> do
                          let store = userListStore gui
                          username <- liftIO $ listStoreGetValue store $ head pth
                          getOrCreateUserTab username
                          return True
main :: IO ()
main = do
  -- Get server / auth info from command line
  args <- getArgs
  when (length args /= 3) $ error "Usage: chat-client <hostname> <port> <username>"
  let [host, port, username] = args

  -- Initialize network connection
  theSocket <- chatConnect host port
  authResult <- doAuth theSocket username

  when (not authResult) $ error "Could not authenticate"

  unsafeInitGUIForThreadedRTS
  (gui, window) <- buildInterface

  let app = AppState { appInterface = gui
                     , clientSock = theSocket
                     , localUsername = username
                     }

  -- when the window is closed, do a clean disconnect and halt
  onDestroy window $ do
         sendProtocolMessage theSocket Disconnect
         mainQuit

  onButtonRelease (userListView gui) (\e -> runReaderT (handleUserListClick e) app)

  -- Start a thread to wait for messages and put actions into the GTK
  -- event queue
  forkIO $ (runReaderT socketListener app)

  widgetShowAll window

  runReaderT (evIdentificationComplete username) app
  sendProtocolMessage theSocket GetUserList

  mainGUI