{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StrictData #-}
module Lambdabot.Plugin.Telegram
  ( -- * Lambdabot state

    lambdabotVersion
  , telegramPlugins
  , telegramPlugin
  , customHaskellPlugins
  , newTelegramState
  , feed
  , handleMsg
  , lockRC
  , unlockRC

  -- * Eval

  -- $eval
  , args, isEval, dropPrefix, runGHC, define, mergeModules, moduleProblems, moveFile, customComp, resetCustomL_hs, findPristine_hs, findCustomL_hs

  -- $chatType
  , ChatInfo(..), ChatType(..), renderChatType, readChatInfoFromSource, dropChatInfoFromSource, getDotFilename, getLFilename, editModuleName
  ) where

import Codec.Binary.UTF8.String
import Control.Concurrent.Lifted
import Control.Concurrent.STM
import Control.Exception.Lifted (SomeException, try, finally)
import Control.Monad (void, when)
import Control.Monad.State (gets, lift, liftIO, modify)
import Data.Char
import Data.List
import qualified Data.Map.Strict as Map
import Data.Ord
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import Data.Version
import qualified Language.Haskell.Exts.Simple as Hs
import System.Directory
import System.Exit
import System.Process
import System.Timeout.Lifted
import Telegram.Bot.Simple
import Text.Pretty.Simple (pStringNoColor)

import Lambdabot.Command
import Lambdabot.Config.Telegram
import Lambdabot.IRC
import Lambdabot.Monad
import Lambdabot.Module
import Lambdabot.Nick
import Lambdabot.Plugin
import Lambdabot.Util

import Lambdabot.Plugin.Telegram.Bot
import Lambdabot.Plugin.Telegram.Callback
import Lambdabot.Plugin.Telegram.Message
import Lambdabot.Plugin.Telegram.Shared

-- * Lambdabot state

-- | Lambdabot version from 'lambdabot-core' package.
lambdabotVersion :: String
lambdabotVersion :: String
lambdabotVersion = VERSION_lambdabot_core

-- | Exported plugin(s).
telegramPlugins :: [String]
telegramPlugins :: [String]
telegramPlugins = [String
"telegram"]

-- | Eval excluded because we provide it by ourselves.
customHaskellPlugins :: [String]
customHaskellPlugins :: [String]
customHaskellPlugins =
  [ String
"check", String
"djinn", String
"free", String
"haddock", String
"hoogle", String
"instances"
  , String
"pl", String
"pointful", String
"pretty", String
"source", String
"type", String
"undo", String
"unmtl"
  ]

-- | Telegram plugin for Lambdabot.
-- Here we redefined @eval@ plugin to provide multiple sandboxes for different chats.
telegramPlugin :: Module TelegramState
telegramPlugin :: Module TelegramState
telegramPlugin = Module TelegramState
forall st. Module st
newModule
  { moduleDefState :: LB TelegramState
moduleDefState = LB TelegramState
newTelegramState
  , moduleInit :: ModuleT TelegramState LB ()
moduleInit = do
      LB () -> ModuleT TelegramState LB ()
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB () -> ModuleT TelegramState LB ())
-> ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState)
-> ModuleT TelegramState LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> ModuleT TelegramState LB ())
-> (IRCRWState -> IRCRWState) -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
s -> IRCRWState
s
        { ircPrivilegedUsers :: Set Nick
ircPrivilegedUsers = Nick -> Set Nick -> Set Nick
forall a. Ord a => a -> Set a -> Set a
Set.insert (String -> String -> Nick
Nick String
"telegramrc" String
"null") (IRCRWState -> Set Nick
ircPrivilegedUsers IRCRWState
s)
        }
      -- register callback for telegram
      String -> Callback TelegramState -> ModuleT TelegramState LB ()
forall st. String -> Callback st -> ModuleT st LB ()
registerCallback String
"TGMSG" Callback TelegramState
doTGMSG
      String -> ModuleT TelegramState LB ()
ldebug String
"TGMSG callback registered"
      -- note: moduleInit is invoked with exceptions masked
      ModuleT TelegramState LB ThreadId -> ModuleT TelegramState LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModuleT TelegramState LB ThreadId -> ModuleT TelegramState LB ())
-> (ModuleT TelegramState LB ()
    -> ModuleT TelegramState LB ThreadId)
