marvin 0.0.2 → 0.0.3
raw patch · 11 files changed
+152/−80 lines, 11 files
Files
- README.md +11/−11
- marvin.cabal +1/−1
- src/Marvin.hs +7/−5
- src/Marvin/Adapter.hs +3/−2
- src/Marvin/Adapter/Slack.hs +45/−19
- src/Marvin/Internal.hs +39/−22
- src/Marvin/Internal/Types.hs +3/−3
- src/Marvin/Prelude.hs +5/−5
- src/Marvin/Run.hs +27/−11
- src/Marvin/Types.hs +1/−1
- src/Marvin/Util/JSON.hs +10/−0
README.md view
@@ -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.
marvin.cabal view
@@ -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
src/Marvin.hs view
@@ -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
src/Marvin/Adapter.hs view
@@ -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 ()
src/Marvin/Adapter/Slack.hs view
@@ -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
src/Marvin/Internal.hs view
@@ -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 ())
src/Marvin/Internal/Types.hs view
@@ -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 }
src/Marvin/Prelude.hs view
@@ -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)
src/Marvin/Run.hs view
@@ -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
src/Marvin/Types.hs view
@@ -8,7 +8,7 @@ Portability : POSIX -} module Marvin.Types- ( User(..), Room(..), Message(..), ScriptId(..)+ ( User(..), Channel(..), Message(..), ScriptId(..) , applicationScriptId, IsScript, getScriptId , HasConfigAccess ) where
src/Marvin/Util/JSON.hs view
@@ -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