{-# 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 a. Config a -> LB a
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Handle
consoleLogHandle
Priority
level <- Config Priority -> LB Priority
forall a. Config a -> LB a
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Priority
consoleLogLevel
[Char]
format <- Config [Char] -> LB [Char]
forall a. Config a -> LB a
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [Char]
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 = simpleLogFormatter format }
Bool
setRoot <- Config Bool -> LB Bool
forall a. Config a -> LB a
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 [Char] -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger [Char]
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 [Char] -> (Logger -> Logger) -> IO ()
L.updateGlobalLogger [Char]
"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)
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
case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just ExitCode
code -> ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
code
Maybe ExitCode
Nothing -> do
[Char] -> IO ()
forall (m :: * -> *). MonadLogging m => [Char] -> m ()
errorM (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e)
ExitCode -> IO ExitCode
forall a. a -> IO a
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
[Char] -> LB ()
forall (m :: * -> *). MonadLogging m => [Char] -> m ()
infoM [Char]
"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
[Char] -> LB ()
forall (m :: * -> *). MonadLogging m => [Char] -> m ()
infoM [Char]
"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{} -> [Char] -> LB ()
forall (m :: * -> *). MonadLogging m => [Char] -> m ()
errorM (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e))
([Char] -> LB ()) -> [[Char]] -> LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> LB ()
ircUnloadModule ([[Char]] -> LB ()) -> LB [[Char]] -> LB ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LB [[Char]]
listModules
ExitCode -> LB ExitCode
forall a. a -> LB a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
type Modules = [(String, Some Module)]
modules :: [String] -> Q Exp
modules :: [[Char]] -> Q Exp
modules [[Char]]
xs = [| $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ([Char] -> Q Exp) -> [[Char]] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Q Exp
forall {m :: * -> *}. Quote m => [Char] -> m Exp
instalify ([[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub [[Char]]
xs)) |]
where
instalify :: [Char] -> m Exp
instalify [Char]
x =
let module' :: m Exp
module' = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName ([Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Plugin")
in [| (x, Some $m Exp
module') |]
withModules :: Modules -> LB a -> LB a
withModules :: forall a. Modules -> LB a -> LB a
withModules [] = LB a -> LB a
forall a. a -> a
id
withModules (([Char]
n, Some Module a
m):Modules
ms) = [Char] -> Module a -> LB a -> LB a
forall st a. [Char] -> Module st -> LB a -> LB a
withModule [Char]
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 :: forall st a. [Char] -> Module st -> LB a -> LB a
withModule [Char]
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_ ([Char] -> Module st -> LB ()
forall st. [Char] -> Module st -> LB ()
ircLoadModule [Char]
name Module st
m) ([Char] -> LB ()
ircUnloadModule [Char]
name)