{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Lambdabot.Plugin.Telegram.Callback where

import Control.Exception.Lifted ( SomeException (..) )
import Control.Exception.Lifted as E (catch)
import Control.Monad.State (gets, lift)
import Data.List
import Data.List.Split
import qualified Data.Text as Text
import qualified Data.Map.Strict as Map
import Text.EditDistance
import Text.Regex.TDFA

import Lambdabot.Bot
import Lambdabot.Command
import Lambdabot.Config
import Lambdabot.IRC
import Lambdabot.Logging
import Lambdabot.Message
import Lambdabot.Monad
import Lambdabot.Nick
import Lambdabot.Plugin.Core
import Lambdabot.Util

import Lambdabot.Plugin.Telegram.Shared
import Lambdabot.Plugin.Telegram.Message


-- | In order to read messages from a different plugin, it is necessary
-- to set a callback with a known label. This function is a main entry point
-- as a plugin callback.
--
-- Since we needed an extended functionality from @eval@ plugin,
-- we used these non-exported functions from corresponding @lambdabot-haskell-plugins@ module.
doTGMSG :: IrcMessage -> Telegram ()
doTGMSG :: IrcMessage -> Telegram ()
doTGMSG IrcMessage
msg = do
  Bool
ignored     <- LB Bool -> ModuleT TelegramState LB Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB Bool -> ModuleT TelegramState LB Bool)
-> LB Bool -> ModuleT TelegramState LB Bool
forall a b. (a -> b) -> a -> b
$ IrcMessage -> LB Bool
checkIgnore IrcMessage
msg
  [String]
commands    <- Config [String] -> ModuleT TelegramState LB [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
commandPrefixes
  if Bool
ignored
    then IrcMessage -> Telegram ()
doIGNORE IrcMessage
msg
    else (Nick -> Telegram ()) -> [Nick] -> Telegram ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([String] -> Nick -> IrcMessage -> Nick -> Telegram ()
doTGMSG' [String]
commands (IrcMessage -> Nick
forall a. Message a => a -> Nick
lambdabotName IrcMessage
msg) IrcMessage
msg) [Nick]
targets
  where
    alltargets :: String
alltargets = [String] -> String
forall a. [a] -> a
head (IrcMessage -> [String]
ircMsgParams IrcMessage
msg)
    targets :: [Nick]
targets = (String -> Nick) -> [String] -> [Nick]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Nick
parseNick (IrcMessage -> String
ircMsgServer IrcMessage
msg)) ([String] -> [Nick]) -> [String] -> [Nick]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"," String
alltargets

doIGNORE :: IrcMessage -> Telegram ()
doIGNORE :: IrcMessage -> Telegram ()
doIGNORE = String -> Telegram ()
forall (m :: * -> *). MonadLogging m => String -> m ()
debugM (String -> Telegram ())
-> (IrcMessage -> String) -> IrcMessage -> Telegram ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IrcMessage -> String
forall a. Show a => a -> String
show

doTGMSG'
  :: [String] -- ^ Commands.
  -> Nick -- ^ My name.
  -> IrcMessage -- ^ IRC Message.
  -> Nick -- ^ Target name.
  -> Telegram ()
doTGMSG' :: [String] -> Nick -> IrcMessage -> Nick -> Telegram ()
doTGMSG' [String]
commands Nick
myname IrcMessage
msg Nick
target
    | Nick
myname Nick -> Nick -> Bool
forall a. Eq a => a -> a -> Bool
== Nick
target
    = let (String
cmd, String
params) = String -> (String, String)
splitFirstWord String
text
      in [String] -> IrcMessage -> String -> String -> Telegram ()
doPersonalMsg [String]
commands IrcMessage
msg String
cmd String
params
    
    | ((Char -> Bool) -> String -> Bool)
