Locations.hs

{- This file is part of funbot.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

-- | Where, lwhere, gwhere, lwhere+, lwhere-, gwhere+, gwhere- commands
--
-- Manage and query locations
module FunBot.Commands.Locations
    ( cmdWhere
    , cmdWhereLocal
    , cmdWhereGlobal
    , cmdAddWhereLocal
    , cmdRemoveWhereLocal
    , cmdAddWhereGlobal
    , cmdRemoveWhereGlobal
    )
where

import Control.Monad (unless, when)
import Data.List (find, intercalate)
import Data.Monoid ((<>))
import Data.Settings.Types (showOption)
import Data.Text (Text)
import Formatting ((%))
import FunBot.History (quote, reportHistory')
import FunBot.Locations
import FunBot.Memos (submitMemo)
import FunBot.Settings
import FunBot.Settings.Sections.Channels
import FunBot.Settings.Sections.Locations
import FunBot.Types
import FunBot.UserOptions
import FunBot.Util
import Network.IRC.Fun.Bot.Behavior
import Network.IRC.Fun.Bot.Chat
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Bot.Types
import Network.IRC.Fun.Color.Format (formatMsg)
import Network.IRC.Fun.Color.Format.Long
import Network.IRC.Fun.Types.Base
import Text.Read (readMaybe)

import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
import qualified Data.Text.Read as TR
--import qualified Network.IRC.Fun.Color.Format.Short as F

respondLookup
    :: (LocationLabel -> BotSession (Maybe Location))
    -> Nickname
    -> Text
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondLookup flookup nick labelt send = do
    let label = LocationLabel $ CI.mk labelt
    mloc <- flookup label
    case mloc of
        Nothing  -> send $ formatMsg
            (nickname % ", location ‘" % text % "’ not found.")
            nick labelt
        Just loc -> send $ MsgContent $ labelt <> " : " <> unLocation loc

respondLookupBoth
    :: Channel
    -> Nickname
    -> Text
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondLookupBoth chan = respondLookup $ lookupBoth chan

respondLookupLocal
    :: Channel
    -> Nickname
    -> Text
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondLookupLocal chan = respondLookup $ lookupLocal chan

respondLookupGlobal
    :: Nickname
    -> Text
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondLookupGlobal = respondLookup lookupGlobal

respondWhere
    :: Maybe Channel
    -> Nickname
    -> [Text]
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondWhere mchan nick [labelt] send =
    let respond = maybe respondLookupGlobal respondLookupBoth mchan
    in  respond nick labelt send
respondWhere mchan nick [labelt, chant] send =
    let chan = Channel chant
    in  if looksLikeChan chan
            then respondLookupBoth chan nick labelt send
            else send $ notchan chan
respondWhere mchan nick args _send =
    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing

cmdWhere = Command
    { cmdNames    = cmds ["where"]
    , cmdRespond  = respondWhere
    , cmdHelp     = 
        "‘where <label>’           - get the location stored for the given \
        \label. This checks in the per-channel location map first. If the \
        \label isn’t found there, then the global map is checked. If used in \
        \private chat with me, only the global map is used.\n\
        \‘where <label> <channel>’ - the same idea, except now the \
        \per-channel map used isn’t picked by the channel in which the command \
        \was sent, but the channel is explicitly specified. This allows the \
        \per-channel maps to be used in privately sent commands too."
    , cmdExamples =
        [ "where code"
        , "where mumble #freepost"
        ]
    }

respondWhereLocal
    :: Maybe Channel
    -> Nickname
    -> [Text]
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondWhereLocal (Just chan) nick [labelt] send =
    respondLookupLocal chan nick labelt send
respondWhereLocal Nothing nick [labelt] send =
    send $ MsgContent $
        unNickname nick <>
        ": please specify a channel, or use this command in a channel"
respondWhereLocal mchan nick [labelt, chant] send =
    let chan = Channel chant
    in  if looksLikeChan chan
            then respondLookupLocal chan nick labelt send
            else send $ notchan chan
respondWhereLocal mchan nick args _send =
    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing

cmdWhereLocal = Command
    { cmdNames    = cmds ["lwhere", "where-local"]
    , cmdRespond  = respondWhereLocal
    , cmdHelp     = helps
        [ ( "lwhere <label>"
          , "get the location stored for the given label. This checks only \
            \the per-channel location map, according to the channel in which \
            \the command is sent."
          )
        , ( "lwhere <label> <channel>"
          , "the same idea, except now the per-channel map of the specified \
            \channel is used. This allows the per-channel maps to be used in \
            \privately sent commands too."
          )
        ]
    , cmdExamples =
        [ "lwhere code"
        , "lwhere mumble #freepost"
        ]
    }

respondWhereGlobal
    :: Maybe Channel
    -> Nickname
    -> [Text]
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondWhereGlobal _mchan nick [labelt] send =
    respondLookupGlobal nick labelt send
respondWhereGlobal mchan nick args _send =
    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)

cmdWhereGlobal = Command
    { cmdNames    = cmds ["gwhere", "where-global"]
    , cmdRespond  = respondWhereGlobal
    , cmdHelp     = helps
        [ ( "gwhere <label>"
          , "get the location stored for the given label. This checks only \
            \the global location map."
          )
        ]
    , cmdExamples =
        [ "gwhere issues"
        ]
    }

respondAddWhereLocal
    :: Maybe Channel
    -> Nickname
    -> [Text]
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondAddWhereLocal Nothing nick (_labelt : _locw@(_:_)) send =
    send $ MsgContent $
    unNickname nick <> ", this command works only in a channel"
respondAddWhereLocal (Just chan) nick (labelt : locw@(_:_)) send = do
    let label = LocationLabel $ CI.mk labelt
        loc = Location $ T.unwords locw
    res <- addLocalLocation chan label loc
    case res of
        Nothing ->
            send $ formatMsg
                ("Location ‘" % text % "’ registered for " % channel)
                labelt chan
        Just False ->
            send $ formatMsg
                ( nickname % ", " % channel % " isn’t one of my autojoin \
                \channels. If you’d like to add it to my list, you should \
                \probably talk to my maintainer. Once added, you can define \
                \locations for this channel."
                )
                nick chan
        Just True -> send $ formatMsg
                ( nickname % ", location ‘" % text % "’ is already registered \
                \for " % channel % ". You can use ‘!set’ to modify it."
                )
                nick labelt chan
respondAddWhereLocal mchan nick args _send =
    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)

