adyxax/hsbot
Archived
1
0
Fork 0
Code Issues Activity

Began a big refactoring/rewriting (again)

Browse source
This commit is contained in:
Julien Dessaux 2011-04-13 20:15:55 +02:00
parent d05aea2def
commit ff07633fb8
41 changed files with 423 additions and 5107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -1,2 +1,3 @@
.*.swp
Session.vim
dist

39
Hsbot.hs Normal file
View 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
View 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
View 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
View 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
View 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
View file

@ -1,3 +0,0 @@
.*.swp
Session.vim
dist

2
HsbotIrcBot/Hsbot/.gitignore vendored
View file

@ -1,2 +0,0 @@
.*.swp
Session.vim

2
HsbotIrcBot/Hsbot/Irc/.gitignore vendored
View file

@ -1,2 +0,0 @@
.*.swp
Session.vim

63
HsbotIrcBot/Hsbot/Irc/CLI.hs
View file

@ -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]"
-- }}}

63
HsbotIrcBot/Hsbot/Irc/Command.hs
View file

@ -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

134
HsbotIrcBot/Hsbot/Irc/Config.hs
View file

@ -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")

130
HsbotIrcBot/Hsbot/Irc/Core.hs
View file

@ -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)

73
HsbotIrcBot/Hsbot/Irc/Message.hs
View file

@ -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

89
HsbotIrcBot/Hsbot/Irc/Plugin.hs
View file

@ -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 ()

66
HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs
View file

@ -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

27
HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs
View file

@ -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 ()

33
HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs
View file

@ -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 ()

201
HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs
View file

@ -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)

66
HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs
View file

@ -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

35
HsbotIrcBot/Hsbot/Irc/Server.hs
View file

@ -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)

50
HsbotIrcBot/Hsbot/Irc/Types.hs
View file

@ -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

3531
HsbotIrcBot/Hsbot/Irc/doc/rfc2812.txt
View file

File diff suppressed because it is too large Load diff

30
HsbotIrcBot/LICENSE
View file

@ -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.

34
HsbotIrcBot/Main.hs
View file

@ -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

5
HsbotIrcBot/Setup.hs
View file

@ -1,5 +0,0 @@
#!/usr/bin/env runhaskell
import Distribution.Simple
main = defaultMain

3
HsbotMaster/.gitignore vendored
View file

@ -1,3 +0,0 @@
.*.swp
Session.vim
dist

2
HsbotMaster/Hsbot/.gitignore vendored
View file

@ -1,2 +0,0 @@
.*.swp
Session.vim

9
HsbotMaster/Hsbot/Config.hs
View file

@ -1,9 +0,0 @@
module Hsbot.Config
( BotConfig (..)
) where
import Hsbot.Irc.Config
-- | Configuration data type
data BotConfig = IrcBotConfig IrcConfig

91
HsbotMaster/Hsbot/Core.hs
View file

@ -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" }

35
HsbotMaster/Hsbot/Message.hs
View file

@ -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

67
HsbotMaster/Hsbot/Plugin.hs
View file

@ -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 ()

15
HsbotMaster/Hsbot/PluginUtils.hs
View file

@ -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

72
HsbotMaster/Hsbot/Types.hs
View file

@ -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)

30
HsbotMaster/LICENSE
View file

@ -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.

74
HsbotMaster/Main.hs
View file

@ -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]"

5
HsbotMaster/Setup.hs
View file

@ -1,5 +0,0 @@
#!/usr/bin/env runhaskell
import Distribution.Simple
main = defaultMain

38
HsbotMaster/hsbot.cabal
View file

@ -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
View file

@ -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
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
All rights reserved.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
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.
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.

6
Main.hs Normal file
View file

@ -0,0 +1,6 @@
import Hsbot
import Hsbot.Config
main :: IO ()
main = hsbot defaultConfig

47
HsbotIrcBot/hsbot-irc.cabal → hsbot.cabal
View file

@ -1,7 +1,7 @@
Name: hsbot-irc
Version: 0.3.11
Name: hsbot
Version: 0.4
Cabal-version: >=1.2
Synopsis: The irc part of a multi-purposes bot.
Synopsis: A multipurposes IRC 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
@ -16,22 +16,33 @@ Category: Hsbot
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
Ghc-options: -Wall
Extensions: DeriveDataTypeable FlexibleContexts ScopedTypeVariables
Build-depends: base >= 4.1 && < 5,
ConfigFile,
containers,
directory,
filepath,
haskell98,
MissingH,
mtl,
network,
parsec,
random,
text,
time,
unix
Build-depends: base >= 4.1 && < 5