-> ModuleT TelegramState LB ()
-> ModuleT TelegramState LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleT TelegramState LB () -> ModuleT TelegramState LB ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
forkUnmasked (ModuleT TelegramState LB () -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ do
        ModuleT TelegramState LB ()
forall (m :: * -> *). MonadLB m => m ()
waitForInit
        ModuleT TelegramState LB ()
lockRC
  , moduleCmds :: ModuleT TelegramState LB [Command (ModuleT TelegramState LB)]
moduleCmds = [Command (ModuleT TelegramState LB)]
-> ModuleT TelegramState LB [Command (ModuleT TelegramState LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ (String -> Command Identity
command String
"telegram")
        { privileged :: Bool
privileged = Bool
True
        , help :: Cmd (ModuleT TelegramState LB) ()
help = String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"telegram. Start a bot"
        , process :: String -> Cmd (ModuleT TelegramState LB) ()
process = Cmd (ModuleT TelegramState LB) ()
-> String -> Cmd (ModuleT TelegramState LB) ()
forall a b. a -> b -> a
const (Cmd (ModuleT TelegramState LB) ()
 -> String -> Cmd (ModuleT TelegramState LB) ())
-> (ModuleT TelegramState LB ()
    -> Cmd (ModuleT TelegramState LB) ())
-> ModuleT TelegramState LB ()
-> String
-> Cmd (ModuleT TelegramState LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleT TelegramState LB () -> Cmd (ModuleT TelegramState LB) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ModuleT TelegramState LB ()
 -> String -> Cmd (ModuleT TelegramState LB) ())
-> ModuleT TelegramState LB ()
-> String
-> Cmd (ModuleT TelegramState LB) ()
forall a b. (a -> b) -> a -> b
$ do
            ModuleT TelegramState LB ()
lockRC
            String
histFile <- LB String -> ModuleT TelegramState LB String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB String -> ModuleT TelegramState LB String)
-> LB String -> ModuleT TelegramState LB String
forall a b. (a -> b) -> a -> b
$ String -> LB String
findLBFileForWriting String
"telegramrc"
            -- FIXME: token should be passed via config or env
            Token
token <- IO Token -> ModuleT TelegramState LB Token
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Token -> ModuleT TelegramState LB Token)
-> IO Token -> ModuleT TelegramState LB Token
forall a b. (a -> b) -> a -> b
$ String -> IO Token
getEnvToken String
"TELEGRAM_LAMBDABOT_TOKEN"
            TelegramState
tgState <- ModuleT TelegramState LB TelegramState
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
            ThreadId
_ <- ModuleT TelegramState LB () -> ModuleT TelegramState LB ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (IO () -> ModuleT TelegramState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT TelegramState LB ())
-> IO () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ Token -> TelegramState -> IO ()
runTelegramBot Token
token TelegramState
tgState)
            String -> ModuleT TelegramState LB ()
ldebug String
"telegram bot started"
            ThreadId
_ <- ModuleT TelegramState LB () -> ModuleT TelegramState LB ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (String -> ModuleT TelegramState LB ()
telegramLoop String
histFile ModuleT TelegramState LB ()
-> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`finally` ModuleT TelegramState LB ()
unlockRC)
            String -> ModuleT TelegramState LB ()
ldebug String
"telegram loop started"
            () -> ModuleT TelegramState LB ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        }
    , (String -> Command Identity
command String
"tgversion")
        { help :: Cmd (ModuleT TelegramState LB) ()
help = String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT TelegramState LB) ())
-> String -> Cmd (ModuleT TelegramState LB) ()
forall a b. (a -> b) -> a -> b
$
            String
"version/source. Report version(s) and git repo of this bot."
        , process :: String -> Cmd (ModuleT TelegramState LB) ()
process = Cmd (ModuleT TelegramState LB) ()
-> String -> Cmd (ModuleT TelegramState LB) ()
forall a b. a -> b -> a
const (Cmd (ModuleT TelegramState LB) ()
 -> String -> Cmd (ModuleT TelegramState LB) ())
-> Cmd (ModuleT TelegramState LB) ()
-> String
-> Cmd (ModuleT TelegramState LB) ()
forall a b. (a -> b) -> a -> b
$ do
            Version
ver <- Config Version -> Cmd (ModuleT TelegramState LB) Version
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Version
telegramLambdabotVersion
            String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT TelegramState LB) ())
-> String -> Cmd (ModuleT TelegramState LB) ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
              [ String
"telegram-lambdabot v."
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
ver
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". git clone https://github.com/swamp-agr/lambdabot-telegram-plugins.git"
              , String
"lambdabot-core v."
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
lambdabotVersion
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". git clone https://github.com/lambdabot/lambdabot.git"
              ]
        }
    , (String -> Command Identity
command String
"run")
        { help :: Cmd (ModuleT TelegramState LB) ()
help = String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!"
        , process :: String -> Cmd (ModuleT TelegramState LB) ()
process = ModuleT TelegramState LB String
-> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 (ModuleT TelegramState LB String
 -> Cmd (ModuleT TelegramState LB) ())
-> (String -> ModuleT TelegramState LB String)
-> String
-> Cmd (ModuleT TelegramState LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleT TelegramState LB String
forall (m :: * -> *). MonadLB m => String -> m String
runGHC
        }
    , (String -> Command Identity
command String
"let")
        { aliases :: [String]
aliases = [String
"define"] -- because @define always gets "corrected" to @undefine
        , help :: Cmd (ModuleT TelegramState LB) ()
help = String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"let <x> = <e>. Add a binding"
        , process :: String -> Cmd (ModuleT TelegramState LB) ()
process = ModuleT TelegramState LB String
-> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => m String -> Cmd m ()
lim80 (ModuleT TelegramState LB String
 -> Cmd (ModuleT TelegramState LB) ())
-> (String -> ModuleT TelegramState LB String)
-> String
-> Cmd (ModuleT TelegramState LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleT TelegramState LB String
forall (m :: * -> *). MonadLB m => String -> m String
define
        }
    , (String -> Command Identity
command String
"undefine")
        { help :: Cmd (ModuleT TelegramState LB) ()
help = String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"undefine. Reset evaluator local bindings"
        , process :: String -> Cmd (ModuleT TelegramState LB) ()
process = \String
s -> 
            let chatInfo :: ChatInfo
chatInfo = String -> ChatInfo
readChatInfoFromSource String
s
                s' :: String
s' = ChatInfo -> String -> String
dropChatInfoFromSource ChatInfo
chatInfo String
s
             in 
            if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s'
              then ChatInfo -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). MonadLB m => ChatInfo -> m ()
resetCustomL_hs ChatInfo
chatInfo Cmd (ModuleT TelegramState LB) ()
-> Cmd (ModuleT TelegramState LB) ()
-> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Undefined."
              else String -> Cmd (ModuleT TelegramState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"There's currently no way to undefine just one thing.  Say @undefine (with no extra words) to undefine everything."
        }
    ]
  }