cmdAddWhereLocal = Command
    { cmdNames    =
        cmds ["lwhere+", "where-local+", "add-lwhere", "add-where-local"]
    , cmdRespond  = respondAddWhereLocal
    , cmdHelp     = helps
        [ ( "lwhere+ <label> <location>"
          , "add a new location with the given label to the per-channel \
            \location map of the channel in which the command is sent."
          )
        ]
    , cmdExamples =
        [ "lwhere+ fsf https://fsf.org"
        , "lwhere+ Jane Climbing a mountain, back next week"
        ]
    }

respondRemoveWhereLocal
    :: Maybe Channel
    -> Nickname
    -> [Text]
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondRemoveWhereLocal Nothing nick [_labelt] send =
    send $ MsgContent $
    unNickname nick <> ", this command works only in a channel"
respondRemoveWhereLocal (Just chan) nick [labelt] send = do
    let label = LocationLabel $ CI.mk labelt
    succ <- removeLocalLocation chan label
    if succ
        then send $ formatMsg
                ("Location ‘" % text % "’ removed for " % channel)
                labelt chan
        else send $ formatMsg
                ( nickname % ", can’t delete: there is no location ‘" % text
                % "’ registered for " % channel
                )
                nick labelt chan
respondRemoveWhereLocal mchan nick args _send =
    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)

cmdRemoveWhereLocal = Command
    { cmdNames    =
        cmds ["lwhere-", "where-local-", "delete-lwhere", "delete-where-local"]
    , cmdRespond  = respondRemoveWhereLocal
    , cmdHelp     = helps
        [ ( "lwhere- <label>"
          , "remove the location with the given label from the per-channel \
            \location map of the channel in which the command is sent."
          )
        ]
    , cmdExamples =
        [ "lwhere- website"
        ]
    }

respondAddWhereGlobal
    :: Maybe Channel
    -> Nickname
    -> [Text]
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondAddWhereGlobal _mchan nick (labelt : locw@(_:_)) send = do
    let label = LocationLabel $ CI.mk labelt
        loc = Location $ T.unwords locw
    success <- addLocation label loc
    send $ if success
        then MsgContent $ "Global location ‘" <> labelt <> "’ registered"
        else formatMsg
                ( nickname % ", global location ‘" % text % "’ is already \
                \registered. You can use ‘!set’ to modify it."
                )
                nick labelt
respondAddWhereGlobal mchan nick args _send =
    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)

cmdAddWhereGlobal = Command
    { cmdNames    =
        cmds ["gwhere+", "where-global+", "add-gwhere", "add-where-global"]
    , cmdRespond  = respondAddWhereGlobal
    , cmdHelp     = helps
        [ ( "gwhere+ <label> <location>"
          , "add a new location with the given label to the global location \
            \map."
          )
        ]
    , cmdExamples =
        [ "gwhere+ fsf https://fsf.org"
        , "gwhere+ John Took a flight to the moon, back next week"
        ]
    }

respondRemoveWhereGlobal
    :: Maybe Channel
    -> Nickname
    -> [Text]
    -> (MsgContent -> BotSession ())
    -> BotSession ()
respondRemoveWhereGlobal _mchan nick [labelt] send = do
    let label = LocationLabel $ CI.mk labelt
    success <- removeLocation label
    send $ if success
        then MsgContent $ "Global location ‘" <> labelt <> "’ removed"
        else formatMsg
                ( nickname % ", can’t delete: there is no global location ‘"
                % text % "’ registered"
                )
                nick labelt
respondRemoveWhereGlobal mchan nick args _send =
    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)

cmdRemoveWhereGlobal = Command
    { cmdNames    = cmds
        ["gwhere-", "where-global-", "delete-gwhere", "delete-where-global"]
    , cmdRespond  = respondRemoveWhereGlobal
    , cmdHelp     = helps
        [ ( "gwhere- <label>"
          , "remove the location with the given label from the global \
            \location map."
          )
        ]
    , cmdExamples =
        [ "gwhere- githu8"
        ]
    }