Queries.hs

{-# Language OverloadedStrings, TemplateHaskell #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module      : Client.Commands.Queries
Description : Query command implementations
Copyright   : (c) Eric Mertens, 2016-2020
License     : ISC
Maintainer  : emertens@gmail.com
-}

module Client.Commands.Queries (queryCommands) where

import Client.Commands.Arguments.Spec (optionalArg, remainingArg, simpleToken, extensionArg, Args)
import Client.Commands.Docs (queriesDocs, cmdDoc)
import Client.Commands.TabCompletion (noNetworkTab, simpleNetworkTab)
import Client.Commands.Types (commandSuccess, commandSuccessUpdateCS, Command(Command), CommandImpl(NetworkCommand), CommandSection(CommandSection), NetworkCommand)
import Client.State (changeSubfocus, ClientState)
import Client.State.Focus (Subfocus(FocusChanList, FocusWho))
import Client.State.Network (sendMsg, csChannelList, clsElist, csPingStatus, _PingConnecting, csWhoReply)
import Client.WhoReply (newWhoReply)
import Control.Applicative (liftA2)
import Control.Lens (has, set, view)
import Control.Monad (unless)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Text qualified as Text
import Irc.Commands

queryCommands :: CommandSection
queryCommands = CommandSection "Queries"

  [ Command
      (pure "who")
      (optionalArg (liftA2 (,) (simpleToken "[channel|nick|mask]") (optionalArg (simpleToken "[options]"))))
      $(queriesDocs `cmdDoc` "who")
    $ NetworkCommand cmdWho simpleNetworkTab

  , Command
      (pure "whois")
      (remainingArg "arguments")
      $(queriesDocs `cmdDoc` "whois")
    $ NetworkCommand cmdWhois simpleNetworkTab

  , Command
      (pure "whowas")
      (remainingArg "arguments")
      $(queriesDocs `cmdDoc` "whowas")
    $ NetworkCommand cmdWhowas simpleNetworkTab

  , Command
      (pure "ison")
      (remainingArg "arguments")
      $(queriesDocs `cmdDoc` "ison")
    $ NetworkCommand cmdIson   simpleNetworkTab

  , Command
      (pure "userhost")
      (remainingArg "arguments")
      $(queriesDocs `cmdDoc` "userhost")
    $ NetworkCommand cmdUserhost simpleNetworkTab

  , Command
      (pure "time")
      (optionalArg (simpleToken "[servername]"))
      $(queriesDocs `cmdDoc` "time")
    $ NetworkCommand cmdTime simpleNetworkTab

  , Command
      (pure "stats")
      (remainingArg "arguments")
      $(queriesDocs `cmdDoc` "stats")
    $ NetworkCommand cmdStats simpleNetworkTab

  , Command
      (pure "lusers")
      (optionalArg (simpleToken "[servername]"))
      $(queriesDocs `cmdDoc` "lusers")
    $ NetworkCommand cmdLusers simpleNetworkTab

  , Command
      (pure "users")
      (optionalArg (simpleToken "[servername]"))
      $(queriesDocs `cmdDoc` "users")
    $ NetworkCommand cmdUsers simpleNetworkTab

  , Command
      (pure "motd")
      (optionalArg (simpleToken "[servername]"))
      $(queriesDocs `cmdDoc` "motd")
    $ NetworkCommand cmdMotd simpleNetworkTab

  , Command
      (pure "admin")
      (optionalArg (simpleToken "[servername]"))
      $(queriesDocs `cmdDoc` "admin")
    $ NetworkCommand cmdAdmin simpleNetworkTab

  , Command
      (pure "rules")
      (optionalArg (simpleToken "[servername]"))
      $(queriesDocs `cmdDoc` "rules")
    $ NetworkCommand cmdRules simpleNetworkTab

  , Command
      (pure "info")
      (pure ())
      $(queriesDocs `cmdDoc` "info")
    $ NetworkCommand cmdInfo noNetworkTab

  , Command
      (pure "list")
      (optionalArg (extensionArg "[clientarg]" listArgs))
      $(queriesDocs `cmdDoc` "list")
    $ NetworkCommand cmdList simpleNetworkTab

  , Command
      (pure "links")
      (remainingArg "arguments")
      $(queriesDocs `cmdDoc` "links")
    $ NetworkCommand cmdLinks simpleNetworkTab

  , Command
      (pure "version")
      (optionalArg (simpleToken "[servername]"))
      $(queriesDocs `cmdDoc` "version")
    $ NetworkCommand cmdVersion simpleNetworkTab

  ]

cmdInfo :: NetworkCommand ()
cmdInfo cs st _ =
  do sendMsg cs ircInfo
     commandSuccess st

cmdVersion :: NetworkCommand (Maybe String)
cmdVersion cs st mbservername =
  do sendMsg cs $ ircVersion $ case mbservername of
                                Just s  -> Text.pack s
                                Nothing -> ""
     commandSuccess st