-- | Initialise 'TelegramState' from Lambdabot config and with defaults. Current defaults are:
-- 
-- * Input queue size: 1000000.
-- * Output queue size: 1000000.
newTelegramState :: LB TelegramState
newTelegramState :: LB TelegramState
newTelegramState = do
  Text
tgBotName <- String -> Text
Text.pack (String -> Text) -> LB String -> LB Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config String -> LB String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
telegramBotName
  IO TelegramState -> LB TelegramState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TelegramState -> LB TelegramState)
-> IO TelegramState -> LB TelegramState
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" bot name is : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (Text
tgBotName)
    let size :: Natural
size = Natural
1000000
        tgCurrent :: Int
tgCurrent = Int
0
    TBQueue Msg
tgInput <- Natural -> IO (TBQueue Msg)
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
size
    TBQueue Msg
tgOutput <- Natural -> IO (TBQueue Msg)
forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
size
  
    TelegramState -> IO TelegramState
forall (m :: * -> *) a. Monad m => a -> m a
return TelegramState :: TBQueue Msg -> TBQueue Msg -> Int -> Text -> TelegramState
TelegramState {Int
Text
TBQueue Msg
tgBotName :: Text
tgCurrent :: Int
tgOutput :: TBQueue Msg
tgInput :: TBQueue Msg
tgOutput :: TBQueue Msg
tgInput :: TBQueue Msg
tgCurrent :: Int
tgBotName :: Text
..}

-- | Commands preprocessing. Commands started with @>@, @!@ would be replaced
-- with @<commadPrefix (from Lambdabot config)> + "run "@.
-- Resulted command would be passed to IRC @system@ plugin.
feed :: Text -> Text -> Text -> Telegram ()
feed :: Text -> Text -> Text -> ModuleT TelegramState LB ()
feed Text
chatId Text
msgId Text
msg = do
    String
