content: {-# Language BangPatterns, BlockArguments, OverloadedStrings, TemplateHaskell #-}
  {-|
  Module      : Client.Commands.Chat
  Description : Common user IRC commands
  Copyright   : (c) Eric Mertens, 2016-2020
  License     : ISC
  Maintainer  : emertens@gmail.com
  -}
  
  module Client.Commands.Chat (chatCommands, chatCommand', executeChat, cmdCtcp) where
  
  import Client.Commands.Arguments.Spec
  import Client.Commands.TabCompletion
  import Client.Commands.Types
  import Client.Commands.Window (parseFocus)
  import Client.Message
  import Client.State
  import Client.State.Channel (chanJoined)
  import Client.State.Extensions (clientChatExtension)
  import Client.State.Focus (focusNetwork, Focus(ChannelFocus), Subfocus(FocusInfo, FocusUsers))
  import Client.State.Network
  import Control.Applicative (liftA2, liftA3)
  import Control.Lens (filteredBy, has, ix, view, preview, views)
  import Control.Monad (when, unless)
  import Data.ByteString qualified as B
  import Data.Char (toUpper)
  import Data.Foldable (foldl', traverse_)
  import Data.HashMap.Strict qualified as HashMap
  import Data.List.NonEmpty (NonEmpty((:|)))
  import Data.Text (Text)
  import Data.Text qualified as Text
  import Data.Text.Encoding qualified as Text
  import Data.Time (getZonedTime)
  import Irc.Commands
  import Irc.Identifier (Identifier, idText, mkId)
  import Irc.Message (IrcMsg(Privmsg, Notice, Ctcp), Source(Source))
  import Irc.RawIrcMsg (RawIrcMsg, parseRawIrcMsg)
  import Client.Commands.Docs (chatDocs, cmdDoc)
  
  chatCommands :: CommandSection
  chatCommands = CommandSection "IRC commands"
    ------------------------------------------------------------------------
  
    [ Command
        ("join" :| ["j"])
        (liftA2 (,) (simpleToken "channels") (optionalArg (simpleToken "[keys]")))
        $(chatDocs `cmdDoc` "join")
      $ NetworkCommand cmdJoin simpleNetworkTab
  
    , Command
        (pure "part")
        (remainingArg "reason")
        $(chatDocs `cmdDoc` "part")
      $ ChannelCommand cmdPart simpleChannelTab
  
    , Command
        (pure "msg")
        (liftA2 (,) (simpleToken "target") (remainingArg "message"))
        $(chatDocs `cmdDoc` "msg")
      $ NetworkCommand cmdMsg simpleNetworkTab
  
    , Command
        (pure "me")
        (remainingArg "message")
        $(chatDocs `cmdDoc` "me")
      $ ChatCommand cmdMe simpleChannelTab
  
    , Command
        (pure "say")
        (remainingArg "message")
        $(chatDocs `cmdDoc` "say")
      $ ChatCommand cmdSay simpleChannelTab
  
    , Command
        ("query" :| ["q"])
        (liftA2 (,) (simpleToken "target") (remainingArg "message"))
        $(chatDocs `cmdDoc` "query")
      $ ClientCommand cmdQuery simpleClientTab
  
    , Command
        (pure "notice")
        (liftA2 (,) (simpleToken "target") (remainingArg "message"))
        $(chatDocs `cmdDoc` "notice")
      $ NetworkCommand cmdNotice simpleNetworkTab
  
    , Command
        (pure "wallops")
        (remainingArg "message to +w users")
        $(chatDocs `cmdDoc` "wallops")
      $ NetworkCommand cmdWallops simpleNetworkTab
  
    , Command
        (pure "operwall")
        (remainingArg "message to +z opers")
        $(chatDocs `cmdDoc` "operwall")
      $ NetworkCommand cmdOperwall simpleNetworkTab
  
    , Command
        (pure "ctcp")
        (liftA3 (,,) (simpleToken "target") (simpleToken "command") (remainingArg "arguments"))
        $(chatDocs `cmdDoc` "ctcp")
      $ NetworkCommand cmdCtcp simpleNetworkTab
  
    , Command
        (pure "nick")
        (simpleToken "nick")
        $(chatDocs `cmdDoc` "nick")
      $ NetworkCommand cmdNick simpleNetworkTab
  
    , Command
        (pure "away")
        (remainingArg "message")
        $(chatDocs `cmdDoc` "away")
      $ NetworkCommand cmdAway simpleNetworkTab
  
    , Command
        (pure "names")
        (pure ())
        $(chatDocs `cmdDoc` "names")
      $ ChannelCommand cmdChanNames noChannelTab
  
    , Command
        ("channelinfo" :| ["cinfo"])
        (pure ())
        $(chatDocs `cmdDoc` "channelinfo")
      $ ChannelCommand cmdChannelInfo noChannelTab
  
    , Command
        (pure "knock")
        (liftA2 (,) (simpleToken "channel") (remainingArg "message"))
        $(chatDocs `cmdDoc` "knock")
      $ NetworkCommand cmdKnock simpleNetworkTab
  
    , Command
        ("quote" :| ["/"])
        (remainingArg "raw IRC command")
        $(chatDocs `cmdDoc` "quote")
      $ NetworkCommand cmdQuote simpleNetworkTab
  
    , Command
        (pure "monitor")
        (extensionArg "[+-CLS]" monitorArgs)
        $(chatDocs `cmdDoc` "monitor")
      $ NetworkCommand cmdMonitor simpleNetworkTab
  
    ]
  
  monitorArgs :: ArgsContext -> String -> Maybe (Args ArgsContext [String])
  monitorArgs _ str =
    case toUpper <$> str of
      "+" -> Just (wrap '+' (simpleToken "target[,target2]*"))
      "-" -> Just (wrap '-' (simpleToken "target[,target2]*"))
      "C" -> Just (pure ["C"])
      "L" -> Just (pure ["L"])
      "S" -> Just (pure ["S"])
      _   -> Nothing
    where
      wrap c = fmap (\s -> [[c], s])
  
  cmdMonitor :: NetworkCommand [String]
  cmdMonitor cs st args =
    do sendMsg cs (ircMonitor (fmap Text.pack args))
       commandSuccess st
  
  cmdChanNames :: ChannelCommand ()
  cmdChanNames chan cs st _ = do
      -- TODO: Uncomment when RPL_NAMREPLY actually creates a ChannelState.
      -- let connecting = has (csPingStatus . _PingConnecting) cs
      --     isJoined   = has (csChannels . ix chan . filteredBy chanJoined) cs
      -- unless (connecting || isJoined)
      --   (sendMsg cs (ircNames chan))
      commandSuccess (changeSubfocus subfocus st)
    where subfocus = FocusUsers (view csNetwork cs) chan
  
  cmdChannelInfo :: ChannelCommand ()
  cmdChannelInfo chan cs st _ = do
      let connecting = has (csPingStatus . _PingConnecting) cs
          isJoined   = has (csChannels . ix chan . filteredBy chanJoined) cs
      unless (connecting || isJoined)
        (sendMsg cs (ircMode chan []) >> sendMsg cs (ircTopic chan ""))
      commandSuccess (changeSubfocus subfocus st)
    where subfocus = FocusInfo (view csNetwork cs) chan
  
  cmdKnock :: NetworkCommand (String, String)
  cmdKnock cs st (chan,message) =
    do sendMsg cs (ircKnock (Text.pack chan) (Text.pack message))
       commandSuccess st
  
  cmdJoin :: NetworkCommand (String, Maybe String)
  cmdJoin cs st (channelsStr, mbKeys) =
   do let network = view csNetwork cs
      let channelId = mkId (Text.pack (takeWhile (',' /=) channelsStr))
      let channels = Text.split (',' ==) (Text.pack channelsStr)
      let keys = maybe [] (Text.split (',' ==) . Text.pack) mbKeys
      traverse_ (sendMsg cs) (chunkJoins channels keys)
      commandSuccess (changeFocus (ChannelFocus network channelId) st)
  
  chunkJoins :: [Text] -> [Text] -> [RawIrcMsg]
  chunkJoins cs0 ks0 =
    case (cs0, ks0) of
      (c:cs, k:ks) -> go (cost c + cost k) [c] [k] cs ks
      (c:cs, []) -> go (cost c) [c] [] cs []
      _ -> []
    where
      limit = 500 -- "JOIN__:\r\n"
      cost x = 1 + B.length (Text.encodeUtf8 x)
  
      finishChannels = Text.intercalate "," . reverse
      finishKeys [] = Nothing
      finishKeys ks = Just (finishChannels ks)
  
      go n acc1 acc2 (c:cs) []
        | n + x > limit = ircJoin (finishChannels acc1) (finishKeys acc2) : go x [c] [] cs []
        | otherwise = go (n + x) (c : acc1) acc2 cs []
        where
          x = cost c
  
      go n acc1 acc2 (c:cs) (k:ks)
        | n + x > limit = ircJoin (finishChannels acc1) (finishKeys acc2) : go x [c] [k] cs ks
        | otherwise = go (n + x) (c : acc1) (k : acc2) cs ks
        where
          x = cost c + cost k
  
      go _ acc1 acc2 [] _ = [ircJoin (finishChannels acc1) (finishKeys acc2)]
  
  -- | @/query@ command. Takes a channel or nickname and switches
  -- focus to that target on the current network.
  cmdQuery :: ClientCommand (String, String)
  cmdQuery st (target, msg) =
    case parseFocus (views clientFocus focusNetwork st) target of
      Just (ChannelFocus net tgt)
  
        | null msg -> commandSuccess st'
  
        | Just cs <- preview (clientConnection net) st ->
             do let tgtTxt = idText tgt
                    msgTxt = Text.pack msg
                chatCommand
                  (ircPrivmsg tgtTxt msgTxt)
                  (\src tgt1 -> Privmsg src tgt1 msgTxt)
                  tgtTxt cs st'
        where
         firstTgt = mkId (Text.takeWhile (','/=) (idText tgt))
         st' = changeFocus (ChannelFocus net firstTgt) st
  
      _ -> commandFailureMsg "Bad target" st
  
  -- | Implementation of @/ctcp@
  cmdCtcp :: NetworkCommand (String, String, String)
  cmdCtcp cs st (target, cmd, args) =
   do let cmdTxt = Text.toUpper (Text.pack cmd)
          argTxt = Text.pack args
          tgtTxt = Text.pack target
  
      let msg = "\^A" <> cmdTxt <>
                (if Text.null argTxt then "" else " " <> argTxt) <>
                "\^A"
      chatCommand
        (ircPrivmsg tgtTxt msg)
        (\src tgt -> Ctcp src tgt cmdTxt argTxt)
        tgtTxt cs st
  
  -- | Implementation of @/wallops@
  cmdWallops :: NetworkCommand String
  cmdWallops cs st rest
    | null rest = commandFailureMsg "empty message" st
    | otherwise =
        do let restTxt = Text.pack rest
           sendMsg cs (ircWallops restTxt)
           commandSuccess st
  
  -- | Implementation of @/operwall@
  cmdOperwall :: NetworkCommand String
  cmdOperwall cs st rest
    | null rest = commandFailureMsg "empty message" st
    | otherwise =
        do let restTxt = Text.pack rest
           sendMsg cs (ircOperwall restTxt)
           commandSuccess st
  
  -- | Implementation of @/notice@
  cmdNotice :: NetworkCommand (String, String)
  cmdNotice cs st (target, rest)
    | null rest = commandFailureMsg "empty message" st
    | otherwise =
       do let restTxt = Text.pack rest
              tgtTxt = Text.pack target
          chatCommand
            (ircNotice tgtTxt restTxt)
            (\src tgt -> Notice src tgt restTxt)
            tgtTxt cs st
  
  -- | Implementation of @/msg@
  cmdMsg :: NetworkCommand (String, String)
  cmdMsg cs st (target, rest)
    | null rest = commandFailureMsg "empty message" st
    | otherwise =
       do let restTxt = Text.pack rest
              tgtTxt = Text.pack target
          chatCommand
            (ircPrivmsg tgtTxt restTxt)
            (\src tgt -> Privmsg src tgt restTxt)
            tgtTxt cs st
  
  
  
  -- | Common logic for @/msg@ and @/notice@
  chatCommand ::
    RawIrcMsg {- ^ irc command -} ->
    (Source -> Identifier -> IrcMsg) ->
    Text {- ^ targets -} ->
    NetworkState         ->
    ClientState          ->
    IO CommandResult
  chatCommand ircMsg mkmsg tgtsTxt cs st
    | any Text.null tgtTxts = commandFailureMsg "empty target" st
    | otherwise =
     do sendMsg cs ircMsg
        st' <- chatCommand' mkmsg tgtTxts cs st
        commandSuccess st'
    where
      tgtTxts = Text.split (','==) tgtsTxt
  
  -- | Common logic for @/msg@ and @/notice@ returning the client state
  chatCommand' ::
    (Source -> Identifier -> IrcMsg) ->
    [Text] {- ^ targets  -} ->
    NetworkState         ->
    ClientState          ->
    IO ClientState
  chatCommand' con targetTxts cs st =
    do now <- getZonedTime
       let targetIds = mkId <$> targetTxts
           !myNick = Source (view csUserInfo cs) (view csAccount cs) "" True
           network = view csNetwork cs
           entries = [ (targetId,
                            ClientMessage
                            { _msgTime = now
                            , _msgNetwork = network
                            , _msgBody = IrcBody (con myNick targetId)
                            })
                         | targetId <- targetIds ]
  
       return $! foldl' (\acc (targetId, entry) ->
                          recordChannelMessage network targetId entry acc)
                        st
                        entries
  
  -- | Implementation of @/quote@. Parses arguments as a raw IRC command and
  -- sends to the current network.
  cmdQuote :: NetworkCommand String
  cmdQuote cs st rest =
    case parseRawIrcMsg (Text.pack (dropWhile (' '==) rest)) of
      Nothing  -> commandFailureMsg "failed to parse raw IRC command" st
      Just raw ->
        do sendMsg cs raw
           commandSuccess st
  
  cmdAway :: NetworkCommand String
  cmdAway cs st rest =
    do sendMsg cs (ircAway (Text.pack rest))
       commandSuccess st
  
  cmdNick :: NetworkCommand String
  cmdNick cs st nick =
    do sendMsg cs (ircNick (Text.pack nick))
       commandSuccess st
  
  cmdPart :: ChannelCommand String
  cmdPart channelId cs st rest =
    do let msg = rest
       sendMsg cs (ircPart channelId (Text.pack msg))
       commandSuccess st
  
  -- | This command is equivalent to chatting without a command. The primary use
  -- at the moment is to be able to send a leading @/@ to chat easily.
  cmdSay :: ChannelCommand String
  cmdSay focus cs st rest = executeChat (ChannelFocus (view csNetwork cs) focus) rest st
  
  -- | Implementation of @/me@
  cmdMe :: ChannelCommand String
  cmdMe channelId cs st rest =
    do now <- getZonedTime
       let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A")
           !myNick = Source (view csUserInfo cs) (view csAccount cs) "" True
           network = view csNetwork cs
           entry = ClientMessage
                      { _msgTime = now
                      , _msgNetwork = network
                      , _msgBody = IrcBody (Ctcp myNick channelId "ACTION" (Text.pack rest))
                      }
       sendMsg cs (ircPrivmsg (idText channelId) actionTxt)
       commandSuccess
         $! recordChannelMessage network channelId entry st
  
  -- | Treat the current text input as a chat message and send it.
  executeChat ::
    Focus                                   ->
    String           {- ^ chat message   -} ->
    ClientState      {- ^ client state   -} ->
    IO CommandResult {- ^ command result -}
  executeChat focus msg st =
    case focus of
      ChannelFocus network channel
        | Just !cs <- preview (clientConnection network) st ->
            do now <- getZonedTime
               let msgTxt = Text.pack $ takeWhile (/='\n') msg
                   tgtTxt = idText channel
  
               (st1,allow) <- clientChatExtension network tgtTxt msgTxt st
  
               when allow (sendMsg cs (ircPrivmsg tgtTxt msgTxt))
  
               let myNick = Source (view csUserInfo cs) (view csAccount cs) "" True
                   entry = ClientMessage
                     { _msgTime    = now
                     , _msgNetwork = network
                     , _msgBody    = IrcBody (Privmsg myNick channel msgTxt) }
               commandSuccess $! recordChannelMessage network channel entry st1
  
      _ -> commandFailureMsg "cannot send chat messages to this window" st
  