diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ 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). +The in-depth documentation can be found on readthedocs https://marvin.readthedocs.org ## Installation @@ -26,26 +26,26 @@ script :: IsAdapter a => ScriptInit a script = defineScript "my-script" $ do - hear "I|i can't stand this (\w+)" $ do + hear "sudo (.+)" $ do match <- getMatch let thing = match !! 1 - reply $ "I'm sorry to tell you but you'll have to do " ++ thing + reply $ "All right, i'll do " ++ thing - respond "open the (\w+) door" $ do + respond "open the (\\w+) door" $ do match <- getMatch let door = match !! 1 openDoor door - send $ printf "Door %v opened" door + send $ printf "Door %s opened" door - respond "what is in file (\w+)" $ do + respond "what is in file (\\w+)\\??" $ do match <- getMatch let file = match !! 1 - liftIO $ readFile file + contents <- liftIO $ readFile file - send file + send contents ``` ## How to Marvin @@ -101,12 +101,12 @@ 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. +- `send` sends it to the same Channel the tiggering message weas sent to. +- `messageChannel` sends a message to a Channel specified by the user. ### Configuration -Configuration for marvin is written in the [configurator](https://hackage.haskell.com/package/configurator) syntax. +Configuration for marvin is written in the [configurator](https://hackage.haskell.org/package/configurator) syntax. Configuration pertaining to the bot is stored under the "bot" key. diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -1,5 +1,5 @@ name: marvin -version: 0.0.2 +version: 0.0.3 synopsis: A modular bot for slack description: Please see README.md homepage: https://github.com/JustusAdam/marvin#readme diff --git a/src/Marvin.hs b/src/Marvin.hs --- a/src/Marvin.hs +++ b/src/Marvin.hs @@ -10,22 +10,24 @@ -} module Marvin ( -- * Scripts - Script, defineScript, ScriptInit + Script(..), defineScript, ScriptInit , ScriptId , ScriptDefinition , IsAdapter -- * Reacting - , hear, respond, send, reply, messageRoom + , hear, respond, send, reply, messageChannel , getMessage, getMatch, getUsername, getChannelName - , Message(..), User(..), Room(..) + , Message(..), User, Channel , getConfigVal, requireConfigVal - , BotReacting, HasMessage, HasMatch - , MessageReactionData, messageField, matchField + , BotReacting, HasMessage(messageLens), HasMatch(matchLens) -- ** Advanced actions , extractAction, extractReaction + -- * Lenses and internal types + , HasScriptId(scriptId), HasConfig(config), HasAdapter(adapter), HasMessageField(messageField), HasMatchField(matchField), HasVariable(variable), BotActionState(BotActionState), MessageReactionData(MessageReactionData), HasActions(actions) ) where import Marvin.Adapter (IsAdapter) import Marvin.Internal +import Marvin.Internal.Types import Marvin.Types diff --git a/src/Marvin/Adapter.hs b/src/Marvin/Adapter.hs --- a/src/Marvin/Adapter.hs +++ b/src/Marvin/Adapter.hs @@ -28,10 +28,11 @@ class IsAdapter a where adapterId :: AdapterId a - messageRoom :: a -> Room -> String -> IO () + messageChannel :: a -> Channel -> String -> IO () runWithAdapter :: RunWithAdapter a getUsername :: a -> User -> IO String - getChannelName :: a -> Room -> IO String + getChannelName :: a -> Channel -> IO String + resolveChannel :: a -> String -> IO (Maybe Channel) type RunWithAdapter a = C.Config -> InitEventHandler a -> IO () 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 @@ -120,11 +120,17 @@ apiResponseParser _ _ = mzero +data ChannelCache = ChannelCache + { ccCache :: HashMap Channel LimitedChannelInfo + , nameResolver :: HashMap String Channel + } + + data SlackRTMAdapter = SlackRTMAdapter { sendMessage :: BS.ByteString -> IO () , userConfig :: C.Config , midTracker :: MVar Int - , channelChache :: MVar (HashMap Room LimitedChannelInfo) + , channelChache :: MVar ChannelCache , userInfoCache :: MVar (HashMap User UserInfo) } @@ -193,7 +199,7 @@ let send d = do conn <- readMVar connTracker sendTextData conn d - adapter <- SlackRTMAdapter send cfg midTracker <$> newMVar mempty <*> newMVar mempty + adapter <- SlackRTMAdapter send cfg midTracker <$> newMVar (ChannelCache mempty mempty) <*> newMVar mempty handler <- handlerInit adapter void $ async $ runConnectionLoop cfg messageChan connTracker runHandlerLoop adapter messageChan handler @@ -216,13 +222,13 @@ return id -messageRoomImpl :: SlackRTMAdapter -> Room -> String -> IO () -messageRoomImpl adapter (Room room) msg = do +messageChannelImpl :: SlackRTMAdapter -> Channel -> String -> IO () +messageChannelImpl adapter (Channel chan) msg = do mid <- newMid adapter sendMessage adapter $ encode $ object [ "id" .= mid , "type" .= ("message" :: Text) - , "channel" .= room + , "channel" .= chan , "text" .= msg ] @@ -249,7 +255,7 @@ data LimitedChannelInfo = LimitedChannelInfo - { lciId :: Room + { lciId :: Channel , lciName :: String } @@ -260,26 +266,46 @@ lciListParser (Array a) = toList <$> mapM lciParser a lciListParser _ = mzero -getChannelNameImpl :: SlackRTMAdapter -> Room -> IO String + +refreshChannels :: SlackRTMAdapter -> IO ChannelCache +refreshChannels adapter = 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 + nmap = mapFromList $ map (lciName &&& lciId) v + cache = ChannelCache cmap nmap + putMVar (channelChache adapter) cache + return cache + Right (APIResponse False _) -> error "Server denied getting channel info request" + + +resolveChannelImpl :: SlackRTMAdapter -> String -> IO (Maybe Channel) +resolveChannelImpl adapter name = do + cc <- readMVar $ channelChache adapter + case lookup name (nameResolver cc) of + Nothing -> do + ncc <- refreshChannels adapter + return $ lookup name (nameResolver ncc) + Just found -> return (Just found) + + +getChannelNameImpl :: SlackRTMAdapter -> Channel -> 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" + case lookup channel (ccCache cc) of + Nothing -> do + ncc <- refreshChannels adapter + return $ lciName $ fromMaybe (error "Channel not found") $ lookup channel (ccCache ncc) + Just found -> return $ lciName found instance IsAdapter SlackRTMAdapter where adapterId = "slack-rtm" - messageRoom = messageRoomImpl + messageChannel = messageChannelImpl runWithAdapter = runnerImpl getUsername a = fmap uiUsername . getUserInfoImpl a getChannelName = getChannelNameImpl + resolveChannel = resolveChannelImpl diff --git a/src/Marvin/Internal.hs b/src/Marvin/Internal.hs --- a/src/Marvin/Internal.hs +++ b/src/Marvin/Internal.hs @@ -10,6 +10,7 @@ module Marvin.Internal where +import Control.Monad.Reader import Control.Monad.State import qualified Data.Configurator as C import qualified Data.Configurator.Types as C @@ -24,7 +25,7 @@ import Marvin.Util.Regex (Match, Regex) - +-- | Read only data available to a handler when the bot reacts to an event. declareFields [d| data BotActionState a d = BotActionState { botActionStateScriptId :: ScriptId @@ -50,20 +51,23 @@ data ActionData d where Hear :: Regex -> ActionData MessageReactionData Respond :: Regex -> ActionData MessageReactionData + Custom :: (A.Event -> Maybe d) -> ActionData d data WrappedAction a = forall d. WrappedAction (ActionData d) (BotReacting a d ()) --- | Monad for reacting in the bot. Allows use of functions like 'send', 'reply' and 'messageRoom' as well as any arbitrary 'IO' action. +-- | Monad for reacting in the bot. Allows use of functions like 'send', 'reply' and 'messageChannel' as well as any arbitrary 'IO' action. -- -- The type parameter @d@ is the accessible data provided by the trigger for this action. -- For message handlers like 'hear' and 'respond' this would be a regex 'Match' and a 'Message' for instance. -newtype BotReacting a d r = BotReacting { runReaction :: StateT (BotActionState a d) IO r } deriving (Monad, MonadIO, Applicative, Functor) +newtype BotReacting a d r = BotReacting { runReaction :: ReaderT (BotActionState a d) IO r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d)) -- | An abstract type describing a marvin script. -- -- This is basically a collection of event handlers. +-- +-- Internal structure is exposed for people wanting to extend this. declareFields [d| data Script a = Script { scriptActions :: [WrappedAction a] @@ -84,29 +88,29 @@ -- | Class which says that there is a way to get to a 'Message' from this type @m@. class HasMessage m where - message :: Lens' m Message + messageLens :: Lens' m Message instance HasMessageField m Message => HasMessage m where - message = messageField + messageLens = messageField -- | Class which says that there is a way to get to a 'Match' from this type @m@. class HasMatch m where - match :: Lens' m Match + matchLens :: Lens' m Match instance HasMatchField m Match => HasMatch m where - match = matchField + matchLens = matchField instance HasConfigAccess (ScriptDefinition a) where getConfigInternal = ScriptDefinition $ use config instance HasConfigAccess (BotReacting a b) where - getConfigInternal = BotReacting $ use config + getConfigInternal = view config instance IsScript (ScriptDefinition a) where getScriptId = ScriptDefinition $ use scriptId instance IsScript (BotReacting a b) where - getScriptId = BotReacting $ use scriptId + getScriptId = view scriptId class AccessAdapter m where type AdapterT m @@ -118,7 +122,7 @@ instance AccessAdapter (BotReacting a b) where type AdapterT (BotReacting a b) = a - getAdapter = BotReacting $ use adapter + getAdapter = view adapter getSubConfFor :: HasConfigAccess m => ScriptId -> m C.Config getSubConfFor (ScriptId name) = C.subconfig ("script." <> name) <$> getConfigInternal @@ -152,7 +156,7 @@ send :: (IsAdapter a, HasMessage m) => String -> BotReacting a m () send msg = do o <- getMessage - messageRoom (channel o) msg + messageChannel' (channel o) msg -- | Get the username of a registered user. @@ -162,8 +166,14 @@ liftIO $ A.getUsername a usr +resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => String -> m (Maybe Channel) +resolveChannel name = do + a <- getAdapter + liftIO $ A.resolveChannel a name + + -- | Get the human readable name of a channel. -getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Room -> m String +getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> m String getChannelName rm = do a <- getAdapter liftIO $ A.getChannelName a rm @@ -179,13 +189,20 @@ send $ user ++ " " ++ msg --- | Send a message to a room -messageRoom :: (IsAdapter (AdapterT m), AccessAdapter m, MonadIO m) => Room -> String -> m () -messageRoom room msg = do +-- | Send a message to a Channel (by name) +messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), IsScript m, MonadIO m) => String -> String -> m () +messageChannel name msg = do + mchan <- resolveChannel name + maybe (errorM $ "No channel known with the name " ++ name) (`messageChannel'` msg) mchan + + +messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), IsScript m, MonadIO m) => Channel -> String -> m () +messageChannel' chan msg = do a <- getAdapter - liftIO $ A.messageRoom a room msg + liftIO $ A.messageChannel a chan msg + -- | Define a new script for marvin -- -- You need to provide a ScriptId (which can simple be written as a non-empty string). @@ -203,20 +220,20 @@ -- | Obtain the reaction dependent data from the bot. getData :: BotReacting a d d -getData = BotReacting $ use variable +getData = view variable -- | Get the results from matching the regular expression. -- -- Equivalent to "msg.match" in hubot. getMatch :: HasMatch m => BotReacting a m Match -getMatch = BotReacting $ use (variable . match) +getMatch = view (variable . matchLens) -- | Get the message that triggered this action -- Includes sender, target channel, as well as the full, untruncated text of the original message getMessage :: HasMessage m => BotReacting a m Message -getMessage = BotReacting $ use (variable . message) +getMessage = view (variable . messageLens) -- | Get a value out of the config, returns 'Nothing' if the value didn't exist. @@ -262,8 +279,8 @@ -- 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 + s <- ask + return $ runReaderT (runReaction reac) s -- | Take an action and produce an IO action with the same effect. @@ -274,4 +291,4 @@ a <- use adapter sid <- use scriptId cfg <- use config - return $ evalStateT (runReaction ac) (BotActionState sid cfg a ()) + return $ runReaderT (runReaction ac) (BotActionState sid cfg a ()) 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 @@ -21,11 +21,11 @@ newtype User = User String deriving (IsString, Eq, Hashable) -newtype Room = Room String deriving (IsString, Eq, Show, Hashable) +newtype Channel = Channel String deriving (IsString, Eq, Show, Hashable) deriveJSON defaultOptions { unwrapUnaryRecords = True } ''User -deriveJSON defaultOptions { unwrapUnaryRecords = True } ''Room +deriveJSON defaultOptions { unwrapUnaryRecords = True } ''Channel newtype TimeStamp = TimeStamp { unwrapTimeStamp :: Double } deriving Show @@ -33,7 +33,7 @@ data Message = Message { sender :: User - , channel :: Room + , channel :: Channel , content :: String , timestamp :: TimeStamp } diff --git a/src/Marvin/Prelude.hs b/src/Marvin/Prelude.hs --- a/src/Marvin/Prelude.hs +++ b/src/Marvin/Prelude.hs @@ -29,6 +29,11 @@ , when, unless, for, for_, fromMaybe ) where +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Foldable (for_) +import Data.Maybe (fromMaybe) +import Data.Traversable (for) import Marvin import Marvin.Util.JSON import Marvin.Util.Logging @@ -36,8 +41,3 @@ 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 @@ -24,11 +24,13 @@ import Control.Concurrent.Async (async, wait) import Control.Exception import Control.Lens hiding (cons) +import Control.Monad.Reader 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.Maybe (fromMaybe, mapMaybe) +import Data.Monoid ((<>)) import Data.Sequences import Data.Traversable (for) import Data.Vector (Vector) @@ -37,13 +39,12 @@ import Marvin.Internal.Types hiding (channel) import Marvin.Util.Regex import Options.Generic -import Prelude hiding (dropWhile, splitAt, (++)) +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 +import Data.Foldable (for_) -(++) :: Monoid a => a -> a -> a -(++) = mappend data CmdOptions = CmdOptions { configPath :: Maybe FilePath @@ -75,13 +76,22 @@ data Handlers = Handlers { handlersResponds :: [(Regex, Message -> Match -> IO ())] , handlersHears :: [(Regex, Message -> Match -> IO ())] + , handlersCustoms :: [Event -> Maybe (IO ())] } |] +-- TODO add timeouts for handlers mkApp :: [Script a] -> C.Config -> a -> EventHandler a -mkApp scripts cfg adapter = handler +mkApp scripts cfg adapter = genericHandler where + genericHandler ev = do + generics <- async $ do + let applicables = mapMaybe ($ ev) allCustoms + asyncs <- for applicables async + for_ asyncs wait + handler ev + wait generics handler (MessageEvent msg) = handleMessage msg handleMessage msg = do @@ -91,7 +101,7 @@ rDispatches <- if toLower trimmed == toLower botname then doIfMatch allReactions remainder else return mempty - mapM_ wait (lDispatches ++ rDispatches) + mapM_ wait (lDispatches <> rDispatches) where text = content msg doIfMatch things toMatch = @@ -102,12 +112,14 @@ flattenActions = foldr $ \script -> flip (foldr (addAction script adapter)) (script^.actions) - allActions = flattenActions (Handlers mempty mempty) scripts + allActions = flattenActions (Handlers mempty mempty mempty) scripts allReactions :: Vector (Regex, Message -> Match -> IO ()) allReactions = fromList $! allActions^.responds allListens :: Vector (Regex, Message -> Match -> IO ()) allListens = fromList $! allActions^.hears + allCustoms :: [Event -> Maybe (IO ())] + allCustoms = allActions^.customs addAction :: Script a -> a -> WrappedAction a -> Handlers -> Handlers @@ -115,18 +127,22 @@ case wa of (WrappedAction (Hear re) ac) -> hears %~ cons (re, runMessageAction script adapter re ac) (WrappedAction (Respond re) ac) -> responds %~ cons (re, runMessageAction script adapter re ac) + (WrappedAction (Custom matcher) ac) -> customs %~ cons h + where + h ev = run <$> matcher ev + run s = runReaderT (runReaction ac) (BotActionState (script^.scriptId) (script^.config) adapter s) runMessageAction :: Script a -> a -> Regex -> BotReacting a MessageReactionData () -> Message -> Match -> IO () runMessageAction script adapter re ac msg mtch = catch - (evalStateT (runReaction ac) (BotActionState (script^.scriptId) (script^.config) adapter (MessageReactionData msg mtch))) + (runReaderT (runReaction ac) (BotActionState (script^.scriptId) (script^.config) adapter (MessageReactionData msg mtch))) (onScriptExcept (script^.scriptId) re) onScriptExcept :: ScriptId -> Regex -> SomeException -> IO () onScriptExcept (ScriptId id) r e = do - err $ "Unhandled exception during execution of script " ++ show id ++ " with trigger " ++ show r + err $ "Unhandled exception during execution of script " <> show id <> " with trigger " <> show r err $ show e where err = L.errorM "bot.dispatch" @@ -141,7 +157,7 @@ where onInitExcept :: ScriptId -> SomeException -> IO (Maybe a') onInitExcept (ScriptId id) e = do - err $ "Unhandled exception during initialization of script " ++ show id + err $ "Unhandled exception during initialization of script " <> show id err $ show e return Nothing where err = L.errorM "bot.init" @@ -174,6 +190,6 @@ unless (verbose args || debug args) $ C.lookup cfg "bot.logging" >>= maybe (return ()) (L.updateGlobalLogger L.rootLoggerName . L.setLevel) runWithAdapter - (C.subconfig ("adapter." ++ unwrapAdapterId (adapterId :: AdapterId a)) cfg) + (C.subconfig ("adapter." <> unwrapAdapterId (adapterId :: AdapterId a)) cfg) $ application s' cfg 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(..), Room(..), Message(..), ScriptId(..) + ( User(..), Channel(..), Message(..), ScriptId(..) , applicationScriptId, IsScript, getScriptId , HasConfigAccess ) where diff --git a/src/Marvin/Util/JSON.hs b/src/Marvin/Util/JSON.hs --- a/src/Marvin/Util/JSON.hs +++ b/src/Marvin/Util/JSON.hs @@ -15,5 +15,15 @@ ) where +import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.TH +import qualified Data.ByteString.Lazy as B + + +readJSON :: (MonadIO m, FromJSON a) => FilePath -> m (Either String a) +readJSON = fmap eitherDecode . liftIO . B.readFile + + +writeJSON :: (MonadIO m, ToJSON a) => FilePath -> a -> m () +writeJSON fp = liftIO . B.writeFile fp . encode