{-|
Module      : $Header$
Description : Running marvin.
Copyright   : (c) Justus Adam, 2016
License     : BSD3
Maintainer  : dev@justus.science
Stability   : experimental
Portability : POSIX
-}
{-# LANGUAGE ExplicitForAll         #-}
{-# 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
    ) where


import           Control.Concurrent.Async.Lifted (async, wait)
import           Control.Exception.Lifted
import           Control.Lens                    hiding (cons)
import           Control.Monad.Logger
import           Control.Monad.Reader
import qualified Data.Configurator               as C
import qualified Data.Configurator.Types         as C
import           Data.Foldable                   (for_)
import qualified Data.HashMap.Strict             as HM
import           Data.Maybe                      (fromMaybe, mapMaybe)
import           Data.Monoid                     ((<>))
import           Data.Sequences
import qualified Data.Text                       as T
import qualified Data.Text.Lazy                  as L
import           Data.Traversable                (for)
import           Data.Vector                     (Vector)
import           Marvin.Adapter                  as A
import           Marvin.Internal
import           Marvin.Internal.Types           hiding (channel)
import           Marvin.Interpolate.Text
import           Marvin.Util.Regex
import           Options.Applicative
import           Prelude                         hiding (dropWhile, splitAt)
import           Util


data CmdOptions = CmdOptions
    { configPath :: Maybe FilePath
    , verbose    :: Bool
    , debug      :: Bool
    }


defaultBotName :: L.Text
defaultBotName = "marvin"


defaultConfigName :: FilePath
defaultConfigName = "config.cfg"


defaultLoggingLevel :: LogLevel
defaultLoggingLevel = LevelWarn


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 f = Handlers
        { handlersResponds :: f (Regex, Message -> Match -> RunnerM ())
        , handlersHears :: f (Regex, Message -> Match -> RunnerM ())
        , handlersCustoms :: f (Event -> Maybe (RunnerM ()))
        , handlersJoins :: f ((User, Channel) -> RunnerM ())
        , handlersLeaves :: f ((User, Channel) -> RunnerM ())
        , handlersTopicChange :: f ((Topic, Channel) -> RunnerM ())
        , handlersJoinsIn :: HM.HashMap L.Text (f ((User, Channel) -> RunnerM ()))
        , handlersLeavesFrom :: HM.HashMap L.Text (f ((User, Channel) -> RunnerM ()))
        , handlersTopicChangeIn :: HM.HashMap L.Text (f ((Topic, Channel) -> RunnerM ()))
        }
    |]


mapHandlerFunctor :: (forall a. f a -> f' a) -> Handlers f -> Handlers f'
mapHandlerFunctor f (Handlers respondsV hearsV customsV joinsV leavesV topicsV joinsInV leavesFromV topicsInV) =
    Handlers (f respondsV) (f hearsV) (f customsV) (f joinsV) (f leavesV) (f topicsV)
             (fmap f joinsInV) (fmap f leavesFromV) (fmap f topicsInV)


-- TODO add timeouts for handlers
mkApp :: IsAdapter a => LoggingFn -> [Script a] -> C.Config -> a -> EventHandler a
mkApp log scripts cfg adapter = flip runLoggingT log . genericHandler
  where
    genericHandler ev = do
        generics <- async $ do
            let applicables = catMaybes $ fmap ($ ev) customsV
            asyncs <- for applicables async
            for_ asyncs wait
        handler ev
        wait generics
    handler (MessageEvent msg) = handleMessage msg
    -- TODO implement other handlers
    handler (ChannelJoinEvent user chan) = changeHandlerHelper joinsV joinsInV user chan
    handler (ChannelLeaveEvent user chan) = changeHandlerHelper leavesV leavesFromV user chan
    handler (TopicChangeEvent topic chan) = changeHandlerHelper topicsV topicsInV topic chan

    changeHandlerHelper :: Vector ((b, Channel) -> RunnerM ())
                        -> (HM.HashMap L.Text (Vector ((b, Channel) -> RunnerM ())))
                        -> b
                        -> Channel
                        -> RunnerM ()
    changeHandlerHelper wildcards specifics other chan = do
        cName <- A.getChannelName adapter chan

        let applicables = fromMaybe mempty $ specifics^?ix cName

        wildcards <- for wildcards (async . ($ (other, chan)))

        applicablesRunning <- for applicables (async . ($ (other, chan)))

        mapM_ wait $ wildcards `mappend` 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)
      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)

    Handlers respondsV hearsV customsV joinsV leavesV topicsV joinsInV leavesFromV topicsInV =
        (mapHandlerFunctor fromList :: Handlers [] -> Handlers Vector)
        $ flattenActions (Handlers mempty mempty mempty mempty mempty mempty mempty mempty mempty :: Handlers []) scripts