cmdPrefix <- ([String] -> String)
-> ModuleT TelegramState LB [String]
-> ModuleT TelegramState LB String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
forall a. [a] -> a
head (Config [String] -> ModuleT TelegramState LB [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
commandPrefixes)
    let msg' :: String
msg' = case Text -> String
Text.unpack Text
msg of
            Char
'>':String
xs -> String
cmdPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"run " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xs
            Char
'!':String
xs -> String
xs
            String
_      -> String
cmdPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (Text -> String
Text.unpack Text
msg)
    -- note that `msg'` is unicode, but lambdabot wants utf-8 lists of bytes
    LB () -> ModuleT TelegramState LB ()
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB () -> ModuleT TelegramState LB ())
-> (IrcMessage -> LB ()) -> Callback TelegramState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LB (Maybe ()) -> LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LB (Maybe ()) -> LB ())
-> (IrcMessage -> LB (Maybe ())) -> IrcMessage -> LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LB () -> LB (Maybe ())
forall (m :: * -> *) a.
MonadBaseControl IO m =>
Int -> m a -> m (Maybe a)
timeout (Int
15 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (LB () -> LB (Maybe ()))
-> (IrcMessage -> LB ()) -> IrcMessage -> LB (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IrcMessage -> LB ()
received Callback TelegramState -> Callback TelegramState
forall a b. (a -> b) -> a -> b
$
      Text -> Text -> Text -> IrcMessage
makeIrcMessage Text
chatId Text
msgId (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
encodeString String
msg')

-- | Transcoding the response from IRC @system@ plugin and sending message back to Telegram. 
handleMsg :: IrcMessage -> Telegram ()
handleMsg :: Callback TelegramState
handleMsg IrcMessage
msg = do
  let str :: String
str = case ([String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String])
-> (IrcMessage -> [String]) -> IrcMessage -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IrcMessage -> [String]
ircMsgParams) IrcMessage
msg of
        []    -> []
        (String
x:[String]
_) -> String -> String
forall a. [a] -> [a]
tail String
x
  -- str contains utf-8 list of bytes; convert to unicode
  TelegramState
tg <- ModuleT TelegramState LB TelegramState
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
  let out :: Msg
out = Msg :: Text -> Text -> Text -> Msg
Msg
        { msgChatId :: Text
msgChatId = IrcMessage -> Text
getTgChatId IrcMessage
msg
        , msgMsgId :: Text
msgMsgId = IrcMessage -> Text
getTgMsgId IrcMessage
msg
        , msgMessage :: Text
msgMessage = (Text -> Text
TL.toStrict (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pStringNoColor (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
decodeString) String
str
        }
  String -> ModuleT TelegramState LB ()
ldebug (String -> ModuleT TelegramState LB ())
-> String -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ String
"handleMsg : irc : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (IrcMessage -> String
forall a. Show a => a -> String
show IrcMessage
msg)
  String -> ModuleT TelegramState LB ()
ldebug (String -> ModuleT TelegramState LB ())
-> String -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ String
"handleMsg : out : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Msg -> String
forall a. Show a => a -> String
show Msg
out)
  IO () -> ModuleT TelegramState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT TelegramState LB ())
-> IO () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ Msg -> TelegramState -> IO ()
writeOutput Msg
out TelegramState
tg

-- | Register @telegram@ plugin in lambdabot core.
lockRC :: Telegram ()
lockRC :: ModuleT TelegramState LB ()
lockRC = do
  (LBState (ModuleT TelegramState LB)
 -> (LBState (ModuleT TelegramState LB)
     -> ModuleT TelegramState LB ())
 -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB ()
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS ((LBState (ModuleT TelegramState LB)
  -> (LBState (ModuleT TelegramState LB)
      -> ModuleT TelegramState LB ())
  -> ModuleT TelegramState LB ())
 -> ModuleT TelegramState LB ())
-> (LBState (ModuleT TelegramState LB)
    -> (LBState (ModuleT TelegramState LB)
        -> ModuleT TelegramState LB ())
    -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ \ LBState (ModuleT TelegramState LB)
tg LBState (ModuleT TelegramState LB) -> ModuleT TelegramState LB ()
writ -> do
    Bool -> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TelegramState -> Int
tgCurrent LBState (ModuleT TelegramState LB)
TelegramState
tg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (ModuleT TelegramState LB () -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ do
      String -> Callback TelegramState -> ModuleT TelegramState LB ()
forall st. String -> Callback st -> ModuleT st LB ()
registerServer String
"telegramrc" Callback TelegramState
handleMsg
      LB () -> ModuleT TelegramState LB ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB () -> ModuleT TelegramState LB ())
-> LB () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ (IRCRWState -> IRCRWState) -> LB ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((IRCRWState -> IRCRWState) -> LB ())
-> (IRCRWState -> IRCRWState) -> LB ()
forall a b. (a -> b) -> a -> b
$ \IRCRWState
state' ->
        IRCRWState
state' { ircPersists :: Map String Bool
ircPersists = String -> Bool -> Map String Bool -> Map String Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
"telegramrc" Bool
True (Map String Bool -> Map String Bool)
-> Map String Bool -> Map String Bool
forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map String Bool
ircPersists IRCRWState
state' }
      LBState (ModuleT TelegramState LB) -> ModuleT TelegramState LB ()
writ (LBState (ModuleT TelegramState LB)
TelegramState
tg { tgCurrent :: Int
tgCurrent = TelegramState -> Int
tgCurrent LBState (ModuleT TelegramState LB)
TelegramState
tg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 })

-- | Unregister @telegram@ plugin in lambdabot core.
unlockRC :: Telegram ()
unlockRC :: ModuleT TelegramState LB ()
unlockRC = (LBState (ModuleT TelegramState LB)
 -> (LBState (ModuleT TelegramState LB)
     -> ModuleT TelegramState LB ())
 -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB ()
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS ((LBState (ModuleT TelegramState LB)
  -> (LBState (ModuleT TelegramState LB)
      -> ModuleT TelegramState LB ())
  -> ModuleT TelegramState LB ())
 -> ModuleT TelegramState LB ())
-> (LBState (ModuleT TelegramState LB)
    -> (LBState (ModuleT TelegramState LB)
        -> ModuleT TelegramState LB ())
    -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ \ LBState (ModuleT TelegramState LB)
tg LBState (ModuleT TelegramState LB) -> ModuleT TelegramState LB ()
writ -> do
  Bool -> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TelegramState -> Int
tgCurrent LBState (ModuleT TelegramState LB)
TelegramState
tg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (ModuleT TelegramState LB () -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ String -> ModuleT TelegramState LB ()
forall mod. String -> ModuleT mod LB ()
unregisterServer String
"telegramrc"
  LBState (ModuleT TelegramState LB) -> ModuleT TelegramState LB ()
writ (LBState (ModuleT TelegramState LB)
TelegramState
tg { tgCurrent :: Int
tgCurrent = TelegramState -> Int
tgCurrent LBState (ModuleT TelegramState LB)
TelegramState
tg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1})

-- | The main loop process.
-- Constantly read the messages from Telegram and passing them to IRC core.
telegramLoop :: FilePath -> Telegram ()
telegramLoop :: String -> ModuleT TelegramState LB ()
telegramLoop String
fp = do
  TelegramState
tg <- ModuleT TelegramState LB TelegramState
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
  Msg
msg <- IO Msg -> ModuleT TelegramState LB Msg
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Msg -> ModuleT TelegramState LB Msg)
-> IO Msg -> ModuleT TelegramState LB Msg
forall a b. (a -> b) -> a -> b
$ TelegramState -> IO Msg
readInput TelegramState
tg
  String -> ModuleT TelegramState LB ()
ldebug (String -> ModuleT TelegramState LB ())
-> String -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ String
"[DEBUG] : lambdabot : input read : " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Msg -> String
forall a. Show a => a -> String
show Msg
msg
  let s' :: Text
s' = (Char -> Bool) -> Text -> Text
Text.dropWhile Char -> Bool
isSpace (Msg -> Text
msgMessage Msg
msg)
  Bool -> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Text -> Bool
Text.null Text
s')) (ModuleT TelegramState LB () -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> ModuleT TelegramState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT TelegramState LB ())
-> IO () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
appendFile String
fp (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Msg -> Text
msgMessage Msg
msg) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
    Text -> Text -> Text -> ModuleT TelegramState LB ()
feed (Msg -> Text
msgChatId Msg
msg) (Msg -> Text
msgMsgId Msg
msg) Text
s'
  Bool
continue <- 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
$ (IRCRWState -> Bool) -> LB Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (String -> Map String Bool -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
"telegramrc" (Map String Bool -> Bool)
-> (IRCRWState -> Map String Bool) -> IRCRWState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IRCRWState -> Map String Bool
ircPersists)
  Bool -> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
continue (ModuleT TelegramState LB () -> ModuleT TelegramState LB ())
-> ModuleT TelegramState LB () -> ModuleT TelegramState LB ()
forall a b. (a -> b) -> a -> b
$ String -> ModuleT TelegramState LB ()
telegramLoop String
fp

-- ** Eval

-- $eval
-- Functions above came from @eval@ plugin from @lambdabot-haskell-plugins@ package.
-- Instead of registering multiple "servers" for each Telegram chat and introducing new entities to manage multiple "servers",
-- we decided to keep a single "server" and to modify "sandboxes".
-- Sandbox is a basically single file "L.hs" that populated once IRC received "@let" command.
-- For every chat used exactly the same file. It means that it was possible to share all definitions across different Telegram chats.
-- To overcome these limitations we decided to create a separate file and associate it with a chat.

-- | Concatenate all input into list of strings to pass to GHC:
--
-- @args filesToLoad sourceExpressionToEvaluate ghcExtensions trustedPackages@
args :: String -> String -> [String] -> [String] -> [String]
args :: String -> String -> [String] -> [String] -> [String]
args String
load String
src [String]
exts [String]
trusted = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [String
"-S"]
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-s" String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
trusted
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
exts
    , [String
"--no-imports", String
"-l", String
load]
    , [String
"--expression=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
decodeString String
src]
    , [String
"+RTS", String
"-N", String
"-RTS"]
    ]

-- | Determine whether command belongs to @eval@ plugin or not.
isEval :: MonadLB m => String -> m Bool
isEval :: String -> m Bool
isEval String
str = do
    [String]
prefixes <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
evalPrefixes
    Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
prefixes [String] -> String -> Bool
`arePrefixesWithSpaceOf` String
str)

-- | Drop command prefix.
dropPrefix :: String -> String
dropPrefix :: String -> String
dropPrefix = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2

-- | Represents "run" command. Actually run GHC.
-- Response would be handled separately via callbacks.
runGHC :: MonadLB m => String -> m String
runGHC :: String -> m String
runGHC String
src' = do
    let chatInfo :: ChatInfo
chatInfo = String -> ChatInfo
readChatInfoFromSource String
src'
        src :: String
src = ChatInfo -> String -> String
dropChatInfoFromSource ChatInfo
chatInfo String
src'

    String
load    <- ChatInfo -> m String
forall (m :: * -> *). MonadLB m => ChatInfo -> m String
findCustomL_hs ChatInfo
chatInfo
    String
binary  <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
muevalBinary
    [String]
exts    <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
    [String]
trusted <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
trustedPackages
    (ExitCode
_,String
out,String
err) <- IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
binary (String -> String -> [String] -> [String] -> [String]
args String
load String
src [String]
exts [String]
trusted) String
"")
    case (String
out,String
err) of
        ([],[]) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Terminated\n"
        (String, String)
_       -> do
            let o :: String
o = String -> String
mungeEnc String
out
                e :: String
e = String -> String
mungeEnc String
err
            String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ case () of {()
_
                | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
o Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
e -> String
"Terminated\n"
                | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
o           -> String
e
                | Bool
otherwise        -> String
o
            }

-- | "define" command. Define a new binding. It would be stored in corresponding sandbox.
define :: MonadLB m => String -> m String
define :: String -> m String
define [] = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Define what?"
define String
src' = do
    [String]
exts <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
    let chatInfo :: ChatInfo
chatInfo = String -> ChatInfo
readChatInfoFromSource String
src'
        src :: String
src = ChatInfo -> String -> String
dropChatInfoFromSource ChatInfo
chatInfo String
src'
        mode :: ParseMode
mode = ParseMode
Hs.defaultParseMode{ extensions :: [Extension]
Hs.extensions = (String -> Extension) -> [String] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Extension
Hs.classifyExtension [String]
exts }
    case ParseMode -> String -> ParseResult Module
Hs.parseModuleWithMode ParseMode
mode (String -> String
decodeString String
src) of
        Hs.ParseOk Module
srcModule -> do
            String
l <- ChatInfo -> m String
forall (m :: * -> *). MonadLB m => ChatInfo -> m String
findCustomL_hs ChatInfo
chatInfo
            ParseResult Module
res <- IO (ParseResult Module) -> m (ParseResult Module)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO (ParseResult Module)
Hs.parseFile String
l)
            case ParseResult Module
res of
                Hs.ParseFailed SrcLoc
loc String
err -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcLoc -> String
forall a. Pretty a => a -> String
Hs.prettyPrint SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
err)
                Hs.ParseOk Module