-> String -> (Char -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
":," :: String)
        ((Char -> Bool) -> Bool) -> (Char -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \Char
c -> (String -> Nick -> String
fmtNick (IrcMessage -> String
ircMsgServer IrcMessage
msg) Nick
myname String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c]) String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
text
    = let Just String
wholeCmd = String -> String -> Maybe String
maybeCommand (String -> Nick -> String
fmtNick (IrcMessage -> String
ircMsgServer IrcMessage
msg) Nick
myname) String
text
          (String
cmd, String
params) = String -> (String, String)
splitFirstWord String
wholeCmd
      in [String] -> IrcMessage -> Nick -> String -> String -> Telegram ()
doPublicMsg [String]
commands IrcMessage
msg Nick
target String
cmd String
params
    
    | ([String]
commands [String] -> String -> Bool
`arePrefixesOf` String
text)
    Bool -> Bool -> Bool
&& String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
    Bool -> Bool -> Bool
&& (String
text String -> Int -> Char
forall a. [a] -> Int -> a
!! Int
1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') -- elem of prefixes
    Bool -> Bool -> Bool
&& (Bool -> Bool
not ([String]
commands [String] -> String -> Bool
`arePrefixesOf` [String
text String -> Int -> Char
forall a. [a] -> Int -> a
!! Int
1]) Bool -> Bool -> Bool
||
      (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& String
text String -> Int -> Char
forall a. [a] -> Int -> a
!! Int
2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')) -- ignore @@ prefix, but not the @@ command itself
    = let (String
cmd, String
params) = String -> (String, String)
splitFirstWord ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') String
text)
      in [String] -> IrcMessage -> Nick -> String -> String -> Telegram ()
doPublicMsg [String]
commands IrcMessage
msg Nick
target String
cmd String
params
    
    | Bool
otherwise = () -> Telegram ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- contextual messages are not allowed here
    
    where
        text :: String
text = String -> String
forall a. [a] -> [a]
tail ([String] -> String
forall a. [a] -> a
head ([String] -> [String]
forall a. [a] -> [a]
tail (IrcMessage -> [String]
ircMsgParams IrcMessage
msg)))

doPersonalMsg
  :: [String]
  -> IrcMessage
  -> String
  -> String
  -> Telegram ()
doPersonalMsg :: [String] -> IrcMessage -> String -> String -> Telegram ()
doPersonalMsg [String]
commands IrcMessage
msg String
s String
r
  | [String]
commands [String] -> String -> Bool
`arePrefixesOf` String
s = IrcMessage -> String -> String -> Nick -> Telegram ()
doMsg IrcMessage
msg (String -> String
forall a. [a] -> [a]
tail String
s) String
r Nick
who
  | Bool
otherwise                  = () -> Telegram ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- contextual messages are not allowed here
  where
    who :: Nick
who = IrcMessage -> Nick
forall a. Message a => a -> Nick
nick IrcMessage
msg

doPublicMsg
  :: [String] -> IrcMessage -> Nick -> String -> String -> Telegram ()
doPublicMsg :: [String] -> IrcMessage -> Nick -> String -> String -> Telegram ()
doPublicMsg [String]
commands IrcMessage
msg Nick
target String
s String
r
    | [String]
commands [String] -> String -> Bool
`arePrefixesOf` String
s  = IrcMessage -> String -> String -> Nick -> Telegram ()
doMsg IrcMessage
msg (String -> String
forall a. [a] -> [a]
tail String
s) String
r Nick
target
    | Bool
otherwise                   = IrcMessage -> Telegram ()
doIGNORE IrcMessage
msg

-- | normal commands.
--
-- check privledges, do any spell correction, dispatch, handling
-- possible timeouts.
--
doMsg :: IrcMessage -> String -> String -> Nick -> Telegram ()
doMsg :: IrcMessage -> String -> String -> Nick -> Telegram ()
doMsg IrcMessage
msg String
cmd String
rest Nick
towhere = do
    String -> Telegram ()
ldebug (String -> Telegram ()) -> String -> Telegram ()
forall a b. (a -> b) -> a -> b
$ String
"doMsg : nick : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Nick -> String
fmtNick String
"" Nick
towhere String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : cmd : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd
    let ircmsg :: String -> LB ()
ircmsg = Text -> Text -> Text -> LB ()
tgIrcPrivMsg (IrcMessage -> Text
getTgChatId IrcMessage
msg) (IrcMessage -> Text
getTgMsgId IrcMessage
msg) (Text -> LB ()) -> (String -> Text) -> String -> LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
    [String]
allcmds <- LB [String] -> ModuleT TelegramState LB [String]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((IRCRWState -> [String]) -> LB [String]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Map String (DSum ModuleID CommandRef) -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String (DSum ModuleID CommandRef) -> [String])
-> (IRCRWState -> Map String (DSum ModuleID CommandRef))
-> IRCRWState
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String (DSum ModuleID CommandRef)
ircCommands))
    let ms :: [String]
