diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -1,5 +1,5 @@ name: marvin -version: 0.0.6 +version: 0.0.7 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -9,7 +9,7 @@ homepage: https://marvin.readthedocs.io synopsis: A modular chat bot description: - The proper documentation is on readthedocs: https://marvin.readthedocs.io + A framework for writing portable chat bots. Inspired by hubot. The documentation is on readthedocs: category: Development author: JustusAdam data-files: @@ -37,6 +37,7 @@ Marvin.Util.JSON Marvin.Util.HTTP Marvin.Adapter + Marvin.Adapter.Shell Marvin.Adapter.Slack Marvin.Adapter.Telegram Marvin.Internal @@ -60,15 +61,17 @@ random ==1.1.*, hashable >=1.2.4.0 && <1.3, text >=1.2.2.1 && <1.3, - mtl >=2.2.1 && <2.3, unordered-containers >=0.2.7.1 && <0.3, - mono-traversable >=1.0.0.1 && <1.1, stm >=2.4.4.1 && <2.5, marvin-interpolate >0.4 && <0.5, lifted-base >=0.2.3.8 && <0.3, lifted-async >=0.9.0 && <0.10, wai >=3.2.1.1 && <3.3, - warp >=3.2.8 && <3.3 + warp >=3.2.8 && <3.3, + haskeline >=0.7.2.3 && <0.8, + monad-loops >=0.4.3 && <0.5, + mono-traversable >=1.0.0.1 && <1.1, + time >=1.6.0.1 && <1.7 default-language: Haskell2010 default-extensions: OverloadedStrings TypeFamilies MultiParamTypeClasses TupleSections GADTs TemplateHaskell @@ -84,7 +87,7 @@ mustache ==2.1.*, directory >=1.2.6.2 && <1.3, filepath >=1.4.1.0 && <1.5, - marvin >=0.0.6 && <0.1, + marvin >=0.0.7 && <0.1, configurator >=0.3.0.0 && <0.4, optparse-applicative >=0.12.1.0 && <0.13, bytestring >=0.10.8.1 && <0.11, diff --git a/preprocessor/Main.hs b/preprocessor/Main.hs --- a/preprocessor/Main.hs +++ b/preprocessor/Main.hs @@ -35,6 +35,7 @@ [ ("slack-rtm", slackRtmData) , ("telegram-poll", ("Marvin.Adapter.Telegram", "(TelegramAdapter Poll)")) , ("telegram-push", ("Marvin.Adapter.Telegram", "(TelegramAdapter Push)")) + , ("shell", ("Marvin.Adapter.Shell", "ShellAdapter")) ] diff --git a/src/Marvin/Adapter/Shell.hs b/src/Marvin/Adapter/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Shell.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Marvin.Adapter.Shell where + + +import Control.Concurrent.Async.Lifted +import Control.Concurrent.MVar.Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Loops +import Data.Char (isSpace) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import Data.Time.Clock (getCurrentTime) +import Marvin.Adapter +import Marvin.Internal (defaultBotName) +import Marvin.Internal.Types +import Marvin.Interpolate.String +import Marvin.Run (lookupFromAppConfig) +import System.Console.Haskeline +import qualified Data.Configurator as C + + +data ShellAdapter = ShellAdapter + { output :: MVar (Maybe L.Text) + } + + +instance IsAdapter ShellAdapter where + type User ShellAdapter = () + type Channel ShellAdapter = () + + adapterId = "shell" + messageChannel ShellAdapter{output} _ = putMVar output . Just + getUsername _ _ = return "shell" + getChannelName _ _ = return "shell" + resolveChannel _ _ = return $ Just () + runWithAdapter cfg initializer = do + bot <- liftIO $ fromMaybe defaultBotName <$> lookupFromAppConfig cfg "name" + histfile <- liftIO $ C.lookup cfg "history-file" + out <- liftIO newEmptyMVar + let ada = ShellAdapter out + handler <- liftIO $ initializer ada + liftIO $ runInputT defaultSettings {historyFile=histfile} $ forever $ do + input <- getInputLine $(isS "#{bot}> ") + case input of + Nothing -> return () + Just i -> do + h <- liftIO $ async $ do + botname <- L.toLower . fromMaybe defaultBotName <$> liftIO (lookupFromAppConfig cfg "name") + let mtext = L.pack i + ts <- TimeStamp <$> getCurrentTime + handler $ case L.stripPrefix botname $ L.stripStart mtext of + Just cmd | fmap (isSpace . fst) (L.uncons cmd) == Just True -> + CommandEvent () () (L.stripStart cmd) ts + _ -> MessageEvent () () mtext ts + putMVar out Nothing + whileJust_ (liftIO $ takeMVar out) $ outputStrLn . L.unpack + liftIO $ wait h 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 @@ -30,10 +30,11 @@ import Data.Aeson.TH import Data.Aeson.Types hiding (Error) import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Char (isSpace) import qualified Data.Configurator as C import qualified Data.Configurator.Types as C import Data.Containers -import Data.Foldable (toList) +import Data.Foldable (asum, toList) import Data.Hashable import Data.HashMap.Strict (HashMap) import Data.IORef.Lifted @@ -43,8 +44,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as L import Marvin.Adapter +import Marvin.Internal +import Marvin.Internal.Types as Types import Marvin.Interpolate.Text -import Marvin.Types as Types +import Marvin.Run import Network.URI import Network.Wai import Network.Wai.Handler.Warp @@ -125,12 +128,12 @@ deriveJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } ''RTMData -messageParser :: Value -> Parser (Types.Message (SlackAdapter a)) -messageParser (Object o) = Message +messageParser :: Value -> Parser (Event (SlackAdapter a)) +messageParser (Object o) = MessageEvent <$> o .: "user" <*> o .: "channel" <*> o .: "text" - <*> o .: "ts" + <*> (o .: "ts" >>= timestampFromNumber) messageParser _ = mzero @@ -162,20 +165,21 @@ "channel_leave" -> cLeave "group_leave" -> cLeave "channel_topic" -> do - t <- TopicChangeEvent <$> o .: "topic" <*> channel + t <- TopicChangeEvent <$> user <*> channel <*> o .: "topic" <*> ts return $ Right t _ -> msgEv _ -> msgEv where - msgEv = Right . MessageEvent <$> messageParser v + ts = o .: "ts" >>= timestampFromNumber + msgEv = Right <$> messageParser v user = o .: "user" channel = o .: "channel" cJoin = do - ev <- ChannelJoinEvent <$> user <*> channel + ev <- ChannelJoinEvent <$> user <*> channel <*> ts return $ Right ev cLeave = do - ev <- ChannelLeaveEvent <$> user <*> channel + ev <- ChannelLeaveEvent <$> user <*> channel <*> ts return $ Right ev "reconnect_url" -> return $ Left Ignored "channel_archive" -> do @@ -269,12 +273,27 @@ where cfg = userConfig ada +stripWhiteSpaceMay :: L.Text -> Maybe L.Text +stripWhiteSpaceMay t = + case L.uncons t of + Just (c, _) | isSpace c -> Just $ L.stripStart t + _ -> Nothing + + runHandlerLoop :: SlackAdapter a -> Chan BS.ByteString -> EventHandler (SlackAdapter a) -> RunnerM () runHandlerLoop adapter messageChan handler = forever $ do d <- readChan messageChan case eitherDecode d >>= parseEither eventParser of Left err -> logErrorN $(isT "Error parsing json: #{err} original data: #{rawBS d}") + Right (Right ev@(MessageEvent u c m t)) -> do + + botname <- L.toLower . fromMaybe defaultBotName <$> liftIO (lookupFromAppConfig cfg "name") + let lmsg = L.stripStart $ L.toLower m + liftIO $ handler $ case asum $ map ((`L.stripPrefix` lmsg) >=> stripWhiteSpaceMay) [botname, L.cons '@' botname, L.cons '/' botname] of + Nothing -> ev + Just m' -> CommandEvent u c m' t + Right (Right event) -> liftIO $ handler event Right (Left internalEvent) -> case internalEvent of @@ -291,6 +310,8 @@ ChannelDeleted chan -> deleteChannel adapter chan ChannelRename info -> renameChannel adapter info UserChange ui -> void $ refreshUserInfo adapter (ui^.idValue) + where + cfg = userConfig adapter sendMessageImpl :: MVar Connection -> BS.ByteString -> RunnerM () diff --git a/src/Marvin/Adapter/Telegram.hs b/src/Marvin/Adapter/Telegram.hs --- a/src/Marvin/Adapter/Telegram.hs +++ b/src/Marvin/Adapter/Telegram.hs @@ -25,9 +25,9 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as L import Marvin.Adapter +import Marvin.Internal.Types import Marvin.Interpolate.String import Marvin.Interpolate.Text -import Marvin.Types import Network.Wai import Network.Wai.Handler.Warp import Network.Wreq @@ -109,18 +109,18 @@ where isMessage = do msg <- o .: "message" >>= msgParser - return $ Ev $ MessageEvent msg - isPost = Ev . MessageEvent <$> (o .: "channel_post" >>= msgParser) + return $ Ev msg + isPost = Ev <$> (o .: "channel_post" >>= msgParser) isUnhandeled = return Unhandeled -msgParser :: Value -> Parser (Message (TelegramAdapter a)) +msgParser :: Value -> Parser (Event (TelegramAdapter a)) msgParser = withObject "expected message object" $ \o -> - Message + MessageEvent <$> o .: "from" <*> o .: "chat" <*> o .: "text" - <*> o .: "date" + <*> (o .: "date" >>= timestampFromNumber) diff --git a/src/Marvin/Internal.hs b/src/Marvin/Internal.hs --- a/src/Marvin/Internal.hs +++ b/src/Marvin/Internal.hs @@ -62,6 +62,7 @@ import Marvin.Internal.Types hiding (getChannelName, getUsername, messageChannel, resolveChannel, resolveChannel) import Marvin.Interpolate.Text +import Marvin.Interpolate.String import Marvin.Util.Regex (Match, Regex) import Util @@ -80,20 +81,17 @@ |] -type Topic = L.Text - - declareFields [d| data Handlers a = Handlers - { handlersResponds :: Vector (Regex, Match -> Message a -> RunnerM ()) - , handlersHears :: Vector (Regex, Match -> Message a -> RunnerM ()) + { handlersResponds :: Vector (Regex, (User' a, Channel' a, Match, Message, TimeStamp) -> RunnerM ()) + , handlersHears :: Vector (Regex, (User' a, Channel' a, Match, Message, TimeStamp) -> RunnerM ()) , handlersCustoms :: Vector (Event a -> Maybe (RunnerM ())) - , handlersJoins :: Vector ((User' a, Channel' a) -> RunnerM ()) - , handlersLeaves :: Vector ((User' a, Channel' a) -> RunnerM ()) - , handlersTopicChange :: Vector ((Topic, Channel' a) -> RunnerM ()) - , handlersJoinsIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a) -> RunnerM ())) - , handlersLeavesFrom :: HM.HashMap L.Text (Vector ((User' a, Channel' a) -> RunnerM ())) - , handlersTopicChangeIn :: HM.HashMap L.Text (Vector ((Topic, Channel' a) -> RunnerM ())) + , handlersJoins :: Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ()) + , handlersLeaves :: Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ()) + , handlersTopicChange :: Vector ((User' a, Channel' a, Topic, TimeStamp) -> RunnerM ()) + , handlersJoinsIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ())) + , handlersLeavesFrom :: HM.HashMap L.Text (Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ())) + , handlersTopicChangeIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a, Topic, TimeStamp) -> RunnerM ())) } |] @@ -102,7 +100,7 @@ mempty = Handlers mempty mempty mempty mempty mempty mempty mempty mempty mempty mappend (Handlers r1 h1 c1 j1 l1 t1 ji1 li1 ti1) (Handlers r2 h2 c2 j2 l2 t2 ji2 li2 ti2) - = Handlers (r1 <> r2) (h1 <> h2) (c1 <> c2) (j1 <> j2) (l1 <> l2) (t1 <> t2) (ji1 <> ji2) (li1 <> li2) (ti1 <> ti2) + = Handlers (r1 <> r2) (h1 <> h2) (c1 <> c2) (j1 <> j2) (l1 <> l2) (t1 <> t2) (HM.unionWith mappend ji1 ji2) (HM.unionWith mappend li1 li2) (HM.unionWith mappend ti1 ti2) -- | Monad for reacting in the bot. Allows use of functions like 'send', 'reply' and 'messageChannel' as well as any arbitrary 'IO' action using 'liftIO'. @@ -144,33 +142,42 @@ class Get a b where getLens :: Lens' a b -instance Get (b, Message a) (Message a) where - getLens = _2 +instance Get (User' a, b, c) (User' a) where + getLens = _1 -instance Get (Match, b) Match where +instance Get (User' a, b, c, d) (User' a) where getLens = _1 -instance Get (Topic, a) Topic where +instance Get (User' a, b, c, d, e) (User' a) where getLens = _1 -idLens :: Lens' a a -idLens = lens id (flip const) +instance Get (a, Channel' b, c) (Channel' b) where + getLens = _2 -instance Get (b, Channel' a) (Channel' a) where +instance Get (a, Channel' b, c, d) (Channel' b) where getLens = _2 -instance Get (b, Message a) (Channel' a) where - getLens = _2 . lens (Channel' . channel) (\a (Channel' b) -> a {channel = b}) +instance Get (a, Channel' b, c, d, e) (Channel' b) where + getLens = _2 -instance Get a a where - getLens = idLens +instance Get (a, b, TimeStamp) TimeStamp where + getLens = _3 -instance Get (User' a, b) (User' a) where - getLens = _1 +instance Get (a, b, c, TimeStamp) TimeStamp where + getLens = _4 -instance Get (b, Message a) (User' a) where - getLens = _2 . lens (User' . sender) (\a (User' b) -> a {sender = b}) +instance Get (a, b, c, d, TimeStamp) TimeStamp where + getLens = _5 +instance Get (a, b, Match, d, e) Match where + getLens = _3 + +instance Get (a, b, c, Message, e) Message where + getLens = _4 + +instance Get (a, b, Topic, d) Topic where + getLens = _3 + instance HasConfigAccess (ScriptDefinition a) where getConfigInternal = ScriptDefinition $ use config @@ -225,34 +232,34 @@ onScriptExcept id trigger e = do case trigger of Just t -> - err $(isT "Unhandled exception during execution of script #{id} with trigger #{t}") + err $(isT "Unhandled exception during execution of script \"#{id}\" with trigger \"#{t}\"") Nothing -> - err $(isT "Unhandled exception during execution of script #{id}") + err $(isT "Unhandled exception during execution of script \"#{id}\"") err $(isT "#{e}") where - err = logErrorNS "#{applicationScriptId}.dispatch" + err = logErrorNS $(isT "#{applicationScriptId}.dispatch") -- | Whenever any message matches the provided regex this handler gets run. -- -- Equivalent to "robot.hear" in hubot -hear :: Regex -> BotReacting a (Match, Message a) () -> ScriptDefinition a () +hear :: Regex -> BotReacting a (User' a, Channel' a, Match, Message, TimeStamp) () -> ScriptDefinition a () hear !re ac = ScriptDefinition $ do pac <- prepareAction (Just re) ac - actions . hears %= V.cons (re, curry pac) + actions . hears %= V.cons (re, pac) -- | Runs the handler only if the bot was directly addressed. -- -- Equivalent to "robot.respond" in hubot -respond :: Regex -> BotReacting a (Match, Message a) () -> ScriptDefinition a () +respond :: Regex -> BotReacting a (User' a, Channel' a, Match, Message, TimeStamp) () -> ScriptDefinition a () respond !re ac = ScriptDefinition $ do pac <- prepareAction (Just re) ac - actions . responds %= V.cons (re, curry pac) + actions . responds %= V.cons (re, pac) -- | This handler runs whenever a user enters __any channel__ (which the bot is subscribed to) -- -- The payload contains the entering user and the channel which was entered. -enter :: BotReacting a (User' a, Channel' a) () -> ScriptDefinition a () +enter :: BotReacting a (User' a, Channel' a, TimeStamp) () -> ScriptDefinition a () enter ac = ScriptDefinition $ do pac <- prepareAction (Just "enter event" :: Maybe T.Text) ac actions . joins %= V.cons pac @@ -261,7 +268,7 @@ -- | This handler runs whenever a user exits __any channel__ (which the bot is subscribed to) -- -- The payload contains the exiting user and the channel which was exited. -exit :: BotReacting a (User' a, Channel' a) () -> ScriptDefinition a () +exit :: BotReacting a (User' a, Channel' a, TimeStamp) () -> ScriptDefinition a () exit ac = ScriptDefinition $ do pac <- prepareAction (Just "exit event" :: Maybe T.Text) ac actions . leaves %= V.cons pac @@ -276,9 +283,9 @@ -- The argument is the human readable name for the channel. -- -- The payload contains the entering user. -enterIn :: L.Text -> BotReacting a (User' a, Channel' a) () -> ScriptDefinition a () +enterIn :: L.Text -> BotReacting a (User' a, Channel' a, TimeStamp) () -> ScriptDefinition a () enterIn !chanName ac = ScriptDefinition $ do - pac <- prepareAction (Just $(isT "anter event in #{chanName}")) ac + pac <- prepareAction (Just $(isT "enter event in #{chanName}")) ac actions . joinsIn %= HM.alter (alterHelper pac) chanName @@ -287,7 +294,7 @@ -- The argument is the human readable name for the channel. -- -- The payload contains the exting user. -exitFrom :: L.Text -> BotReacting a (User' a, Channel' a) () -> ScriptDefinition a () +exitFrom :: L.Text -> BotReacting a (User' a, Channel' a, TimeStamp) () -> ScriptDefinition a () exitFrom !chanName ac = ScriptDefinition $ do pac <- prepareAction (Just $(isT "exit event in #{chanName}")) ac actions . leavesFrom %= HM.alter (alterHelper pac) chanName @@ -296,7 +303,7 @@ -- | This handler runs when the topic in __any channel__ the bot is subscribed to changes. -- -- The payload contains the new topic and the channel in which it was set. -topic :: BotReacting a (Topic, Channel' a) () -> ScriptDefinition a () +topic :: BotReacting a (User' a, Channel' a, Topic, TimeStamp) () -> ScriptDefinition a () topic ac = ScriptDefinition $ do pac <- prepareAction (Just "topic event" :: Maybe T.Text) ac actions . topicChange %= V.cons pac @@ -305,7 +312,7 @@ -- | This handler runs when the topic in __the specified channel__ is changed, provided the bot is subscribed to the channel in question. -- -- The argument is the human readable channel name. -topicIn :: L.Text -> BotReacting a (Topic, Channel' a) () -> ScriptDefinition a () +topicIn :: L.Text -> BotReacting a (User' a, Channel' a, Topic, TimeStamp) () -> ScriptDefinition a () topicIn !chanName ac = ScriptDefinition $ do pac <- prepareAction (Just $(isT "topic event in #{chanName}")) ac actions . topicChangeIn %= HM.alter (alterHelper pac) chanName @@ -325,7 +332,7 @@ -- | Send a message to the channel the triggering message came from. -- -- Equivalent to "robot.send" in hubot -send :: (IsAdapter a, Get m (Channel' a)) => L.Text -> BotReacting a m () +send :: (IsAdapter a, Get d (Channel' a)) => L.Text -> BotReacting a d () send msg = do o <- getChannel messageChannel' o msg @@ -354,11 +361,11 @@ -- | 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, Get m (Message a)) => L.Text -> BotReacting a m () +reply :: (IsAdapter a, Get d (User' a), Get d (Channel' a)) => L.Text -> BotReacting a d () reply msg = do - om <- getMessage - user <- getUsername $ sender om - messageChannel' (channel om) $ user <> " " <> msg + chan <- getChannel + user <- getUser >>= getUsername + messageChannel' chan $ user <> " " <> msg -- | Send a message to a Channel (by name) @@ -408,7 +415,7 @@ -- | Get the message that triggered this action -- Includes sender, target channel, as well as the full, untruncated text of the original message -getMessage :: Get m (Message a) => BotReacting a m (Message a) +getMessage :: Get m Message => BotReacting a m Message getMessage = view (payload . getLens) @@ -446,7 +453,12 @@ requireConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a requireConfigVal name = do cfg <- getConfig - liftIO $ C.require cfg name + l <- liftIO $ C.lookup cfg name + case l of + Just v -> return v + _ -> do + sid <- getScriptId + error $(isS "Could not find required config value \"#{name}\" in script \"#{sid}\"") -- | INTERNAL, USE WITH CARE @@ -483,17 +495,14 @@ -- 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 <- ask - return $ runStderrLoggingT $ runReaderT (runReaction reac) s +extractReaction reac = BotReacting $ + runStderrLoggingT . runReaderT (runReaction reac) <$> ask -- | 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 - sid <- use scriptId - cfg <- use config - return $ runStderrLoggingT $ runReaderT (runReaction ac) (BotActionState sid cfg a ()) +extractAction ac = ScriptDefinition $ + fmap (runStderrLoggingT . runReaderT (runReaction ac)) $ + BotActionState <$> use scriptId <*> use config <*> use adapter <*> pure () 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 @@ -9,21 +9,28 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Data.Aeson +import Data.Aeson.Types import Data.Char (isAlphaNum, isLetter) import qualified Data.Configurator.Types as C import Data.String import qualified Data.Text as T import qualified Data.Text.Lazy as L +import Data.Time.Clock +import Data.Time.Clock.POSIX import Marvin.Interpolate.Text import Text.Read (readMaybe) +type Topic = L.Text +type Message = L.Text + -- | Representation for the types of events which can occur data Event a - = MessageEvent (Message a) - | ChannelJoinEvent (User a) (Channel a) - | ChannelLeaveEvent (User a) (Channel a) - | TopicChangeEvent L.Text (Channel a) + = MessageEvent (User a) (Channel a) Message TimeStamp + | CommandEvent (User a) (Channel a) Message TimeStamp + | ChannelJoinEvent (User a) (Channel a) TimeStamp + | ChannelLeaveEvent (User a) (Channel a) TimeStamp + | TopicChangeEvent (User a) (Channel a) Topic TimeStamp type EventHandler a = Event a -> IO () @@ -51,24 +58,11 @@ newtype User' a = User' {unwrapUser' :: User a} newtype Channel' a = Channel' {unwrapChannel' :: Channel a} -newtype TimeStamp = TimeStamp { unwrapTimeStamp :: Double } deriving Show - - --- | contents and meta information of a recieved message -data Message a = Message - { sender :: User a - , channel :: Channel a - , content :: L.Text - , timestamp :: TimeStamp - } +newtype TimeStamp = TimeStamp { unwrapTimeStamp :: UTCTime } deriving Show -instance FromJSON TimeStamp where - parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMaybe (T.unpack s) - parseJSON _ = mzero - -instance ToJSON TimeStamp where - toJSON = toJSON . show . unwrapTimeStamp +timestampFromNumber :: Value -> Parser TimeStamp +timestampFromNumber = withScientific "expected number type" $ return . TimeStamp . posixSecondsToUTCTime . realToFrac -- | A type, basically a String, which identifies a script to the config and the logging facilities. diff --git a/src/Marvin/Run.hs b/src/Marvin/Run.hs --- a/src/Marvin/Run.hs +++ b/src/Marvin/Run.hs @@ -11,11 +11,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} module Marvin.Run ( runMarvin, ScriptInit, IsAdapter , requireFromAppConfig, lookupFromAppConfig, defaultConfigName @@ -80,15 +78,16 @@ for_ asyncs wait handler ev wait generics - handler (MessageEvent msg) = handleMessage msg + handler (MessageEvent user chan msg ts) = handleMessage user chan msg ts + handler (CommandEvent user chan msg ts) = handleCommand user chan msg ts -- TODO implement other handlers - handler (ChannelJoinEvent user chan) = changeHandlerHelper joinsV joinsInV (User' user) chan - handler (ChannelLeaveEvent user chan) = changeHandlerHelper leavesV leavesFromV (User' user) chan - handler (TopicChangeEvent topic chan) = changeHandlerHelper topicsV topicsInV topic chan + handler (ChannelJoinEvent user chan ts) = changeHandlerHelper joinsV joinsInV (User' user, , ts) chan + handler (ChannelLeaveEvent user chan ts) = changeHandlerHelper leavesV leavesFromV (User' user, , ts) chan + handler (TopicChangeEvent user chan topic ts) = changeHandlerHelper topicsV topicsInV (User' user, , topic, ts) chan - changeHandlerHelper :: Vector ((b, Channel' a) -> RunnerM ()) - -> HM.HashMap L.Text (Vector ((b, Channel' a) -> RunnerM ())) - -> b + changeHandlerHelper :: Vector (d -> RunnerM ()) + -> HM.HashMap L.Text (Vector (d -> RunnerM ())) + -> (Channel' a -> d) -> Channel a -> RunnerM () changeHandlerHelper wildcards specifics other chan = do @@ -96,30 +95,31 @@ let applicables = fromMaybe mempty $ specifics^?ix cName - wildcardsRunning <- for wildcards (async . ($ (other, Channel' chan))) - - applicablesRunning <- for applicables (async . ($ (other, Channel' chan))) + wildcardsRunning <- for wildcards (async . ($ other (Channel' chan))) - mapM_ wait $ wildcardsRunning `mappend` applicablesRunning + applicablesRunning <- for applicables (async . ($ other (Channel' chan))) + mapM_ wait wildcardsRunning + mapM_ wait applicablesRunning - handleMessage msg = do - lDispatches <- doIfMatch hearsV text - botname <- fromMaybe defaultBotName <$> liftIO (lookupFromAppConfig cfg "name") - let (trimmed, remainder) = L.splitAt (fromIntegral $ succ $ L.length botname) $ L.stripStart text - -- TODO At some point this needs to support derivations of the name. Maybe make that configurable? - rDispatches <- if L.stripEnd (L.toLower trimmed) == L.strip (L.toLower botname) - then doIfMatch respondsV remainder - else return mempty - mapM_ wait (lDispatches <> rDispatches) + handleMessageLike :: Vector (Regex, (User' a, Channel' a, Match, Message, TimeStamp) -> RunnerM ()) + -> User a + -> Channel a + -> Message + -> TimeStamp + -> RunnerM () + handleMessageLike v user chan msg ts = do + lDispatches <- doIfMatch v + mapM_ wait lDispatches where - text = content msg - doIfMatch things toMatch = + doIfMatch things = catMaybes <$> for things (\(trigger, action) -> - case match trigger toMatch of + case match trigger msg of Nothing -> return Nothing - Just m -> Just <$> async (action m msg)) + Just m -> Just <$> async (action (User' user, Channel' chan, m, msg, ts))) + handleCommand = handleMessageLike respondsV + handleMessage = handleMessageLike hearsV Handlers respondsV hearsV customsV joinsV leavesV topicsV joinsInV leavesFromV topicsInV = foldMap (^.actions) scripts @@ -128,16 +128,17 @@ -- | Create a wai compliant application application :: IsAdapter a => LoggingFn -> [ScriptInit a] -> C.Config -> InitEventHandler a application log inits config ada = flip runLoggingT log $ do - $logInfoS "bot" "Initializing scripts" + logInfoNS logSource "Initializing scripts" s <- catMaybes <$> mapM (\(ScriptInit (sid, s)) -> catch (Just <$> s ada config) (onInitExcept sid)) inits return $ mkApp log s config ada where + logSource = $(isT "#{applicationScriptId}.init") onInitExcept :: ScriptId -> SomeException -> RunnerM (Maybe a') onInitExcept (ScriptId id) e = do err $(isT "Unhandled exception during initialization of script #{id}") err $(isT "#{e}") return Nothing - where err = logErrorNS $(isT "#{applicationScriptId}.init") + where err = logErrorNS logSource setLoggingLevelIn :: LogLevel -> RunnerM a -> RunnerM a @@ -152,7 +153,7 @@ args <- liftIO $ execParser infoParser cfgLoc <- maybe - ($logInfoS $(isT "${applicationScriptId}") "Using default config: config.cfg" >> return defaultConfigName) + ($logInfoS $(isT "#{applicationScriptId}") "Using default config: config.cfg" >> return defaultConfigName) return (configPath args) (cfg, _) <- liftIO $ C.autoReload C.autoConfig [C.Required cfgLoc]