cmdList :: NetworkCommand (Maybe ListArgs)
cmdList cs st rest =
    do
      let lsa = fromMaybe lsaDefault rest
      let connecting = has (csPingStatus . _PingConnecting) cs
      let elist = Just (Text.pack (fromMaybe "" (_lsaElist lsa)))
      let cached = elist == view (csChannelList . clsElist) cs
      let sendM = sendMsg cs (ircList (Text.pack <$> maybeToList (_lsaElist lsa)))
      unless (connecting || (cached && not (_lsaRefresh lsa))) sendM
      let cs' = set (csChannelList . clsElist) elist cs 
      let subfocus = FocusChanList (_lsaMin lsa) (_lsaMax lsa)
      commandSuccessUpdateCS cs' (changeSubfocus subfocus st)

listArgs :: ClientState -> String -> Maybe (Args ClientState ListArgs)
listArgs _ = fmap (withElist (optionalArg (simpleToken "[serverarg]"))) . lsaParse
    where withElist arg a = fmap (\s -> a { _lsaElist = s }) arg

data ListArgs = ListArgs
  { _lsaElist   :: Maybe String
  , _lsaRefresh :: Bool
  , _lsaMin     :: Maybe Int
  , _lsaMax     :: Maybe Int
  }

lsaDefault :: ListArgs
lsaDefault = ListArgs
  { _lsaElist = Nothing
  , _lsaRefresh = False
  , _lsaMin = Nothing
  , _lsaMax = Nothing
  }

lsaParse :: String -> Maybe ListArgs
lsaParse = lsaParse' lsaDefault
  where
    lsaParse' lsa str = case str of
      '~':rest -> lsaParse' lsa{ _lsaRefresh = True } rest
      ',':rest -> lsaParse' lsa rest
      '>':(reads -> [(min', rest)]) | min' >= 0 ->
        lsaParse' lsa{ _lsaMin = Just min'} rest
      '<':(reads -> [(max', rest)]) | max' >= 0 ->
        lsaParse' lsa{ _lsaMax = Just max'} rest
      "" -> Just lsa
      _ -> Nothing

cmdLusers :: NetworkCommand (Maybe String)
cmdLusers cs st arg =
  do sendMsg cs $ ircLusers $ fmap Text.pack $
       case arg of
         Nothing -> []
         Just x -> ["*", x] -- mask field is legacy
     commandSuccess st

cmdUsers :: NetworkCommand (Maybe String)
cmdUsers cs st arg =
  do sendMsg cs $ ircUsers $ maybe "" Text.pack arg
     commandSuccess st

cmdMotd :: NetworkCommand (Maybe String)
cmdMotd cs st mbservername =
  do sendMsg cs $ ircMotd $ case mbservername of
                              Just s  -> Text.pack s
                              Nothing -> ""
     commandSuccess st

cmdAdmin :: NetworkCommand (Maybe String)
cmdAdmin cs st mbservername =
  do sendMsg cs $ ircAdmin $ case mbservername of
                              Just s  -> Text.pack s
                              Nothing -> ""
     commandSuccess st

cmdRules :: NetworkCommand (Maybe String)
cmdRules cs st mbservername =
  do sendMsg cs $ ircRules $
       case mbservername of
         Just s  -> Text.pack s
         Nothing -> ""
     commandSuccess st

cmdStats :: NetworkCommand String
cmdStats cs st rest =
  do sendMsg cs (ircStats (Text.pack <$> words rest))
     commandSuccess st

cmdLinks :: NetworkCommand String
cmdLinks cs st rest =
  do sendMsg cs (ircLinks (Text.pack <$> words rest))
     commandSuccess st

cmdTime :: NetworkCommand (Maybe String)
cmdTime cs st arg =
  do sendMsg cs (ircTime (maybe "" Text.pack arg))
     commandSuccess st

cmdWhois :: NetworkCommand String
cmdWhois cs st rest =
  do sendMsg cs (ircWhois (Text.pack <$> words rest))
     commandSuccess st

cmdWho :: NetworkCommand (Maybe (String, Maybe String))
cmdWho _  st Nothing = commandSuccess (changeSubfocus FocusWho st)
cmdWho cs st (Just (query, arg)) =
  do
    let query' = Text.pack query
    let arg' = fromMaybe "" arg
    let cs' = set csWhoReply (newWhoReply query' arg') cs
    sendMsg cs (ircWho (query' : maybeToList (Text.pack <$> arg)))
    commandSuccessUpdateCS cs' (changeSubfocus FocusWho st)

cmdWhowas :: NetworkCommand String
cmdWhowas cs st rest =
  do sendMsg cs (ircWhowas (Text.pack <$> words rest))
     commandSuccess st

cmdIson :: NetworkCommand String
cmdIson cs st rest =
  do sendMsg cs (ircIson (Text.pack <$> words rest))
     commandSuccess st

cmdUserhost :: NetworkCommand String
cmdUserhost cs st rest =
  do sendMsg cs (ircUserhost (Text.pack <$> words rest))
     commandSuccess st