ms      = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
cmd) [String]
allcmds
    Int
e <- Config Int -> ModuleT TelegramState LB Int
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Int
editDistanceLimit
    case [String]
ms of
        [String
s] -> IrcMessage -> Nick -> String -> String -> Telegram ()
docmd IrcMessage
msg Nick
towhere String
rest String
s                  -- a unique prefix
        [String]
_ | String
cmd String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
ms -> IrcMessage -> Nick -> String -> String -> Telegram ()
docmd IrcMessage
msg Nick
towhere String
rest String
cmd  -- correct command (usual case)
        [String]
_ | Bool
otherwise     -> case String -> [String] -> (Int, [String])
closests String
cmd [String]
allcmds of
          (Int
n,[String
s]) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
e ,  [String]
ms [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [] -> IrcMessage -> Nick -> String -> String -> Telegram ()
docmd IrcMessage
msg Nick
towhere String
rest String
s -- unique edit match
          (Int
n,[String]
ss)  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
e Bool -> Bool -> Bool
|| [String]
ms [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []            -- some possibilities
              -> LB () -> Telegram ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB () -> Telegram ())
-> (String -> LB ()) -> String -> Telegram ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LB ()
ircmsg (String -> Telegram ()) -> String -> Telegram ()
forall a b. (a -> b) -> a -> b
$ String
"Maybe you meant: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
forall a. Show a => [a] -> String
showClean([String] -> [String]
forall a. Eq a => [a] -> [a]
nub([String]
ms[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
ss))
          (Int, [String])
_   -> IrcMessage -> Nick -> String -> String -> Telegram ()
docmd IrcMessage
msg Nick
towhere String
rest String
cmd         -- no prefix, edit distance too far

docmd :: IrcMessage -> Nick -> [Char] -> String -> Telegram ()
docmd :: IrcMessage -> Nick -> String -> String -> Telegram ()
docmd IrcMessage
msg Nick
towhere String
rest String
cmd' = LB () -> Telegram ()
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB () -> Telegram ()) -> LB () -> Telegram ()
forall a b. (a -> b) -> a -> b
$ 
    String
-> LB ()
-> (forall st. Command (ModuleT st LB) -> ModuleT st LB ())
-> LB ()
forall a.
String
-> LB a
-> (forall st. Command (ModuleT st LB) -> ModuleT st LB a)
-> LB a
withCommand String
cmd'   -- Important.
        (Text -> Text -> Text -> LB ()
tgIrcPrivMsg (IrcMessage -> Text
getTgChatId IrcMessage
msg) (IrcMessage -> Text
getTgMsgId IrcMessage
msg)  Text
"Unknown command, try @list")
        (\Command (ModuleT st LB)
theCmd -> do
            Bool
hasPrivs <- LB Bool -> ModuleT st LB Bool
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (IrcMessage -> LB Bool
checkPrivs IrcMessage
msg)
            -- TODO: handle disabled commands earlier
            -- users should probably see no difference between a
            -- command that is disabled and one that doesn't exist.
            Bool
disabled <- String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
cmd' ([String] -> Bool) -> ModuleT st LB [String] -> ModuleT st LB Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config [String] -> ModuleT st LB [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
disabledCommands
            let ok :: Bool
ok = Bool -> Bool
not Bool
disabled Bool -> Bool -> Bool
&& (Bool -> Bool
not (Command (ModuleT st LB) -> Bool
forall (m :: * -> *). Command m -> Bool
privileged Command (ModuleT st LB)
theCmd) Bool -> Bool -> Bool
|| Bool
hasPrivs)

            -- unfortunately we have to pre-process command here to add some context,
            -- since the 'process' accepts a 'String' but we want more info specified
            -- (e.g. 'ChatId') to create multiple sandboxes
            String -> ModuleT st LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
debugM (String -> ModuleT st LB ()) -> String -> ModuleT st LB ()
forall a b. (a -> b) -> a -> b
$ String
"docmd : nick : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Nick -> String
fmtNick String
"" Nick
towhere String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : cmd : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" : input : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rest
            let new :: String
new = if String
cmd' String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"@run", String
"@define", String
"@undefine", String
"@let", String
"run", String
"define", String
"undefine", String
"let"]
                  then Text -> String
Text.unpack (IrcMessage -> Text
getTgChatId IrcMessage
msg) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"|" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rest
                  else String
rest

            [String]
response <- if Bool -> Bool
not Bool
ok
                then [String] -> ModuleT st LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Not enough privileges"]
                else Command (ModuleT st LB)
-> IrcMessage -> Nick -> String -> String -> ModuleT st LB [String]
forall (m :: * -> *) a.
(Monad m, Message a) =>
Command m -> a -> Nick -> String -> String -> m [String]
runCommand Command (ModuleT st LB)
theCmd IrcMessage
msg Nick
towhere String
cmd' String
new
                    ModuleT st LB [String]
-> (SomeException -> ModuleT st LB [String])
-> ModuleT st LB [String]
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \exc :: SomeException
exc@SomeException{} ->
                        [String] -> ModuleT st LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Plugin `Telegram` failed with: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exc]
            
            LB () -> ModuleT st LB ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB () -> ModuleT st LB ()) -> LB () -> ModuleT st LB ()