lModule -> do
                    let merged :: Module
merged = Module -> Module -> Module
mergeModules Module
lModule Module
srcModule
                    case Module -> Maybe String
moduleProblems Module
merged of
                        Just String
msg -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
msg
                        Maybe String
Nothing  -> ChatInfo -> Module -> m String
forall (m :: * -> *). MonadLB m => ChatInfo -> Module -> m String
customComp ChatInfo
chatInfo Module
merged
        Hs.ParseFailed SrcLoc
_loc String
err -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Parse failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)

-- | Merge the second module _into_ the first - meaning where merging doesn't
-- make sense, the field from the first will be used.
mergeModules :: Hs.Module -> Hs.Module -> Hs.Module
mergeModules :: Module -> Module -> Module
mergeModules (Hs.Module  Maybe ModuleHead
head1  [ModulePragma]
exports1 [ImportDecl]
imports1 [Decl]
decls1)
             (Hs.Module Maybe ModuleHead
_head2 [ModulePragma]
_exports2 [ImportDecl]
imports2 [Decl]
decls2)
    = Maybe ModuleHead
-> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module
Hs.Module Maybe ModuleHead
head1 [ModulePragma]
exports1
        ([ImportDecl] -> [ImportDecl] -> [ImportDecl]
mergeImports [ImportDecl]
imports1 [ImportDecl]
imports2)
        ([Decl] -> [Decl] -> [Decl]
mergeDecls   [Decl]
decls1   [Decl]
decls2)
    where
        mergeImports :: [ImportDecl] -> [ImportDecl] -> [ImportDecl]
