{-# LANGUAGE TemplateHaskell #-}
module Lambdabot.Main
    ( lambdabotVersion
    
    , Config
    , DSum(..)
    , (==>)
    , lambdabotMain

    , Modules
    , modules

    , module Lambdabot.Plugin.Core
    , Priority(..)
    ) where

import Lambdabot.Bot
import Lambdabot.Config
import Lambdabot.Logging
import Lambdabot.Module
import Lambdabot.Monad
import Lambdabot.Plugin.Core
import Lambdabot.Util
import Lambdabot.Util.Signals

import Control.Exception.Lifted as E
import Control.Monad.Identity
import Data.Dependent.Sum
import Data.List
import Data.IORef
import Data.Some
import Data.Version
import Language.Haskell.TH
import Paths_lambdabot_core (version)
import System.Exit
import System.Log.Formatter
import qualified System.Log.Logger as L
import System.Log.Handler.Simple
import Network.Socket (withSocketsDo)

lambdabotVersion :: Version
lambdabotVersion :: Version
lambdabotVersion = Version
version

setupLogging :: LB ()
setupLogging :: LB ()
setupLogging = do
    Handle
stream <- Config Handle -> LB Handle
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Handle
consoleLogHandle
    Priority
level  <- Config Priority -> LB Priority
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Priority
consoleLogLevel
    String
format <- Config String -> LB String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
consoleLogFormat
    
    GenericHandler Handle
unformattedHandler <- IO (GenericHandler Handle) -> LB (GenericHandler Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
stream Priority
level)
    let consoleHandler :: GenericHandler Handle
consoleHandler = GenericHandler Handle
unformattedHandler
            { formatter :: LogFormatter (GenericHandler Handle)
formatter = String -> LogFormatter (GenericHandler Handle)
forall a. String -> LogFormatter a
simpleLogFormatter String
format }
    
    Bool
setRoot <- Config Bool -> LB Bool
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Bool
replaceRootLogger
    
    IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> IO () -> LB ()
forall a b. (a -> b) -> a -> b
$ if Bool
setRoot
        then String -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger String
L.rootLoggerName
            (Priority -> Logger -> Logger
L.setLevel Priority
level (Logger -> Logger) -> (Logger -> Logger) -> Logger -> Logger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenericHandler Handle] -> Logger -> Logger
forall a. LogHandler a => [a] -> Logger -> Logger
L.setHandlers [GenericHandler Handle
consoleHandler])
        else String -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger String
"Lambdabot"
            (Priority -> Logger -> Logger
L.setLevel Priority
level (Logger -> Logger) -> (Logger -> Logger) -> Logger -> Logger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericHandler Handle -> Logger -> Logger
forall a. LogHandler a => a -> Logger -> Logger
L.addHandler GenericHandler Handle
consoleHandler)

-- | The Lambdabot entry point.
-- Initialise plugins, connect, and run the bot in the LB monad
--
-- Also, handle any fatal exceptions (such as non-recoverable signals),
-- (i.e. print a message and exit). Non-fatal exceptions should be dealt
-- with in the mainLoop or further down.
lambdabotMain :: Modules -> [DSum Config Identity] -> IO ExitCode
lambdabotMain :: Modules -> [DSum Config Identity] -> IO ExitCode
lambdabotMain Modules
initialise [DSum Config Identity]
cfg = IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
withSocketsDo (IO ExitCode -> IO ExitCode)
-> (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ExitCode -> IO ExitCode
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
withIrcSignalCatch (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
    IRCRState
rost <- [DSum Config Identity] -> IO IRCRState
initRoState [DSum Config Identity]
cfg
    IORef IRCRWState
rwst <- IRCRWState -> IO (IORef IRCRWState)
forall a. a -> IO (IORef a)
newIORef IRCRWState
initRwState
    LB ExitCode -> (IRCRState, IORef IRCRWState) -> IO ExitCode
forall a. LB a -> (IRCRState, IORef IRCRWState) -> IO a
runLB (Modules -> LB ExitCode
lambdabotRun Modules
initialise) (IRCRState
rost, IORef IRCRWState
rwst)
        IO ExitCode -> (SomeException -> IO ExitCode) -> IO ExitCode
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \SomeException
e -> do
            -- clean up and go home
            case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                Just ExitCode
code -> ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
code
                Maybe ExitCode
Nothing   -> do
                    String -> IO ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
                    ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
1)

lambdabotRun :: Modules -> LB ExitCode
lambdabotRun :: Modules -> LB ExitCode
lambdabotRun Modules
ms = do
    LB ()
setupLogging
    String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
infoM String
"Initialising plugins"
    Modules -> LB () -> LB ()
forall a. Modules -> LB a -> LB a
withModules Modules
ms (LB () -> LB ()) -> LB () -> LB ()
forall a b. (a -> b) -> a -> b
$ do
        String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
infoM String
"Done loading plugins"
        LB ()
reportInitDone
        
        LB ()
forall (m :: * -> *). MonadLB m => m ()
waitForQuit LB () -> (SomeException -> LB ()) -> LB ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch`
            (\e :: SomeException
e@SomeException{} -> String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)) -- catch anything, print informative message, and clean up
    
    -- clean up any dynamically loaded modules
    (String -> LB ()) -> [String] -> LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> LB ()
ircUnloadModule ([String] -> LB ()) -> LB [String] -> LB ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB [String]
listModules
    ExitCode -> LB ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess

------------------------------------------------------------------------

type Modules = [(String, Some Module)]

modules :: [String] -> Q Exp
modules :: [String] -> Q Exp
modules [String]
xs = [| $(listE $ map instalify (nub xs)) |]
    where
        instalify :: String -> Q Exp
instalify String
x =
            let module' :: Q Exp
module' = Name -> Q Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Plugin")
             in [| (x, Some $module') |]

withModules :: Modules -> LB a -> LB a
withModules :: Modules -> LB a -> LB a
withModules []      = LB a -> LB a
forall a. a -> a
id
withModules ((String
n, Some Module a
m):Modules
ms)  = String -> Module a -> LB a -> LB a
forall st a. String -> Module st -> LB a -> LB a
withModule String
n Module a
m (LB a -> LB a) -> (LB a -> LB a) -> LB a -> LB a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modules -> LB a -> LB a
forall a. Modules -> LB a -> LB a
withModules Modules
ms

withModule :: String -> Module st -> LB a -> LB a
withModule :: String -> Module st -> LB a -> LB a
withModule String
name Module st
m = LB () -> LB () -> LB a -> LB a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> m b -> m c -> m c
bracket_ (String -> Module st -> LB ()
forall st. String -> Module st -> LB ()
ircLoadModule String
name Module st
m) (String -> LB ()
ircUnloadModule String
name)