forall a b. (a -> b) -> a -> b
$ (String -> LB ()) -> [String] -> LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> Text -> Text -> LB ()
tgIrcPrivMsg (IrcMessage -> Text
getTgChatId IrcMessage
msg) (IrcMessage -> Text
getTgMsgId IrcMessage
msg) (Text -> LB ()) -> (String -> Text) -> String -> LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
expandTab Int
8) [String]
response
        )


closests :: String -> [String] -> (Int,[String])
closests :: String -> [String] -> (Int, [String])
closests String
pat [String]
ss = Map Int [String] -> (Int, [String])
forall k a. Map k a -> (k, a)
Map.findMin Map Int [String]
m
  where
    m :: Map Int [String]
m = ([String] -> [String] -> [String])
-> [(Int, [String])] -> Map Int [String]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++) [(Int, [String])]
ls
    ls :: [(Int, [String])]
ls = [ (EditCosts -> String -> String -> Int
levenshteinDistance EditCosts
defaultEditCosts String
pat String
s, [String
s]) | String
s <- [String]
ss ]

maybeCommand :: String -> String -> Maybe String
maybeCommand :: String -> String -> Maybe String
maybeCommand String
nm String
text = MatchResult String -> String
forall a. MatchResult a -> a
mrAfter (MatchResult String -> String)
-> Maybe (MatchResult String) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Regex -> String -> Maybe (MatchResult String)
forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
re String
text
  where
    re :: Regex
    re :: Regex
re = String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex (String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[.:,]*[[:space:]]*")