mergeImports [ImportDecl]
x [ImportDecl]
y = [ImportDecl] -> [ImportDecl]
forall a. Ord a => [a] -> [a]
nub' ((ImportDecl -> ImportDecl -> Ordering)
-> [ImportDecl] -> [ImportDecl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((ImportDecl -> ModuleName ())
-> ImportDecl -> ImportDecl -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ImportDecl -> ModuleName ()
Hs.importModule) ([ImportDecl]
x [ImportDecl] -> [ImportDecl] -> [ImportDecl]
forall a. [a] -> [a] -> [a]
++ [ImportDecl]
y))
        mergeDecls :: [Decl] -> [Decl] -> [Decl]
mergeDecls [Decl]
x [Decl]
y = (Decl -> Decl -> Ordering) -> [Decl] -> [Decl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Decl -> [Name]) -> Decl -> Decl -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Decl -> [Name]
funcNamesBound) ([Decl]
x [Decl] -> [Decl] -> [Decl]
forall a. [a] -> [a] -> [a]
++ [Decl]
y)

        -- this is a very conservative measure... we really only even care about function names,
        -- because we just want to sort those together so clauses can be added in the right places
        -- TODO: find out whether the [Hs.Match] can contain clauses for more than one function (e,g. might it be a whole binding group?)
        funcNamesBound :: Decl -> [Name]
funcNamesBound (Hs.FunBind [Match]
ms) = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Ord a => [a] -> [a]
sort [ Name
n | Hs.Match Name
n [Pat]
_ Rhs
_ Maybe Binds
_ <- [Match]
ms]
        funcNamesBound Decl
_ = []
-- we simply do not care about XML cases
mergeModules Module
_ Module
_ = String -> Module
forall a. HasCallStack => String -> a
error String
"Not supported module met"

-- | Import validations.
moduleProblems :: Hs.Module -> Maybe [Char]
moduleProblems :: Module -> Maybe String
moduleProblems (Hs.Module Maybe ModuleHead
_head [ModulePragma]
pragmas [ImportDecl]
_imports [Decl]
_decls)
    | Name
safe Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
langs  = String -> Maybe String
forall a. a -> Maybe a
Just String
"Module has no \"Safe\" language pragma"
    | Name
trusted Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
langs  = String -> Maybe String
forall a. a -> Maybe a
Just String
"\"Trustworthy\" language pragma is set"
    | Bool
