module Marvin.Internal
(
defineScript
, hear, respond, topic, topicIn, enter, exit, enterIn, exitFrom, customTrigger
, send, reply, messageChannel, messageChannel'
, getData, getUser, getMatch, getMessage, getChannel, getTopic, getBotName, getChannelName, resolveChannel, getUsername
, getConfigVal, requireConfigVal
, getAppConfigVal, requireAppConfigVal, getConfig, getConfigInternal
, Topic
, extractAction, extractReaction
, defaultBotName
, runDefinitions
, BotActionState(BotActionState)
, BotReacting(..), Script(..), ScriptDefinition(..), ScriptInit(..), ScriptId(..), Handlers(..)
, HasActions(actions), HasHears(hears), HasResponds(responds), HasJoins(joins), HasCustoms(customs), HasJoinsIn(joinsIn), HasLeaves(leaves), HasLeavesFrom(leavesFrom), HasTopicChange(topicChange), HasTopicChangeIn(topicChangeIn)
, AccessAdapter(AdapterT, getAdapter), Get(getLens)
) where
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Configurator as C
import qualified Data.Configurator.Types as C
import Control.Arrow
import Control.Exception.Lifted
import Control.Lens hiding (cons)
import Control.Monad.Logger
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import Data.Vector (Vector)
import qualified Data.Vector as V
import Marvin.Adapter (IsAdapter)
import qualified Marvin.Adapter as A
import Marvin.Internal.Types hiding (getChannelName, getUsername, messageChannel,
resolveChannel, resolveChannel)
import Marvin.Interpolate.Text
import Marvin.Util.Regex (Match, Regex)
import Util
defaultBotName :: L.Text
defaultBotName = "marvin"
declareFields [d|
data BotActionState a d = BotActionState
{ botActionStateScriptId :: ScriptId
, botActionStateConfig :: C.Config
, botActionStateAdapter :: a
, botActionStatePayload :: d
}
|]
type Topic = L.Text
declareFields [d|
data Handlers a = Handlers
{ handlersResponds :: Vector (Regex, Match -> Message a -> RunnerM ())
, handlersHears :: Vector (Regex, Match -> Message a -> 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 ()))
}
|]
instance Monoid (Handlers a) where
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)
newtype BotReacting a d r = BotReacting { runReaction :: ReaderT (BotActionState a d) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d), MonadLogger, MonadLoggerIO)
declareFields [d|
data Script a = Script
{ scriptActions :: Handlers a
, scriptScriptId :: ScriptId
, scriptConfig :: C.Config
, scriptAdapter :: a
}
|]
newtype ScriptDefinition a r = ScriptDefinition { runScript :: StateT (Script a) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadLogger)
newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> RunnerM (Script a))
class Get a b where
getLens :: Lens' a b
instance Get (b, Message a) (Message a) where
getLens = _2
instance Get (Match, b) Match where
getLens = _1
instance Get (Topic, a) Topic where
getLens = _1
idLens :: Lens' a a
idLens = lens id (flip const)
instance Get (b, Channel' a) (Channel' a) 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 a where
getLens = idLens
instance Get (User' a, b) (User' a) where
getLens = _1
instance Get (b, Message a) (User' a) where
getLens = _2 . lens (User' . sender) (\a (User' b) -> a {sender = b})
instance HasConfigAccess (ScriptDefinition a) where
getConfigInternal = ScriptDefinition $ use config
instance HasConfigAccess (BotReacting a b) where
getConfigInternal = view config
instance IsScript (ScriptDefinition a) where
getScriptId = ScriptDefinition $ use scriptId
instance IsScript (BotReacting a b) where
getScriptId = view 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 = view adapter
getSubConfFor :: HasConfigAccess m => ScriptId -> m C.Config
getSubConfFor (ScriptId name) = C.subconfig ("script." <> name) <$> getConfigInternal
getConfig :: HasConfigAccess m => m C.Config
getConfig = getScriptId >>= getSubConfFor
runBotAction :: ShowT t => ScriptId -> C.Config -> a -> Maybe t -> d -> BotReacting a d () -> RunnerM ()
runBotAction scriptId config adapter trigger data_ action = do
oldLogFn <- askLoggerIO
catch
(liftIO $ flip runLoggingT (loggingAddSourcePrefix $(isT "script.#{scriptId}") oldLogFn) $ flip runReaderT actionState $ runReaction action)
(onScriptExcept scriptId trigger)
where
actionState = BotActionState scriptId config adapter data_
prepareAction :: (MonadState (Script a) m, ShowT t) => Maybe t -> BotReacting a d () -> m (d -> RunnerM ())
prepareAction trigger reac = do
ada <- use adapter
cfg <- use config
sid <- use scriptId
return $ \d -> runBotAction sid cfg ada trigger d reac
onScriptExcept :: ShowT t => ScriptId -> Maybe t -> SomeException -> RunnerM ()
onScriptExcept id trigger e = do
case trigger of
Just 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 "#{e}")
where
err = logErrorNS "#{applicationScriptId}.dispatch"
hear :: Regex -> BotReacting a (Match, Message a) () -> ScriptDefinition a ()
hear !re ac = ScriptDefinition $ do
pac <- prepareAction (Just re) ac
actions . hears %= V.cons (re, curry pac)
respond :: Regex -> BotReacting a (Match, Message a) () -> ScriptDefinition a ()
respond !re ac = ScriptDefinition $ do
pac <- prepareAction (Just re) ac
actions . responds %= V.cons (re, curry pac)
enter :: BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()
enter ac = ScriptDefinition $ do
pac <- prepareAction (Just "enter event" :: Maybe T.Text) ac
actions . joins %= V.cons pac
exit :: BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()
exit ac = ScriptDefinition $ do
pac <- prepareAction (Just "exit event" :: Maybe T.Text) ac
actions . leaves %= V.cons pac
alterHelper :: a -> Maybe (Vector a) -> Maybe (Vector a)
alterHelper v = return . maybe (return v) (V.cons v)
enterIn :: L.Text -> BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()
enterIn !chanName ac = ScriptDefinition $ do
pac <- prepareAction (Just $(isT "anter event in #{chanName}")) ac
actions . joinsIn %= HM.alter (alterHelper pac) chanName
exitFrom :: L.Text -> BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()
exitFrom !chanName ac = ScriptDefinition $ do
pac <- prepareAction (Just $(isT "exit event in #{chanName}")) ac
actions . leavesFrom %= HM.alter (alterHelper pac) chanName
topic :: BotReacting a (Topic, Channel' a) () -> ScriptDefinition a ()
topic ac = ScriptDefinition $ do
pac <- prepareAction (Just "topic event" :: Maybe T.Text) ac
actions . topicChange %= V.cons pac
topicIn :: L.Text -> BotReacting a (Topic, Channel' a) () -> ScriptDefinition a ()
topicIn !chanName ac = ScriptDefinition $ do
pac <- prepareAction (Just $(isT "topic event in #{chanName}")) ac
actions . topicChangeIn %= HM.alter (alterHelper pac) chanName
customTrigger :: (A.Event a -> Maybe d) -> BotReacting a d () -> ScriptDefinition a ()
customTrigger tr ac = ScriptDefinition $ do
pac <- prepareAction (Nothing :: Maybe T.Text) ac
actions . customs %= V.cons (maybe Nothing (return . pac) . tr)
send :: (IsAdapter a, Get m (Channel' a)) => L.Text -> BotReacting a m ()
send msg = do
o <- getChannel
messageChannel' o msg
getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User (AdapterT m) -> m L.Text
getUsername usr = do
a <- getAdapter
A.liftAdapterAction $ A.getUsername a usr
resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => L.Text -> m (Maybe (Channel (AdapterT m)))
resolveChannel name = do
a <- getAdapter
A.liftAdapterAction (A.resolveChannel a name)
getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> m L.Text
getChannelName rm = do
a <- getAdapter
A.liftAdapterAction $ A.getChannelName a rm
reply :: (IsAdapter a, Get m (Message a)) => L.Text -> BotReacting a m ()
reply msg = do
om <- getMessage
user <- getUsername $ sender om
messageChannel' (channel om) $ user <> " " <> msg
messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadLoggerIO m) => L.Text -> L.Text -> m ()
messageChannel name msg = do
mchan <- resolveChannel name
maybe ($logError $(isT "No channel known with the name #{name}")) (`messageChannel'` msg) mchan
messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> L.Text -> m ()
messageChannel' chan msg = do
a <- getAdapter
A.liftAdapterAction $ A.messageChannel a chan msg
defineScript :: ScriptId -> ScriptDefinition a () -> ScriptInit a
defineScript sid definitions =
ScriptInit (sid, runDefinitions sid definitions)
runDefinitions :: ScriptId -> ScriptDefinition a () -> a -> C.Config -> RunnerM (Script a)
runDefinitions sid definitions ada cfg = execStateT (runScript definitions) (Script mempty sid cfg ada)
getData :: BotReacting a d d
getData = view payload
getMatch :: Get m Match => BotReacting a m Match
getMatch = view (payload . getLens)
getMessage :: Get m (Message a) => BotReacting a m (Message a)
getMessage = view (payload . getLens)
getTopic :: Get m Topic => BotReacting a m Topic
getTopic = view (payload . getLens)
getChannel :: forall a m. Get m (Channel' a) => BotReacting a m (Channel a)
getChannel = (unwrapChannel' :: Channel' a -> Channel a) <$> view (payload . getLens)
getUser :: forall m a. Get m (User' a) => BotReacting a m (User a)
getUser = (unwrapUser' :: User' a -> User a) <$> view (payload . getLens)
getConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m (Maybe a)
getConfigVal name = do
cfg <- getConfig
liftIO $ C.lookup cfg name
requireConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a
requireConfigVal name = do
cfg <- getConfig
liftIO $ C.require cfg name
getAppConfig :: HasConfigAccess m => m C.Config
getAppConfig = getSubConfFor applicationScriptId
getAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m (Maybe a)
getAppConfigVal name = do
cfg <- getAppConfig
liftIO $ C.lookup cfg name
requireAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a
requireAppConfigVal name = do
cfg <- getAppConfig
liftIO $ C.require cfg name
getBotName :: HasConfigAccess m => m L.Text
getBotName = fromMaybe defaultBotName <$> getAppConfigVal "name"
extractReaction :: BotReacting a s o -> BotReacting a s (IO o)
extractReaction reac = BotReacting $ do
s <- ask
return $ runStderrLoggingT $ runReaderT (runReaction reac) s
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 ())