diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# lambdabot-zulip + +A [`lambdabot`](https://wiki.haskell.org/Lambdabot)-like bot for [Zulip](https://zulipchat.com/). + +Can evaluate Haskell expressions and show their types. + +### Screenshot + +![Screenshot of the bot in action](images/evaluation-screenshot.png) + + +## Usage + +Run the `lambdabot-zulip-server` executable to start the bot. + +It reads a `settings.yaml` in the working directory (or passed via command line). + +See [`example-settings/settings.yaml`](example-settings/settings.yaml) for an example. +You have to provide Zulip API credentials, and streams (channels) the bot should be active on. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/lambdabot-zulip-server/Main.hs b/app/lambdabot-zulip-server/Main.hs new file mode 100644 --- /dev/null +++ b/app/lambdabot-zulip-server/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Web.Zulip.Lambdabot + +main :: IO () +main = Web.Zulip.Lambdabot.runServer diff --git a/example-settings/settings.yaml b/example-settings/settings.yaml new file mode 100644 --- /dev/null +++ b/example-settings/settings.yaml @@ -0,0 +1,7 @@ +zulipUserName: "lambdabot-bot@myteam.zulipchat.com" +zulipApiKey: "abc123abc123abc123abc123abc123ab" +zulipBaseUrl: "https://myteam.zulipchat.com/api/v1" +floodProtectionOutputLength: 2000 +botStreams: + - bot-testing + - haskell diff --git a/lambdabot-zulip.cabal b/lambdabot-zulip.cabal new file mode 100644 --- /dev/null +++ b/lambdabot-zulip.cabal @@ -0,0 +1,71 @@ +name: lambdabot-zulip +version: 0.1.0 +license: MIT +copyright: 2017 Niklas Hambüchen +author: Niklas Hambüchen +maintainer: Niklas Hambüchen +category: Web +build-type: Simple +tested-with: GHC==8.4.3 +cabal-version: >= 1.8 +homepage: https://github.com/nh2/lambdabot-zulip +bug-Reports: https://github.com/nh2/lambdabot-zulip/issues +synopsis: Lambdabot for Zulip Chat +description: + Integrates lambdabot with Zulip Chat. + +extra-source-files: + README.md + example-settings/settings.yaml + +source-repository head + type: git + location: git://github.com/nh2/lambdabot-zulip.git + +library + exposed-modules: + Web.Zulip.Lambdabot + hs-source-dirs: + src + build-depends: + base >= 4 && < 5 + , containers + , hint + , hzulip + , mueval + , optparse-applicative + , say + , text + , yaml + + ghc-options: + -Wall + + +executable lamdabot-zulip-server + hs-source-dirs: + app/lambdabot-zulip-server + main-is: + Main.hs + build-depends: + base >= 4 && < 5 + , lambdabot-zulip + + ghc-options: + -Wall -threaded -with-rtsopts=-N + + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Main.hs + build-depends: + base >= 4 && < 5 + , lambdabot-zulip + , hspec >= 1.3.0.1 + , HUnit >= 1.2 + , text + ghc-options: + -Wall -threaded -with-rtsopts=-N diff --git a/src/Web/Zulip/Lambdabot.hs b/src/Web/Zulip/Lambdabot.hs new file mode 100644 --- /dev/null +++ b/src/Web/Zulip/Lambdabot.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} + +-- | A lambdabot for the Zulip web chat. +module Web.Zulip.Lambdabot where + +import Control.Monad (when) +import Control.Monad.IO.Class +import Data.Char (isDigit) +import Data.List (stripPrefix) +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Yaml.Aeson (FromJSON, ToJSON) +import Data.Yaml.Config +import GHC.Generics +import Language.Haskell.Interpreter (runInterpreter, InterpreterError(..), GhcError(errMsg)) +import Mueval.ArgsParse (typeOnly, interpreterOpts) +import Mueval.Interpreter (interpreter) +import qualified Options.Applicative as Opts +import Say (say) +import Text.ParserCombinators.ReadP (ReadP, readP_to_S, char, munch1, skipSpaces) +import Web.HZulip +import System.IO (hSetBuffering, stdout, BufferMode(LineBuffering)) + + +-- Adapted from https://hackage.haskell.org/package/mueval-0.9.3/docs/src/Mueval-Interpreter.html#printInterpreterError + +-- | Removes uninteresting parts of error messages. +-- Example: +-- > dropErrorLinePosition ":1:1: error: Variable not in scope: help" +-- is +-- > "error: Variable not in scope: help" +dropErrorLinePosition :: String -> String +dropErrorLinePosition e = + case parseReturnRest interactiveErrorPrefixParser e of + Just rest -> rest + Nothing -> e -- if the parse fails we fallback on printing the whole error + where + interactiveErrorPrefixParser :: ReadP () + interactiveErrorPrefixParser = do + pure () + <* char '<' <* munch1 (/= '>') <* char '>' <* char ':' -- e.g. : + <* munch1 isDigit <* char ':' -- line + <* munch1 isDigit <* char ':' -- column + <* skipSpaces + + parseReturnRest :: ReadP () -> String -> Maybe String + parseReturnRest parser input = + case readP_to_S parser input of + [] -> Nothing + (_dropped, rest):_ -> Just rest + + +-- | Turns a @hint@ `InterpreterError` into our simple error type. +formatInterpreterError :: InterpreterError -> EvalErrors +formatInterpreterError err = case err of + WontCompile errors -> EvalErrors $ map (dropErrorLinePosition . errMsg) errors + UnknownError str -> EvalErrors [str] + NotAllowed str -> EvalErrors [str] + GhcException str -> EvalErrors [str] + + +-- | List of errors output by the bot when a query string couldn't be run +-- or didn't succeed (such as GHC compiler error messages). +-- Returns a list so that they can be displayed as independent code blocks +-- if desired. +newtype EvalErrors = EvalErrors [String] + deriving (Eq, Ord, Show) + +-- | Result for input like @1 + 1@. +data EvalSuccess = EvalSuccess + { evalSuccessValue :: String + , evalSuccessType :: String + } deriving (Eq, Ord, Show) + +-- | Result for input like @:type 1 + 1@. +newtype TypecheckSuccess = TypecheckSuccess String -- ^ type + deriving (Eq, Ord, Show) + + +-- | Result of the bot trying to run one string. +data LambdabotResult + = ResultErrors EvalErrors + | ResultEvalSuccess EvalSuccess + | ResultTypecheckSuccess TypecheckSuccess + deriving (Eq, Ord, Show) + + +-- | Evaluates an expression. +-- Returns the value and type on success, or the +-- error message(s) on failure. +evalCommand :: String -> IO LambdabotResult +evalCommand command = do + let (typecheckOnly, expr) + | Just e <- stripPrefix ":type " command = (True, e) + | Just e <- stripPrefix ":t " command = (True, e) + | otherwise = (False, command) + case interpreterOpts ["--expression", expr] of + Left (_success, output) -> + return $ ResultErrors $ EvalErrors [output] + Right opts -> do + r <- runInterpreter (interpreter opts{ typeOnly = typecheckOnly }) + return $ case r of + Left err -> ResultErrors $ formatInterpreterError err + Right (_expr, exprType, resultVal) + | typecheckOnly -> ResultTypecheckSuccess $ TypecheckSuccess exprType + | otherwise -> ResultEvalSuccess $ EvalSuccess resultVal exprType + + +-- | Turns the result of one query string to the bot into a nicely formatted +-- Zulip message. +formatResult :: FloodProtectionOutputLength -> LambdabotResult -> Text +formatResult (FloodProtectionOutputLength maxOutputLength) result = reply + where + floodProtect str = + if length str > maxOutputLength + then take maxOutputLength str ++ "..." + else str + reply = case result of + ResultErrors (EvalErrors errs) -> + T.concat $ flip map errs $ \err -> T.unlines + [ ":cross_mark:" + , "```" + , T.pack (floodProtect err) + , "```" + ] + ResultTypecheckSuccess (TypecheckSuccess typ) -> + ":check_mark: `:: " <> T.pack typ <> "`" + ResultEvalSuccess EvalSuccess{ evalSuccessValue = val + , evalSuccessType = typ } -> + T.unlines + [ ":check_mark:" + , "```" + , T.pack (floodProtect val) + , "```" + , "`:: " <> T.pack typ <> "`" + ] + + +newtype FloodProtectionOutputLength = FloodProtectionOutputLength Int + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + + +-- | Settings for the bot. +data Settings = Settings + { zulipUserName :: Text -- ^ Example: @lambdabot-bot@myteam.zulipchat.com@ + , zulipApiKey :: Text -- ^ Example: @abc123abc123abc123abc123abc123ab@ + , zulipBaseUrl :: Text -- ^ Example: @https://myteam.zulipchat.com/api/v1@ + , botStreams :: [Text] -- ^ Example: @["haskell"]@ + , floodProtectionOutputLength :: FloodProtectionOutputLength -- ^ Outputs beyond this length will be @...@'d. + } deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) + + +-- | Main entry point for the Zulip lambdabot. +runZulipLambdabot :: Settings -> IO () +runZulipLambdabot settings = do + let Settings + { zulipUserName = botUserName + , zulipApiKey = apiKey + , zulipBaseUrl = baseUrl + , botStreams = botStreamsList + , floodProtectionOutputLength + } = settings + + let botStreamsSet = Set.fromList botStreamsList + + options <- do + o <- zulipOptions botUserName apiKey + return o{ clientBaseUrl = baseUrl } + + withZulip options $ do + -- Show current subscriptions + subscriptions <- getSubscriptions + + when (Set.fromList subscriptions /= botStreamsSet) $ do + -- Remove undesired stream subscriptions + removeSubscriptions [ s | s <- subscriptions, s `Set.notMember` botStreamsSet] + -- Subscribe to desired streams + addSubscriptions botStreamsList + + say $ "Listening to streams: " <> T.intercalate ", " (Set.toList botStreamsSet) + + me <- getProfile + let myUserId = profileUserId me + + -- Listening for events works with a callback based API: + onNewMessage $ \msg -> do + let sender = messageSender msg :: User + _senderName = userFullName sender + subject = messageSubject msg + + -- Private messages one sends also appear as message events. + -- Ignore them to avoid generating an infinite stream of messages. + if userId sender == myUserId + then liftIO $ putStrLn "Got message from myself, ignoring" + else + -- Only answer requests that go to the right stream. + case messageDisplayRecipient msg of + Right _user -> do + liftIO $ putStrLn "Got direct message to user, ignoring" + Left stream | stream `Set.member` botStreamsSet -> do + + -- Only answer requests that start with the evaluation symbol. + case T.stripPrefix "> " (messageContent msg) of + Nothing -> return () + Just input -> do + -- Run interpreter + result <- liftIO $ evalCommand (T.unpack input) + let format = formatResult floodProtectionOutputLength + -- Post reply + _msgId <- sendStreamMessage stream subject (format result) + return () + + Left _stream -> do + liftIO $ putStrLn "Got message to non-'haskell' stream, ignoring" + + +-- | Command line arguments for this program. +data Args = Args + { argsSettingsFile :: FilePath -- ^ Path to the settings YAML file + } deriving (Eq, Ord, Show) + + +-- | Command line argument parser for this program. +argsParser :: Opts.Parser Args +argsParser = + Args + <$> Opts.strOption + ( Opts.long "config-file" + <> Opts.metavar "FILE" + <> Opts.value "settings.yaml" + <> Opts.help "Path to configuration file" + ) + + +-- | Parses command line arguments for this program. +parseCommandLine :: IO Args +parseCommandLine = Opts.execParser $ Opts.info (Opts.helper <*> argsParser) Opts.fullDesc + + +runServer :: IO () +runServer = do + hSetBuffering stdout LineBuffering + + Args{ argsSettingsFile } <- parseCommandLine + settings <- loadYamlSettings [argsSettingsFile] [] useEnv + + runZulipLambdabot settings diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE LambdaCase #-} + +module Main where + +import qualified Data.Text as T +import Test.Hspec + +import Web.Zulip.Lambdabot + + +main :: IO () +main = hspec $ do + + describe "type inference" $ do + + it "evaluates 1 + 1" $ do + actual <- evalCommand ":t 1 + 1" + actual `shouldBe` ResultTypecheckSuccess (TypecheckSuccess "Num a => a") + + describe "expression evaluation" $ do + + it "evaluates 1 + 1" $ do + actual <- evalCommand "1 + 1" + actual `shouldBe` ResultEvalSuccess (EvalSuccess "2" "Num a => a") + + it "fails on invalid input `1 + `" $ do + actual <- evalCommand "1 +" + actual `shouldSatisfy` \case + ResultErrors{} -> True + _ -> False + + describe "result formatting" $ do + + it "shortens long commands" $ do + result <- evalCommand "[1..100000]" + let actual = formatResult (FloodProtectionOutputLength 2000) result + actual `shouldSatisfy` ((< 10000) . T.length)