lambdabot-telegram-plugins (empty) → 0.2.0
raw patch · 11 files changed
+1494/−0 lines, 11 filesdep +basedep +containersdep +dependent-map
Dependencies added: base, containers, dependent-map, dependent-sum, directory, edit-distance, haskell-src-exts-simple, lambdabot-core, lambdabot-haskell-plugins, lambdabot-telegram-plugins, lifted-base, monad-control, mtl, pretty-simple, process, regex-tdfa, split, stm, telegram-bot-simple, text, transformers, utf8-string
Files
- CHANGELOG.md +37/−0
- app/Main.hs +81/−0
- app/Modules.hs +13/−0
- lambdabot-telegram-plugins.cabal +86/−0
- src/Lambdabot/Config/Telegram.hs +56/−0
- src/Lambdabot/Plugin/Telegram.hs +475/−0
- src/Lambdabot/Plugin/Telegram/Bot.hs +391/−0
- src/Lambdabot/Plugin/Telegram/Bot/Generic.hs +106/−0
- src/Lambdabot/Plugin/Telegram/Callback.hs +159/−0
- src/Lambdabot/Plugin/Telegram/Message.hs +47/−0
- src/Lambdabot/Plugin/Telegram/Shared.hs +43/−0
+ CHANGELOG.md view
@@ -0,0 +1,37 @@+# Revision history for telegram-lambdabot++## 0.2.0 -- 2022-05-12++Implementation phase is finished. Lambdabot might be considered ready with current release.+See README for more details. Here is a history of changes since its creation.++* Fix unicode output (see [#1](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/1));+* Fix unicode input (see [#2](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/2));+* Support `eval` plugin (see [#3](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/2));+* Support `check` plugin, add type class for different commands from different plugins (see [#4](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/4));+* Add maintenance shell scripts (see [#5](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/5));+* Support `djinn` plugin, derive `FromCommand` via `DeriveGeneric` (see [#6](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/6));+* Support `free` plugin (see [#7](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/7));+* Support `haddock` and `hoogle` plugins (see [#8](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/8));+* Support following plugins: `instances`, `more`, `pl`, `pointful`, `pretty`, `system`, `type`, `undo`, `unmtl`, `version`, `help`, `source` (see [#9](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/9));+* Fix errors from `telegram-bot-simple` via bumping its version (see [#10](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/10));+* Fix `sendMessage` to comply with Bot API 5.7 (see [#11](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/11));+* Fix `/cmd@botname` commands (see [#12](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/12));+* Add lambdabot `Pristine.hs`, fix `source` plugin and disable lambdabot's insults (see [#13](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/13));+* Fix empty `/help` command (see [#14](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/14));+* Show two different versions via `/help` command (see [#15](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/15));+* Support multiple sandboxes, remove shared state across chats (see [#16](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/16));+* Remove `more` command and plugin (see [#17](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/17));+* Enable `TypeApplications` GHC extension (see [#18](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/18));+* Reply to user messages and support user edits (see [#19](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/19));+* Fix commands from all plugins except `eval` (see [#20](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/20));+* Extend `/help` message (see [#21](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/21));+* Unescape unicode output from interpreter (see [#22](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/22));+* Render response from bot as `monospace` (see [#26](https://github.com/swamp-agr/lambdabot-telegram-plugins/pulls?page=1&q=is%3Apr+is%3Aclosed));+* Move bot parser helpers to upstream `telegram-bot-simple` package and use them (see [#27](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/27));+* Add haddock annotations to the code (see [#28](https://github.com/swamp-agr/lambdabot-telegram-plugins/pull/28));++## 0.1.0 -- 2022-02-16++* First version. Released on an unsuspecting world.+* Only `/irc` command added.
+ app/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad+import Control.Monad.Identity+import Data.Char+import Data.Version+import Lambdabot.Main+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++import Lambdabot.Config.Telegram+import Modules (modulesInfo)+import qualified Paths_lambdabot_telegram_plugins as P++flags :: [OptDescr (IO (DSum Config Identity))]+flags = + [ Option "h?" ["help"] (NoArg (usage [])) "Print this help message"+ , Option "l" [] (arg "<level>" consoleLogLevel level) "Set the logging level"+ , Option "t" ["trust"] (arg "<package>" trustedPackages strs) "Trust the specified packages when evaluating code"+ , Option "V" ["version"] (NoArg version) "Print the version of lambdabot"+ , Option "X" [] (arg "<extension>" languageExts strs) "Set a GHC language extension for @run"+ , Option "n" ["name"] (arg "<name>" telegramBotName name) "Set telegram bot name"+ ]+ where + arg :: String -> Config t -> (String -> IO t) -> ArgDescr (IO (DSum Config Identity))+ arg descr key fn = ReqArg (fmap (key ==>) . fn) descr+ + strs = return . (:[])++ name = return+ + level str = case reads (map toUpper str) of+ (lv, []):_ -> return lv+ _ -> usage+ [ "Unknown log level."+ , "Valid levels are: " ++ show [minBound .. maxBound :: Priority]+ ]+ +versionString :: String+versionString = ("lambdabot version " ++ showVersion P.version)++version :: IO a+version = do+ putStrLn versionString+ exitWith ExitSuccess++usage :: [String] -> IO a+usage errors = do+ cmd <- getProgName+ + let isErr = not (null errors)+ out = if isErr then stderr else stdout+ + mapM_ (hPutStrLn out) errors+ when isErr (hPutStrLn out "")+ + hPutStrLn out versionString+ hPutStr out (usageInfo (cmd ++ " [options]") flags)+ + exitWith (if isErr then ExitFailure 1 else ExitSuccess)++-- do argument handling+main :: IO ()+main = do+ (config, nonOpts, errors) <- getOpt Permute flags <$> getArgs+ when (not (null errors && null nonOpts)) (usage errors)+ config' <- sequence config+ dir <- P.getDataDir+ exitWith <=< lambdabotMain modulesInfo $+ [ dataDir ==> dir+ , disabledCommands ==> ["quit"]+ , telegramLambdabotVersion ==> P.version+ , onStartupCmds ==> ["telegram"]+ , enableInsults ==> False+ ] ++ config'+++
+ app/Modules.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}++module Modules (modulesInfo) where++import Lambdabot.Main++-- to add a new plugin, one must first add a qualified import here, and also+-- add a string in the list below+import Lambdabot.Plugin.Haskell+import Lambdabot.Plugin.Telegram++modulesInfo :: Modules+modulesInfo = $(modules $ corePlugins ++ customHaskellPlugins ++ telegramPlugins)
+ lambdabot-telegram-plugins.cabal view
@@ -0,0 +1,86 @@+cabal-version: 2.4+name: lambdabot-telegram-plugins+version: 0.2.0++-- A short (one-line) description of the package.+-- synopsis:++-- A longer description of the package.+-- description:++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+license: GPL-2.0-or-later+author: Andrey Prokopenko+maintainer: persiantiger@yandex.ru+synopsis: Lambdabot for Telegram+description: Lambdabot is an IRC bot written over several years by+ those on the #haskell IRC channel.+ .+ It operates as a command line tool, embedded in an editor,+ embedded in GHCi, via internet relay chat and on the web.+ .+ Telegram bot provided via telegram-bot-simple package.+ .+ This package is a combination of both Lambdabot and Telegram bot.++-- A copyright notice.+-- copyright:+category: Development, Web+extra-source-files: CHANGELOG.md++library+ exposed-modules: Lambdabot.Config.Telegram+ , Lambdabot.Plugin.Telegram+ , Lambdabot.Plugin.Telegram.Bot+ , Lambdabot.Plugin.Telegram.Bot.Generic+ , Lambdabot.Plugin.Telegram.Callback+ , Lambdabot.Plugin.Telegram.Message+ , Lambdabot.Plugin.Telegram.Shared + hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010+ build-depends: base < 4.17+ , containers+ , dependent-map+ , dependent-sum+ , directory+ , edit-distance+ , haskell-src-exts-simple+ , telegram-bot-simple >= 0.5.2+ , text+ , lambdabot-core+ , lifted-base+ , monad-control+ , mtl+ , pretty-simple+ , process+ , regex-tdfa+ , split+ , stm+ , transformers+ , utf8-string+ autogen-modules:+ Paths_lambdabot_telegram_plugins+ other-modules:+ Paths_lambdabot_telegram_plugins++executable telegram-lambdabot+ main-is: Main.hs++ -- Modules included in this executable, other than Main.+ other-modules: Modules+ , Paths_lambdabot_telegram_plugins++ build-depends: base < 4.17+ , lambdabot-core+ , lambdabot-haskell-plugins+ , lambdabot-telegram-plugins+ , mtl++ + hs-source-dirs: app+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010
+ src/Lambdabot/Config/Telegram.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+module Lambdabot.Config.Telegram where++import Data.Version+import Lambdabot.Config++-- | Telegram Bot Name.+config "telegramBotName" [t| String |] [| "TelegramLambdabot" |]++-- | Telegram Lambdabot Version.+config "telegramLambdabotVersion" [t| Version |] [| Version [] [] |]++-- | Path to @mueval@ executable.+config "muevalBinary" [t| String |] [| "mueval" |]+++-- | Extensions to enable for the interpreted expression+-- (and probably also @L.hs@ if it doesn't already have these set)+--+-- Some of these settings were propagated from 'lambdabot-haskell-plugins'+-- because @eval@ plugin internals were hidden.+defaultExts :: [String]+defaultExts =+ [ "ImplicitPrelude" -- workaround for bug in hint package+ , "ExtendedDefaultRules"+ , "TypeApplications"+ ]++-- | Language extensions used by Telegram Lambdabot: combination of predefined 'defaultExts' and user-defined ones.+configWithMerge [| (++) |] "languageExts" [t| [String] |] [| defaultExts |]++-- | Predefined packages that are mandatory.+trustedPkgs :: [String]+trustedPkgs =+ [ "array"+ , "base"+ , "bytestring"+ , "containers"+ , "lambdabot-trusted"+ , "random"+ ]++-- | Set of trusted packages. Combination of predefined 'trustedPkgs' and user-defined ones.+configWithMerge [| (++) |] "trustedPackages" [t| [String] |] [| trustedPkgs |]++-- | Command prefixes for fork of @eval@ plugin.+config "evalPrefixes" [t| [String] |] [| [">"] |]++-- | Command to invoke @ghc@.+config "ghcBinary" [t| String |] [| "ghc" |]++-- | Command to invoke @ghci@.+config "ghciBinary" [t| String |] [| "ghci" |]
+ src/Lambdabot/Plugin/Telegram.hs view
@@ -0,0 +1,475 @@+{-# 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 = VERSION_lambdabot_core++-- | Exported plugin(s).+telegramPlugins :: [String]+telegramPlugins = ["telegram"]++-- | Eval excluded because we provide it by ourselves.+customHaskellPlugins :: [String]+customHaskellPlugins =+ [ "check", "djinn", "free", "haddock", "hoogle", "instances"+ , "pl", "pointful", "pretty", "source", "type", "undo", "unmtl"+ ]++-- | Telegram plugin for Lambdabot.+-- Here we redefined @eval@ plugin to provide multiple sandboxes for different chats.+telegramPlugin :: Module TelegramState+telegramPlugin = newModule+ { moduleDefState = newTelegramState+ , moduleInit = do+ lb . modify $ \s -> s+ { ircPrivilegedUsers = Set.insert (Nick "telegramrc" "null") (ircPrivilegedUsers s)+ }+ -- register callback for telegram+ registerCallback "TGMSG" doTGMSG+ ldebug "TGMSG callback registered"+ -- note: moduleInit is invoked with exceptions masked+ void . forkUnmasked $ do+ waitForInit+ lockRC+ , moduleCmds = return+ [ (command "telegram")+ { privileged = True+ , help = say "telegram. Start a bot"+ , process = const . lift $ do+ lockRC+ histFile <- lb $ findLBFileForWriting "telegramrc"+ -- FIXME: token should be passed via config or env+ token <- io $ getEnvToken "TELEGRAM_LAMBDABOT_TOKEN"+ tgState <- readMS+ _ <- fork (io $ runTelegramBot token tgState)+ ldebug "telegram bot started"+ _ <- fork (telegramLoop histFile `finally` unlockRC)+ ldebug "telegram loop started"+ return ()+ }+ , (command "tgversion")+ { help = say $+ "version/source. Report version(s) and git repo of this bot."+ , process = const $ do+ ver <- getConfig telegramLambdabotVersion+ say $ unlines $+ [ "telegram-lambdabot v."+ <> showVersion ver+ <> ". git clone https://github.com/swamp-agr/lambdabot-telegram-plugins.git"+ , "lambdabot-core v."+ <> lambdabotVersion+ <> ". git clone https://github.com/lambdabot/lambdabot.git"+ ]+ }+ , (command "run")+ { help = say "run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!"+ , process = lim80 . runGHC+ }+ , (command "let")+ { aliases = ["define"] -- because @define always gets "corrected" to @undefine+ , help = say "let <x> = <e>. Add a binding"+ , process = lim80 . define+ }+ , (command "undefine")+ { help = say "undefine. Reset evaluator local bindings"+ , process = \s -> + let chatInfo = readChatInfoFromSource s+ s' = dropChatInfoFromSource chatInfo s+ in + if null s'+ then resetCustomL_hs chatInfo >> say "Undefined."+ else say "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 = do+ tgBotName <- Text.pack <$> getConfig telegramBotName+ liftIO $ do+ putStrLn $ " bot name is : " <> Text.unpack (tgBotName)+ let size = 1000000+ tgCurrent = 0+ tgInput <- newTBQueueIO size+ tgOutput <- newTBQueueIO size+ + return TelegramState {..}++-- | 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 chatId msgId msg = do+ cmdPrefix <- fmap head (getConfig commandPrefixes)+ let msg' = case Text.unpack msg of+ '>':xs -> cmdPrefix ++ "run " ++ xs+ '!':xs -> xs+ _ -> cmdPrefix ++ dropWhile (== ' ') (Text.unpack msg)+ -- note that `msg'` is unicode, but lambdabot wants utf-8 lists of bytes+ lb . void . timeout (15 * 1000 * 1000) . received $+ makeIrcMessage chatId msgId (Text.pack $ encodeString msg')++-- | Transcoding the response from IRC @system@ plugin and sending message back to Telegram. +handleMsg :: IrcMessage -> Telegram ()+handleMsg msg = do+ let str = case (tail . ircMsgParams) msg of+ [] -> []+ (x:_) -> tail x+ -- str contains utf-8 list of bytes; convert to unicode+ tg <- readMS+ let out = Msg+ { msgChatId = getTgChatId msg+ , msgMsgId = getTgMsgId msg+ , msgMessage = (TL.toStrict . pStringNoColor . decodeString) str+ }+ ldebug $ "handleMsg : irc : " <> (show msg)+ ldebug $ "handleMsg : out : " <> (show out)+ io $ writeOutput out tg++-- | Register @telegram@ plugin in lambdabot core.+lockRC :: Telegram ()+lockRC = do+ withMS $ \ tg writ -> do+ when (tgCurrent tg == 0) $ do+ registerServer "telegramrc" handleMsg+ lift $ modify $ \state' ->+ state' { ircPersists = Map.insert "telegramrc" True $ ircPersists state' }+ writ (tg { tgCurrent = tgCurrent tg + 1 })++-- | Unregister @telegram@ plugin in lambdabot core.+unlockRC :: Telegram ()+unlockRC = withMS $ \ tg writ -> do+ when (tgCurrent tg == 1) $ unregisterServer "telegramrc"+ writ (tg { tgCurrent = tgCurrent tg - 1})++-- | The main loop process.+-- Constantly read the messages from Telegram and passing them to IRC core.+telegramLoop :: FilePath -> Telegram ()+telegramLoop fp = do+ tg <- readMS+ msg <- io $ readInput tg+ ldebug $ "[DEBUG] : lambdabot : input read : " <> show msg+ let s' = Text.dropWhile isSpace (msgMessage msg)+ when (not (Text.null s')) $ do+ io $ appendFile fp $ Text.unpack (msgMessage msg) <> "\n"+ feed (msgChatId msg) (msgMsgId msg) s'+ continue <- lift $ gets (Map.member "telegramrc" . ircPersists)+ when continue $ telegramLoop 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 load src exts trusted = concat+ [ ["-S"]+ , map ("-s" ++) trusted+ , map ("-X" ++) exts+ , ["--no-imports", "-l", load]+ , ["--expression=" ++ decodeString src]+ , ["+RTS", "-N", "-RTS"]+ ]++-- | Determine whether command belongs to @eval@ plugin or not.+isEval :: MonadLB m => String -> m Bool+isEval str = do+ prefixes <- getConfig evalPrefixes+ return (prefixes `arePrefixesWithSpaceOf` str)++-- | Drop command prefix.+dropPrefix :: String -> String+dropPrefix = dropWhile (' ' ==) . drop 2++-- | Represents "run" command. Actually run GHC.+-- Response would be handled separately via callbacks.+runGHC :: MonadLB m => String -> m String+runGHC src' = do+ let chatInfo = readChatInfoFromSource src'+ src = dropChatInfoFromSource chatInfo src'++ load <- findCustomL_hs chatInfo+ binary <- getConfig muevalBinary+ exts <- getConfig languageExts+ trusted <- getConfig trustedPackages+ (_,out,err) <- io (readProcessWithExitCode binary (args load src exts trusted) "")+ case (out,err) of+ ([],[]) -> return "Terminated\n"+ _ -> do+ let o = mungeEnc out+ e = mungeEnc err+ return $ case () of {_+ | null o && null e -> "Terminated\n"+ | null o -> e+ | otherwise -> o+ }++-- | "define" command. Define a new binding. It would be stored in corresponding sandbox.+define :: MonadLB m => String -> m String+define [] = return "Define what?"+define src' = do+ exts <- getConfig languageExts+ let chatInfo = readChatInfoFromSource src'+ src = dropChatInfoFromSource chatInfo src'+ mode = Hs.defaultParseMode{ Hs.extensions = map Hs.classifyExtension exts }+ case Hs.parseModuleWithMode mode (decodeString src) of+ Hs.ParseOk srcModule -> do+ l <- findCustomL_hs chatInfo+ res <- io (Hs.parseFile l)+ case res of+ Hs.ParseFailed loc err -> return (Hs.prettyPrint loc ++ ':' : err)+ Hs.ParseOk lModule -> do+ let merged = mergeModules lModule srcModule+ case moduleProblems merged of+ Just msg -> return msg+ Nothing -> customComp chatInfo merged+ Hs.ParseFailed _loc err -> return ("Parse failed: " ++ 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 (Hs.Module head1 exports1 imports1 decls1)+ (Hs.Module _head2 _exports2 imports2 decls2)+ = Hs.Module head1 exports1+ (mergeImports imports1 imports2)+ (mergeDecls decls1 decls2)+ where+ mergeImports x y = nub' (sortBy (comparing Hs.importModule) (x ++ y))+ mergeDecls x y = sortBy (comparing funcNamesBound) (x ++ 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 (Hs.FunBind ms) = nub $ sort [ n | Hs.Match n _ _ _ <- ms]+ funcNamesBound _ = []+-- we simply do not care about XML cases+mergeModules _ _ = error "Not supported module met"++-- | Import validations.+moduleProblems :: Hs.Module -> Maybe [Char]+moduleProblems (Hs.Module _head pragmas _imports _decls)+ | safe `notElem` langs = Just "Module has no \"Safe\" language pragma"+ | trusted `elem` langs = Just "\"Trustworthy\" language pragma is set"+ | otherwise = Nothing+ where+ safe = Hs.name "Safe"+ trusted = Hs.name "Trustworthy"+ langs = concat [ ls | Hs.LanguagePragma ls <- pragmas ]+-- we simply do not care about XML cases+moduleProblems _ = error "Not supported module met"++-- | Helper for sandboxes. Used to move temporary file.+moveFile :: FilePath -> FilePath -> IO ()+moveFile from to = do+ copyFile from to+ removeFile from++-- | Custom compilation of temporary files for binding. Used as part of "define" command.+customComp :: MonadLB m => ChatInfo -> Hs.Module -> m String+customComp chatInfo src = do+ -- calculate temporary filename for source, interface and compiled library+ let hs = getDotFilename chatInfo "hs"+ hi = getDotFilename chatInfo "hi"+ lib = getDotFilename chatInfo "o"+ lhs = getLFilename chatInfo+ -- Note we copy to .L.hs, not L.hs. This hides the temporary files as dot-files+ io (writeFile hs (Hs.prettyPrint src))++ -- and compile .L.hs+ -- careful with timeouts here. need a wrapper.+ trusted <- getConfig trustedPackages+ let ghcArgs = concat+ [ ["-O", "-v0", "-c", "-Werror", "-fpackage-trust"]+ , concat [["-trust", pkg] | pkg <- trusted]+ , [hs]+ ]+ ghc <- getConfig ghcBinary+ (c, o',e') <- io (readProcessWithExitCode ghc ghcArgs "")+ -- cleanup, 'try' because in case of error the files are not generated+ _ <- io (try (removeFile hi) :: IO (Either SomeException ()))+ _ <- io (try (removeFile lib) :: IO (Either SomeException ()))++ case (mungeEnc o', mungeEnc e') of+ ([],[]) | c /= ExitSuccess -> do+ io (removeFile hs)+ return "Error."+ | otherwise -> do+ l <- lb (findLBFileForWriting lhs)+ io (moveFile hs l)+ return "Defined."+ (ee,[]) -> return ee+ (_ ,ee) -> return ee++-- | Reset sandbox. Associated "L.hs" file would be reset to defaults.+resetCustomL_hs :: MonadLB m => ChatInfo -> m ()+resetCustomL_hs chatInfo = do+ let lhs = getLFilename chatInfo+ p <- findPristine_hs+ contents <- liftIO (readFile p)+ l <- lb (findLBFileForWriting lhs)+ io (writeFile l $ editModuleName chatInfo 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 = do+ p <- lb (findLBFileForReading "Pristine.hs")+ case p of+ Nothing -> do+ p' <- lb (findOrCreateLBFile "Pristine.hs")+ p0 <- lb (findLBFileForReading ("Pristine.hs." ++ show (__GLASGOW_HASKELL__ :: Integer)))+ p0' <- case p0 of+ Nothing -> lb (findLBFileForReading "Pristine.hs.default")+ p0' -> return p0'+ case p0' of+ Just p0'' -> do+ p'' <- lb (findLBFileForWriting "Pristine.hs")+ io (copyFile p0'' p'')+ _ -> return ()+ return p'+ Just p' -> return 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 = do+ let lhs = getLFilename chatInfo+ file <- lb (findLBFileForReading lhs)+ case file of+ -- if L.hs+ Nothing -> resetCustomL_hs chatInfo >> lb (findOrCreateLBFile lhs)+ Just file' -> return 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+ { chatInfoChatId :: !Text+ , 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 Public = ""+renderChatType Private = "P"++-- | Read 'ChatInfo' from command string.+readChatInfoFromSource :: String -> ChatInfo+readChatInfoFromSource str =+ let prefix = takeWhile (/= '|') str+ mode = case find (== '-') str of+ Nothing -> Public+ Just _ -> Private+ onlyChatId = filter isDigit prefix+ in ChatInfo (Text.pack onlyChatId) mode++-- | Drop 'ChatInfo' from command string. Original command is returned.+dropChatInfoFromSource :: ChatInfo -> String -> String+dropChatInfoFromSource ChatInfo{..} str = drop 1 . dropWhile (/= '|') $ drop prefixLength str+ where+ prefixLength = Text.length chatInfoChatId + m+ m = case chatInfoType of+ Private -> 1+ Public -> 0++-- | Generate temporary filename for given 'ChatInfo' and file extension.+getDotFilename :: ChatInfo -> String -> FilePath+getDotFilename ChatInfo{..} extension+ = ".L" <> renderChatType chatInfoType <> Text.unpack chatInfoChatId <> "." <> extension++-- | Generate "L.hs" filename for given 'ChatInfo'.+getLFilename :: ChatInfo -> FilePath+getLFilename ChatInfo{..}+ = "L" <> renderChatType chatInfoType <> Text.unpack chatInfoChatId <> ".hs"++-- | Replace @module L where@ with @module L\<chatId\> where@ where @\<chatId\>@ is a telegram chat ID.+editModuleName :: ChatInfo -> String -> String+editModuleName ChatInfo{..} str =+ let moduleName = "L" <> Text.pack (renderChatType chatInfoType) <> chatInfoChatId+ moduleLine = "module " <> moduleName <> " where"+ in (Text.unpack . Text.replace "module L where" moduleLine . Text.pack) str++munge, mungeEnc :: String -> String+munge = expandTab 8 . strip (=='\n')+mungeEnc = encodeString . munge++nub' :: Ord a => [a] -> [a]+nub' = Set.toList . Set.fromList
+ src/Lambdabot/Plugin/Telegram/Bot.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+module Lambdabot.Plugin.Telegram.Bot where++import Control.Monad+import Control.Monad.State +import Data.Char+import Data.Coerce+import Data.Maybe+import qualified Data.Text as Text+import Data.Text (Text)+import GHC.Generics+import Telegram.Bot.API+import Telegram.Bot.Simple+import Telegram.Bot.Simple.UpdateParser+import Text.Read (readMaybe)++import Lambdabot.Plugin.Telegram.Shared+import Lambdabot.Plugin.Telegram.Bot.Generic++-- | Telegram Model.+type Model = TelegramState++-- | Supported actions:+-- * send everything obtained from user to lambdabot ("proxy" command).+-- * send exact module command to lambdabot.+-- * send response back to user.+data Action = SendEverything Msg | SendModule ModuleCmd | SendBack Msg++-- | Supported modules.+data ModuleCmd+ = EvalModule EvalCmd+ | CheckModule CheckCmd+ | DjinnModule DjinnCmd+ | FreeModule FreeCmd+ | HaddockModule HaddockCmd+ | HoogleModule HoogleCmd+ | InstancesModule InstancesCmd+ | PlModule PlCmd+ | PointfulModule PointfulCmd+ | PrettyModule PrettyCmd+ | SystemModule SystemCmd+ | TypeModule TypeCmd+ | UndoModule UndoCmd+ | UnmtlModule UnmtlCmd+ | VersionModule VersionCmd+ | HelpModule HelpCmd+ | SourceModule SourceCmd++-- | Supported commands from @eval@ plugin.+data EvalCmd = Let Msg | Undefine Msg | Run Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @check@ plugin.+data CheckCmd = Check Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @djinn@ plugin.+data DjinnCmd = Djinn Msg | DjinnAdd Msg | DjinnDel Msg | DjinnEnv Msg | DjinnNames Msg | DjinnClr Msg | DjinnVer Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @free@ plugin.+data FreeCmd = Free Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @haddock@ plugin.+data HaddockCmd = Index Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @hoogle@ plugin.+data HoogleCmd = Hoogle Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @instances@ plugin.+data InstancesCmd = Instances Msg | InstancesImporting Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @pl@ plugin.+data PlCmd = Pl Msg | PlResume Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @pointful@ plugin.+data PointfulCmd = Pointful Msg | Pointy Msg | Repoint Msg | Unpointless Msg | Unpl Msg | Unpf Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @pretty@ plugin.+data PrettyCmd = Pretty Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @system@ plugin.+data SystemCmd = Listchans Msg | Listmodules Msg | Listservers Msg | List Msg | Echo Msg | Uptime Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @type@ plugin.+data TypeCmd = Type Msg | Kind Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @undo@ plugin.+data UndoCmd = Undo Msg | Do Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @unmtl@ plugin.+data UnmtlCmd = Unmtl Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @version@ plugin.+data VersionCmd = Tgversion Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @help@ plugin.+data HelpCmd = Help Msg+ deriving (Generic, FromCommand)++-- | Supported commands from @source@ plugin.+data SourceCmd = Src Msg+ deriving (Generic, FromCommand)++-- | The bot.+telegramLambdaBot :: TelegramState -> BotApp Model Action+telegramLambdaBot tgstate = BotApp+ { botInitialModel = tgstate+ , botAction = flip updateToAction+ , botHandler = handleAction+ , botJobs = []+ }++-- | How to handle updates from Telegram.+updateToAction :: Model -> Update -> Maybe Action+updateToAction TelegramState{..} update+ -- proxy command+ | isCommand "irc" update = SendEverything <$> updateToMsg update+ -- eval commands+ | isCommand "let" update = SendModule <$> (EvalModule <$> (Let <$> updateToMsg update))+ | isCommand "run" update = SendModule <$> (EvalModule <$> (Run <$> updateToMsg update))+ | isCommand "define" update = SendModule <$> (EvalModule <$> (Let <$> updateToMsg update))+ | isCommand "undefine" update = SendModule <$> (EvalModule <$> (Undefine <$> updateToMsg update))+ -- check commands+ | isCommand "check" update = SendModule <$> (CheckModule <$> (Check <$> updateToMsg update))+ -- djinn commands+ | isCommand "djinn" update = SendModule <$> (DjinnModule <$> (Djinn <$> updateToMsg update))+ | isCommand "djinnadd" update+ = SendModule <$> (DjinnModule <$> (DjinnAdd <$> updateToMsg update))+ | isCommand "djinndel" update+ = SendModule <$> (DjinnModule <$> (DjinnDel <$> updateToMsg update))+ | isCommand "djinnenv" update+ = SendModule <$> (DjinnModule <$> (DjinnEnv <$> updateToMsg update))+ | isCommand "djinnnames" update+ = SendModule <$> (DjinnModule <$> (DjinnNames <$> updateToMsg update))+ | isCommand "djinnclr" update+ = SendModule <$> (DjinnModule <$> (DjinnClr <$> updateToMsg update))+ | isCommand "djinnver" update+ = SendModule <$> (DjinnModule <$> (DjinnVer <$> updateToMsg update))+ -- free commands+ | isCommand "free" update = SendModule <$> (FreeModule <$> (Free <$> updateToMsg update))+ -- haddock+ | isCommand "index" update = SendModule <$> (HaddockModule <$> (Index <$> updateToMsg update))+ -- hoogle+ | isCommand "hoogle" update+ = SendModule <$> (HoogleModule <$> (Hoogle <$> updateToMsg update))+ -- instances+ | isCommand "instances" update+ = SendModule <$> (InstancesModule <$> (Instances <$> updateToMsg update))+ | isCommand "instancesimporting" update+ = SendModule <$> (InstancesModule <$> (InstancesImporting <$> updateToMsg update))+ -- pl+ | isCommand "pl" update+ = SendModule <$> (PlModule <$> (Pl <$> updateToMsg update))+ | isCommand "plresume" update+ = SendModule <$> (PlModule <$> (PlResume <$> updateToMsg update))+ -- pointful+ | isCommand "pointful" update+ = SendModule <$> (PointfulModule <$> (Pointful <$> updateToMsg update))+ | isCommand "pointy" update+ = SendModule <$> (PointfulModule <$> (Pointy <$> updateToMsg update))+ | isCommand "repoint" update+ = SendModule <$> (PointfulModule <$> (Repoint <$> updateToMsg update))+ | isCommand "unpointless" update+ = SendModule <$> (PointfulModule <$> (Unpointless <$> updateToMsg update))+ | isCommand "unpl" update+ = SendModule <$> (PointfulModule <$> (Unpl <$> updateToMsg update))+ | isCommand "unpf" update+ = SendModule <$> (PointfulModule <$> (Unpf <$> updateToMsg update))+ -- pretty+ | isCommand "pretty" update+ = SendModule <$> (PrettyModule <$> (Pretty <$> updateToMsg update))+ -- system+ -- FIXME: decide about `listchans`, `listservers`+ | isCommand "listmodules" update+ = SendModule <$> (SystemModule <$> (Listmodules <$> updateToMsg update))+ | isCommand "list" update+ = SendModule <$> (SystemModule <$> (List <$> updateToMsg update))+ | isCommand "echo" update+ = SendModule <$> (SystemModule <$> (Echo <$> updateToMsg update))+ | isCommand "uptime" update+ = SendModule <$> (SystemModule <$> (Uptime <$> updateToMsg update))+ -- type+ | isCommand "type" update+ = SendModule <$> (TypeModule <$> (Type <$> updateToMsg update))+ | isCommand "kind" update+ = SendModule <$> (TypeModule <$> (Kind <$> updateToMsg update))+ -- undo+ | isCommand "undo" update+ = SendModule <$> (UndoModule <$> (Undo <$> updateToMsg update))+ | isCommand "do" update+ = SendModule <$> (UndoModule <$> (Do <$> updateToMsg update))+ -- unmtl+ | isCommand "unmtl" update+ = SendModule <$> (UnmtlModule <$> (Unmtl <$> updateToMsg update))+ -- version+ | isCommand "version" update+ = SendModule <$> (VersionModule <$> (Tgversion <$> updateToMsg update))+ -- help+ | isCommand "help" update+ = SendModule <$> (HelpModule <$> (Help <$> updateToMsg update))+ -- source+ | isCommand "src" update+ = SendModule <$> (SourceModule <$> (Src <$> updateToMsg update))+ | otherwise = Nothing+ where+ isCommand cmd = isJust . parseUpdate (commandWithBotName tgBotName cmd)+ dropCommand = Text.dropWhile isSpace . Text.dropWhile (not . isSpace)+ intToText :: Coercible a Integer => a -> Text+ intToText = Text.pack . show . coerce @_ @Integer+ updateToMsg upd =+ Msg <$> (fmap intToText . updateChatId) upd+ <*> (fmap (intToText . messageMessageId) . extractUpdateMessage) upd+ <*> (fmap dropCommand . updateMessageText) upd++-- | Extract 'Msg' from incoming command and send to Lambdabot.+handlePluginCommand :: FromCommand cmd => cmd -> Model -> Eff Action Model+handlePluginCommand cmd model = model <# do+ liftIO $ writeInput (fromCommand cmd) model+ return ()++-- | How to handle module 'Action'.+handleModuleAction :: ModuleCmd -> Model -> Eff Action Model+handleModuleAction (EvalModule cmd) model = handlePluginCommand cmd model +handleModuleAction (CheckModule cmd) model = handlePluginCommand cmd model+handleModuleAction (DjinnModule cmd) model = handlePluginCommand cmd model+handleModuleAction (FreeModule cmd) model = handlePluginCommand cmd model+handleModuleAction (HaddockModule cmd) model = handlePluginCommand cmd model+handleModuleAction (HoogleModule cmd) model = handlePluginCommand cmd model+handleModuleAction (InstancesModule cmd) model = handlePluginCommand cmd model+handleModuleAction (PlModule cmd) model = handlePluginCommand cmd model+handleModuleAction (PointfulModule cmd) model = handlePluginCommand cmd model+handleModuleAction (PrettyModule cmd) model = handlePluginCommand cmd model+handleModuleAction (SystemModule cmd) model = handlePluginCommand cmd model+handleModuleAction (TypeModule cmd) model = handlePluginCommand cmd model+handleModuleAction (UndoModule cmd) model = handlePluginCommand cmd model+handleModuleAction (UnmtlModule cmd) model = handlePluginCommand cmd model+handleModuleAction (VersionModule cmd) model = handlePluginCommand cmd model+handleModuleAction (HelpModule cmd) model = case (msgMessage $ getMessage cmd) of+ "" -> model <# do+ pure+ $ SendBack+ $ Msg { msgChatId = msgChatId $ getMessage cmd+ , msgMsgId = msgMsgId $ getMessage cmd+ , msgMessage = helpCmd+ }+ _ -> handlePluginCommand cmd model+handleModuleAction (SourceModule cmd) model = handlePluginCommand cmd model++-- | How to handle 'Action'.+handleAction :: Action -> Model -> Eff Action Model+handleAction (SendEverything msg) model = model <# do+ liftIO $ writeInput msg model+ return ()+handleAction (SendModule moduleCmd) model = handleModuleAction moduleCmd model+handleAction (SendBack msg) model = model <# do+ let Msg chatIdText msgIdText response = msg+ parseChatId = fmap ChatId . readMaybe . Text.unpack+ parseMsgId = fmap MessageId . readMaybe . Text.unpack+ mchatId = parseChatId chatIdText+ mreplyMessageId = parseMsgId msgIdText+ case mchatId of+ Nothing -> pure ()+ Just tgchatId -> do+ let req = SendMessageRequest+ { sendMessageChatId = SomeChatId tgchatId+ , sendMessageText = "```\n" <> response <> "\n```\n"+ , sendMessageParseMode = Just MarkdownV2+ , sendMessageEntities = Nothing+ , sendMessageDisableWebPagePreview = Nothing+ , sendMessageDisableNotification = Nothing+ , sendMessageProtectContent = Nothing+ , sendMessageReplyToMessageId = mreplyMessageId+ , sendMessageAllowSendingWithoutReply = Nothing+ , sendMessageReplyMarkup = Nothing+ }+ _ <- liftClientM (sendMessage req)+ pure ()++-- | Run Telegram bot.+runTelegramBot :: Token -> TelegramState -> IO ()+runTelegramBot token tgstate = do+ env <- defaultTelegramClientEnv token+ botActionFun <- startBotAsync (telegramLambdaBot tgstate) env+ forever $ do+ response <- readOutput tgstate+ botActionFun (SendBack response)++-- | Help command text.+helpCmd :: Text+helpCmd = "Lambdabot for Telegram provides following plugins:\n\+\\n\+\telegram check djinn free haddock hoogle instances pl pointful pretty source system type undo unmtl\n\+\\n\+\telegram plugin has following commands:\n\+\\n\+\- /version - version/source. Report the version and git repo of this bot\n\+\- /run - run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!\n\+\- /let - let <x> = <e>. Add a binding.\n\+\- /define - let <x> = <e>. Add a binding.\n\+\- /undefine - undefine. Reset evaluator local bindings.\n\+\\n\+\check plugin has following command:\n\+\\n\+\- /check - check <expr>. You have QuickCheck and 3 seconds. Prove something.\n\+\\n\+\djinn plugin has following commands:\n\+\\n\+\- /djinn - djinn <type>. Generates Haskell code from a type.\n\+\- /djinnadd - djinn-add <expr>. Define a new function type or type synonym.\n\+\- /djinndel - djinn-del <ident>. Remove a symbol from the environment.\n\+\- /djinnenv - Show the current djinn environment.\n\+\- /djinnnames - Show the current djinn environment, compactly.\n\+\- /djinnclr - Reset the djinn environment.\n\+\- /djinnver - Show current djinn version.\n\+\\n\+\free plugin has following command:\n\+\\n\+\- /free - free <ident>. Generate theorems for free.\n\+\\n\+\haddock plugin has following command:\n\+\\n\+\- /index - index <ident>. Returns the Haskell modules in which <ident> is defined.\n\+\\n\+\hoogle plugin has following command:\n\+\\n\+\- /hoogle - hoogle <expr>. Haskell API Search for either names, or types.\n\+\\n\+\instances plugin has following commands:\n\+\\n\+\- /instances - instances <typeclass>. Fetch the instances of a typeclass.\n\+\- /instancesimporting - instancesimporting [<module> [<module> [<module...]]] <typeclass>. Fetch the instances of a typeclass, importing specified modules first.\n\+\\n\+\pl plugin has following command:\n\+\\n\+\- /pl - pointless <expr>. Play with pointfree code.\n\+\\n\+\pointful plugin has following commands:\n\+\\n\+\- /pointy - pointful <expr>. Make code pointier.\n\+\- /repoint - pointful <expr>. Make code pointier.\n\+\- /unpointless - pointful <expr>. Make code pointier.\n\+\- /unpl - pointful <expr>. Make code pointier.\n\+\- /unpf - pointful <expr>. Make code pointier.\n\+\\n\+\pretty plugin has following commands:\n\+\\n\+\- /pretty - pretty <expr>. Display haskell code in a pretty-printed manner\n\+\\n\+\type plugin has following commands:\n\+\\n\+\- /type - type <expr>. Return the type of a value.\n\+\- /kind - kind <type>. Return the kind of a type.\n\+\\n\+\source plugin has following commands:\n\+\- /src - src <id>. Display the implementation of a standard function.\n\+\\n\+\undo plugin has following commands:\n\+\\n\+\- /undo - undo <expr>. Translate do notation to Monad operators.\n\+\- /do - do <expr>. Translate Monad operators to do notation.\n\+\\n\+\unmtl has following commands:\n\+\\n\+\- /unmtl - unroll mtl monads.\n\+\\n\+\Other commands:\n\+\- /help - shows this help.\n\+\- /version - version/source. Report the version and git repo of this bot\n\+\\n\+\All plugins are independent from each other, i.e. have their own state or use different programs under the hood."+
+ src/Lambdabot/Plugin/Telegram/Bot/Generic.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+module Lambdabot.Plugin.Telegram.Bot.Generic where++import Data.Char+import Data.Text (Text)+import Data.Proxy+import qualified Data.Text as Text+import GHC.Generics+import GHC.TypeLits++import Lambdabot.Plugin.Telegram.Shared++-- | Helper type class used to derive 'FromCommand' via DeriveGeneric extension.+class GFromCommand command where+ gGetMessage :: command proxy -> Msg+ gGetPrefix :: command proxy -> Text++-- Empty data decl+instance GFromCommand V1 where+ gGetMessage x = case x of { }+ gGetPrefix x = case x of { } ++instance (FromCommand c) => GFromCommand (K1 i c) where+ gGetMessage (K1 x) = getMessage x+ gGetPrefix (K1 x) = getPrefix x++instance (Constructor t, GFromCommand f) => GFromCommand (M1 C t f) where+ gGetMessage (M1 x) = gGetMessage x+ gGetPrefix m@(M1 _) = Text.cons '@' $ toKebabCase $ Text.pack $ conName m++instance (GFromCommand f) => GFromCommand (M1 S t f) where+ gGetMessage (M1 x) = gGetMessage x+ gGetPrefix (M1 x) = gGetPrefix x++instance (GFromCommand f) => GFromCommand (M1 D t f) where+ gGetMessage (M1 x) = gGetMessage x+ gGetPrefix (M1 x) = gGetPrefix x++instance (GFromCommand f, GFromCommand g) => GFromCommand (f :+: g) where+ gGetMessage (L1 x) = gGetMessage x+ gGetMessage (R1 x) = gGetMessage x++ gGetPrefix (L1 x) = gGetPrefix x+ gGetPrefix (R1 x) = gGetPrefix x++instance (GFromCommand f, GFromCommand g) => GFromCommand (f :*: g) where+ gGetMessage (x :*: _y) = gGetMessage x+ gGetPrefix (x :*: _y) = gGetPrefix x++class FromCommand command where+ getMessage :: command -> Msg++ default getMessage :: (Generic command, GFromCommand (Rep command)) => command -> Msg+ getMessage x = gGetMessage (from x)++ getPrefix :: command -> Text++ default getPrefix :: (Generic command, GFromCommand (Rep command)) => command -> Text+ getPrefix x = gGetPrefix (from x)++-- | Type class to identify the essence of incoming command and transform it to 'Msg' transport type.+instance FromCommand Msg where+ getMessage = id+ getPrefix = const ""++-- | Transform incoming telegram command into 'Msg'.+fromCommand :: FromCommand command => command -> Msg+fromCommand cmd = old { msgMessage = getPrefix cmd <> " " <> msgMessage old }+ where+ old = getMessage cmd++-- ** Helpers++-- | Helper to transform text into kebab case.+toKebabCase :: Text -> Text+toKebabCase txt =+ let str = Text.unpack txt+ uppers = isUpper <$> str+ indices = zip [0..] uppers :: [(Int, Bool)]+ onlyUpperIndices = filter (/= 0) $ fmap fst $ filter snd indices+ go ix txt' =+ let (begin, end) = Text.splitAt ix txt'+ in Text.concat [ begin, "-", Text.toLower end ]+ in Text.toLower $ foldr go txt onlyUpperIndices++data MaybeWith (modifier :: Modifier) a = MaybeWith a++data Modifier = AtEnd Symbol++instance (KnownSymbol postfix, FromCommand a, modifier ~ 'AtEnd postfix) =>+ FromCommand (MaybeWith modifier a) where++ getMessage (MaybeWith x) = getMessage x+ getPrefix (MaybeWith x) = getPrefix x <> Text.pack (symbolVal (Proxy @postfix))
+ src/Lambdabot/Plugin/Telegram/Callback.hs view
@@ -0,0 +1,159 @@+{-# 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 msg = do+ ignored <- lift $ checkIgnore msg+ commands <- getConfig commandPrefixes+ if ignored+ then doIGNORE msg+ else mapM_ (doTGMSG' commands (lambdabotName msg) msg) targets+ where+ alltargets = head (ircMsgParams msg)+ targets = map (parseNick (ircMsgServer msg)) $ splitOn "," alltargets++doIGNORE :: IrcMessage -> Telegram ()+doIGNORE = debugM . show++doTGMSG'+ :: [String] -- ^ Commands.+ -> Nick -- ^ My name.+ -> IrcMessage -- ^ IRC Message.+ -> Nick -- ^ Target name.+ -> Telegram ()+doTGMSG' commands myname msg target+ | myname == target+ = let (cmd, params) = splitFirstWord text+ in doPersonalMsg commands msg cmd params+ + | flip any (":," :: String)+ $ \c -> (fmtNick (ircMsgServer msg) myname ++ [c]) `isPrefixOf` text+ = let Just wholeCmd = maybeCommand (fmtNick (ircMsgServer msg) myname) text+ (cmd, params) = splitFirstWord wholeCmd+ in doPublicMsg commands msg target cmd params+ + | (commands `arePrefixesOf` text)+ && length text > 1+ && (text !! 1 /= ' ') -- elem of prefixes+ && (not (commands `arePrefixesOf` [text !! 1]) ||+ (length text > 2 && text !! 2 == ' ')) -- ignore @@ prefix, but not the @@ command itself+ = let (cmd, params) = splitFirstWord (dropWhile (==' ') text)+ in doPublicMsg commands msg target cmd params+ + | otherwise = return () -- contextual messages are not allowed here+ + where+ text = tail (head (tail (ircMsgParams msg)))++doPersonalMsg+ :: [String]+ -> IrcMessage+ -> String+ -> String+ -> Telegram ()+doPersonalMsg commands msg s r+ | commands `arePrefixesOf` s = doMsg msg (tail s) r who+ | otherwise = return () -- contextual messages are not allowed here+ where+ who = nick msg++doPublicMsg+ :: [String] -> IrcMessage -> Nick -> String -> String -> Telegram ()+doPublicMsg commands msg target s r+ | commands `arePrefixesOf` s = doMsg msg (tail s) r target+ | otherwise = doIGNORE msg++-- | normal commands.+--+-- check privledges, do any spell correction, dispatch, handling+-- possible timeouts.+--+doMsg :: IrcMessage -> String -> String -> Nick -> Telegram ()+doMsg msg cmd rest towhere = do+ ldebug $ "doMsg : nick : " <> fmtNick "" towhere <> " : cmd : " <> cmd+ let ircmsg = tgIrcPrivMsg (getTgChatId msg) (getTgMsgId msg) . Text.pack+ allcmds <- lift (gets (Map.keys . ircCommands))+ let ms = filter (isPrefixOf cmd) allcmds+ e <- getConfig editDistanceLimit+ case ms of+ [s] -> docmd msg towhere rest s -- a unique prefix+ _ | cmd `elem` ms -> docmd msg towhere rest cmd -- correct command (usual case)+ _ | otherwise -> case closests cmd allcmds of+ (n,[s]) | n < e , ms == [] -> docmd msg towhere rest s -- unique edit match+ (n,ss) | n < e || ms /= [] -- some possibilities+ -> lift . ircmsg $ "Maybe you meant: "++showClean(nub(ms++ss))+ _ -> docmd msg towhere rest cmd -- no prefix, edit distance too far++docmd :: IrcMessage -> Nick -> [Char] -> String -> Telegram ()+docmd msg towhere rest cmd' = lb $ + withCommand cmd' -- Important.+ (tgIrcPrivMsg (getTgChatId msg) (getTgMsgId msg) "Unknown command, try @list")+ (\theCmd -> do+ hasPrivs <- lb (checkPrivs msg)+ -- TODO: handle disabled commands earlier+ -- users should probably see no difference between a+ -- command that is disabled and one that doesn't exist.+ disabled <- elem cmd' <$> getConfig disabledCommands+ let ok = not disabled && (not (privileged theCmd) || 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+ debugM $ "docmd : nick : " <> fmtNick "" towhere <> " : cmd : " <> cmd' <> " : input : " <> rest+ let new = if cmd' `elem` ["@run", "@define", "@undefine", "@let", "run", "define", "undefine", "let"]+ then Text.unpack (getTgChatId msg) <> "|" <> rest+ else rest++ response <- if not ok+ then return ["Not enough privileges"]+ else runCommand theCmd msg towhere cmd' new+ `E.catch` \exc@SomeException{} ->+ return ["Plugin `Telegram` failed with: " ++ show exc]+ + lift $ mapM_ (tgIrcPrivMsg (getTgChatId msg) (getTgMsgId msg) . Text.pack . expandTab 8) response+ )+++closests :: String -> [String] -> (Int,[String])+closests pat ss = Map.findMin m+ where+ m = Map.fromListWith (++) ls+ ls = [ (levenshteinDistance defaultEditCosts pat s, [s]) | s <- ss ]++maybeCommand :: String -> String -> Maybe String+maybeCommand nm text = mrAfter <$> matchM re text+ where+ re :: Regex+ re = makeRegex (nm ++ "[.:,]*[[:space:]]*")
+ src/Lambdabot/Plugin/Telegram/Message.hs view
@@ -0,0 +1,47 @@+module Lambdabot.Plugin.Telegram.Message where++import Data.Text+import qualified Data.Text as Text++import Lambdabot.IRC+import Lambdabot.Monad+import Lambdabot.Logging++import Lambdabot.Plugin.Telegram.Shared++-- * IRC Messaging++-- | IRC communicating model consists of the core and plugins which are sending messages to each other.+--+-- @Telegram module <---> Lambdabot core module <------> Haskell/Telegram module@+--+-- In order to pass Telegram-related necessary information for responding, we are embedding Telegram metadata into 'IrcMessage' inside 'ircMsgPrefix': @"null!n=user\@" + chatId + "/" + msgId@+--+makeIrcMessage :: Text -> Text -> Text -> IrcMessage+makeIrcMessage chatId msgId msg = IrcMessage+ { ircMsgServer = "telegramrc"+ , ircMsgLBName = "telegram"+ , ircMsgPrefix = "null!n=user@" ++ Text.unpack chatId ++ "/" ++ Text.unpack msgId+ , ircMsgCommand = "TGMSG"+ , ircMsgParams = ["telegram", ":" ++ ((Text.unpack msg)) ]+ }++-- | To extract Telegram @chatId@ from 'IrcMessage'.+getTgChatId :: IrcMessage -> Text+getTgChatId+ = Text.takeWhile (/= '/') . Text.drop 1 . Text.dropWhile (/= '@') . Text.pack . ircMsgPrefix++-- | To extract Telegram @msgId@ from 'IrcMessage'.+getTgMsgId :: IrcMessage -> Text+getTgMsgId+ = Text.drop 1 . Text.dropWhile (/= '/')+ . Text.drop 1 . Text.dropWhile (/= '@')+ . Text.pack . ircMsgPrefix ++-- | Send privileged IRC Message across modules.+tgIrcPrivMsg :: Text -> Text -> Text -> LB ()+tgIrcPrivMsg chatId msgId txt = send $ makeIrcMessage chatId msgId txt++-- | Debug helper function.+ldebug :: String -> Telegram ()+ldebug msg = debugM ("lambdabot : " <> show msg)
@@ -0,0 +1,43 @@+{-# LANGUAGE RecordWildCards #-}+module Lambdabot.Plugin.Telegram.Shared where++import Control.Concurrent.STM (TBQueue, atomically, readTBQueue, writeTBQueue)+import Data.Text (Text)++import Lambdabot.Module (ModuleT)+import Lambdabot.Monad (LB)++-- | Transport type used to communicate between Telegram and Lambdabot.+data Msg = Msg+ { msgChatId :: !Text+ , msgMsgId :: !Text+ , msgMessage :: !Text+ }+ deriving Show++-- | Shared state between Lambdabot and Telegram.+data TelegramState = TelegramState+ { tgInput :: TBQueue Msg+ , tgOutput :: TBQueue Msg+ , tgCurrent :: Int+ , tgBotName :: Text+ }++-- | Lambdabot Monad with embedded Telegram State.+type Telegram = ModuleT TelegramState LB++-- | Read input message from Telegram bot on Lambdabot side.+readInput :: TelegramState -> IO Msg+readInput TelegramState{..} = atomically $ readTBQueue tgInput++-- | Read output message from Lambdabot on Telegram bot side.+readOutput :: TelegramState -> IO Msg+readOutput TelegramState{..} = atomically $ readTBQueue tgOutput++-- | Send input message to Lambdabot from Telegram bot side.+writeInput :: Msg -> TelegramState -> IO ()+writeInput msg TelegramState{..} = atomically $ writeTBQueue tgInput msg++-- | Send output message to Telegram bot from Lambdabot side.+writeOutput :: Msg -> TelegramState -> IO ()+writeOutput msg TelegramState{..} = atomically $ writeTBQueue tgOutput msg