diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,206 @@ +# Marvin, the paranoid bot (⍺ stage) + +[![Travis](https://travis-ci.org/JustusAdam/marvin.svg?branch=master)](https://travis-ci.org/JustusAdam/marvin) +[![Hackage](https://img.shields.io/hackage/v/marvin.svg)](http://hackage.haskell.org/package/marvin) + +Marvin is an attempt to combine the ease of use of [hubot](https://hubot.github.com) with the typesafety and easy syntax of Haskell and the performance gains from compiled languages. + +A more in-depth version of the contents of this readme can be found on the [wiki](https://github.com/JustusAdam/marvin/wiki). + + +## Installation + +You can get a release version of marvin on [Hackage](https://hackage.haskell.org/package/marvin). + +However this library is still a very early stage so you might want to get updates quicker. +You can do so by using [stack](https://docs.haskellstack.org) and adding a recent commit of this repository to your `stack.yaml` file. +Stack will take care of downloading and building it for you. + + +## TLDR + +```Haskell +module MyScript where + +import Marvin.Prelude + +script :: IsAdapter a => ScriptInit a +script = defineScript "my-script" $ do + hear "I|i can't stand this (\w+)" $ do + match <- getMatch + + let thing = match !! 1 + + reply $ "I'm sorry to tell you but you'll have to do " ++ thing + + respond "open the (\w+) door" $ do + match <- getMatch + let door = match !! 1 + openDoor door + send $ printf "Door %v opened" door + + respond "what is in file (\w+)" $ do + match <- getMatch + let file = match !! 1 + + liftIO $ readFile file + + send file +``` + +## How to Marvin + +The best way to use Marvin is very much taken from hubot. + +A Marvin instance composes of a collection of scripts which are reactions or actions on certain messages posted in slack. +Each script is a Haskell source file. +They get compiled into one single static binary, which is a HTTP server that listens for slack's event calls. + +### Defining scripts + +Defining scripts is very easy. + +Create a new Haskell source file like "MyScript.hs" and import marvins prelude `Marvin.Prelude`. +This provides you with all the tools you need to interact with marvin. + +Now you can start to define your script with `defineScript` which produces a script initializer. +If you wish to use marvins automatic script discovery your script initializer should be named `script` + +```Haskell +module MyScript where + +import Marvin.Prelude + +script :: IsAdapter a => ScriptInit a +script = defineScript "my-script" $ do + ... +``` + +The script id, "my-script" in this case, is the name used for this script when repoting loggin messages as well as the key for this scripts configuration, see [configuration](#configuration). + +In the define script block you can have marvin react to certain events with `hear` and `respond`. +More information on those in the section [reacting](#reacting) + +Finally after you have defined your scripts you have to tie them together. +You can do this [manually](#wiring-manually) or you can have marvin create the boilerplate code for you. + +To do this simply place a main file (this is the file you'll be compiling later) in the same directory the scripts are placed in. +Leave the file empty except for this line at the top `{-# OPTIONS_GHC -F -pgmF marvin-pp #-}`. +When you compile the file marvin will look for any other ".hs" and ".lhs" files in the same directory, import them and define a server which runs with the `script` from each. +If you wish to hide a file from the auto discovery either place it in a different directory or prefix it with "." or "_". + +### Reacting + +There are two main ways (currently) of reacting to events, `hear` and `respond`. + +`hear` is for matching any incoming message. The provided regex is tried against all incomming messages, if one matches the handler is called. + +`repond` only triggers on message which have the bot name, or a case variation thereof as the first word. + + +Once a handler has triggered it may perform arbitrary IO actions (using `liftIO`) and send messages using `reply` and `send`. + +- `reply` addresses the message to the original sender of the message that triggered the handler. +- `send` sends it to the same room the tiggering message weas sent to. +- `messageRoom` sends a message to a room specified by the user. + +### Configuration + +Configuration for marvin is written in the [configurator](https://hackage.haskell.com/package/configurator) syntax. + +Configuration pertaining to the bot is stored under the "bot" key. + +``` +bot { + name = "my-bot" + logging = "INFO" +} +``` + +By default each script has access to a configuration stored under `script.`. +And of course these scripts can have nested config groups. + +``` +bot { + name = "my-bot" +} + +script { + script-1 { + some-string = "foo" + some-int = 1337 + bome-bool = true + } + script 2 { + nested-group { + val = false + } + name = "Trump" + capable = false + } +} +``` + +Configuration pertaining to the adapter is stored under `adapter.` + +``` +bot { + name = "my-bot" + logging = "INFO" +} +adapter { + slack-rtm { + token = "eofk" + } +} +``` + +### Wiring manually + +How Marvin interacts with your chat program depends on the used Adapter. +For instance the currently default `slack-rtm` adapter creates a (client) websocket connection with the slack API and listens to the events there. +Other adapters may require to set up a server. + +### Utilities + +All these utilities are already available to you if you import `Marvin.Prelude`. + +#### Regex + +Implemented in `Marvin.Util.Regex`, documentation coming soon. + +#### Mutable variables + +Implementation started in `Marvin.Util.Mutable`, documentation coming soon. + +#### Format strings + +For String formatting Marvin re-exposes the `Text.Printf` module. + +Format strings use placeholders with `%`, the default formatter (works for all `Show` datatypes) is `%v`. +Substitution is done with the varargs function `printf`. +You can find the full documentation in the documentation for the [`Text.Printf`](https://www.stackage.org/haddock/lts-7.12/base-4.9.0.0/Text-Printf.html#v:printf) module. + +#### JSON + +Exposed in `Marvin.Util.JSON` documentation coming soon. Until then refer to [aeson](https://hackage.haskell.org/package/aeson). + +#### Logging + +Marvin comes with a logging facility built in. +`Marvin.Util.Logging` expose the logging facility. +Several functions are available, depending on the urgency of your message, like `errorM`, `infoM` and `criticalM`. +Logging messages made this way are automatically formatted and tagged with the scripts that reported them. + +By default all logging messages with higher priority `NOTICE` or higher are shown. +Using the command line parameter `verbose` also adds `INFO` messages and `debug` adds `DEBUG` messages. +You can select the exact logging level in your config file (see also [configuration](#configuration)). + + +#### Random + +Implemented in `Marvin.Util.Random`, documentation coming soon. + +#### HTTP + +Coarsely implemented in `Marvin.Util.HTTP`, documentation coming soon. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/initializer/Main.hs b/initializer/Main.hs --- a/initializer/Main.hs +++ b/initializer/Main.hs @@ -1,38 +1,41 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} module Main where -import ClassyPrelude -import Options.Generic -import Paths_marvin -import System.Directory -import System.FilePath -import Text.Mustache.Compile -import Text.Mustache.Render -import Text.Mustache.Types +import Control.Arrow (second) +import Control.Monad +import Data.Containers +import Data.Foldable (for_) +import Data.Sequences +import qualified Data.Text.IO as T +import Options.Applicative +import Paths_marvin +import Prelude hiding (lookup) +import System.Directory +import System.FilePath +import Text.Mustache.Compile +import Text.Mustache.Render +import Text.Mustache.Types -data Opts = Opts +data Opts = Opts { botname :: String - , adapter :: Maybe String - } deriving (Generic) - - -instance ParseRecord Opts + , adapter :: String + } fromEither :: Show a => Either a b -> b -fromEither (Left e) = error $ "Was left: " ++ show e +fromEither (Left e) = error $ "Was left: " <> show e fromEither (Right v) = v wantDirectories :: [FilePath] -wantDirectories = +wantDirectories = [ "bot" ] wantFiles :: [(FilePath, Template)] wantFiles = map (second $ fromEither . compileTemplate "") - [ ("Main.hs.mustache", "bot/Main.hs") + [ ("Main.hs.mustache", "bot/Main.hs") , ("MyScript.hs.mustache", "bot/MyScript.hs") , ("config.cfg.mustache", "config.cfg") , ("bot.cabal.mustache", "{{name}}.cabal") @@ -46,13 +49,13 @@ main :: IO () main = do - opts <- getRecord "Marvin init" + Opts{..} <- execParser infoParser d <- ( "initializer") <$> getDataDir - unless ((== Just True) $ (`member` adType) <$> adapter opts) $ putStrLn "Unrecognized adapter" + unless (adapter `member` adType) $ putStrLn "Unrecognized adapter" - let subsData = object [ "name" ~> botname opts - , "scriptsig" ~> maybe "IsAdapter a => ScriptInit a" ("ScriptInit " ++) (adapter opts >>= flip lookup adType) - , "adapter" ~> adapter opts + let subsData = object [ "name" ~> botname + , "scriptsig" ~> maybe "IsAdapter a => ScriptInit a" ("ScriptInit " <>) (lookup adapter adType) + , "adapter" ~> adapter ] for_ wantDirectories $ \dir -> do @@ -64,7 +67,20 @@ if ".mustache" == takeExtension source then do tpl <- fromEither <$> automaticCompile [d] source - writeFile targetName $ substituteValue tpl subsData + T.writeFile targetName $ substituteValue tpl subsData else copyFile source targetName return () + where + infoParser = info + (helper <*> optsParser) + (fullDesc <> header "marvin-init ~ make a new marvin project") + optsParser = Opts + <$> argument str (metavar "BOTNAME") + <*> strOption + ( long "adapter" + <> short 'a' + <> metavar "ID" + <> value "slack-rtm" + <> help "id of the adapter to use" ) + diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -1,5 +1,5 @@ name: marvin -version: 0.0.1 +version: 0.0.2 synopsis: A modular bot for slack description: Please see README.md homepage: https://github.com/JustusAdam/marvin#readme @@ -10,7 +10,8 @@ copyright: Copyright: (c) 2016 Justus Adam category: Development build-type: Simple -extra-source-files: preprocessor/Main.mustache +extra-source-files: README.md + , preprocessor/Main.mustache data-dir: resources data-files: initializer/*.hs.mustache initializer/config.cfg.mustache @@ -34,12 +35,11 @@ other-modules: Marvin.Internal , Marvin.Internal.Types build-depends: base >= 4.7 && < 5 - , classy-prelude , wreq , aeson , mtl , lens - , text-icu + , pcre-light , vector , optparse-generic , configurator @@ -52,31 +52,39 @@ , network-uri , wuss , random + , hashable + , text + , mtl + , unordered-containers + , mono-traversable default-language: Haskell2010 default-extensions: OverloadedStrings , TypeFamilies , MultiParamTypeClasses , TupleSections , GADTs - , NoImplicitPrelude executable marvin-pp hs-source-dirs: preprocessor main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base - , classy-prelude , mustache , directory , filepath - , optparse-generic + , marvin + , configurator + , optparse-applicative + , bytestring + , mono-traversable + , text + , aeson default-language: Haskell2010 default-extensions: OverloadedStrings , TypeFamilies , MultiParamTypeClasses , TupleSections , GADTs - , NoImplicitPrelude executable marvin-init hs-source-dirs: initializer @@ -84,18 +92,18 @@ other-modules: Paths_marvin ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base - , classy-prelude , mustache , directory , filepath - , optparse-generic + , optparse-applicative + , mono-traversable + , text default-language: Haskell2010 default-extensions: OverloadedStrings , TypeFamilies , MultiParamTypeClasses , TupleSections , GADTs - , NoImplicitPrelude -- test-suite slackbot-framework-test -- type: exitcode-stdio-1.0 @@ -103,7 +111,6 @@ -- main-is: Spec.hs -- build-depends: base -- , marvin --- , classy-prelude -- ghc-options: -threaded -rtsopts -with-rtsopts=-N -- default-language: Haskell2010 -- default-extensions: OverloadedStrings @@ -111,7 +118,6 @@ -- , MultiParamTypeClasses -- , TupleSections -- , GADTs --- , NoImplicitPrelude source-repository head type: git diff --git a/preprocessor/Main.hs b/preprocessor/Main.hs --- a/preprocessor/Main.hs +++ b/preprocessor/Main.hs @@ -1,46 +1,105 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -import ClassyPrelude +import Data.Aeson hiding (object) +import qualified Data.ByteString.Lazy as B +import qualified Data.Configurator as C +import Data.Maybe (fromMaybe) +import Data.MonoTraversable.Unprefixed +import Data.Sequences +import qualified Data.Text.IO as T +import Marvin.Run (defaultConfigName, lookupFromAppConfig) +import Options.Applicative +import Prelude hiding (elem, filter) import System.Directory import System.FilePath import Text.Mustache import Text.Mustache.Compile -import Options.Generic -data Opts = Opts - { adapter :: Maybe String - } deriving (Generic) +data Opts = Opts + { adapter :: Maybe String + , sourceName :: FilePath + , sourceLocation :: FilePath + , targetFile :: FilePath + , externalScripts :: FilePath + , configLocation :: Maybe FilePath + } -instance ParseRecord Opts +slackRtmData = ("Marvin.Adapter.Slack", "SlackRTMAdapter") adapters :: [(String, (String, String))] adapters = - [("slack-rtm", ("Marvin.Adapter.Slack", "SlackRTMAdapter"))] + [("slack-rtm", slackRtmData)] tpl :: Template -tpl = $(embedTemplate ["app"] "Main.mustache") +tpl = $(embedTemplate ["preprocessor"] "Main.mustache") main :: IO () main = do - args <- getArgs - case args of - (srcname': srcLoc: out:r) -> do - let opts = getRecordPure r - srcname = unpack srcname' - dir = takeDirectory srcname - paths <- filter (not . ((||) <$> isPrefixOf "_" <*> isPrefixOf ".")) <$> getDirectoryContents dir - files <- filterM (doesFileExist . (dir )) paths - let hsFiles = map dropExtensions $ filter (/= takeFileName srcname) $ filter ((`elem` [".hs", ".lhs"]) . takeExtension) files - adapterType = opts >>= adapter >>= flip lookup adapters - processed = substitute tpl (object [ "scripts" ~> intercalate ", " (map (++ ".script") hsFiles) - , "imports" ~> hsFiles - , "adapter-import" ~> map fst adapterType - , "adapter-type" ~> maybe "AddYourAdapterTypeHere" snd adapterType - ]) - writeFile (unpack out) processed - _ -> error "unexpected arguments" + Opts{..} <- execParser infoParser + + adapter' <- maybe + (do + (cfg, _) <- C.autoReload C.autoConfig $ maybe [] (return . C.Optional) configLocation + lookupFromAppConfig cfg "adapter" + ) + (return . return) + adapter + + let (adapterImport, adapterType) = fromMaybe slackRtmData $ adapter' >>= flip lookup adapters + + let dir = takeDirectory sourceName + paths <- filter (not . ((||) <$> isPrefixOf "_" <*> isPrefixOf ".")) <$> getDirectoryContents dir + files <- filterM (doesFileExist . (dir )) paths + externals <- do + exists <- doesFileExist externalScripts + if exists + then do + f <- B.readFile externalScripts + either error return $ eitherDecode f + else return mempty + let hsFiles = map dropExtensions $ filter (/= takeFileName sourceName) $ filter ((`elem` [".hs", ".lhs"]) . takeExtension) files + scripts = hsFiles <> externals + processed = substitute tpl (object [ "scripts" ~> intercalate ", " (map (<> ".script") scripts) + , "imports" ~> scripts + , "adapter-import" ~> adapterImport + , "adapter-type" ~> adapterType + ]) + T.writeFile targetFile processed + where + infoParser = info + (helper <*> optsParser) + (fullDesc <> header "marvin-pp ~ the marvin preprocessor") + optsParser = Opts + <$> optional + (strOption + $ long "adapter" + <> short 'a' + <> metavar "ID" + <> help "adapter to use" + <> showDefault + ) + <*> argument str (metavar "NAME") + <*> argument str (metavar "PATH") + <*> argument str (metavar "PATH") + <*> strOption + ( long "external-scripts" + <> short 's' + <> value "external-scripts.json" + <> metavar "PATH" + <> help "config file of external scripts to load" + <> showDefault + ) + <*> optional + (strOption + $ long "config-location" + <> short 'c' + <> metavar "PATH" + <> help "config to use" + <> showDefault + <> value defaultConfigName + ) diff --git a/src/Marvin.hs b/src/Marvin.hs --- a/src/Marvin.hs +++ b/src/Marvin.hs @@ -16,7 +16,7 @@ , IsAdapter -- * Reacting , hear, respond, send, reply, messageRoom - , getMessage, getMatch + , getMessage, getMatch, getUsername, getChannelName , Message(..), User(..), Room(..) , getConfigVal, requireConfigVal , BotReacting, HasMessage, HasMatch diff --git a/src/Marvin/Adapter.hs b/src/Marvin/Adapter.hs --- a/src/Marvin/Adapter.hs +++ b/src/Marvin/Adapter.hs @@ -12,8 +12,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Marvin.Adapter where -import ClassyPrelude +import Control.Monad.IO.Class import qualified Data.Configurator.Types as C +import Data.Text (unpack) import Marvin.Internal.Types import qualified System.Log.Logger as L @@ -27,22 +28,23 @@ class IsAdapter a where adapterId :: AdapterId a - messageRoom :: a -> Room -> Text -> IO () - getUserInfo :: a -> User -> IO (Maybe UserInfo) + messageRoom :: a -> Room -> String -> IO () runWithAdapter :: RunWithAdapter a + getUsername :: a -> User -> IO String + getChannelName :: a -> Room -> IO String type RunWithAdapter a = C.Config -> InitEventHandler a -> IO () -adapterLog :: forall m a. (MonadIO m, IsAdapter a) => (String -> String -> IO ()) -> a -> Text -> m () +adapterLog :: forall m a. (MonadIO m, IsAdapter a) => (String -> String -> IO ()) -> a -> String -> m () adapterLog inner _ message = - liftIO $ inner (unpack $ "adapter." ++ aid) (unpack message) + liftIO $ inner ("adapter." ++ unpack aid) message where (AdapterId aid) = adapterId :: AdapterId a -debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsAdapter a) => a -> Text -> m () +debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsAdapter a) => a -> String -> m () debugM = adapterLog L.debugM infoM = adapterLog L.infoM noticeM = adapterLog L.noticeM @@ -53,5 +55,5 @@ emergencyM = adapterLog L.emergencyM -logM :: (MonadIO m, IsAdapter a) => L.Priority -> a -> Text -> m () +logM :: (MonadIO m, IsAdapter a) => L.Priority -> a -> String -> m () logM prio = adapterLog (`L.logM` prio) diff --git a/src/Marvin/Adapter/Slack.hs b/src/Marvin/Adapter/Slack.hs --- a/src/Marvin/Adapter/Slack.hs +++ b/src/Marvin/Adapter/Slack.hs @@ -2,84 +2,55 @@ {-# LANGUAGE TemplateHaskell #-} module Marvin.Adapter.Slack (SlackRTMAdapter) where -import ClassyPrelude + +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Control.Concurrent.Async (async, wait) +import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, + readMVar, takeMVar) +import Control.Exception import Control.Lens hiding ((.=)) +import Control.Monad import Data.Aeson hiding (Error) import Data.Aeson.TH import Data.Aeson.Types hiding (Error) import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Configurator as C import qualified Data.Configurator.Types as C +import Data.Containers +import Data.Foldable (toList) +import Data.HashMap.Strict (HashMap) +import Data.Maybe (fromMaybe) +import Data.Sequences +import Data.Text (Text, pack) import Marvin.Adapter import Marvin.Types import Network.URI import Network.WebSockets import Network.Wreq +import Prelude hiding (lookup) +import Text.Read (readMaybe) import Wuss data InternalType = Error { code :: Int - , msg :: Text + , msg :: String } - | Unhandeled Text + | Unhandeled String | Ignored instance FromJSON URI where parseJSON (String t) = maybe mzero return $ parseURI $ unpack t - parseJSON _ = mzero + parseJSON _ = mzero instance ToJSON URI where toJSON = toJSON . show - --- data BotData = BotData --- { botId :: Text --- , notName :: Text --- , botCreated :: UTCTime --- } - --- { --- "ok": true, --- "url": "wss:\/\/ms9.slack-msgs.com\/websocket\/7I5yBpcvk", - --- "self": { --- "id": "U023BECGF", --- "name": "bobby", --- "prefs": { --- … --- }, --- "created": 1402463766, --- "manual_presence": "active" --- }, --- "team": { --- "id": "T024BE7LD", --- "name": "Example Team", --- "email_domain": "", --- "domain": "example", --- "icon": { --- … --- }, --- "msg_edit_window_mins": -1, --- "over_storage_limit": false --- "prefs": { --- … --- }, --- "plan": "std" --- }, --- "users": [ … ], - --- "channels": [ … ], --- "groups": [ … ], --- "mpims": [ … ], --- "ims": [ … ], - --- "bots": [ … ], --- } data RTMData = RTMData { ok :: Bool , url :: URI @@ -124,12 +95,8 @@ eventParser _ = mzero -rawBS :: BS.ByteString -> Text -rawBS bs = "\"" ++ toStrict (decodeUtf8 bs) ++ "\"" - - -showt :: Show a => a -> Text -showt = pack . show +rawBS :: BS.ByteString -> String +rawBS bs = "\"" ++ BS.unpack bs ++ "\"" helloParser :: Value -> Parser Bool @@ -144,34 +111,43 @@ usr <- o .: "user" case usr of (Object o) -> UserInfo <$> o .: "name" <*> o .: "id" - _ -> mzero + _ -> mzero userInfoParser _ = mzero apiResponseParser :: (Value -> Parser a) -> Value -> Parser (APIResponse a) apiResponseParser f v@(Object o) = APIResponse <$> o .: "ok" <*> f v -apiResponseParser _ _ = mzero +apiResponseParser _ _ = mzero +data SlackRTMAdapter = SlackRTMAdapter + { sendMessage :: BS.ByteString -> IO () + , userConfig :: C.Config + , midTracker :: MVar Int + , channelChache :: MVar (HashMap Room LimitedChannelInfo) + , userInfoCache :: MVar (HashMap User UserInfo) + } + + runConnectionLoop :: C.Config -> MVar BS.ByteString -> MVar Connection -> IO () runConnectionLoop cfg messageChan connTracker = forever $ do token <- C.require cfg "token" debugM pa "initializing socket" r <- post "https://slack.com/api/rtm.start" [ "token" := (token :: Text) ] case eitherDecode (r^.responseBody) of - Left err -> errorM pa $ "Error decoding rtm json: " ++ pack err + Left err -> errorM pa $ "Error decoding rtm json: " ++ err Right js -> do let uri = url js authority = fromMaybe (error "URI lacks authority") (uriAuthority uri) host = uriUserInfo authority ++ uriRegName authority path = uriPath uri portOnErr v = do - debugM pa $ "Unreadable port '" ++ pack v ++ "'" + debugM pa $ "Unreadable port '" ++ v ++ "'" return 443 port <- case uriPort authority of - v@(':':r) -> maybe (portOnErr v) return $ readMay r - v -> portOnErr v - debugM pa $ "connecting to socket '" ++ showt uri ++ "'" + v@(':':r) -> maybe (portOnErr v) return $ readMaybe r + v -> portOnErr v + debugM pa $ "connecting to socket '" ++ show uri ++ "'" catch (runSecureClient host port path $ \conn -> do debugM pa "Connection established" @@ -186,7 +162,7 @@ putMVar messageChan d) $ \e -> do void $ takeMVar connTracker - errorM pa (pack $ show (e :: ConnectionException)) + errorM pa (show (e :: ConnectionException)) where pa = error "Phantom value" :: SlackRTMAdapter @@ -196,7 +172,7 @@ forever $ do d <- takeMVar messageChan case eitherDecode d >>= parseEither eventParser of - Left err -> errorM adapter $ "Error parsing json: " ++ pack err ++ " original data: " ++ rawBS d + Left err -> errorM adapter $ "Error parsing json: " ++ err ++ " original data: " ++ rawBS d Right v -> case v of Right event -> handler event @@ -205,7 +181,7 @@ Unhandeled type_ -> debugM adapter $ "Unhandeled event type " ++ type_ ++ " payload " ++ rawBS d Error code msg -> - errorM adapter $ "Error from remote code: " ++ showt code ++ " msg: " ++ msg + errorM adapter $ "Error from remote code: " ++ show code ++ " msg: " ++ msg Ignored -> return () @@ -217,7 +193,7 @@ let send d = do conn <- readMVar connTracker sendTextData conn d - adapter = SlackRTMAdapter send cfg midTracker + adapter <- SlackRTMAdapter send cfg midTracker <$> newMVar mempty <*> newMVar mempty handler <- handlerInit adapter void $ async $ runConnectionLoop cfg messageChan connTracker runHandlerLoop adapter messageChan handler @@ -227,7 +203,7 @@ execAPIMethod innerParser adapter method params = do token <- C.require cfg "token" response <- post ("https://slack.com/api/" ++ method) (("token" := (token :: Text)):params) - debugM adapter (toStrict $ decodeUtf8 $ response^.responseBody) + debugM adapter (BS.unpack $ response^.responseBody) return $ eitherDecode (response^.responseBody) >>= parseEither (apiResponseParser innerParser) where cfg = userConfig adapter @@ -240,7 +216,7 @@ return id -messageRoomImpl :: SlackRTMAdapter -> Room -> Text -> IO () +messageRoomImpl :: SlackRTMAdapter -> Room -> String -> IO () messageRoomImpl adapter (Room room) msg = do mid <- newMid adapter sendMessage adapter $ encode $ @@ -251,24 +227,59 @@ ] -getUserInfoImpl :: SlackRTMAdapter -> User -> IO (Maybe UserInfo) -getUserInfoImpl adapter (User user) = do - usr <- execAPIMethod userInfoParser adapter "users.info" ["user" := user] - case usr of - Left err -> errorM adapter ("Parse error when getting user data " ++ pack err) >> return Nothing - Right (APIResponse True v) -> return (Just v) - Right (APIResponse False _) -> errorM adapter "Server denied getting user info request" >> return Nothing +data UserInfo = UserInfo + { uiUsername :: String + , uiId :: User + } -data SlackRTMAdapter = SlackRTMAdapter - { sendMessage :: BS.ByteString -> IO () - , userConfig :: C.Config - , midTracker :: MVar Int +getUserInfoImpl :: SlackRTMAdapter -> User -> IO UserInfo +getUserInfoImpl adapter user@(User user') = do + uc <- readMVar $ userInfoCache adapter + maybe refreshAndReturn return $ lookup user uc + where + refreshAndReturn = do + usr <- execAPIMethod userInfoParser adapter "users.info" ["user" := user'] + case usr of + Left err -> error ("Parse error when getting user data " ++ err) + Right (APIResponse True v) -> do + modifyMVar_ (userInfoCache adapter) (return . insertMap user v) + return v + Right (APIResponse False _) -> error "Server denied getting user info request" + + +data LimitedChannelInfo = LimitedChannelInfo + { lciId :: Room + , lciName :: String } +lciParser (Object o) = LimitedChannelInfo <$> o .: "id" <*> o .: "name" +lciParser _ = mzero + +lciListParser (Array a) = toList <$> mapM lciParser a +lciListParser _ = mzero + +getChannelNameImpl :: SlackRTMAdapter -> Room -> IO String +getChannelNameImpl adapter channel = do + cc <- readMVar $ channelChache adapter + maybe refreshAndReturn return $ lciName <$> lookup channel cc + where + refreshAndReturn = do + usr <- execAPIMethod lciListParser adapter "channels.list" [] + case usr of + Left err -> error ("Parse error when getting channel data " ++ err) + Right (APIResponse True v) -> do + let cmap = mapFromList $ map (lciId &&& id) v + putMVar (channelChache adapter) cmap + return $ lciName $ fromMaybe (error "Room not found") $ lookup channel cmap + Right (APIResponse False _) -> error "Server denied getting channel info request" + + instance IsAdapter SlackRTMAdapter where adapterId = "slack-rtm" messageRoom = messageRoomImpl - getUserInfo = getUserInfoImpl runWithAdapter = runnerImpl + getUsername a = fmap uiUsername . getUserInfoImpl a + getChannelName = getChannelNameImpl + diff --git a/src/Marvin/Internal.hs b/src/Marvin/Internal.hs --- a/src/Marvin/Internal.hs +++ b/src/Marvin/Internal.hs @@ -10,12 +10,13 @@ module Marvin.Internal where -import ClassyPrelude import Control.Monad.State import qualified Data.Configurator as C import qualified Data.Configurator.Types as C import Control.Lens hiding (cons) +import Data.Monoid ((<>)) +import Data.Sequences import Marvin.Adapter (IsAdapter) import qualified Marvin.Adapter as A import Marvin.Internal.Types @@ -107,8 +108,20 @@ instance IsScript (BotReacting a b) where getScriptId = BotReacting $ use scriptId +class AccessAdapter m where + type AdapterT m + getAdapter :: m (AdapterT m) + +instance AccessAdapter (ScriptDefinition a) where + type AdapterT (ScriptDefinition a) = a + getAdapter = ScriptDefinition $ use adapter + +instance AccessAdapter (BotReacting a b) where + type AdapterT (BotReacting a b) = a + getAdapter = BotReacting $ use adapter + getSubConfFor :: HasConfigAccess m => ScriptId -> m C.Config -getSubConfFor (ScriptId name) = C.subconfig ("script." ++ name) <$> getConfigInternal +getSubConfFor (ScriptId name) = C.subconfig ("script." <> name) <$> getConfigInternal getConfig :: HasConfigAccess m => m C.Config @@ -136,46 +149,43 @@ -- | Send a message to the channel the triggering message came from. -- -- Equivalent to "robot.send" in hubot -send :: (IsAdapter a, HasMessage m) => Text -> BotReacting a m () +send :: (IsAdapter a, HasMessage m) => String -> BotReacting a m () send msg = do o <- getMessage messageRoom (channel o) msg -getUserInfo :: IsAdapter a => User -> BotReacting a m (Maybe UserInfo) -getUserInfo u = do - a <- BotReacting $ use adapter - liftIO $ A.getUserInfo a u +-- | Get the username of a registered user. +getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User -> m String +getUsername usr = do + a <- getAdapter + liftIO $ A.getUsername a usr +-- | Get the human readable name of a channel. +getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Room -> m String +getChannelName rm = do + a <- getAdapter + liftIO $ A.getChannelName a rm + + -- | Send a message to the channel the original message came from and address the user that sent the original message. -- -- Equivalent to "robot.reply" in hubot -reply :: (IsAdapter a, HasMessage m) => Text -> BotReacting a m () +reply :: (IsAdapter a, HasMessage m) => String -> BotReacting a m () reply msg = do om <- getMessage - user <- getUserInfo $ sender om - case user of - Nothing -> errorM "Message sender has no info, message was not sent" - Just user -> send $ username user ++ " " ++ msg + user <- getUsername $ sender om + send $ user ++ " " ++ msg -- | Send a message to a room -messageRoom :: IsAdapter a => Room -> Text -> BotReacting a s () +messageRoom :: (IsAdapter (AdapterT m), AccessAdapter m, MonadIO m) => Room -> String -> m () messageRoom room msg = do - a <- BotReacting $ use adapter + a <- getAdapter liftIO $ A.messageRoom a room msg - -- token <- requireAppConfigVal "token" - -- liftIO $ async $ post "https://slack.com/api/chat.postMessage" - -- [ "token" := (token :: Text) - -- , "channel" := roomname room - -- , "text" := msg - -- ] - -- return () - - -- | Define a new script for marvin -- -- You need to provide a ScriptId (which can simple be written as a non-empty string). @@ -247,12 +257,18 @@ liftIO $ C.require cfg name +-- | Take a reaction and produce an IO action with the same effect. +-- Useful for creating actions which can be scheduled to execute a certain time or asynchronous. +-- The idea is that one can conveniently send messages from inside a schedulable action. extractReaction :: BotReacting a s o -> BotReacting a s (IO o) extractReaction reac = BotReacting $ do s <- get return $ evalStateT (runReaction reac) s +-- | Take an action and produce an IO action with the same effect. +-- Useful for creating actions which can be scheduled to execute a certain time or asynchronous. +-- The idea is that one can conveniently send messages from inside a schedulable action. extractAction :: BotReacting a () o -> ScriptDefinition a (IO o) extractAction ac = ScriptDefinition $ do a <- use adapter diff --git a/src/Marvin/Internal/Types.hs b/src/Marvin/Internal/Types.hs --- a/src/Marvin/Internal/Types.hs +++ b/src/Marvin/Internal/Types.hs @@ -5,43 +5,43 @@ module Marvin.Internal.Types where -import ClassyPrelude +import Control.Arrow ((&&&)) import Control.Lens +import Control.Monad +import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.TH import Data.Char (isAlphaNum, isLetter) import qualified Data.Configurator.Types as C +import Data.Hashable +import Data.String +import Data.Text (Text, pack, toUpper, unpack) import qualified System.Log.Logger as L +import Text.Read (readMaybe) -newtype User = User Text deriving (IsString, Eq) -newtype Room = Room Text deriving (IsString, Eq, Show) +newtype User = User String deriving (IsString, Eq, Hashable) +newtype Room = Room String deriving (IsString, Eq, Show, Hashable) deriveJSON defaultOptions { unwrapUnaryRecords = True } ''User deriveJSON defaultOptions { unwrapUnaryRecords = True } ''Room -data UserInfo = UserInfo - { username :: Text - , userID :: User - } - - newtype TimeStamp = TimeStamp { unwrapTimeStamp :: Double } deriving Show data Message = Message { sender :: User , channel :: Room - , content :: Text + , content :: String , timestamp :: TimeStamp } instance FromJSON TimeStamp where - parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMay s - parseJSON _ = mzero + parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMaybe (unpack s) + parseJSON _ = mzero instance ToJSON TimeStamp where toJSON = toJSON . show . unwrapTimeStamp @@ -95,5 +95,5 @@ instance C.Configured L.Priority where convert (C.String s) = lookup (toUpper s) prioMapping - convert _ = Nothing + convert _ = Nothing diff --git a/src/Marvin/Prelude.hs b/src/Marvin/Prelude.hs --- a/src/Marvin/Prelude.hs +++ b/src/Marvin/Prelude.hs @@ -9,12 +9,8 @@ -} module Marvin.Prelude ( - -- | For exposing parameterised and generalised versions of prelude functions - module ClassyPrelude - -- | Marvin :3 - -- - -- Common functions and Types for scripts - , module Marvin + -- | Common functions and Types for scripts + module Marvin -- | Mutable references in marvin scripts , module Marvin.Util.Mutable -- | Logging in Scripts @@ -26,14 +22,22 @@ -- | Dealing with JSON , module Marvin.Util.JSON -- | Format strings which resolve to efficient Strings, aka 'Text' - , module Data.Text.Format + , module Text.Printf + -- | Arbitrary IO in scripts + , MonadIO, liftIO + -- | Useful functions not in the normal Prelude + , when, unless, for, for_, fromMaybe ) where -import ClassyPrelude -import Data.Text.Format (format) import Marvin import Marvin.Util.JSON import Marvin.Util.Logging import Marvin.Util.Mutable import Marvin.Util.Random import Marvin.Util.Regex +import Text.Printf +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (when, unless) +import Data.Foldable (for_) +import Data.Traversable (for) +import Data.Maybe (fromMaybe) diff --git a/src/Marvin/Run.hs b/src/Marvin/Run.hs --- a/src/Marvin/Run.hs +++ b/src/Marvin/Run.hs @@ -17,28 +17,33 @@ {-# LANGUAGE TemplateHaskell #-} module Marvin.Run ( runMarvin, ScriptInit, IsAdapter + , requireFromAppConfig, lookupFromAppConfig, defaultConfigName ) where -import ClassyPrelude -import Control.Concurrent.Async (wait) +import Control.Concurrent.Async (async, wait) +import Control.Exception import Control.Lens hiding (cons) import Control.Monad.State hiding (mapM_) import Data.Char (isSpace) import qualified Data.Configurator as C import qualified Data.Configurator.Types as C +import Data.Maybe (fromMaybe) +import Data.Sequences +import Data.Traversable (for) import Data.Vector (Vector) import Marvin.Adapter import Marvin.Internal hiding (match) import Marvin.Internal.Types hiding (channel) import Marvin.Util.Regex import Options.Generic -import qualified Prelude as P +import Prelude hiding (dropWhile, splitAt, (++)) import qualified System.Log.Formatter as L import qualified System.Log.Handler.Simple as L import qualified System.Log.Logger as L - +(++) :: Monoid a => a -> a -> a +(++) = mappend data CmdOptions = CmdOptions { configPath :: Maybe FilePath @@ -50,10 +55,14 @@ instance ParseRecord CmdOptions -defaultBotName :: Text +defaultBotName :: String defaultBotName = "marvin" +defaultConfigName :: FilePath +defaultConfigName = "config.cfg" + + requireFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO a requireFromAppConfig cfg = C.require (C.subconfig (unwrapScriptId applicationScriptId) cfg) @@ -78,7 +87,7 @@ handleMessage msg = do lDispatches <- doIfMatch allListens text botname <- fromMaybe defaultBotName <$> lookupFromAppConfig cfg "name" - let (trimmed, remainder) = splitAt (length botname) $ dropWhile isSpace text + let (trimmed, remainder) = splitAt (fromIntegral $ length botname) $ dropWhile isSpace text rDispatches <- if toLower trimmed == toLower botname then doIfMatch allReactions remainder else return mempty @@ -87,9 +96,9 @@ text = content msg doIfMatch things toMatch = catMaybes <$> for things (\(trigger, action) -> - case match trigger toMatch of + case match [] trigger toMatch of Nothing -> return Nothing - Just m -> Just <$> async (action msg m)) + Just m -> Just <$> async (action msg m)) flattenActions = foldr $ \script -> flip (foldr (addAction script adapter)) (script^.actions) @@ -145,7 +154,7 @@ handler = L.GenericHandler { L.priority = L.DEBUG , L.formatter = L.simpleLogFormatter "$time [$prio:$loggername] $msg" , L.privData = () - , L.writeFunc = const P.putStrLn + , L.writeFunc = const putStrLn , L.closeFunc = const $ return () } @@ -158,7 +167,7 @@ when (verbose args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.INFO) when (debug args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.DEBUG) cfgLoc <- maybe - (L.noticeM "bot" "Using default config: config.cfg" >> return "config.cfg") + (L.noticeM "bot" "Using default config: config.cfg" >> return defaultConfigName) return (configPath args) (cfg, cfgTid) <- C.autoReload C.autoConfig [C.Required cfgLoc] diff --git a/src/Marvin/Types.hs b/src/Marvin/Types.hs --- a/src/Marvin/Types.hs +++ b/src/Marvin/Types.hs @@ -8,7 +8,7 @@ Portability : POSIX -} module Marvin.Types - ( User(..), UserInfo(..), Room(..), Message(..), ScriptId(..) + ( User(..), Room(..), Message(..), ScriptId(..) , applicationScriptId, IsScript, getScriptId , HasConfigAccess ) where diff --git a/src/Marvin/Util/Logging.hs b/src/Marvin/Util/Logging.hs --- a/src/Marvin/Util/Logging.hs +++ b/src/Marvin/Util/Logging.hs @@ -11,18 +11,18 @@ ( debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM, logM ) where -import ClassyPrelude +import Control.Monad.IO.Class +import Data.Text (unpack) import Marvin.Types -import qualified System.Log.Logger as L - +import qualified System.Log.Logger as L -scriptLog :: (MonadIO m, IsScript m) => (String -> String -> IO ()) -> Text -> m () +scriptLog :: (MonadIO m, IsScript m) => (String -> String -> IO ()) -> String -> m () scriptLog inner message = do (ScriptId sid) <- getScriptId - liftIO $ inner (unpack $ "script." ++ sid) (unpack message) + liftIO $ inner ("script." ++ unpack sid) message -debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsScript m) => Text -> m () +debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsScript m) => String -> m () debugM = scriptLog L.debugM infoM = scriptLog L.infoM noticeM = scriptLog L.noticeM @@ -33,5 +33,5 @@ emergencyM = scriptLog L.emergencyM -logM :: (MonadIO m, IsScript m) => L.Priority -> Text -> m () +logM :: (MonadIO m, IsScript m) => L.Priority -> String -> m () logM prio = scriptLog (`L.logM` prio) diff --git a/src/Marvin/Util/Mutable.hs b/src/Marvin/Util/Mutable.hs --- a/src/Marvin/Util/Mutable.hs +++ b/src/Marvin/Util/Mutable.hs @@ -10,8 +10,8 @@ module Marvin.Util.Mutable where -import ClassyPrelude - +import Control.Monad.IO.Class +import Data.IORef -- | A mutable reference to a value of type @v@ type Mutable v = IORef v diff --git a/src/Marvin/Util/Random.hs b/src/Marvin/Util/Random.hs --- a/src/Marvin/Util/Random.hs +++ b/src/Marvin/Util/Random.hs @@ -13,7 +13,9 @@ ) where -import ClassyPrelude +import Control.Monad.IO.Class +import Data.MonoTraversable +import Data.Sequences import System.Random @@ -35,5 +37,5 @@ -- Usable in all IO capable monads, such as 'BotReacting' and 'ScriptDefinition'. randomFrom :: (IsSequence s, Index s ~ Int, MonadIO m) => s -> m (Element s) randomFrom list = do - n <- randomValFromRange (0, pred $ length list) + n <- randomValFromRange (0, pred $ olength list) return $ list `indexEx` n diff --git a/src/Marvin/Util/Regex.hs b/src/Marvin/Util/Regex.hs --- a/src/Marvin/Util/Regex.hs +++ b/src/Marvin/Util/Regex.hs @@ -8,15 +8,31 @@ Portability : POSIX -} module Marvin.Util.Regex - ( Regex, Match, r, match, MatchOption(..) + ( Regex, Match, r, match + -- * Compile time regex options + , Re.PCREOption + + , Re.anchored, Re.auto_callout + , Re.caseless, Re.dollar_endonly + , Re.dotall, Re.dupnames, Re.extended + , Re.extra, Re.firstline, Re.multiline + , Re.newline_cr + , Re.newline_crlf, Re.newline_lf, Re.no_auto_capture + , Re.ungreedy, Re.utf8, Re.no_utf8_check + + -- * Runtime regex options + , Re.PCREExecOption + + , Re.exec_anchored + , Re.exec_newline_cr, Re.exec_newline_crlf, Re.exec_newline_lf + , Re.exec_notbol, Re.exec_noteol, Re.exec_notempty + , Re.exec_no_utf8_check, Re.exec_partial -- ** Unstable , unwrapRegex ) where - -import ClassyPrelude -import Data.Text.ICU (MatchOption (..)) -import qualified Data.Text.ICU as Re +import Data.String +import qualified Text.Regex.PCRE.Light.Char8 as Re -- | Abstract Wrapper for a reglar expression implementation. Has an 'IsString' implementation, so literal strings can be used to create a 'Regex'. @@ -33,20 +49,20 @@ -- | A match to a 'Regex'. Index 0 is the full match, all other indexes are match groups. -type Match = [Text] +type Match = [String] -- | Compile a regex with options -- -- Normally it is sufficient to just write the regex as a plain string and have it be converted automatically, but if you want certain match options you can use this function. -r :: [Re.MatchOption] -> Text -> Regex -r opts s = Regex $ Re.regex opts s +r :: [Re.PCREOption] -> String -> Regex +r opts s = Regex $ Re.compile s opts instance IsString Regex where fromString "" = error "Empty regex is not permitted, use '.*' or similar instead" - fromString s = r [] $ pack s + fromString s = r [] s -- | Match a regex against a string and return the first match found (if any). -match :: Regex -> Text -> Maybe Match -match re = fmap (Re.unfold Re.group) . Re.find (unwrapRegex re) +match :: [Re.PCREExecOption] -> Regex -> String -> Maybe Match +match opts re s = Re.match (unwrapRegex re) s opts