addAction :: forall a. 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 Join ac -> joins %~ cons (\d -> botAcWith (Just "Join event" :: Maybe T.Text) d ac)
        WrappedAction Leave ac -> leaves %~ cons (\d -> botAcWith (Just "Leave event" :: Maybe T.Text) d ac)
        WrappedAction (JoinIn chName) ac -> joinsIn . at chName %~ Just . maybe (return reac) (cons reac)
          where reac chan = botAcWith (Just "Join event" :: Maybe T.Text) chan ac
        WrappedAction (LeaveFrom chName) ac -> leavesFrom . at chName %~ Just . maybe (return reac) (cons reac)
          where reac chan = botAcWith (Just "Leave event" :: Maybe T.Text) chan ac
        WrappedAction TopicC ac -> topicChange %~ cons (\d -> botAcWith (Just "Topic event" :: Maybe T.Text) d ac)
        WrappedAction (TopicCIn chanName) ac -> topicChangeIn . at chanName %~ Just . maybe (return reac) (cons reac)
          where reac chan = botAcWith (Just "Topic event" :: Maybe T.Text) chan ac
        WrappedAction (Custom matcher) ac -> customs %~ cons h
          where
            h ev = run <$> matcher ev
            run s = botAcWith (Nothing :: Maybe ()) s ac
  where
    botAcWith :: ShowT t =>  Maybe t -> d -> BotReacting a d () -> RunnerM ()
    botAcWith = runBotAction script adapter


runBotAction :: ShowT t => Script a -> a -> Maybe t -> d -> BotReacting a d () -> RunnerM ()
runBotAction script adapter trigger data_ action = do
    oldLogFn <- askLoggerIO
    catch
        (liftIO $ flip runLoggingT (loggingAddSourcePrefix $(isT "script.#{script^.scriptId}") oldLogFn) $ flip runReaderT actionState $ runReaction action)
        (onScriptExcept (script^.scriptId) trigger)

  where
    actionState = BotActionState (script^.scriptId) (script^.config) adapter data_


runMessageAction :: Script a -> a -> Regex -> BotReacting a MessageReactionData () -> Message -> Match -> RunnerM ()
runMessageAction script adapter re ac msg mtch =
    runBotAction script adapter (Just re) (MessageReactionData msg mtch) ac


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"


-- | 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"
    s <- catMaybes <$> mapM (\(ScriptInit (sid, s)) -> catch (Just <$> s ada config) (onInitExcept sid)) inits
    return $ mkApp log s config ada
  where
    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")


setLoggingLevelIn :: LogLevel -> RunnerM a -> RunnerM a
setLoggingLevelIn lvl = filterLogger f
    where f _ lvl2 = lvl2 >= lvl


-- | Runs the marvin bot using whatever method the adapter uses.
runMarvin :: forall a. IsAdapter a => [ScriptInit a] -> IO ()
runMarvin s' = runStderrLoggingT $ do
    -- prepareLogger
    args <- liftIO $ execParser infoParser

    cfgLoc <- maybe
                    ($logInfoS $(isT "${applicationScriptId}") "Using default config: config.cfg" >> return defaultConfigName)
                    return
                    (configPath args)
    (cfg, cfgTid) <- liftIO $ C.autoReload C.autoConfig [C.Required cfgLoc]
    loggingLevelFromCfg <- liftIO $ C.lookup cfg $(isT "#{applicationScriptId}.logging")

    let loggingLevel
            | debug args = LevelDebug
            | verbose args = LevelInfo
            | otherwise = fromMaybe defaultLoggingLevel loggingLevelFromCfg

    setLoggingLevelIn loggingLevel $ do
        oldLogFn <- askLoggerIO
        liftIO $ flip runLoggingT (loggingAddSourcePrefix adapterPrefix oldLogFn) $ runWithAdapter
            (C.subconfig adapterPrefix cfg)
            $ application oldLogFn s' cfg
  where
    adapterPrefix = $(isT "adapter.#{adapterId :: AdapterId a}")
    infoParser = info
        (helper <*> optsParser)
        (fullDesc <> header "Instance of marvin, the modular bot.")
    optsParser = CmdOptions
        <$> optional
            ( strOption
            $  long "config-path"
            <> value defaultConfigName
            <> short 'c'
            <> metavar "PATH"
            <> help "root cofiguration file for the bot"
            <> showDefault
            )
        <*> switch
            (  long "verbose"
            <> short 'v'
            <> help "enable verbose logging (overrides config)"
            )
        <*> switch
            (  long "debug"
            <> help "enable debug logging (overrides config and verbose flag)"
            )