otherwise             = Maybe String
forall a. Maybe a
Nothing
    where
        safe :: Name
safe    = String -> Name
Hs.name String
"Safe"
        trusted :: Name
trusted = String -> Name
Hs.name String
"Trustworthy"
        langs :: [Name]
langs = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name]
ls | Hs.LanguagePragma [Name]
ls <- [ModulePragma]
pragmas ]
-- we simply do not care about XML cases
moduleProblems Module
_ = String -> Maybe String
forall a. HasCallStack => String -> a
error String
"Not supported module met"

-- | Helper for sandboxes. Used to move temporary file.
moveFile :: FilePath -> FilePath -> IO ()
moveFile :: String -> String -> IO ()
moveFile String
from String
to = do
  String -> String -> IO ()
copyFile String
from String
to
  String -> IO ()
removeFile String
from

-- | Custom compilation of temporary files for binding. Used as part of "define" command.
customComp :: MonadLB m => ChatInfo -> Hs.Module -> m String
customComp :: ChatInfo -> Module -> m String
customComp ChatInfo
chatInfo Module
src = do
    -- calculate temporary filename for source, interface and compiled library
    let hs :: String
hs = ChatInfo -> String -> String
getDotFilename ChatInfo
chatInfo String
"hs"
        hi :: String
hi = ChatInfo -> String -> String
getDotFilename ChatInfo
chatInfo String
"hi"
        lib :: String
lib = ChatInfo -> String -> String
getDotFilename ChatInfo
chatInfo String
"o"
        lhs :: String
lhs = ChatInfo -> String
getLFilename ChatInfo
chatInfo
    -- Note we copy to .L.hs, not L.hs. This hides the temporary files as dot-files
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
writeFile String
hs (Module -> String
forall a. Pretty a => a -> String
Hs.prettyPrint Module
src))

    -- and compile .L.hs
    -- careful with timeouts here. need a wrapper.
    [String]
trusted <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
trustedPackages
    let ghcArgs :: [String]
ghcArgs = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [String
"-O", String
"-v0", String
"-c", String
"-Werror", String
"-fpackage-trust"]
            , [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
"-trust", String
pkg] | String
pkg <- [String]
trusted]
            , [String
hs]
            ]
    String
ghc <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghcBinary
    (ExitCode
c, String
o',String
e') <- IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
ghc [String]
ghcArgs String
"")
    -- cleanup, 'try' because in case of error the files are not generated
    Either SomeException ()
_ <- IO (Either SomeException ()) -> m (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try (String -> IO ()
removeFile String
hi) :: IO (Either SomeException ()))
    Either SomeException ()
_ <- IO (Either SomeException ()) -> m (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try (String -> IO ()
removeFile String
lib)  :: IO (Either SomeException ()))

    case (String -> String
mungeEnc String
o', String -> String
mungeEnc String
e') of
        ([],[]) | ExitCode
c ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess -> do
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO ()
removeFile String
hs)
                    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Error."
                | Bool
otherwise -> do
                    String
l <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
lhs)
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
moveFile String
hs String
l)
                    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Defined."
        (String
ee,[]) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ee
        (String
_ ,String
ee) -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ee

-- | Reset sandbox. Associated "L.hs" file would be reset to defaults.
resetCustomL_hs :: MonadLB m => ChatInfo -> m ()
resetCustomL_hs :: ChatInfo -> m ()
resetCustomL_hs ChatInfo
chatInfo = do
    let lhs :: String
lhs = ChatInfo -> String
getLFilename ChatInfo
chatInfo
    String
p <- m String
forall (m :: * -> *). MonadLB m => m String
findPristine_hs
    String
contents <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO String
readFile String
p)
    String
l <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
lhs)
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
writeFile String
l (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatInfo -> String -> String
editModuleName ChatInfo
chatInfo String
contents)

-- | Find "Pristine.hs"; if not found, we try to install a compiler-specific
-- version from lambdabot's data directory, and finally the default one.
findPristine_hs :: MonadLB m => m FilePath
findPristine_hs :: m String
findPristine_hs = do
    Maybe String
p <- LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
"Pristine.hs")
    case Maybe String
p of
        Maybe String
Nothing -> do
            String
p' <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findOrCreateLBFile String
"Pristine.hs")
            Maybe String
p0 <- LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading (String
"Pristine.hs." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (__GLASGOW_HASKELL__ :: Integer)))
            Maybe String
p0' <- case Maybe String
p0 of
                Maybe String
Nothing -> LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
"Pristine.hs.default")
                Maybe String
p0' -> Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
p0'
            case Maybe String
p0' of
                Just String
p0'' -> do
                    String
p'' <- LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
"Pristine.hs")
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO ()
copyFile String
p0'' String
p'')
                Maybe String
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p'
        Just String
p' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
p'

-- | Find associated with a chat "L.hs" file; if not found, we copy it from "Pristine.hs".
findCustomL_hs :: MonadLB m => ChatInfo -> m FilePath
findCustomL_hs :: ChatInfo -> m String
findCustomL_hs ChatInfo
chatInfo = do
    let lhs :: String
