module Marvin.Run
( runMarvin, ScriptInit, IsAdapter
, requireFromAppConfig, lookupFromAppConfig, defaultConfigName
) where
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, mapMaybe)
import Data.Monoid ((<>))
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 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_)
data CmdOptions = CmdOptions
{ configPath :: Maybe FilePath
, verbose :: Bool
, debug :: Bool
} deriving (Generic)
instance ParseRecord CmdOptions
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)
lookupFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO (Maybe a)
lookupFromAppConfig cfg = C.lookup (C.subconfig (unwrapScriptId applicationScriptId) cfg)
declareFields [d|
data Handlers = Handlers
{ handlersResponds :: [(Regex, Message -> Match -> IO ())]
, handlersHears :: [(Regex, Message -> Match -> IO ())]
, handlersCustoms :: [Event -> Maybe (IO ())]
}
|]
mkApp :: [Script a] -> C.Config -> a -> EventHandler a
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
lDispatches <- doIfMatch allListens text
botname <- fromMaybe defaultBotName <$> lookupFromAppConfig cfg "name"
let (trimmed, remainder) = splitAt (fromIntegral $ length botname) $ dropWhile isSpace text
rDispatches <- if toLower trimmed == toLower botname
then doIfMatch allReactions remainder
else return mempty
mapM_ wait (lDispatches <> rDispatches)
where
text = content msg
doIfMatch things toMatch =
catMaybes <$> for things (\(trigger, action) ->
case match [] trigger toMatch of
Nothing -> return Nothing
Just m -> Just <$> async (action msg m))
flattenActions = foldr $ \script -> flip (foldr (addAction script adapter)) (script^.actions)
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
addAction script adapter wa =
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
(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 $ show e
where
err = L.errorM "bot.dispatch"
application :: [ScriptInit a] -> C.Config -> InitEventHandler a
application inits config ada = do
L.infoM "bot" "Initializing scripts"
s <- catMaybes <$> mapM (\(ScriptInit (sid, s)) -> catch (Just <$> s ada config) (onInitExcept sid)) inits
return $ mkApp s config ada
where
onInitExcept :: ScriptId -> SomeException -> IO (Maybe a')
onInitExcept (ScriptId id) e = do
err $ "Unhandled exception during initialization of script " <> show id
err $ show e
return Nothing
where err = L.errorM "bot.init"
prepareLogger :: IO ()
prepareLogger =
L.updateGlobalLogger L.rootLoggerName (L.setHandlers [handler])
where
handler = L.GenericHandler { L.priority = L.DEBUG
, L.formatter = L.simpleLogFormatter "$time [$prio:$loggername] $msg"
, L.privData = ()
, L.writeFunc = const putStrLn
, L.closeFunc = const $ return ()
}
runMarvin :: forall a. IsAdapter a => [ScriptInit a] -> IO ()
runMarvin s' = do
prepareLogger
args <- getRecord "bot server"
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 defaultConfigName)
return
(configPath args)
(cfg, cfgTid) <- C.autoReload C.autoConfig [C.Required cfgLoc]
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)
$ application s' cfg