Began a big refactoring/rewriting (again)
This commit is contained in:
Julien Dessaux
parent
d05aea2def
commit
ff07633fb8
41 changed files with 423 additions and 5107 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -1,2 +1,3 @@
|
||||||
.*.swp
|
.*.swp
|
||||||
Session.vim
|
Session.vim
|
||||||
|
dist
|
||||||
|
|
|
||||||
39
Hsbot.hs
Normal file
39
Hsbot.hs
Normal file
|
|
@ -0,0 +1,39 @@
|
||||||
|
module Hsbot
|
||||||
|
( hsbot
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified Config.Dyre as Dyre
|
||||||
|
import Config.Dyre.Relaunch
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import System.Log.Logger
|
||||||
|
|
||||||
|
import Hsbot.Config
|
||||||
|
import Hsbot.Core
|
||||||
|
import Hsbot.Types
|
||||||
|
|
||||||
|
startHsbot :: Config -> IO ()
|
||||||
|
startHsbot config = do
|
||||||
|
-- checking for configuration file compilation error
|
||||||
|
case configErrors config of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just em -> putStrLn $ "Error: " ++ em
|
||||||
|
-- initialization
|
||||||
|
infoM "Hsbot" "Bot initializations"
|
||||||
|
hsbotEnv <- initHsbot config
|
||||||
|
-- main stuff
|
||||||
|
infoM "Hsbot" "Bot core starting"
|
||||||
|
status <- runReaderT runHsbot hsbotEnv
|
||||||
|
infoM "Hsbot" $ "Bot core exited with status " ++ (show status)
|
||||||
|
-- Handling exit signal
|
||||||
|
case status of
|
||||||
|
BotContinue -> startHsbot config -- TODO do something not so dumb about starting over
|
||||||
|
BotExit -> runReaderT terminateHsbot hsbotEnv
|
||||||
|
BotReload -> relaunchMaster Nothing -- TODO relaunchWithTextState (state { stateConfig = config }) Nothing, add a flag that prevent spawning the sockets again
|
||||||
|
BotRestart -> relaunchMaster Nothing -- TODO relaunch and kill sockets
|
||||||
|
|
||||||
|
hsbot :: Config -> IO ()
|
||||||
|
hsbot = Dyre.wrapMain $ Dyre.defaultParams
|
||||||
|
{ Dyre.projectName = "hsbot"
|
||||||
|
, Dyre.realMain = startHsbot
|
||||||
|
, Dyre.showError = (\config err -> config { configErrors = Just err }) }
|
||||||
|
|
||||||
63
Hsbot/Config.hs
Normal file
63
Hsbot/Config.hs
Normal file
|
|
@ -0,0 +1,63 @@
|
||||||
|
module Hsbot.Config
|
||||||
|
( Config (..)
|
||||||
|
, TLSConfig (..)
|
||||||
|
, defaultConfig
|
||||||
|
, defaultTLSConfig
|
||||||
|
, noSSL
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Network
|
||||||
|
import Network.TLS
|
||||||
|
import Network.TLS.Extra
|
||||||
|
|
||||||
|
data Config = Config
|
||||||
|
{ configErrors :: Maybe String
|
||||||
|
, configTLS :: TLSConfig
|
||||||
|
, configAddress :: String
|
||||||
|
, configPort :: PortID
|
||||||
|
, configChannels :: [String]
|
||||||
|
, configNicknames :: [String]
|
||||||
|
, configRealname :: String
|
||||||
|
, configPlugins :: [String]
|
||||||
|
}
|
||||||
|
|
||||||
|
defaultConfig :: Config
|
||||||
|
defaultConfig = Config
|
||||||
|
{ configErrors = Nothing
|
||||||
|
, configTLS = noSSL
|
||||||
|
, configAddress = "localhost"
|
||||||
|
, configPort = PortNumber 6667
|
||||||
|
, configChannels = ["#hsbot"]
|
||||||
|
, configNicknames = ["hsbot"]
|
||||||
|
, configRealname = "The One True bot, with it's haskell soul."
|
||||||
|
, configPlugins = ["Ping", "Core"] }
|
||||||
|
|
||||||
|
data TLSConfig = TLSConfig
|
||||||
|
{ sslOn :: Bool
|
||||||
|
, sslCert :: String
|
||||||
|
, sslKey :: String
|
||||||
|
, sslVersions :: [Network.TLS.Version]
|
||||||
|
, sslCiphers :: [Network.TLS.Cipher]
|
||||||
|
, sslVerify :: Bool
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
|
defaultTLSConfig :: TLSConfig
|
||||||
|
defaultTLSConfig = TLSConfig
|
||||||
|
{ sslOn = True
|
||||||
|
, sslCert = ""
|
||||||
|
, sslKey = ""
|
||||||
|
, sslVersions = [SSL3, TLS10, TLS11, TLS12]
|
||||||
|
, sslCiphers = [ cipher_null_MD5
|
||||||
|
, cipher_null_SHA1
|
||||||
|
, cipher_AES128_SHA1
|
||||||
|
, cipher_AES256_SHA1
|
||||||
|
, cipher_RC4_128_MD5
|
||||||
|
, cipher_RC4_128_SHA1
|
||||||
|
, cipher_AES256_SHA1
|
||||||
|
, cipher_AES128_SHA256
|
||||||
|
, cipher_AES256_SHA256 ]
|
||||||
|
, sslVerify = True }
|
||||||
|
|
||||||
|
noSSL :: TLSConfig
|
||||||
|
noSSL = defaultTLSConfig { sslOn = False }
|
||||||
|
|
||||||
105
Hsbot/Core.hs
Normal file
105
Hsbot/Core.hs
Normal file
|
|
@ -0,0 +1,105 @@
|
||||||
|
module Hsbot.Core
|
||||||
|
( initHsbot
|
||||||
|
, runHsbot
|
||||||
|
, terminateHsbot
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Exception (IOException, catch)
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import qualified Data.ByteString.Char8 as C
|
||||||
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
import Network
|
||||||
|
import qualified Network.IRC as IRC
|
||||||
|
import Network.BSD (getHostName)
|
||||||
|
import Network.TLS
|
||||||
|
import Prelude hiding (catch)
|
||||||
|
import System.IO
|
||||||
|
import System.Log.Logger
|
||||||
|
|
||||||
|
import Hsbot.Config
|
||||||
|
import Hsbot.Types
|
||||||
|
import Hsbot.Utils
|
||||||
|
|
||||||
|
initHsbot :: Config -> IO (BotEnv)
|
||||||
|
initHsbot config = do
|
||||||
|
chan <- newChan :: IO (Chan Message)
|
||||||
|
threadIdsMv <- newMVar []
|
||||||
|
quitMv <- newEmptyMVar
|
||||||
|
let hostname = configAddress config
|
||||||
|
port = configPort config
|
||||||
|
infoM "Hsbot.Core" $ "Connecting to " ++ hostname -- ++ ":" ++ port
|
||||||
|
connhdl <- connectTo hostname port
|
||||||
|
hSetBuffering connhdl LineBuffering
|
||||||
|
hSetEncoding connhdl utf8
|
||||||
|
(tls, tlsCtx) <- case sslOn $ configTLS config of
|
||||||
|
True -> do
|
||||||
|
infoM "Hsbot.Core" "TLS init"
|
||||||
|
tlsenv <- initTLSEnv (configTLS config)
|
||||||
|
randomGen <- makeSRandomGen >>= either (fail . show) (return . id)
|
||||||
|
sCtx <- client tlsenv randomGen connhdl
|
||||||
|
handshake sCtx
|
||||||
|
return (Just tlsenv, Just sCtx)
|
||||||
|
False -> return (Nothing, Nothing)
|
||||||
|
return BotEnv { envHandle = connhdl
|
||||||
|
, envChan = chan
|
||||||
|
, envQuitMv = quitMv
|
||||||
|
, envThreadIdsMv = threadIdsMv
|
||||||
|
, envConfig = config
|
||||||
|
, envTLS = tls
|
||||||
|
, envTLSCtx = tlsCtx }
|
||||||
|
|
||||||
|
runHsbot :: Env IO (BotStatus)
|
||||||
|
runHsbot = do
|
||||||
|
-- First we say hello
|
||||||
|
env <- ask
|
||||||
|
hostname <- liftIO getHostName
|
||||||
|
let connhdl = envHandle env
|
||||||
|
tlsCtx = envTLSCtx env
|
||||||
|
config = envConfig env
|
||||||
|
nickname = head $ configNicknames config
|
||||||
|
channels = configChannels config
|
||||||
|
liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.nick nickname
|
||||||
|
liftIO . sendStrToClient connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
|
||||||
|
mapM_ (liftIO . sendStrToClient connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
|
||||||
|
-- Next we spawn the reader thread
|
||||||
|
liftIO $ debugM "Hsbot.Core" $ "Spawning reader thread"
|
||||||
|
myOwnThreadId <- liftIO $ myThreadId
|
||||||
|
chan <- asks envChan
|
||||||
|
(liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar
|
||||||
|
-- Then we spawn all plugins
|
||||||
|
-- asks envSocket >>= mapM_ ( ----- what's next? the core server handling! ----- )
|
||||||
|
-- Finally we spawn the main bot loop
|
||||||
|
--
|
||||||
|
-- We wait for the quit signal
|
||||||
|
code <- asks envQuitMv >>= liftIO . takeMVar
|
||||||
|
-- and we clean things up
|
||||||
|
asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread
|
||||||
|
return code
|
||||||
|
|
||||||
|
botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
|
||||||
|
botReader _ (Just ctx) chan _ = forever $
|
||||||
|
recvData ctx >>= return . L.toChunks >>= mapM_ (handleIncomingStr chan . C.unpack) -- TODO exceptions
|
||||||
|
botReader handle Nothing chan fatherThreadId = forever $
|
||||||
|
(hGetLine handle) `catch` handleIOException >>= handleIncomingStr chan
|
||||||
|
where
|
||||||
|
handleIOException :: IOException -> IO (String)
|
||||||
|
handleIOException ioException = do
|
||||||
|
throwTo fatherThreadId ioException
|
||||||
|
myId <- myThreadId
|
||||||
|
killThread myId
|
||||||
|
return ""
|
||||||
|
|
||||||
|
handleIncomingStr :: Chan Message -> String -> IO ()
|
||||||
|
handleIncomingStr chan str = do
|
||||||
|
case IRC.decode str of
|
||||||
|
Just msg -> do
|
||||||
|
debugM "Ircd.Reader" $ "<-- " ++ (show msg)
|
||||||
|
writeChan chan $ IncomingMsg msg
|
||||||
|
Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control
|
||||||
|
|
||||||
|
terminateHsbot :: Env IO ()
|
||||||
|
terminateHsbot = do
|
||||||
|
liftIO $ infoM "Hsbot.Core" "Closing connection"
|
||||||
|
asks envHandle >>= liftIO . hClose
|
||||||
|
|
||||||
54
Hsbot/Types.hs
Normal file
54
Hsbot/Types.hs
Normal file
|
|
@ -0,0 +1,54 @@
|
||||||
|
module Hsbot.Types
|
||||||
|
( Bot
|
||||||
|
, BotState (..)
|
||||||
|
, BotStatus (..)
|
||||||
|
, BotEnv (..)
|
||||||
|
, Env
|
||||||
|
, Message (..)
|
||||||
|
, PluginState (..)
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.State
|
||||||
|
import qualified Network.IRC as IRC
|
||||||
|
import Network.TLS
|
||||||
|
import System.IO
|
||||||
|
|
||||||
|
import Hsbot.Config
|
||||||
|
|
||||||
|
-- The bot environment
|
||||||
|
type Env = ReaderT BotEnv
|
||||||
|
|
||||||
|
data BotEnv = BotEnv
|
||||||
|
{ envHandle :: Handle
|
||||||
|
, envChan :: Chan Message
|
||||||
|
, envQuitMv :: MVar (BotStatus)
|
||||||
|
, envThreadIdsMv :: MVar [ThreadId]
|
||||||
|
, envConfig :: Config
|
||||||
|
, envTLS :: Maybe TLSParams
|
||||||
|
, envTLSCtx :: Maybe TLSCtx
|
||||||
|
}
|
||||||
|
|
||||||
|
-- The bot monad
|
||||||
|
type Bot = StateT BotState
|
||||||
|
|
||||||
|
data BotState = BotState
|
||||||
|
{ botPlugins :: M.Map String (PluginState, MVar (), ThreadId)
|
||||||
|
, botCommands :: M.Map String [String]
|
||||||
|
, botChannels :: [String]
|
||||||
|
, botNickname :: String
|
||||||
|
}
|
||||||
|
|
||||||
|
-- The Plugin monad
|
||||||
|
data PluginState = PluginState
|
||||||
|
{ pluginName :: String
|
||||||
|
, pluginChan :: Chan Message
|
||||||
|
}
|
||||||
|
|
||||||
|
data BotStatus = BotContinue | BotExit | BotReload | BotRestart deriving (Show)
|
||||||
|
|
||||||
|
data Message = IncomingMsg IRC.Message
|
||||||
|
| OutgoingMsg IRC.Message
|
||||||
|
|
||||||
99
Hsbot/Utils.hs
Normal file
99
Hsbot/Utils.hs
Normal file
|
|
@ -0,0 +1,99 @@
|
||||||
|
module Hsbot.Utils
|
||||||
|
( addThreadIdToQuitMVar
|
||||||
|
, delThreadIdFromQuitMVar
|
||||||
|
, first
|
||||||
|
, initTLSEnv
|
||||||
|
, readCertificate
|
||||||
|
, readPrivateKey
|
||||||
|
, sendStrToClient
|
||||||
|
, setGlobalQuitMVar
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import qualified Crypto.Cipher.RSA as RSA
|
||||||
|
import qualified Data.ByteString as B
|
||||||
|
import qualified Data.ByteString.Char8 as C
|
||||||
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
import qualified Data.Certificate.KeyRSA as KeyRSA
|
||||||
|
import Data.Certificate.PEM
|
||||||
|
import Data.Certificate.X509
|
||||||
|
import Data.List
|
||||||
|
import Network.TLS
|
||||||
|
import System.IO
|
||||||
|
|
||||||
|
import Hsbot.Config
|
||||||
|
import Hsbot.Types
|
||||||
|
|
||||||
|
-- utility functions
|
||||||
|
addThreadIdToQuitMVar :: ThreadId -> Env IO ()
|
||||||
|
addThreadIdToQuitMVar thrId = do
|
||||||
|
threadIdsMv <- asks envThreadIdsMv
|
||||||
|
liftIO $ modifyMVar_ threadIdsMv (\l -> return $ thrId:l)
|
||||||
|
|
||||||
|
delThreadIdFromQuitMVar :: ThreadId -> Env IO ()
|
||||||
|
delThreadIdFromQuitMVar thrId = do
|
||||||
|
threadIdsMv <- asks envThreadIdsMv
|
||||||
|
liftIO $ modifyMVar_ threadIdsMv (\l -> return $ delete thrId l)
|
||||||
|
|
||||||
|
setGlobalQuitMVar :: BotStatus -> Env IO ()
|
||||||
|
setGlobalQuitMVar status = do
|
||||||
|
quitMv <- asks envQuitMv
|
||||||
|
liftIO $ putMVar quitMv status
|
||||||
|
|
||||||
|
first :: (a, b, c) -> a
|
||||||
|
first (a, _, _) = a
|
||||||
|
|
||||||
|
-- Helpers
|
||||||
|
sendStrToClient :: Handle -> Maybe TLSCtx -> String -> IO ()
|
||||||
|
sendStrToClient _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
|
||||||
|
sendStrToClient handle Nothing msg = hPutStrLn handle msg
|
||||||
|
|
||||||
|
-- TLS utils
|
||||||
|
initTLSEnv :: TLSConfig -> IO (TLSParams)
|
||||||
|
initTLSEnv ssl = do
|
||||||
|
let certFile = sslCert ssl
|
||||||
|
keyFile = sslKey ssl
|
||||||
|
versions = sslVersions ssl
|
||||||
|
ciphers = sslCiphers ssl
|
||||||
|
verify = sslVerify ssl
|
||||||
|
-- TODO : exception on loading keys
|
||||||
|
cert <- readCertificate certFile
|
||||||
|
pk <- readPrivateKey keyFile
|
||||||
|
return $ defaultParams { pConnectVersion = TLS12
|
||||||
|
, pAllowedVersions = versions
|
||||||
|
, pCiphers = ciphers
|
||||||
|
, pWantClientCert = verify
|
||||||
|
, pCertificates = [(cert, Just pk)] }
|
||||||
|
|
||||||
|
readCertificate :: FilePath -> IO X509
|
||||||
|
readCertificate filepath = do
|
||||||
|
content <- B.readFile filepath
|
||||||
|
let certdata = case parsePEMCert content of
|
||||||
|
Nothing -> error ("no valid certificate section")
|
||||||
|
Just x -> x
|
||||||
|
let cert = case decodeCertificate $ L.fromChunks [certdata] of
|
||||||
|
Left err -> error ("cannot decode certificate: " ++ err)
|
||||||
|
Right x -> x
|
||||||
|
return cert
|
||||||
|
|
||||||
|
readPrivateKey :: FilePath -> IO PrivateKey
|
||||||
|
readPrivateKey filepath = do
|
||||||
|
content <- B.readFile filepath
|
||||||
|
let pkdata = case parsePEMKeyRSA content of
|
||||||
|
Nothing -> error ("no valid RSA key section")
|
||||||
|
Just x -> L.fromChunks [x]
|
||||||
|
let pk = case KeyRSA.decodePrivate pkdata of
|
||||||
|
Left err -> error ("cannot decode key: " ++ err)
|
||||||
|
Right x -> PrivRSA $ RSA.PrivateKey
|
||||||
|
{ RSA.private_sz = fromIntegral $ KeyRSA.lenmodulus x
|
||||||
|
, RSA.private_n = KeyRSA.modulus x
|
||||||
|
, RSA.private_d = KeyRSA.private_exponant x
|
||||||
|
, RSA.private_p = KeyRSA.p1 x
|
||||||
|
, RSA.private_q = KeyRSA.p2 x
|
||||||
|
, RSA.private_dP = KeyRSA.exp1 x
|
||||||
|
, RSA.private_dQ = KeyRSA.exp2 x
|
||||||
|
, RSA.private_qinv = KeyRSA.coef x
|
||||||
|
}
|
||||||
|
return pk
|
||||||
|
|
||||||
3
HsbotIrcBot/.gitignore
vendored
3
HsbotIrcBot/.gitignore
vendored
|
|
@ -1,3 +0,0 @@
|
||||||
.*.swp
|
|
||||||
Session.vim
|
|
||||||
dist
|
|
||||||
2
HsbotIrcBot/Hsbot/.gitignore
vendored
2
HsbotIrcBot/Hsbot/.gitignore
vendored
|
|
@ -1,2 +0,0 @@
|
||||||
.*.swp
|
|
||||||
Session.vim
|
|
||||||
2
HsbotIrcBot/Hsbot/Irc/.gitignore
vendored
2
HsbotIrcBot/Hsbot/Irc/.gitignore
vendored
|
|
@ -1,2 +0,0 @@
|
||||||
.*.swp
|
|
||||||
Session.vim
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
module Hsbot.Irc.CLI
|
|
||||||
( Options (..)
|
|
||||||
, defaultOptions
|
|
||||||
, header
|
|
||||||
, options
|
|
||||||
) where
|
|
||||||
|
|
||||||
import System.Console.GetOpt
|
|
||||||
import System.Exit
|
|
||||||
|
|
||||||
-- CLI argument parting stuff {{{
|
|
||||||
-- | CLI options
|
|
||||||
data Options = Options
|
|
||||||
{ optDebug :: Bool
|
|
||||||
, optConfigFile :: Maybe String
|
|
||||||
, optGroup :: Maybe String
|
|
||||||
, optUser :: Maybe String
|
|
||||||
, optVerbose :: Bool
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
-- | CLI default options
|
|
||||||
defaultOptions :: Options
|
|
||||||
defaultOptions = Options { optDebug = False
|
|
||||||
, optConfigFile = Nothing
|
|
||||||
, optGroup = Nothing
|
|
||||||
, optUser = Nothing
|
|
||||||
, optVerbose = False }
|
|
||||||
|
|
||||||
-- | CLI options logic
|
|
||||||
options :: [ OptDescr (Options -> IO Options) ]
|
|
||||||
options =
|
|
||||||
[ Option "d" ["debug"]
|
|
||||||
(NoArg (\opt -> return opt { optDebug = True, optVerbose = True }))
|
|
||||||
"Enter verbose debug mode and prevents Hsbot from forking in background"
|
|
||||||
, Option "f" ["file"]
|
|
||||||
(ReqArg (\arg opt -> return opt { optConfigFile = return arg }) "<config_file>")
|
|
||||||
"The config file to use"
|
|
||||||
, Option "g" ["group"]
|
|
||||||
(ReqArg (\arg opt -> return opt { optGroup = return arg }) "<group>")
|
|
||||||
"The group hsbot will run as"
|
|
||||||
, Option "h" ["help"]
|
|
||||||
(NoArg (\_ -> do
|
|
||||||
putStrLn $ usageInfo header options
|
|
||||||
exitWith ExitSuccess))
|
|
||||||
"Print this help message"
|
|
||||||
, Option "u" ["user"]
|
|
||||||
(ReqArg (\arg opt -> return opt { optUser = return arg }) "<user>")
|
|
||||||
"The user hsbot will run as"
|
|
||||||
, Option "v" ["verbose"]
|
|
||||||
(NoArg (\opt -> return opt { optVerbose = True }))
|
|
||||||
"Enable verbose messages"
|
|
||||||
, Option "V" ["version"]
|
|
||||||
(NoArg (\_ -> do
|
|
||||||
putStrLn "hsbot-irc version 0.3"
|
|
||||||
exitWith ExitSuccess))
|
|
||||||
"Show version"
|
|
||||||
]
|
|
||||||
|
|
||||||
-- | Usage header
|
|
||||||
header :: String
|
|
||||||
header = "Usage: hsbot-irc [-dhvV] [-f config_file] [-u user] [-g group]"
|
|
||||||
-- }}}
|
|
||||||
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
module Hsbot.Irc.Command
|
|
||||||
( processInternalCommand
|
|
||||||
, registerCommand
|
|
||||||
, unregisterCommand
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.List as L
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Maybe
|
|
||||||
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin
|
|
||||||
import Hsbot.Irc.Types
|
|
||||||
|
|
||||||
-- | Registers a plugin's command
|
|
||||||
registerCommand :: String -> String -> IrcBot ()
|
|
||||||
registerCommand cmd pluginName' = do
|
|
||||||
ircBot <- get
|
|
||||||
let cmds = ircBotCommands ircBot
|
|
||||||
plugins = ircBotPlugins ircBot
|
|
||||||
case M.lookup pluginName' plugins of
|
|
||||||
Just _ -> let pluginNames = pluginName' : fromMaybe [] (M.lookup cmd cmds) -- TODO : remove/check for duplicates ?
|
|
||||||
newCmds = M.insert cmd pluginNames cmds
|
|
||||||
in put $ ircBot { ircBotCommands = newCmds }
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
-- | Unregisters a plugin's command
|
|
||||||
unregisterCommand :: String -> String -> IrcBot ()
|
|
||||||
unregisterCommand cmd pluginName' = do
|
|
||||||
ircBot <- get
|
|
||||||
let cmds = ircBotCommands ircBot
|
|
||||||
newCmds = M.adjust (L.delete pluginName') cmd cmds
|
|
||||||
put $ ircBot { ircBotCommands = newCmds }
|
|
||||||
|
|
||||||
-- | Processes an internal command
|
|
||||||
processInternalCommand :: IrcBotMsg -> IrcBot (BotStatus)
|
|
||||||
processInternalCommand (IntIrcCmd ircCmd)
|
|
||||||
| ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd
|
|
||||||
| otherwise = do
|
|
||||||
plugins <- gets ircBotPlugins
|
|
||||||
case M.lookup (ircCmdTo ircCmd) plugins of
|
|
||||||
Just (plugin, _, _) -> sendToPlugin (IntIrcCmd ircCmd) plugin
|
|
||||||
Nothing -> return ()
|
|
||||||
return BotContinue
|
|
||||||
processInternalCommand _ = return (BotContinue)
|
|
||||||
|
|
||||||
-- | Processes a core command
|
|
||||||
processCoreCommand :: IrcCmd -> IrcBot (BotStatus)
|
|
||||||
processCoreCommand ircCmd = do
|
|
||||||
let command' = ircCmdCmd ircCmd
|
|
||||||
originalRequest = ircCmdBotMsg ircCmd
|
|
||||||
case command' of
|
|
||||||
"LIST" -> listPlugins originalRequest (ircCmdFrom ircCmd)
|
|
||||||
"LOAD" -> loadIrcPlugin $ ircCmdMsg ircCmd
|
|
||||||
"REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
|
|
||||||
"UNLOAD" -> unloadIrcPlugin $ ircCmdMsg ircCmd
|
|
||||||
"UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd)
|
|
||||||
_ -> return ()
|
|
||||||
if command' == "REBOOT"
|
|
||||||
then return BotReboot
|
|
||||||
else return BotContinue
|
|
||||||
|
|
||||||
|
|
@ -1,134 +0,0 @@
|
||||||
module Hsbot.Irc.Config
|
|
||||||
( IrcConfig(..)
|
|
||||||
, ircDefaultConfig
|
|
||||||
, getIrcConfig
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad.Error
|
|
||||||
import Data.Char (isDigit)
|
|
||||||
import qualified Data.ConfigFile as C
|
|
||||||
import Data.Either.Utils
|
|
||||||
import Network
|
|
||||||
import System.Exit
|
|
||||||
import System.Posix.Files
|
|
||||||
|
|
||||||
-- | Configuration data type
|
|
||||||
data IrcConfig = IrcConfig
|
|
||||||
{ ircConfigAddress :: String -- the server's address
|
|
||||||
, ircConfigPort :: PortID -- the server's port
|
|
||||||
, ircConfigChannels :: [String] -- the Channels to join on start
|
|
||||||
, ircConfigNickname :: String -- the hsbot's nickname
|
|
||||||
, ircConfigPassword :: String -- the hsbot's password, optional
|
|
||||||
, ircConfigRealname :: String -- the hsbot's real name, optional
|
|
||||||
, ircConfigCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
|
|
||||||
, ircConfigPlugins :: [String] -- the ircPlugins to load
|
|
||||||
}
|
|
||||||
|
|
||||||
instance Show IrcConfig where
|
|
||||||
show (IrcConfig address port channels nickname password realname commandPrefix plugins) = unlines $
|
|
||||||
concat [ "Address: ", address ] :
|
|
||||||
concat [ "Port: ", case port of
|
|
||||||
PortNumber num -> show num
|
|
||||||
Service s -> show s
|
|
||||||
UnixSocket u -> show u ] :
|
|
||||||
concat [ "Channels: ", show channels ] :
|
|
||||||
concat [ "Nickname: ", nickname ] :
|
|
||||||
concat [ "Password: ", password ] :
|
|
||||||
concat [ "Realname: ", realname ] :
|
|
||||||
concat [ "CommandPrefix: ", show commandPrefix ] :
|
|
||||||
[ "Plugins: ", show plugins ]
|
|
||||||
|
|
||||||
-- | User configuration
|
|
||||||
ircDefaultConfig :: IrcConfig
|
|
||||||
ircDefaultConfig = IrcConfig
|
|
||||||
{ ircConfigAddress = "localhost"
|
|
||||||
, ircConfigPort = PortNumber 6667
|
|
||||||
, ircConfigChannels = ["#hsbot"]
|
|
||||||
, ircConfigNickname = "hsbot"
|
|
||||||
, ircConfigPassword = ""
|
|
||||||
, ircConfigRealname = "The One True bot, with it's haskell soul."
|
|
||||||
, ircConfigCommandPrefix = '@'
|
|
||||||
, ircConfigPlugins = ["Ping", "Core"]
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | config file retrieving
|
|
||||||
getIrcConfig :: Maybe String -> IO (IrcConfig)
|
|
||||||
getIrcConfig maybePath =
|
|
||||||
case maybePath of
|
|
||||||
Just path -> do
|
|
||||||
doesFileExists <- fileExist path
|
|
||||||
case doesFileExists of
|
|
||||||
True -> do
|
|
||||||
fileStatus <- getFileStatus path
|
|
||||||
case isRegularFile $ fileStatus of
|
|
||||||
True -> getConfigFromFile path
|
|
||||||
False -> do
|
|
||||||
putStrLn "Invalid configuration file path."
|
|
||||||
exitWith $ ExitFailure 1
|
|
||||||
False -> do
|
|
||||||
putStrLn "The specified configuration file does not exists."
|
|
||||||
exitWith $ ExitFailure 1
|
|
||||||
Nothing -> return ircDefaultConfig -- TODO : try defaults like $HOME/.hsbotrc, /etc/hsbotrc or /usr/local/etc/hsbotrc
|
|
||||||
|
|
||||||
-- | Get configuration from config file
|
|
||||||
getConfigFromFile :: FilePath -> IO IrcConfig
|
|
||||||
getConfigFromFile fname = readfile C.emptyCP fname >>= extractConfig . forceEither
|
|
||||||
|
|
||||||
-- | A version of readfile that treats the file as UTF-8
|
|
||||||
readfile :: MonadError C.CPError m => C.ConfigParser -> FilePath -> IO (m C.ConfigParser)
|
|
||||||
readfile cp path' = do
|
|
||||||
contents <- readFile path'
|
|
||||||
return $ C.readstring cp contents
|
|
||||||
|
|
||||||
-- | config file processing
|
|
||||||
extractConfig :: C.ConfigParser -> IO IrcConfig
|
|
||||||
extractConfig cp = do
|
|
||||||
config' <- runErrorT $ do
|
|
||||||
cfAddress <- getit "address"
|
|
||||||
cfPort <- getit "port"
|
|
||||||
cfChannels <- getit "channels"
|
|
||||||
cfNickname <- getit "nickname"
|
|
||||||
cfPassword <- getit "password"
|
|
||||||
cfRealname <- getit "realname"
|
|
||||||
cfCommandPrefix <- getit "commandprefix"
|
|
||||||
cfPlugins <- getit "plugins"
|
|
||||||
return $! IrcConfig {
|
|
||||||
ircConfigAddress = cfAddress
|
|
||||||
, ircConfigPort = PortNumber . fromIntegral $ readInteger "port" cfPort
|
|
||||||
, ircConfigChannels = splitCommaList cfChannels
|
|
||||||
, ircConfigNickname = cfNickname
|
|
||||||
, ircConfigPassword = cfPassword
|
|
||||||
, ircConfigRealname = cfRealname
|
|
||||||
, ircConfigCommandPrefix = readChar "commandprefix" cfCommandPrefix
|
|
||||||
, ircConfigPlugins = splitCommaList cfPlugins }
|
|
||||||
case config' of
|
|
||||||
Left (C.ParseError e, e') -> error $ "Parse error: " ++ e ++ "\n" ++ e'
|
|
||||||
Left e -> error (show e)
|
|
||||||
Right c -> return c
|
|
||||||
where
|
|
||||||
getit = C.get cp "IRC"
|
|
||||||
|
|
||||||
readChar :: String -> String -> Char
|
|
||||||
readChar _ x | length x == 1 = head x
|
|
||||||
readChar opt _ = error $ opt ++ " must be one character long."
|
|
||||||
|
|
||||||
readInteger :: String -> String -> Int
|
|
||||||
readInteger _ x | all isDigit x = read x ::Int
|
|
||||||
readInteger opt _ = error $ opt ++ " must be an integer."
|
|
||||||
|
|
||||||
-- readNumber :: (Num a, Read a) => String -> String -> a
|
|
||||||
-- readNumber _ x | all isDigit x = read x
|
|
||||||
-- readNumber opt _ = error $ opt ++ " must be a number."
|
|
||||||
|
|
||||||
splitCommaList :: String -> [String]
|
|
||||||
splitCommaList l =
|
|
||||||
let (first, rest) = break (== ',') l
|
|
||||||
first' = lrStrip first
|
|
||||||
in case rest of
|
|
||||||
[] -> if null first' then [] else [first']
|
|
||||||
(_:rs) -> first' : splitCommaList rs
|
|
||||||
|
|
||||||
lrStrip :: String -> String
|
|
||||||
lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace
|
|
||||||
where isWhitespace = (`elem` " \t\n")
|
|
||||||
|
|
||||||
|
|
@ -1,130 +0,0 @@
|
||||||
module Hsbot.Irc.Core
|
|
||||||
( startIrcbot
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Exception (AsyncException, Handler (..), IOException, catch, catches)
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Network
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
import System.IO
|
|
||||||
|
|
||||||
import Hsbot.Irc.CLI
|
|
||||||
import Hsbot.Irc.Command
|
|
||||||
import Hsbot.Irc.Config
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin
|
|
||||||
import Hsbot.Irc.Server
|
|
||||||
import Hsbot.Irc.Types
|
|
||||||
|
|
||||||
-- | IrcBot's main entry point
|
|
||||||
startIrcbot :: Options -> IrcConfig -> IO ()
|
|
||||||
startIrcbot opts ircConfig = do
|
|
||||||
when (optDebug opts) $ putStrLn "[IrcBot] Opening communication channel... "
|
|
||||||
chan <- newChan :: IO (Chan IrcBotMsg)
|
|
||||||
when (optDebug opts) . putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress ircConfig, "... "]
|
|
||||||
handle <- connectTo (ircConfigAddress ircConfig) (ircConfigPort ircConfig)
|
|
||||||
hSetBuffering handle NoBuffering
|
|
||||||
hSetEncoding handle utf8
|
|
||||||
when (optDebug opts) $ putStrLn "[IrcBot] Spawning reader thread..."
|
|
||||||
myOwnThreadId <- myThreadId
|
|
||||||
readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId
|
|
||||||
when (optDebug opts) $ putStrLn "[IrcBot] Initializing server connection..."
|
|
||||||
let ircServerState = IrcServerState { ircServerId = ircConfigAddress ircConfig
|
|
||||||
, ircServerChannels = []
|
|
||||||
, ircServerNickname = ircConfigNickname ircConfig
|
|
||||||
, ircServerCommandPrefix = ircConfigCommandPrefix ircConfig
|
|
||||||
, ircServerChan = chan }
|
|
||||||
ircBotState = IrcBotState { ircBotPlugins = M.empty
|
|
||||||
, ircBotCommands = M.empty
|
|
||||||
, ircBotChan = chan
|
|
||||||
, ircBotServerState = ircServerState
|
|
||||||
, ircBotHandle = handle
|
|
||||||
, ircBotConfig = ircConfig }
|
|
||||||
ircBotState' <- execStateT (initBotServerConnection ircConfig) ircBotState
|
|
||||||
when (optDebug opts) $ putStrLn "[IrcBot] Spawning plugins..."
|
|
||||||
ircBotState'' <- execStateT spawnIrcPlugins ircBotState'
|
|
||||||
when (optDebug opts) $ putStrLn "[IrcBot] Entering Core loop... "
|
|
||||||
(_, ircBotState''') <- runLoop ircBotState''
|
|
||||||
when (optDebug opts) $ putStrLn "[IrcBot] Killing reader thread..."
|
|
||||||
killThread readerThreadId
|
|
||||||
when (optDebug opts) $ putStrLn "[IrcBot] Killing active plugins... "
|
|
||||||
evalStateT (mapM_ killIrcPlugin . M.keys $ ircBotPlugins ircBotState''') ircBotState'''
|
|
||||||
where
|
|
||||||
runLoop :: IrcBotState -> IO (BotStatus, IrcBotState)
|
|
||||||
runLoop botState = do
|
|
||||||
(status, botState') <- (runStateT ircBotCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState))
|
|
||||||
, Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ]
|
|
||||||
case status of
|
|
||||||
BotContinue -> runLoop botState'
|
|
||||||
_ -> return (status, botState')
|
|
||||||
|
|
||||||
-- | Runs the IrcBot's reader loop
|
|
||||||
ircBotReader :: Handle -> Chan IrcBotMsg -> ThreadId -> IO ()
|
|
||||||
ircBotReader handle chan fatherThreadId = forever $ do
|
|
||||||
str <- (hGetLine handle) `catch` handleIOException
|
|
||||||
let msg = parseIrcMsg str
|
|
||||||
case msg of
|
|
||||||
Right msg' -> writeChan chan (InIrcMsg msg')
|
|
||||||
_ -> return ()
|
|
||||||
where
|
|
||||||
handleIOException :: IOException -> IO (String)
|
|
||||||
handleIOException ioException = do
|
|
||||||
throwTo fatherThreadId ioException
|
|
||||||
myId <- myThreadId
|
|
||||||
killThread myId
|
|
||||||
return ""
|
|
||||||
|
|
||||||
-- | Initialize the bot's server connection
|
|
||||||
initBotServerConnection :: IrcConfig -> IrcBot ()
|
|
||||||
initBotServerConnection config = do
|
|
||||||
ircBot <- get
|
|
||||||
let ircServerState = ircBotServerState ircBot
|
|
||||||
ircServerState' <- execStateT (initServerConnection config) ircServerState
|
|
||||||
put $ ircBot { ircBotServerState = ircServerState' }
|
|
||||||
|
|
||||||
-- | Run the IrcBot's main loop
|
|
||||||
ircBotCore :: IrcBot (BotStatus)
|
|
||||||
ircBotCore = do
|
|
||||||
chan <- gets ircBotChan
|
|
||||||
msg <- liftIO $ readChan chan
|
|
||||||
case msg of
|
|
||||||
InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg
|
|
||||||
OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg
|
|
||||||
IntIrcCmd intIrcCmd -> processInternalCommand $ IntIrcCmd intIrcCmd
|
|
||||||
where
|
|
||||||
sendThisMessage :: IrcMsg -> IrcBot (BotStatus)
|
|
||||||
sendThisMessage outputMsg = do
|
|
||||||
let str = serializeIrcMsg outputMsg
|
|
||||||
handle <- gets ircBotHandle
|
|
||||||
liftIO $ hPutStr handle (str ++ "\r\n")
|
|
||||||
return BotContinue
|
|
||||||
|
|
||||||
-- | Dispatches an input message
|
|
||||||
dispatchMessage :: IrcBotMsg -> IrcBot (BotStatus)
|
|
||||||
dispatchMessage (InIrcMsg inIrcMsg) = do
|
|
||||||
bot <- get
|
|
||||||
let config = ircBotConfig bot
|
|
||||||
plugins = ircBotPlugins bot
|
|
||||||
cmds = ircBotCommands bot
|
|
||||||
if isPluginCommand config
|
|
||||||
then
|
|
||||||
let getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg
|
|
||||||
key = tail . head $ words getMsgContent
|
|
||||||
pluginNames = fromMaybe [] $ M.lookup key cmds
|
|
||||||
plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames
|
|
||||||
sendRunCommand cmd plugin = sendToPlugin (IntIrcCmd $ IrcCmd "RUN" "CORE" (ircPluginName plugin) cmd inIrcMsg) plugin
|
|
||||||
in mapM_ (sendRunCommand (tail getMsgContent) . first) plugins'
|
|
||||||
else
|
|
||||||
mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (M.elems plugins)
|
|
||||||
return BotContinue
|
|
||||||
where
|
|
||||||
isPluginCommand config = and [ ircMsgCommand inIrcMsg == "PRIVMSG", prefix == ircConfigCommandPrefix config ]
|
|
||||||
prefix | length msgWords >= 1 = head . head $ msgWords
|
|
||||||
| otherwise = ' '
|
|
||||||
where
|
|
||||||
msgWords = tail $ ircMsgParameters inIrcMsg
|
|
||||||
dispatchMessage _ = return (BotContinue)
|
|
||||||
|
|
||||||
|
|
@ -1,73 +0,0 @@
|
||||||
module Hsbot.Irc.Message
|
|
||||||
( IrcBotMsg (..)
|
|
||||||
, IrcCmd (..)
|
|
||||||
, IrcMsg (..)
|
|
||||||
, emptyIrcMsg
|
|
||||||
, parseIrcMsg
|
|
||||||
, serializeIrcMsg
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad.Identity
|
|
||||||
import Text.ParserCombinators.Parsec
|
|
||||||
|
|
||||||
-- | An IRC message
|
|
||||||
data IrcMsg = IrcMsg
|
|
||||||
{ ircMsgPrefix :: Maybe String -- the message prefix
|
|
||||||
, ircMsgCommand :: String -- the message command
|
|
||||||
, ircMsgParameters :: [String] -- the message parameters
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
emptyIrcMsg :: IrcMsg
|
|
||||||
emptyIrcMsg = IrcMsg Nothing "" []
|
|
||||||
|
|
||||||
-- | An internal command
|
|
||||||
data IrcCmd = IrcCmd
|
|
||||||
{ ircCmdCmd :: String -- the internal command
|
|
||||||
, ircCmdFrom :: String -- who issues it
|
|
||||||
, ircCmdTo :: String -- who it is destinated to
|
|
||||||
, ircCmdMsg :: String -- the message to be transfered
|
|
||||||
, ircCmdBotMsg :: IrcMsg -- An IrcMsg attached to the command
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
data IrcBotMsg = InIrcMsg IrcMsg | OutIrcMsg IrcMsg | IntIrcCmd IrcCmd deriving (Show)
|
|
||||||
|
|
||||||
-- | Parses an IrcInput
|
|
||||||
parseIrcMsg :: String -> Either ParseError IrcMsg
|
|
||||||
parseIrcMsg line = parse pMsg "" line
|
|
||||||
|
|
||||||
--pMsg :: Parser String u Identity IrcMsg
|
|
||||||
pMsg = do
|
|
||||||
pfx <- optionMaybe pPrefix
|
|
||||||
cmd <- pCommand
|
|
||||||
params <- many (char ' ' >> (pLongParam <|> pShortParam))
|
|
||||||
_ <- char '\r'
|
|
||||||
eof
|
|
||||||
return $ IrcMsg pfx cmd params
|
|
||||||
|
|
||||||
--pPrefix :: Parser String u Identity [Char]
|
|
||||||
pPrefix = do
|
|
||||||
_ <- char ':'
|
|
||||||
pfx <- many1 (noneOf " ")
|
|
||||||
_ <- space
|
|
||||||
return pfx
|
|
||||||
|
|
||||||
--pCommand :: Parser String u Identity [Char]
|
|
||||||
pCommand = count 3 digit <|> many1 upper
|
|
||||||
|
|
||||||
--pLongParam :: Parser String u Identity [Char]
|
|
||||||
pLongParam = char ':' >> (many1 (noneOf "\r"))
|
|
||||||
|
|
||||||
--pShortParam :: Parser String u Identity [Char]
|
|
||||||
pShortParam = many1 (noneOf " \r")
|
|
||||||
|
|
||||||
-- | Serialize an IRC message to a string.
|
|
||||||
serializeIrcMsg :: IrcMsg -> String
|
|
||||||
serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
|
|
||||||
where pfxStr = case pfx of
|
|
||||||
Nothing -> ""
|
|
||||||
Just pfx' -> ":" ++ pfx' ++ " "
|
|
||||||
paramStr = concat (map paramToStr (init params)
|
|
||||||
++ [lastParamToStr (last params)])
|
|
||||||
paramToStr p = " " ++ p
|
|
||||||
lastParamToStr p = " :" ++ p
|
|
||||||
|
|
||||||
|
|
@ -1,89 +0,0 @@
|
||||||
module Hsbot.Irc.Plugin
|
|
||||||
( IrcPlugin
|
|
||||||
, IrcPluginState (..)
|
|
||||||
, killIrcPlugin
|
|
||||||
, listPlugins
|
|
||||||
, loadIrcPlugin
|
|
||||||
, sendToPlugin
|
|
||||||
, spawnIrcPlugins
|
|
||||||
, unloadIrcPlugin
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Concurrent.Chan ()
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
|
|
||||||
import Hsbot.Irc.Config
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin.Core
|
|
||||||
import Hsbot.Irc.Plugin.Dummy
|
|
||||||
import Hsbot.Irc.Plugin.Ping
|
|
||||||
import Hsbot.Irc.Plugin.Quote
|
|
||||||
import Hsbot.Irc.Plugin.Utils
|
|
||||||
import Hsbot.Irc.Types
|
|
||||||
|
|
||||||
-- | Sends a msg to a plugin
|
|
||||||
sendToPlugin :: IrcBotMsg -> IrcPluginState -> IrcBot ()
|
|
||||||
sendToPlugin ircBotMsg plugin = do
|
|
||||||
liftIO $ writeChan (ircPluginChan plugin) ircBotMsg
|
|
||||||
|
|
||||||
-- | spawns IrcPlugins
|
|
||||||
spawnIrcPlugins :: IrcBot ()
|
|
||||||
spawnIrcPlugins = do
|
|
||||||
config <- gets ircBotConfig
|
|
||||||
mapM_ (loadIrcPlugin) (ircConfigPlugins config)
|
|
||||||
|
|
||||||
-- | loads an ircbot plugin
|
|
||||||
loadIrcPlugin :: String -> IrcBot ()
|
|
||||||
loadIrcPlugin pluginName = do
|
|
||||||
ircbot <- get
|
|
||||||
let masterChan = ircBotChan ircbot
|
|
||||||
(entryPoint, loadIt) = case pluginName of
|
|
||||||
"Core" -> (ircBotPluginCore, True)
|
|
||||||
"Ping" -> (ircBotPluginPing, True)
|
|
||||||
"Quote" -> (ircBotPluginQuote, True)
|
|
||||||
_ -> (ircBotPluginDummy, False)
|
|
||||||
when loadIt $ do
|
|
||||||
pluginChan <- liftIO (newChan :: IO (Chan IrcBotMsg))
|
|
||||||
let oldPlugins = ircBotPlugins ircbot
|
|
||||||
-- We check for unicity
|
|
||||||
case M.lookup pluginName oldPlugins of
|
|
||||||
Just _ -> return ()
|
|
||||||
Nothing -> do
|
|
||||||
mvar <- liftIO newEmptyMVar
|
|
||||||
threadId <- liftIO . forkIO $ finally (entryPoint pluginChan masterChan) (putMVar mvar ())
|
|
||||||
let plugin = IrcPluginState { ircPluginName = pluginName
|
|
||||||
, ircPluginChan = pluginChan
|
|
||||||
, ircPluginMasterChan = masterChan }
|
|
||||||
newPlugins = M.insert pluginName (plugin, mvar, threadId) oldPlugins
|
|
||||||
put $ ircbot { ircBotPlugins = newPlugins }
|
|
||||||
|
|
||||||
-- | Sends a list of loaded plugins
|
|
||||||
listPlugins :: IrcMsg -> String -> IrcBot ()
|
|
||||||
listPlugins originalRequest dest = do
|
|
||||||
plugins <- gets ircBotPlugins
|
|
||||||
let listing = unwords $ M.keys plugins
|
|
||||||
case M.lookup dest plugins of
|
|
||||||
Just (plugin, _, _) -> sendToPlugin (IntIrcCmd $ IrcCmd "ANSWER" "CORE" dest listing originalRequest) plugin
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
-- | Unloads a plugin
|
|
||||||
unloadIrcPlugin :: String -> IrcBot ()
|
|
||||||
unloadIrcPlugin name = killIrcPlugin name
|
|
||||||
|
|
||||||
-- | kills a plugin
|
|
||||||
killIrcPlugin :: String -> IrcBot ()
|
|
||||||
killIrcPlugin name = do
|
|
||||||
ircbot <- get
|
|
||||||
let oldPlugins = ircBotPlugins ircbot
|
|
||||||
-- We check if the plugin exists
|
|
||||||
case M.lookup name oldPlugins of
|
|
||||||
Just (_, mvar, threadId) -> do
|
|
||||||
let newPlugins = M.delete name oldPlugins
|
|
||||||
liftIO $ throwTo threadId UserInterrupt
|
|
||||||
put $ ircbot { ircBotPlugins = newPlugins }
|
|
||||||
liftIO $ takeMVar mvar
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
|
|
@ -1,66 +0,0 @@
|
||||||
module Hsbot.Irc.Plugin.Core
|
|
||||||
( ircBotPluginCore
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent (Chan)
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.State
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin.Utils
|
|
||||||
|
|
||||||
-- | The plugin's main entry point
|
|
||||||
ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
|
||||||
ircBotPluginCore myChan masterChan = do
|
|
||||||
let plugin = IrcPluginState { ircPluginName = "Core"
|
|
||||||
, ircPluginChan = myChan
|
|
||||||
, ircPluginMasterChan = masterChan }
|
|
||||||
evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin
|
|
||||||
plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
|
||||||
evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin'
|
|
||||||
|
|
||||||
-- | The IrcPlugin monad main function
|
|
||||||
run :: IrcPlugin ()
|
|
||||||
run = forever $ do
|
|
||||||
msg <- readMsg
|
|
||||||
eval msg
|
|
||||||
where
|
|
||||||
eval :: IrcBotMsg -> IrcPlugin ()
|
|
||||||
eval (IntIrcCmd intCmd) = do
|
|
||||||
let request = ircCmdBotMsg intCmd
|
|
||||||
case ircCmdCmd intCmd of
|
|
||||||
"RUN" -> let stuff = words $ ircCmdMsg intCmd
|
|
||||||
in case head stuff of
|
|
||||||
"list" -> listPlugins request
|
|
||||||
"load" -> loadPlugin $ tail stuff
|
|
||||||
"reload" -> reloadPlugin $ tail stuff
|
|
||||||
"unload" -> unloadPlugin $ tail stuff
|
|
||||||
"reboot" -> rebootBot $ tail stuff
|
|
||||||
_ -> return () -- TODO : help message
|
|
||||||
"ANSWER" -> let stuff = ircCmdMsg intCmd
|
|
||||||
in answerMsg request ("Loaded plugins : " ++ stuff)
|
|
||||||
_ -> return ()
|
|
||||||
eval _ = return ()
|
|
||||||
|
|
||||||
-- | The list command
|
|
||||||
listPlugins :: IrcMsg -> IrcPlugin ()
|
|
||||||
listPlugins request = do
|
|
||||||
sendCommandWithRequest "LIST" "CORE" (unwords []) request
|
|
||||||
|
|
||||||
-- | The load command
|
|
||||||
loadPlugin :: [String] -> IrcPlugin ()
|
|
||||||
loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames
|
|
||||||
|
|
||||||
-- | The reload command
|
|
||||||
reloadPlugin :: [String] -> IrcPlugin ()
|
|
||||||
reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames
|
|
||||||
|
|
||||||
-- | The unload command
|
|
||||||
unloadPlugin :: [String] -> IrcPlugin ()
|
|
||||||
unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames
|
|
||||||
|
|
||||||
-- | The reboot command
|
|
||||||
rebootBot :: [String] -> IrcPlugin ()
|
|
||||||
rebootBot stuff = sendCommand "REBOOT" "CORE" $ unwords stuff
|
|
||||||
|
|
||||||
|
|
@ -1,27 +0,0 @@
|
||||||
module Hsbot.Irc.Plugin.Dummy
|
|
||||||
( ircBotPluginDummy
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.State
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin.Utils
|
|
||||||
|
|
||||||
-- | The plugin's main entry point
|
|
||||||
ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
|
||||||
ircBotPluginDummy myChan masterChan = do
|
|
||||||
let plugin = IrcPluginState { ircPluginName = "Dummy"
|
|
||||||
, ircPluginChan = myChan
|
|
||||||
, ircPluginMasterChan = masterChan }
|
|
||||||
_ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
|
||||||
return ()
|
|
||||||
|
|
||||||
-- | The IrcPlugin monad main function
|
|
||||||
run :: IrcPlugin ()
|
|
||||||
run = forever $ do
|
|
||||||
_ <- readMsg
|
|
||||||
return ()
|
|
||||||
|
|
||||||
|
|
@ -1,33 +0,0 @@
|
||||||
module Hsbot.Irc.Plugin.Ping
|
|
||||||
( ircBotPluginPing
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.State
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin.Utils
|
|
||||||
|
|
||||||
-- | The plugin's main entry point
|
|
||||||
ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
|
||||||
ircBotPluginPing myChan masterChan = do
|
|
||||||
let plugin = IrcPluginState { ircPluginName = "Ping"
|
|
||||||
, ircPluginChan = myChan
|
|
||||||
, ircPluginMasterChan = masterChan }
|
|
||||||
_ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
|
|
||||||
return ()
|
|
||||||
|
|
||||||
-- | The IrcPlugin monad main function
|
|
||||||
run :: IrcPlugin ()
|
|
||||||
run = forever $ do
|
|
||||||
msg <- readMsg
|
|
||||||
eval msg
|
|
||||||
where
|
|
||||||
eval :: IrcBotMsg -> IrcPlugin ()
|
|
||||||
eval (InIrcMsg msg)
|
|
||||||
| (ircMsgCommand msg) == "PING" = writeMsg . OutIrcMsg $ IrcMsg Nothing "PONG" (ircMsgParameters msg)
|
|
||||||
| otherwise = return ()
|
|
||||||
eval _ = return ()
|
|
||||||
|
|
||||||
|
|
@ -1,201 +0,0 @@
|
||||||
module Hsbot.Irc.Plugin.Quote
|
|
||||||
( ircBotPluginQuote
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Maybe(fromMaybe)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.IO as TIO
|
|
||||||
import Data.Time
|
|
||||||
import System.Directory
|
|
||||||
import IO hiding (catch)
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
import System.FilePath
|
|
||||||
import System.Posix.Files
|
|
||||||
import System.Random(randomRIO)
|
|
||||||
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin.Utils
|
|
||||||
|
|
||||||
-- | A quote element
|
|
||||||
data QuoteElt = QuoteElt
|
|
||||||
{ eltQuoter :: String
|
|
||||||
, eltQuote :: String
|
|
||||||
} deriving (Read, Show)
|
|
||||||
|
|
||||||
-- | A quote object
|
|
||||||
data Quote = Quote
|
|
||||||
{ quoter :: String
|
|
||||||
, quote :: [QuoteElt]
|
|
||||||
, quoteTime :: UTCTime
|
|
||||||
, votes :: Int
|
|
||||||
} deriving (Read, Show)
|
|
||||||
|
|
||||||
-- | A QuoteBot state
|
|
||||||
data QuoteBotState = QuoteBotState
|
|
||||||
{ nextQuoteId :: Integer
|
|
||||||
, quoteBotDB :: M.Map Integer Quote
|
|
||||||
, quotesInProgress :: M.Map Integer Quote
|
|
||||||
} deriving (Read, Show)
|
|
||||||
|
|
||||||
-- | The QuoteBot monad
|
|
||||||
type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a
|
|
||||||
|
|
||||||
-- | The plugin's main entry point
|
|
||||||
ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
|
|
||||||
ircBotPluginQuote myChan masterChan = do
|
|
||||||
-- First of all we restore the database
|
|
||||||
dir <- getAppUserDataDirectory "hsbot"
|
|
||||||
let dbfile = dir </> "quotedb.txt"
|
|
||||||
dbfileExists <- fileExist dbfile
|
|
||||||
if not dbfileExists
|
|
||||||
then
|
|
||||||
let quoteBot = QuoteBotState 0 M.empty M.empty
|
|
||||||
in TIO.writeFile dbfile (T.pack $ show quoteBot)
|
|
||||||
else
|
|
||||||
return ()
|
|
||||||
txtQuoteBot <- TIO.readFile $ dbfile
|
|
||||||
let quoteBot = read (T.unpack txtQuoteBot) :: QuoteBotState
|
|
||||||
-- The plugin main loop
|
|
||||||
let plugin = IrcPluginState { ircPluginName = "Quote"
|
|
||||||
, ircPluginChan = myChan
|
|
||||||
, ircPluginMasterChan = masterChan }
|
|
||||||
evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin
|
|
||||||
_ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot)
|
|
||||||
evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin
|
|
||||||
|
|
||||||
-- | The IrcPlugin monad main function
|
|
||||||
run :: QuoteBotState -> IrcPlugin (QuoteBotState)
|
|
||||||
run quoteBot = do
|
|
||||||
msg <- readMsg
|
|
||||||
quoteBot' <- eval msg
|
|
||||||
run quoteBot'
|
|
||||||
where
|
|
||||||
-- | evaluate what we just received
|
|
||||||
eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
|
|
||||||
eval (IntIrcCmd intCmd)
|
|
||||||
| ircCmdCmd intCmd == "RUN" = do
|
|
||||||
quoteBot' <- execStateT (runCommand intCmd) quoteBot
|
|
||||||
return quoteBot'
|
|
||||||
| otherwise = return quoteBot
|
|
||||||
eval (InIrcMsg _) = return (quoteBot)
|
|
||||||
eval (OutIrcMsg _) = return (quoteBot)
|
|
||||||
|
|
||||||
-- | run a command we received
|
|
||||||
runCommand :: IrcCmd -> QuoteBot ()
|
|
||||||
runCommand intCmd
|
|
||||||
| theCommand == "quote" = runQuoteCommand
|
|
||||||
| otherwise = return ()
|
|
||||||
where
|
|
||||||
-- | the message is a quote command
|
|
||||||
runQuoteCommand :: QuoteBot ()
|
|
||||||
| length args == 0 = do
|
|
||||||
quoteDB <- gets quoteBotDB
|
|
||||||
x <- liftIO $ randomRIO (0, (length $ M.keys quoteDB) - 1)
|
|
||||||
if (length $ M.keys quoteDB) > 0
|
|
||||||
then
|
|
||||||
mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
|
|
||||||
else
|
|
||||||
lift $ answerMsg request "The quote database is empty."
|
|
||||||
| otherwise = do
|
|
||||||
dispatchQuoteCmd $ head args
|
|
||||||
-- | quote command dispatcher
|
|
||||||
dispatchQuoteCmd :: String -> QuoteBot ()
|
|
||||||
dispatchQuoteCmd cmd
|
|
||||||
| cmd == "help" =
|
|
||||||
case length stuff of
|
|
||||||
0 -> lift $ answerMsg request ("Usage: quote [append|commit|help|quick|start] {quoteId} {nickname} {quote}")
|
|
||||||
_ -> case head stuff of
|
|
||||||
"quick" -> do
|
|
||||||
lift $ answerMsg request ("quote quick [nickname] [quote]")
|
|
||||||
lift $ answerMsg request (" Performs a single line quote.")
|
|
||||||
"start" -> do
|
|
||||||
lift $ answerMsg request ("quote start [nickname] [quote]")
|
|
||||||
lift $ answerMsg request (" Begins a multi lines quote. Use either append to append new lines, or commit to terminate the quoting process.")
|
|
||||||
"append" -> do
|
|
||||||
lift $ answerMsg request ("quote append [quoteId] [nickname] [quote]")
|
|
||||||
lift $ answerMsg request (" Continue a multi line quote by appending to it.")
|
|
||||||
"commit" -> do
|
|
||||||
lift $ answerMsg request ("quote commit [quoteId]")
|
|
||||||
lift $ answerMsg request (" Terminates a multi lines quote.")
|
|
||||||
_ -> lift $ answerMsg request ("Usage: quote [append|commit|help|quick|start] {quoteId} {nickname} {quote}")
|
|
||||||
| cmd == "quick" = do
|
|
||||||
quoteBot <- get
|
|
||||||
now <- liftIO $ getCurrentTime
|
|
||||||
let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
|
|
||||||
newQuote = Quote sender [(quoteElt stuff)] now 0
|
|
||||||
quoteId = nextQuoteId quoteBot
|
|
||||||
quoteBotDB' = M.insert quoteId newQuote (quoteBotDB quoteBot)
|
|
||||||
put $ quoteBot { nextQuoteId = quoteId + 1, quoteBotDB = quoteBotDB' }
|
|
||||||
lift $ answerMsg request ("New quoteId : " ++ show quoteId)
|
|
||||||
syncQuoteBot
|
|
||||||
| cmd == "start" = do
|
|
||||||
quoteBot <- get
|
|
||||||
now <- liftIO $ getCurrentTime
|
|
||||||
let sender = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
|
|
||||||
newQuote = Quote sender [(quoteElt stuff)] now 0
|
|
||||||
quoteId = nextQuoteId quoteBot
|
|
||||||
quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot)
|
|
||||||
put $ quoteBot { nextQuoteId = quoteId + 1, quotesInProgress = quotesInProgress' }
|
|
||||||
lift $ answerMsg request ("New quoteId : " ++ show quoteId)
|
|
||||||
syncQuoteBot
|
|
||||||
| cmd == "append" = do
|
|
||||||
quoteBot <- get
|
|
||||||
case reads (head stuff) of
|
|
||||||
[(quoteId :: Integer,"")] -> do
|
|
||||||
case M.lookup quoteId (quotesInProgress quoteBot) of
|
|
||||||
Just theQuote -> do
|
|
||||||
let newQuote = theQuote { quote = (quoteElt $ tail stuff) : (quote theQuote) }
|
|
||||||
quotesInProgress' = M.insert quoteId newQuote (quotesInProgress quoteBot)
|
|
||||||
put $ quoteBot { quotesInProgress = quotesInProgress' }
|
|
||||||
syncQuoteBot
|
|
||||||
Nothing -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
|
|
||||||
_ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
|
|
||||||
| cmd == "commit" = do
|
|
||||||
quoteBot <- get
|
|
||||||
case reads (head stuff) of
|
|
||||||
[(quoteId :: Integer,"")] -> do
|
|
||||||
case M.lookup quoteId (quotesInProgress quoteBot) of
|
|
||||||
Just theQuote -> do
|
|
||||||
let quoteBotDB' = M.insert quoteId theQuote (quoteBotDB quoteBot)
|
|
||||||
quotesInProgress' = M.delete quoteId (quotesInProgress quoteBot)
|
|
||||||
put $ quoteBot { quoteBotDB = quoteBotDB', quotesInProgress = quotesInProgress' }
|
|
||||||
syncQuoteBot
|
|
||||||
Nothing -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
|
|
||||||
_ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
|
|
||||||
-- | cmd == "abort" =
|
|
||||||
| otherwise = lift $ answerMsg request ("Invalid command : " ++ cmd)
|
|
||||||
-- | Gets the new QuoteElt
|
|
||||||
quoteElt :: [String] -> QuoteElt
|
|
||||||
quoteElt msg = do
|
|
||||||
let budy = head $ msg
|
|
||||||
theQuote = unwords . tail $ msg
|
|
||||||
QuoteElt budy theQuote
|
|
||||||
-- | utilities
|
|
||||||
params = words . ircCmdMsg $ intCmd
|
|
||||||
theCommand = head params
|
|
||||||
args = tail params
|
|
||||||
stuff = tail args
|
|
||||||
request = ircCmdBotMsg intCmd
|
|
||||||
|
|
||||||
-- | The function that sync the quoteDB on disk
|
|
||||||
syncQuoteBot :: QuoteBot ()
|
|
||||||
syncQuoteBot = do
|
|
||||||
dir <- liftIO $ getAppUserDataDirectory "hsbot"
|
|
||||||
let dbfile = dir </> "quotedb.txt"
|
|
||||||
file' <- liftIO $ openFile dbfile WriteMode
|
|
||||||
quoteBot <- get
|
|
||||||
liftIO . hPutStr file' $ show quoteBot
|
|
||||||
liftIO $ hClose file'
|
|
||||||
|
|
||||||
formatQuote :: Integer -> Quote -> [String]
|
|
||||||
formatQuote quoteId theQuote =
|
|
||||||
("+---| " ++ (show quoteId) ++ " |-- Reported by " ++ (quoter theQuote) ++ " on " ++ (show $ quoteTime theQuote)) :
|
|
||||||
foldl (\acc x -> formatQuoteElt x : acc) ["`------------------------------------------"] (quote theQuote)
|
|
||||||
where
|
|
||||||
formatQuoteElt :: QuoteElt -> String
|
|
||||||
formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt)
|
|
||||||
|
|
||||||
|
|
@ -1,66 +0,0 @@
|
||||||
module Hsbot.Irc.Plugin.Utils
|
|
||||||
( IrcPlugin
|
|
||||||
, IrcPluginState (..)
|
|
||||||
, answerMsg
|
|
||||||
, readMsg
|
|
||||||
, sendCommand
|
|
||||||
, sendCommandWithRequest
|
|
||||||
, sendRegisterCommand
|
|
||||||
, sendUnregisterCommand
|
|
||||||
, writeMsg
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Concurrent.Chan ()
|
|
||||||
import Control.Monad.State
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
|
|
||||||
-- | The IrcPlugin monad
|
|
||||||
type IrcPlugin = StateT IrcPluginState IO
|
|
||||||
|
|
||||||
-- | A plugin state
|
|
||||||
data IrcPluginState = IrcPluginState
|
|
||||||
{ ircPluginName :: String -- The plugin's name
|
|
||||||
, ircPluginChan :: Chan IrcBotMsg -- The plugin chan
|
|
||||||
, ircPluginMasterChan :: Chan IrcBotMsg -- The master's chan
|
|
||||||
}
|
|
||||||
|
|
||||||
--- | Basic input output for IrcPlugins
|
|
||||||
readMsg :: IrcPlugin (IrcBotMsg)
|
|
||||||
readMsg = do
|
|
||||||
chan <- gets ircPluginChan
|
|
||||||
input <- liftIO $ readChan chan
|
|
||||||
return input
|
|
||||||
|
|
||||||
writeMsg :: IrcBotMsg -> IrcPlugin ()
|
|
||||||
writeMsg (OutIrcMsg msg) = do
|
|
||||||
chan <- gets ircPluginMasterChan
|
|
||||||
liftIO $ writeChan chan (OutIrcMsg msg)
|
|
||||||
writeMsg _ = return ()
|
|
||||||
|
|
||||||
answerMsg :: IrcMsg -> String -> IrcPlugin ()
|
|
||||||
answerMsg request msg = do
|
|
||||||
let chanOrigin = head $ ircMsgParameters request
|
|
||||||
sender = takeWhile (/= '!') $ fromMaybe "" (ircMsgPrefix request)
|
|
||||||
case head chanOrigin of
|
|
||||||
'#' -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg]
|
|
||||||
_ -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg]
|
|
||||||
|
|
||||||
-- | Command management
|
|
||||||
sendCommand :: String -> String -> String -> IrcPlugin ()
|
|
||||||
sendCommand cmd to params = sendCommandWithRequest cmd to params emptyIrcMsg
|
|
||||||
|
|
||||||
sendCommandWithRequest :: String -> String -> String -> IrcMsg -> IrcPlugin ()
|
|
||||||
sendCommandWithRequest cmd to params originalRequest = do
|
|
||||||
masterChan <- gets ircPluginMasterChan
|
|
||||||
from <- gets ircPluginName
|
|
||||||
liftIO . writeChan masterChan . IntIrcCmd $ IrcCmd cmd from to params originalRequest
|
|
||||||
|
|
||||||
sendRegisterCommand :: String -> IrcPlugin ()
|
|
||||||
sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd
|
|
||||||
|
|
||||||
sendUnregisterCommand :: String -> IrcPlugin ()
|
|
||||||
sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd
|
|
||||||
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
module Hsbot.Irc.Server
|
|
||||||
( initServerConnection
|
|
||||||
, sendIrcMsg
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
import Control.Monad.State
|
|
||||||
|
|
||||||
import Hsbot.Irc.Config
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Types
|
|
||||||
|
|
||||||
-- | Setup a newly connected server by sending nick and join stuff
|
|
||||||
initServerConnection :: IrcConfig -> IrcServer ()
|
|
||||||
initServerConnection config = do
|
|
||||||
sendIrcMsg $ IrcMsg Nothing "NICK" [(ircConfigNickname config)]
|
|
||||||
sendIrcMsg $ IrcMsg Nothing "USER" [(ircConfigNickname config), "0", "*", (ircConfigRealname config)]
|
|
||||||
when (not . null $ ircConfigPassword config) $ do
|
|
||||||
sendIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (ircConfigPassword config)]
|
|
||||||
mapM_ joinChan (ircConfigChannels config)
|
|
||||||
|
|
||||||
-- | Joins a chan
|
|
||||||
joinChan :: String -> IrcServer ()
|
|
||||||
joinChan channel = do
|
|
||||||
ircServer <- get
|
|
||||||
let oldChannels = ircServerChannels ircServer
|
|
||||||
sendIrcMsg $ IrcMsg Nothing "JOIN" [channel]
|
|
||||||
put $ ircServer { ircServerChannels = channel : oldChannels }
|
|
||||||
|
|
||||||
-- | Sends an IrcMsg
|
|
||||||
sendIrcMsg :: IrcMsg -> IrcServer ()
|
|
||||||
sendIrcMsg ircMsg = do
|
|
||||||
chan <- gets ircServerChan
|
|
||||||
liftIO $ writeChan chan (OutIrcMsg ircMsg)
|
|
||||||
|
|
||||||
|
|
@ -1,50 +0,0 @@
|
||||||
module Hsbot.Irc.Types
|
|
||||||
( BotStatus (..)
|
|
||||||
, IrcBot
|
|
||||||
, IrcBotState (..)
|
|
||||||
, IrcServer
|
|
||||||
, IrcServerState (..)
|
|
||||||
, first
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import System.IO
|
|
||||||
|
|
||||||
import Hsbot.Irc.Config
|
|
||||||
import Hsbot.Irc.Message
|
|
||||||
import Hsbot.Irc.Plugin.Utils
|
|
||||||
|
|
||||||
-- | The Ircbot monad
|
|
||||||
type IrcBot = StateT IrcBotState IO
|
|
||||||
|
|
||||||
-- | An Ircbot state
|
|
||||||
data IrcBotState = IrcBotState
|
|
||||||
{ ircBotPlugins :: M.Map String (IrcPluginState, MVar (), ThreadId) -- Loaded plugins
|
|
||||||
, ircBotCommands :: M.Map String [String] -- Loaded plugins
|
|
||||||
, ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel
|
|
||||||
, ircBotServerState :: IrcServerState -- The state of the IrcServer
|
|
||||||
, ircBotHandle :: Handle -- The server's socket/handle
|
|
||||||
, ircBotConfig :: IrcConfig -- The starting configuration
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | how we exit from the botLoop
|
|
||||||
data BotStatus = BotExit | BotReboot | BotContinue deriving (Eq)
|
|
||||||
|
|
||||||
-- | The IrcServer monad
|
|
||||||
type IrcServer = StateT IrcServerState IrcBot
|
|
||||||
|
|
||||||
-- | An IRC server
|
|
||||||
data IrcServerState = IrcServerState
|
|
||||||
{ ircServerId :: String -- the server's address
|
|
||||||
, ircServerChannels :: [String] -- the Channels we are connected to
|
|
||||||
, ircServerNickname :: String -- the hsbot's nickname
|
|
||||||
, ircServerCommandPrefix :: Char -- the prefix the ircbot will recognize as commands
|
|
||||||
, ircServerChan :: Chan IrcBotMsg -- the IrcBot channel
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Utilities for triplets
|
|
||||||
first :: (a, b, c) -> a
|
|
||||||
first (a, _, _) = a
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load diff
|
|
@ -1,30 +0,0 @@
|
||||||
Copyright (c)2010, Julien Dessaux
|
|
||||||
|
|
||||||
All rights reserved.
|
|
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without
|
|
||||||
modification, are permitted provided that the following conditions are met:
|
|
||||||
|
|
||||||
* Redistributions of source code must retain the above copyright
|
|
||||||
notice, this list of conditions and the following disclaimer.
|
|
||||||
|
|
||||||
* Redistributions in binary form must reproduce the above
|
|
||||||
copyright notice, this list of conditions and the following
|
|
||||||
disclaimer in the documentation and/or other materials provided
|
|
||||||
with the distribution.
|
|
||||||
|
|
||||||
* Neither the name of Julien Dessaux nor the names of other
|
|
||||||
contributors may be used to endorse or promote products derived
|
|
||||||
from this software without specific prior written permission.
|
|
||||||
|
|
||||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
||||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
|
||||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
|
||||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
||||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
||||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
||||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
||||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
||||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
|
|
@ -1,34 +0,0 @@
|
||||||
module Main (main) where
|
|
||||||
|
|
||||||
import Control.Monad (when)
|
|
||||||
import System.Console.GetOpt
|
|
||||||
import System.Environment
|
|
||||||
import System.Exit
|
|
||||||
import System.IO
|
|
||||||
|
|
||||||
import Hsbot.Irc.CLI
|
|
||||||
import Hsbot.Irc.Config
|
|
||||||
import Hsbot.Irc.Core
|
|
||||||
|
|
||||||
-- | Main function
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
args <- getArgs
|
|
||||||
-- Parse options, getting a list of option actions
|
|
||||||
let (actions, nonOptions, errors) = getOpt RequireOrder options args
|
|
||||||
-- Here we thread startOptions through all supplied option actions
|
|
||||||
opts <- case (nonOptions, errors) of
|
|
||||||
([], []) -> foldl (>>=) (return defaultOptions) actions
|
|
||||||
(_, _) -> do
|
|
||||||
hPutStrLn stderr $ concat errors ++ usageInfo header options
|
|
||||||
exitWith $ ExitFailure 1
|
|
||||||
-- From there the initialization code truly begins
|
|
||||||
when (optDebug opts) . putStrLn $ "[hsbot-irc] Got CLI options :\n" ++ (show opts)
|
|
||||||
-- We find and parse the config file
|
|
||||||
ircConfig <- getIrcConfig $ optConfigFile opts
|
|
||||||
when (optDebug opts) . putStrLn $ "[hsbot-irc] Compiled config :\n" ++ (show ircConfig)
|
|
||||||
-- Finally we get into the ircbot stuff
|
|
||||||
case optDebug opts of
|
|
||||||
True -> startIrcbot opts ircConfig
|
|
||||||
False -> startIrcbot opts ircConfig -- TODO : fork process in background
|
|
||||||
|
|
||||||
|
|
@ -1,5 +0,0 @@
|
||||||
#!/usr/bin/env runhaskell
|
|
||||||
|
|
||||||
import Distribution.Simple
|
|
||||||
|
|
||||||
main = defaultMain
|
|
||||||
3
HsbotMaster/.gitignore
vendored
3
HsbotMaster/.gitignore
vendored
|
|
@ -1,3 +0,0 @@
|
||||||
.*.swp
|
|
||||||
Session.vim
|
|
||||||
dist
|
|
||||||
2
HsbotMaster/Hsbot/.gitignore
vendored
2
HsbotMaster/Hsbot/.gitignore
vendored
|
|
@ -1,2 +0,0 @@
|
||||||
.*.swp
|
|
||||||
Session.vim
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
module Hsbot.Config
|
|
||||||
( BotConfig (..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Hsbot.Irc.Config
|
|
||||||
|
|
||||||
-- | Configuration data type
|
|
||||||
data BotConfig = IrcBotConfig IrcConfig
|
|
||||||
|
|
||||||
|
|
@ -1,91 +0,0 @@
|
||||||
module Hsbot.Core
|
|
||||||
( hsbot
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
import Control.Concurrent.MVar
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Time
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
import System.IO()
|
|
||||||
import System.Posix.Signals
|
|
||||||
|
|
||||||
import Hsbot.Config
|
|
||||||
import Hsbot.Message
|
|
||||||
import Hsbot.Plugin
|
|
||||||
import Hsbot.Types
|
|
||||||
|
|
||||||
-- | Bot's main entry point
|
|
||||||
hsbot :: [BotConfig] -> Maybe String -> IO ()
|
|
||||||
hsbot config txtResumeData= do
|
|
||||||
let resumeData = case txtResumeData of
|
|
||||||
Just txtData -> read txtData :: BotResumeData -- TODO : catch exception
|
|
||||||
Nothing -> M.empty :: BotResumeData
|
|
||||||
startTime <- case M.lookup "HSBOT" resumeData of
|
|
||||||
Just hsbotData -> do
|
|
||||||
case M.lookup "STARTTIME" hsbotData of
|
|
||||||
Just txtStartTime -> do
|
|
||||||
let gotStartTime = read txtStartTime :: UTCTime
|
|
||||||
return gotStartTime
|
|
||||||
Nothing -> getCurrentTime
|
|
||||||
Nothing -> getCurrentTime
|
|
||||||
let resumeData' = M.insert "HSBOT" (M.singleton "STARTTIME" $ show startTime) resumeData
|
|
||||||
putStrLn "[Hsbot] Opening communication channel... "
|
|
||||||
chan <- newChan :: IO (Chan BotMsg)
|
|
||||||
mvar <- newMVar resumeData' :: IO (MVar BotResumeData)
|
|
||||||
putStrLn "[Hsbot] Installing signal handlers... "
|
|
||||||
_ <- installHandler sigHUP (Catch $ sigHupHandler chan) Nothing
|
|
||||||
_ <- installHandler sigTERM (Catch $ sigTermHandler chan) Nothing
|
|
||||||
putStrLn "[Hsbot] Spawning IrcBot plugins... "
|
|
||||||
botState <- execStateT spawnPlugins BotState { botStartTime = startTime
|
|
||||||
, botPlugins = M.empty
|
|
||||||
, botChan = chan
|
|
||||||
, botConfig = config
|
|
||||||
, botResumeData = mvar }
|
|
||||||
putStrLn "[Hsbot] Entering main loop... "
|
|
||||||
(status, botState') <- runLoop botState
|
|
||||||
putStrLn "[Hsbot] Killing active plugins... "
|
|
||||||
newResumeData <- takeMVar mvar
|
|
||||||
evalStateT (mapM_ killPlugin $ M.keys newResumeData) botState'
|
|
||||||
if status == BotReboot
|
|
||||||
then hsbot config (Just $ show newResumeData) -- TODO : exec on the hsbot launcher with the reload string
|
|
||||||
else return ()
|
|
||||||
where
|
|
||||||
runLoop :: BotState -> IO (BotStatus, BotState)
|
|
||||||
runLoop botState = do
|
|
||||||
(status, botState') <- (runStateT botCore botState) `catches` [ Handler (\ (_ :: IOException) -> return (BotExit, botState))
|
|
||||||
, Handler (\ (_ :: AsyncException) -> return (BotExit, botState)) ]
|
|
||||||
case status of
|
|
||||||
BotContinue -> runLoop botState'
|
|
||||||
_ -> return (status, botState')
|
|
||||||
|
|
||||||
-- | Run the bot main loop
|
|
||||||
botCore :: Bot (BotStatus)
|
|
||||||
botCore = do
|
|
||||||
chan <- gets botChan
|
|
||||||
msg <- liftIO $ readChan chan
|
|
||||||
case msg of
|
|
||||||
IntMsg intMsg -> processInternalMessage intMsg
|
|
||||||
UpdMsg updMsg -> processUpdateMessage updMsg
|
|
||||||
RebMsg rebMsg -> processRebootMessage rebMsg
|
|
||||||
ExiMsg exiMsg -> processExitMessage exiMsg
|
|
||||||
|
|
||||||
-- | Process an update command
|
|
||||||
processUpdateMessage :: ResumeMsg -> Bot (BotStatus)
|
|
||||||
processUpdateMessage msg = do
|
|
||||||
resumeData <- gets botResumeData
|
|
||||||
let from = resMsgFrom msg
|
|
||||||
stuff = resMsgData msg
|
|
||||||
liftIO $ modifyMVar_ resumeData (\oldData -> return $ M.insert from stuff oldData)
|
|
||||||
return BotContinue
|
|
||||||
|
|
||||||
-- | signals handlers
|
|
||||||
sigHupHandler :: Chan BotMsg -> IO ()
|
|
||||||
sigHupHandler chan = writeChan chan $ RebMsg RebootMsg { rebMsgFrom = "HUP handler" }
|
|
||||||
|
|
||||||
-- | signals handlers
|
|
||||||
sigTermHandler :: Chan BotMsg -> IO ()
|
|
||||||
sigTermHandler chan = writeChan chan $ ExiMsg ExitMsg { exiMsgFrom = "TERM handler" }
|
|
||||||
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
module Hsbot.Message
|
|
||||||
( processInternalMessage
|
|
||||||
, processRebootMessage
|
|
||||||
, processExitMessage
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
|
|
||||||
import Hsbot.PluginUtils
|
|
||||||
import Hsbot.Types
|
|
||||||
|
|
||||||
-- | Processes an internal message
|
|
||||||
processInternalMessage :: Msg -> Bot (BotStatus)
|
|
||||||
processInternalMessage msg
|
|
||||||
| msgTo msg == "CORE" = processCoreMessage msg
|
|
||||||
| otherwise = do
|
|
||||||
plugins <- gets botPlugins
|
|
||||||
case M.lookup (msgTo msg) plugins of
|
|
||||||
Just (plugin, _, _) -> sendToPlugin (IntMsg msg) plugin
|
|
||||||
Nothing -> return ()
|
|
||||||
return BotContinue
|
|
||||||
|
|
||||||
processCoreMessage :: Msg -> Bot (BotStatus)
|
|
||||||
processCoreMessage msg = do
|
|
||||||
case msgType msg of
|
|
||||||
"REBOOT" -> return BotReboot
|
|
||||||
_ -> return BotContinue
|
|
||||||
|
|
||||||
processRebootMessage :: RebootMsg -> Bot (BotStatus)
|
|
||||||
processRebootMessage _ = return BotReboot -- TODO : check who is sending that to us
|
|
||||||
|
|
||||||
processExitMessage :: ExitMsg -> Bot (BotStatus)
|
|
||||||
processExitMessage _ = return BotExit -- TODO : check who is sending that to us
|
|
||||||
|
|
||||||
|
|
@ -1,67 +0,0 @@
|
||||||
module Hsbot.Plugin
|
|
||||||
( killPlugin
|
|
||||||
, spawnPlugins
|
|
||||||
, spawnPlugin
|
|
||||||
, unloadPlugin
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent (forkIO)
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
import Control.Concurrent.MVar
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
|
|
||||||
import Hsbot.Config
|
|
||||||
import Hsbot.Irc.Config
|
|
||||||
import Hsbot.Irc.Core
|
|
||||||
import Hsbot.Types
|
|
||||||
|
|
||||||
-- | spawns plugins
|
|
||||||
spawnPlugins :: Bot ()
|
|
||||||
spawnPlugins = do
|
|
||||||
config <- gets botConfig
|
|
||||||
mapM_ (spawnPlugin) config
|
|
||||||
|
|
||||||
-- | spawns a single plugin
|
|
||||||
spawnPlugin :: BotConfig -> Bot ()
|
|
||||||
spawnPlugin (IrcBotConfig ircConfig) = do
|
|
||||||
bot <- get
|
|
||||||
let mvar = botResumeData bot
|
|
||||||
name = ircConfigName ircConfig
|
|
||||||
resumeData <- liftIO $ takeMVar mvar
|
|
||||||
let pluginResumeData = fromMaybe M.empty $ M.lookup name resumeData
|
|
||||||
chan = botChan bot
|
|
||||||
pchan <- liftIO (newChan :: IO (Chan BotMsg))
|
|
||||||
pluginMVar <- liftIO newEmptyMVar
|
|
||||||
threadId <- liftIO . forkIO $ finally (startIrcbot ircConfig chan pchan (Just $ show pluginResumeData)) (putMVar pluginMVar ())
|
|
||||||
let plugin = PluginState { pluginName = name
|
|
||||||
, pluginChan = pchan
|
|
||||||
, pluginHandles = M.empty }
|
|
||||||
plugins = botPlugins bot
|
|
||||||
put $ bot { botPlugins = M.insert (pluginName plugin) (plugin, pluginMVar, threadId) plugins }
|
|
||||||
liftIO . putMVar mvar $ M.insert name pluginResumeData resumeData
|
|
||||||
|
|
||||||
-- | Unloads a plugin
|
|
||||||
unloadPlugin :: String -> Bot ()
|
|
||||||
unloadPlugin name = do
|
|
||||||
killPlugin name
|
|
||||||
resumeData <- gets botResumeData
|
|
||||||
liftIO $ modifyMVar_ resumeData (\oldData -> return $ M.delete name oldData)
|
|
||||||
|
|
||||||
-- | kills a plugin
|
|
||||||
killPlugin :: String -> Bot ()
|
|
||||||
killPlugin name = do
|
|
||||||
bot <- get
|
|
||||||
let oldPlugins = botPlugins bot
|
|
||||||
-- We check if the plugin exists
|
|
||||||
case M.lookup name oldPlugins of
|
|
||||||
Just (_, mvar, threadId) -> do
|
|
||||||
let newPlugins = M.delete name oldPlugins
|
|
||||||
liftIO $ throwTo threadId UserInterrupt
|
|
||||||
put $ bot { botPlugins = newPlugins }
|
|
||||||
liftIO $ takeMVar mvar
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
|
|
@ -1,15 +0,0 @@
|
||||||
module Hsbot.PluginUtils
|
|
||||||
( sendToPlugin
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Concurrent.Chan ()
|
|
||||||
import Control.Monad.State
|
|
||||||
|
|
||||||
import Hsbot.Types
|
|
||||||
|
|
||||||
-- | Sends a msg to a plugin
|
|
||||||
sendToPlugin :: BotMsg -> PluginState -> Bot ()
|
|
||||||
sendToPlugin botMsg plugin = do
|
|
||||||
liftIO $ writeChan (pluginChan plugin) botMsg
|
|
||||||
|
|
||||||
|
|
@ -1,72 +0,0 @@
|
||||||
module Hsbot.Types
|
|
||||||
( Bot
|
|
||||||
, BotMsg (..)
|
|
||||||
, BotResumeData
|
|
||||||
, BotState (..)
|
|
||||||
, BotStatus (..)
|
|
||||||
, ExitMsg (..)
|
|
||||||
, Msg (..)
|
|
||||||
, Plugin
|
|
||||||
, PluginState (..)
|
|
||||||
, RebootMsg (..)
|
|
||||||
, ResumeData
|
|
||||||
, ResumeMsg (..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Monad.State
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Time
|
|
||||||
import System.IO
|
|
||||||
|
|
||||||
-- | The Bot monad
|
|
||||||
type Bot = StateT BotState IO
|
|
||||||
|
|
||||||
-- | An Hsbot state
|
|
||||||
data BotState = BotState
|
|
||||||
{ botStartTime :: UTCTime -- the bot's uptime
|
|
||||||
, botPlugins :: M.Map String (PluginState, MVar (), ThreadId) -- Loaded plugins
|
|
||||||
, botChan :: Chan BotMsg -- the bot's communication channel
|
|
||||||
, botResumeData :: MVar BotResumeData -- the necessary data to resume the bot's operations on reboot
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | how we exit from the botLoop
|
|
||||||
data BotStatus = BotExit | BotReboot | BotContinue deriving (Eq)
|
|
||||||
|
|
||||||
-- | Types to factorise resume data
|
|
||||||
type ResumeData = M.Map String String
|
|
||||||
type BotResumeData = M.Map String ResumeData
|
|
||||||
|
|
||||||
-- | The Plugin monad
|
|
||||||
type Plugin = StateT PluginState IO
|
|
||||||
|
|
||||||
-- | A plugin state
|
|
||||||
data PluginState = PluginState
|
|
||||||
{ pluginName :: String -- The plugin's name
|
|
||||||
, pluginChan :: Chan BotMsg -- The plugin chan
|
|
||||||
, pluginHandles :: M.Map String Handle -- the plugins's handles
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | A hsbot message
|
|
||||||
data Msg = Msg
|
|
||||||
{ msgType :: String -- the message type
|
|
||||||
, msgFrom :: String -- who issues it
|
|
||||||
, msgTo :: String -- who it is destinated to
|
|
||||||
, msgStuff :: String -- the message to be transfered
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
data ResumeMsg = ResMsg
|
|
||||||
{ resMsgFrom :: String
|
|
||||||
, resMsgData :: ResumeData
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
data RebootMsg = RebootMsg
|
|
||||||
{ rebMsgFrom :: String
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
data ExitMsg = ExitMsg
|
|
||||||
{ exiMsgFrom :: String
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
data BotMsg = IntMsg Msg | UpdMsg ResumeMsg | RebMsg RebootMsg | ExiMsg ExitMsg deriving (Show)
|
|
||||||
|
|
||||||
|
|
@ -1,30 +0,0 @@
|
||||||
Copyright (c)2010, Julien Dessaux
|
|
||||||
|
|
||||||
All rights reserved.
|
|
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without
|
|
||||||
modification, are permitted provided that the following conditions are met:
|
|
||||||
|
|
||||||
* Redistributions of source code must retain the above copyright
|
|
||||||
notice, this list of conditions and the following disclaimer.
|
|
||||||
|
|
||||||
* Redistributions in binary form must reproduce the above
|
|
||||||
copyright notice, this list of conditions and the following
|
|
||||||
disclaimer in the documentation and/or other materials provided
|
|
||||||
with the distribution.
|
|
||||||
|
|
||||||
* Neither the name of Julien Dessaux nor the names of other
|
|
||||||
contributors may be used to endorse or promote products derived
|
|
||||||
from this software without specific prior written permission.
|
|
||||||
|
|
||||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
||||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
|
||||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
|
||||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
||||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
||||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
||||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
||||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
||||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
|
|
@ -1,74 +0,0 @@
|
||||||
module Main (main) where
|
|
||||||
|
|
||||||
import Control.Monad (when)
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
import System.Console.GetOpt
|
|
||||||
import System.Environment
|
|
||||||
import System.Exit
|
|
||||||
import System.IO
|
|
||||||
|
|
||||||
-- | Main function
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
args <- getArgs
|
|
||||||
-- Parse options, getting a list of option actions
|
|
||||||
let (actions, nonOptions, errors) = getOpt RequireOrder options args
|
|
||||||
-- Here we thread startOptions through all supplied option actions
|
|
||||||
opts <- case (nonOptions, errors) of
|
|
||||||
([], []) -> foldl (>>=) (return defaultOptions) actions
|
|
||||||
(_, _) -> do
|
|
||||||
hPutStrLn stderr $ concat errors ++ usageInfo header options
|
|
||||||
exitWith $ ExitFailure 1
|
|
||||||
when (optDebug opts) . putStrLn $ "Got options : " ++ (show opts)
|
|
||||||
|
|
||||||
-- | CLI options
|
|
||||||
data Options = Options
|
|
||||||
{ optDebug :: Bool
|
|
||||||
, optConfigFile :: Maybe String
|
|
||||||
, optGroup :: Maybe String
|
|
||||||
, optUser :: Maybe String
|
|
||||||
, optVerbose :: Bool
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
-- | CLI default options
|
|
||||||
defaultOptions :: Options
|
|
||||||
defaultOptions = Options { optDebug = False
|
|
||||||
, optConfigFile = Nothing
|
|
||||||
, optGroup = Nothing
|
|
||||||
, optUser = Nothing
|
|
||||||
, optVerbose = False }
|
|
||||||
|
|
||||||
-- | CLI options logic
|
|
||||||
options :: [ OptDescr (Options -> IO Options) ]
|
|
||||||
options =
|
|
||||||
[ Option "d" ["debug"]
|
|
||||||
(NoArg (\opt -> return opt { optDebug = True, optVerbose = True }))
|
|
||||||
"Enter verbose debug mode and prevents Hsbot from forking in background"
|
|
||||||
, Option "f" ["file"]
|
|
||||||
(ReqArg (\arg opt -> return opt { optConfigFile = return arg }) "<config_file>")
|
|
||||||
"The config file to use"
|
|
||||||
, Option "g" ["group"]
|
|
||||||
(ReqArg (\arg opt -> return opt { optGroup = return arg }) "<group>")
|
|
||||||
"The group hsbot will run as"
|
|
||||||
, Option "h" ["help"]
|
|
||||||
(NoArg (\_ -> do
|
|
||||||
putStrLn $ usageInfo header options
|
|
||||||
exitWith ExitSuccess))
|
|
||||||
"Print this help message"
|
|
||||||
, Option "u" ["user"]
|
|
||||||
(ReqArg (\arg opt -> return opt { optUser = return arg }) "<user>")
|
|
||||||
"The user hsbot will run as"
|
|
||||||
, Option "v" ["verbose"]
|
|
||||||
(NoArg (\opt -> return opt { optVerbose = True }))
|
|
||||||
"Enable verbose messages"
|
|
||||||
, Option "V" ["version"]
|
|
||||||
(NoArg (\_ -> do
|
|
||||||
putStrLn "Hsbot version 0.3"
|
|
||||||
exitWith ExitSuccess))
|
|
||||||
"Show version"
|
|
||||||
]
|
|
||||||
|
|
||||||
-- | Usage header
|
|
||||||
header :: String
|
|
||||||
header = "Usage: hsbot [-dhvV] [-f config_file] [-u user] [-g group]"
|
|
||||||
|
|
||||||
|
|
@ -1,5 +0,0 @@
|
||||||
#!/usr/bin/env runhaskell
|
|
||||||
|
|
||||||
import Distribution.Simple
|
|
||||||
|
|
||||||
main = defaultMain
|
|
||||||
|
|
@ -1,38 +0,0 @@
|
||||||
Name: hsbot
|
|
||||||
Version: 0.3
|
|
||||||
Cabal-version: >=1.2
|
|
||||||
Synopsis: A multi-purposes bot.
|
|
||||||
Description:
|
|
||||||
hsbot is a multi-purpose bot, written slowly, as long as I learned more
|
|
||||||
haskell. It features IRC integration and some plugins. I tried to design
|
|
||||||
a bot architecture as modular and as flexible as possible.
|
|
||||||
Homepage: http://hsbot.adyxax.org/
|
|
||||||
License: BSD3
|
|
||||||
License-file: LICENSE
|
|
||||||
Author: Julien Dessaux
|
|
||||||
Maintainer: judessaux@gmail.com
|
|
||||||
Copyright: Copyright (c) 2010 Julien Dessaux
|
|
||||||
Category: Hsbot
|
|
||||||
Build-type: Simple
|
|
||||||
|
|
||||||
|
|
||||||
Executable hsbot
|
|
||||||
Main-is: Main.hs
|
|
||||||
Ghc-options: -Wall
|
|
||||||
Extensions: DeriveDataTypeable ScopedTypeVariables
|
|
||||||
Build-depends: base >= 4.1 && < 5
|
|
||||||
|
|
||||||
Library
|
|
||||||
Ghc-options: -Wall
|
|
||||||
Extensions: DeriveDataTypeable ScopedTypeVariables
|
|
||||||
Exposed-modules: Hsbot.Message,
|
|
||||||
Hsbot.Types
|
|
||||||
Build-depends: base >= 4.1 && < 5,
|
|
||||||
containers >= 0.3,
|
|
||||||
mtl >= 1.1,
|
|
||||||
time >= 1.1
|
|
||||||
|
|
||||||
-- Extra files to be distributed with the package, such as examples or
|
|
||||||
-- a README.
|
|
||||||
-- Extra-source-files:
|
|
||||||
|
|
||||||
38
LICENSE
38
LICENSE
|
|
@ -1,14 +1,30 @@
|
||||||
Copyright (c) 2009, Julien Dessaux judessaux@gmail.com
|
Copyright (c)2010, Julien Dessaux
|
||||||
|
|
||||||
Permission to use, copy, modify, and/or distribute this software for any
|
All rights reserved.
|
||||||
purpose with or without fee is hereby granted, provided that the above
|
|
||||||
copyright notice and this permission notice appear in all copies.
|
|
||||||
|
|
||||||
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
Redistribution and use in source and binary forms, with or without
|
||||||
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
modification, are permitted provided that the following conditions are met:
|
||||||
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
||||||
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
||||||
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
||||||
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
||||||
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
|
|
||||||
|
* Redistributions of source code must retain the above copyright
|
||||||
|
notice, this list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
* Redistributions in binary form must reproduce the above
|
||||||
|
copyright notice, this list of conditions and the following
|
||||||
|
disclaimer in the documentation and/or other materials provided
|
||||||
|
with the distribution.
|
||||||
|
|
||||||
|
* Neither the name of Julien Dessaux nor the names of other
|
||||||
|
contributors may be used to endorse or promote products derived
|
||||||
|
from this software without specific prior written permission.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||||
|
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||||
|
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||||
|
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||||
|
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||||
|
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||||
|
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||||
|
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||||
|
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
|
||||||
6
Main.hs
Normal file
6
Main.hs
Normal file
|
|
@ -0,0 +1,6 @@
|
||||||
|
import Hsbot
|
||||||
|
import Hsbot.Config
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = hsbot defaultConfig
|
||||||
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
Name: hsbot-irc
|
Name: hsbot
|
||||||
Version: 0.3.11
|
Version: 0.4
|
||||||
Cabal-version: >=1.2
|
Cabal-version: >=1.2
|
||||||
Synopsis: The irc part of a multi-purposes bot.
|
Synopsis: A multipurposes IRC bot
|
||||||
Description:
|
Description:
|
||||||
hsbot is a multi-purpose bot, written slowly, as long as I learned more
|
hsbot is a multi-purpose bot, written slowly, as long as I learned more
|
||||||
haskell. It features IRC integration and some plugins. I tried to design
|
haskell. It features IRC integration and some plugins. I tried to design
|
||||||
|
|
@ -16,22 +16,33 @@ Category: Hsbot
|
||||||
Build-type: Simple
|
Build-type: Simple
|
||||||
|
|
||||||
|
|
||||||
Executable hsbot-irc
|
Library
|
||||||
|
ghc-options: -Wall
|
||||||
|
exposed-modules: Hsbot
|
||||||
|
--Hsbot.Command
|
||||||
|
Hsbot.Config
|
||||||
|
Hsbot.Core
|
||||||
|
--Hsbot.Plugin
|
||||||
|
Hsbot.Types
|
||||||
|
Hsbot.Utils
|
||||||
|
Extensions: DeriveDataTypeable FlexibleContexts ScopedTypeVariables
|
||||||
|
Build-depends: base >= 4.1 && < 5,
|
||||||
|
bytestring,
|
||||||
|
certificate,
|
||||||
|
containers,
|
||||||
|
cryptocipher,
|
||||||
|
dyre,
|
||||||
|
hslogger,
|
||||||
|
irc,
|
||||||
|
mtl,
|
||||||
|
network,
|
||||||
|
tls >= 0.5.1,
|
||||||
|
tls-extra >= 0.1.2
|
||||||
|
|
||||||
|
|
||||||
|
Executable hsbot
|
||||||
Main-is: Main.hs
|
Main-is: Main.hs
|
||||||
Ghc-options: -Wall
|
Ghc-options: -Wall
|
||||||
Extensions: DeriveDataTypeable FlexibleContexts ScopedTypeVariables
|
Extensions: DeriveDataTypeable FlexibleContexts ScopedTypeVariables
|
||||||
Build-depends: base >= 4.1 && < 5,
|
Build-depends: base >= 4.1 && < 5
|
||||||
ConfigFile,
|
|
||||||
containers,
|
|
||||||
directory,
|
|
||||||
filepath,
|
|
||||||
haskell98,
|
|
||||||
MissingH,
|
|
||||||
mtl,
|
|
||||||
network,
|
|
||||||
parsec,
|
|
||||||
random,
|
|
||||||
text,
|
|
||||||
time,
|
|
||||||
unix
|
|
||||||
|
|
||||||
Reference in a new issue