packages feed

lambdabot-zulip (empty) → 0.1.0

raw patch · 7 files changed

+395/−0 lines, 7 filesdep +HUnitdep +basedep +containerssetup-changed

Dependencies added: HUnit, base, containers, hint, hspec, hzulip, lambdabot-zulip, mueval, optparse-applicative, say, text, yaml

Files

+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/lambdabot-zulip-server/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Web.Zulip.Lambdabot++main :: IO ()+main = Web.Zulip.Lambdabot.runServer
+ example-settings/settings.yaml view
@@ -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
+ lambdabot-zulip.cabal view
@@ -0,0 +1,71 @@+name:          lambdabot-zulip+version:       0.1.0+license:       MIT+copyright:     2017 Niklas Hambüchen <mail@nh2.me>+author:        Niklas Hambüchen <mail@nh2.me>+maintainer:    Niklas Hambüchen <mail@nh2.me>+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
+ src/Web/Zulip/Lambdabot.hs view
@@ -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 "<interactive>: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. <interactive>:+      <* 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
+ test/Main.hs view
@@ -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)