lhs = ChatInfo -> String
getLFilename ChatInfo
chatInfo
    Maybe String
file <- LB (Maybe String) -> m (Maybe String)
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB (Maybe String)
findLBFileForReading String
lhs)
    case Maybe String
file of
        -- if L.hs
        Maybe String
Nothing -> ChatInfo -> m ()
forall (m :: * -> *). MonadLB m => ChatInfo -> m ()
resetCustomL_hs ChatInfo
chatInfo m () -> m String -> m String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LB String -> m String
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findOrCreateLBFile String
lhs)
        Just String
file' -> String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file'

-- $chatType
-- Since Lambdabot is passing 'String' inside one plugin (see 'process' for more details), Telegram chat information rendered as 'String' and attached to every command to pass between commands and callbacks inside a plugin.

-- | 'ChatInfo' represents an associated Telegram chat. Currently supports private and public chats.
data ChatInfo = ChatInfo
  { ChatInfo -> Text
chatInfoChatId :: !Text
  , ChatInfo -> ChatType
chatInfoType   :: !ChatType
  }

-- | 'ChatType' represents whether chat is public or private.
data ChatType = Public | Private

-- | Since it's not possible to define module with "L-1000" name and private chats in Telegram are usually represented by negative digits, we simple encode it with a character.
renderChatType :: ChatType -> String
renderChatType :: ChatType -> String
renderChatType ChatType
Public = String
""
renderChatType ChatType
Private = String
"P"

-- | Read 'ChatInfo' from command string.
readChatInfoFromSource :: String -> ChatInfo
readChatInfoFromSource :: String -> ChatInfo
readChatInfoFromSource String
str =
  let prefix :: String
prefix = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|') String
str
      mode :: ChatType
mode = case (Char -> Bool) -> String -> Maybe Char
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') String
str of
        Maybe Char
Nothing -> ChatType
Public
        Just Char
_  -> ChatType
Private
      onlyChatId :: String
onlyChatId = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit String
prefix
  in Text -> ChatType -> ChatInfo
ChatInfo (String -> Text
Text.pack String
onlyChatId) ChatType
mode

-- | Drop 'ChatInfo' from command string. Original command is returned.
dropChatInfoFromSource :: ChatInfo -> String -> String
dropChatInfoFromSource :: ChatInfo -> String -> String
dropChatInfoFromSource ChatInfo{Text
ChatType
chatInfoType :: ChatType
chatInfoChatId :: Text
chatInfoType :: ChatInfo -> ChatType
chatInfoChatId :: ChatInfo -> Text
..} String
str = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
prefixLength String
str
  where
    prefixLength :: Int
prefixLength = Text -> Int
Text.length Text
chatInfoChatId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
    m :: Int
m = case ChatType
chatInfoType of
      ChatType
Private -> Int
1
      ChatType
Public  -> Int
0

-- | Generate temporary filename for given 'ChatInfo' and file extension.
getDotFilename :: ChatInfo -> String -> FilePath
getDotFilename :: ChatInfo -> String -> String
getDotFilename ChatInfo{Text
ChatType
chatInfoType :: ChatType
chatInfoChatId :: Text
chatInfoType :: ChatInfo -> ChatType
chatInfoChatId :: ChatInfo -> Text
..} String
extension
  = String
".L" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ChatType -> String
renderChatType ChatType
chatInfoType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
chatInfoChatId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
extension

-- | Generate "L.hs" filename for given 'ChatInfo'.
getLFilename :: ChatInfo -> FilePath
getLFilename :: ChatInfo -> String
getLFilename ChatInfo{Text
ChatType
chatInfoType :: ChatType
chatInfoChatId :: Text
chatInfoType :: ChatInfo -> ChatType
chatInfoChatId :: ChatInfo -> Text
..}
  = String
"L" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ChatType -> String
renderChatType ChatType
chatInfoType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
chatInfoChatId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".hs"

-- | Replace @module L where@ with @module L\<chatId\> where@ where @\<chatId\>@ is a telegram chat ID.
editModuleName :: ChatInfo -> String -> String
editModuleName :: ChatInfo -> String -> String
editModuleName ChatInfo{Text
ChatType
chatInfoType :: ChatType
chatInfoChatId :: Text
chatInfoType :: ChatInfo -> ChatType
chatInfoChatId :: ChatInfo -> Text
..} String
str =
  let moduleName :: Text
moduleName = Text
"L" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (ChatType -> String
renderChatType ChatType
chatInfoType) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
chatInfoChatId
      moduleLine :: Text
moduleLine = Text
"module " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
moduleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" where"
  in (Text -> String
Text.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
"module L where" Text
moduleLine (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) String
str

munge, mungeEnc :: String -> String
munge :: String -> String
munge = Int -> String -> String
expandTab Int
8 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
strip (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')
mungeEnc :: String -> String
mungeEnc = String -> String
encodeString (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
munge

nub' :: Ord a => [a] -> [a]
nub' :: [a] -> [a]
nub' = Set a -> [a]
forall a. Set a -> [a]
Set.toList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList