adyxax/hsbot
Archived
1
0
Fork 0
Code Issues Activity

Merge branch 'master' into quoteModule

Browse source 
Conflicts:
	hsbot.cabal
This commit is contained in:
Julien Dessaux 2011-09-10 00:10:00 +02:00
commit 900c242551
11 changed files with 203 additions and 169 deletions
Download patch file Download diff file Expand all files Collapse all files

26
Hsbot.hs
View file

@ -5,30 +5,48 @@ module Hsbot
import qualified Config.Dyre as Dyre
import Config.Dyre.Relaunch
import Control.Monad.Reader
import qualified Data.Map as M
import System.Log.Logger
import Hsbot.Core
import Hsbot.Types
data State = State (M.Map String String) deriving (Read, Show)
startHsbot :: Config -> IO ()
startHsbot config = do
(State buffer) <- restoreTextState $ State M.empty
-- checking for configuration file compilation error
case configErrors config of
Nothing -> return ()
Just em -> putStrLn $ "Error: " ++ em
-- Handle previous exit state if it exists
dieMsgs <- case M.lookup "die_msg" buffer of
Just dieMsg -> case reads dieMsg :: [(BotStatus, String)] of
(status, _):_ -> case status of
BotReload reason -> return ["hsbot reloaded, reason : " ++ reason]
BotRestart (reason, Just info) -> return ["hsbot restarted, reason : " ++ reason, "additional information: " ++ info]
BotRestart (reason, Nothing) -> return ["hsbot restarted, reason : " ++ reason]
BotExit -> return []
_ -> return ["hsbot die_msg parsing error, this should not happen"]
Nothing -> return []
mapM_ (infoM "Hsbot") dieMsgs
-- initialization
infoM "Hsbot" "Bot initializations"
hsbotEnv <- initHsbot config
-- main stuff
infoM "Hsbot" "Bot core starting"
status <- runReaderT runHsbot hsbotEnv
status <- runReaderT (runHsbot dieMsgs) 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
BotReload reason -> do
runReaderT terminateHsbot hsbotEnv
relaunchWithTextState (State $ M.singleton "die_msg" . show $ BotReload reason) Nothing -- TODO find a way to properly implement that, then insert necessary information in this MVar
BotRestart reason -> do
runReaderT terminateHsbot hsbotEnv
relaunchWithTextState (State $ M.singleton "die_msg" . show $ BotRestart reason) Nothing
hsbot :: Config -> IO ()
hsbot = Dyre.wrapMain $ Dyre.defaultParams

7
Hsbot/Config.hs
View file

@ -16,6 +16,7 @@ defaultConfig = Config
, configTLS = noSSL
, configAddress = "localhost"
, configPort = PortNumber 6667
, configAccess = []
, configChannels = ["#hsbot"]
, configNicknames = ["hsbot"]
, configRealname = "The One True bot, with it's haskell soul."
@ -24,12 +25,8 @@ defaultConfig = Config
defaultTLSConfig :: TLSConfig
defaultTLSConfig = TLSConfig
{ sslOn = True
, sslCert = ""
, sslKey = ""
, sslVersions = [SSL3, TLS10, TLS11, TLS12]
, sslCiphers = [ cipher_null_MD5
, cipher_null_SHA1
, cipher_AES128_SHA1
, sslCiphers = [ cipher_AES128_SHA1
, cipher_AES256_SHA1
, cipher_RC4_128_MD5
, cipher_RC4_128_SHA1

58
Hsbot/Core.hs
View file

@ -8,8 +8,7 @@ import Control.Concurrent
import Control.Exception (IOException, catch)
import Control.Monad.Reader
import Crypto.Random
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as L
import qualified Data.Map as M
import Network
import qualified Network.IRC as IRC
@ -33,15 +32,16 @@ initHsbot config = do
port = configPort config
infoM "Hsbot.Core" $ "Connecting to " ++ hostname -- ++ ":" ++ port
connhdl <- connectTo hostname port
hSetBuffering connhdl LineBuffering
hSetBuffering connhdl NoBuffering
hSetEncoding connhdl utf8
(tls, tlsCtx) <- if sslOn $ configTLS config
then (do
infoM "Hsbot.Core" "TLS init"
infoM "Hsbot.Core" "Initializing TLS communication"
tlsenv <- initTLSEnv (configTLS config)
randomGen <- newGenIO :: IO SystemRandom
sCtx <- client tlsenv randomGen connhdl
handshake sCtx
success <- handshake sCtx
unless success $ errorM "Hsbot.Core" "TLS handshake failed" -- TODO: do some usefull error handling
return (Just tlsenv, Just sCtx))
else return (Nothing, Nothing)
return BotEnv { envBotState = botState
@ -53,8 +53,8 @@ initHsbot config = do
, envTLS = tls
, envTLSCtx = tlsCtx }
runHsbot :: Env IO BotStatus
runHsbot = do
runHsbot :: [String] -> Env IO BotStatus
runHsbot die_msgs = do
botNotInitialized <- asks envBotState >>= liftIO . isEmptyMVar
when botNotInitialized runFirstSteps
trueRunHsbot
@ -70,12 +70,15 @@ runHsbot = do
config = envConfig env
nickname = head $ configNicknames config
channels = configChannels config
liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.nick nickname
liftIO . sendStr connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.nick nickname
liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
-- Then we join channels
mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
mapM_ (liftIO . sendStr env connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
-- We advertise any death message we should
mapM_ (\msg -> mapM_ (\channel -> liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.Message Nothing "PRIVMSG" [channel, msg]) channels) die_msgs
-- Finally we set the new bot state
asks envBotState >>= liftIO . flip putMVar BotState { botPlugins = M.empty
, botAccess = configAccess config
, botHooks = []
, botChannels = channels
, botNickname = nickname }
@ -87,9 +90,8 @@ runHsbot = do
liftIO $ debugM "Hsbot.Core" "Spawning reader thread"
let connhdl = envHandle env
tlsCtx = envTLSCtx env
myOwnThreadId <- liftIO myThreadId
chan <- asks envChan
(liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= addThreadIdToQuitMVar
(liftIO . forkIO $ botReader env connhdl tlsCtx chan) >>= addThreadIdToQuitMVar
-- Then we spawn all plugins
asks envConfig >>= mapM_ loadPlugin . configPlugins
-- Finally we spawn the main bot loop
@ -101,26 +103,26 @@ runHsbot = do
-- TODO : kill plugin threads
return code
botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
botReader _ (Just ctx) chan _ = forever $
fmap L.toChunks (recvData ctx) >>= 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 ""
botReader :: BotEnv -> Handle -> Maybe TLSCtx -> Chan Message -> IO ()
botReader env _ (Just ctx) chan = forever $
fmap L.toString (recvData ctx) `catch` handleIOException env "botReader died" >>= handleIncomingStr chan
botReader env handle Nothing chan = forever $
hGetLine handle `catch` handleIOException env "botReader died" >>= handleIncomingStr chan
handleIOException :: BotEnv -> String -> IOException -> IO String
handleIOException env msg ioException = do
runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env
myId <- myThreadId
killThread myId
return ""
handleIncomingStr :: Chan Message -> String -> IO ()
handleIncomingStr chan str =
case IRC.decode str of
Just msg -> do
debugM "Ircd.Reader" $ "<-- " ++ show msg
debugM "Hsbot.Reader" $ "<-- " ++ show msg
writeChan chan $ IncomingMsg msg
Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control
Nothing -> return ()
botLoop :: Env IO ()
botLoop = forever $ do
@ -134,8 +136,8 @@ botLoop = forever $ do
env <- ask
let connhdl = envHandle env
tlsCtx = envTLSCtx env
liftIO $ debugM "Ircd.Reader" $ "--> " ++ show outMsg
liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg
liftIO . sendStr env connhdl tlsCtx $ IRC.encode outMsg
terminateHsbot :: Env IO ()
terminateHsbot = do

15
Hsbot/Message.hs
View file

@ -30,12 +30,15 @@ answerMsg _ _ = return ()
-- | Get the command in the IRC message if there is one
getCommand :: IRC.Message -> Env IO [String]
getCommand (IRC.Message _ _ (_:msg:[])) = do
currentBotState <- asks envBotState >>= liftIO . readMVar
let cmd:stuff = if msg /= "" then words msg else ["",""]
if botNickname currentBotState `L.isPrefixOf` cmd
then return stuff
else return []
getCommand (IRC.Message _ _ (_:msg:[])) = getCommandFrom $ words msg
where
getCommandFrom :: [String] -> Env IO [String]
getCommandFrom (cmd:stuff) = do
currentBotState <- asks envBotState >>= liftIO . readMVar
if botNickname currentBotState `L.isPrefixOf` cmd
then return stuff
else return []
getCommandFrom _ = return []
getCommand _ = return []
getSender :: IRC.Message -> String

45
Hsbot/Plugin/Admin.hs Normal file
View file

@ -0,0 +1,45 @@
module Hsbot.Plugin.Admin
( admin
, theAdmin
) where
import Control.Concurrent.Chan ()
import Control.Monad.Reader
import qualified Network.IRC as IRC
import Prelude hiding (catch)
import Hsbot.Message
import Hsbot.Types
import Hsbot.Utils
-- | The Admin plugin identity
admin :: PluginId
admin = PluginId
{ pluginName = "admin"
, pluginEp = theAdmin }
-- | An IRC plugin for manage hsbot
theAdmin :: Plugin (Env IO) ()
theAdmin = forever $ readMsg >>= eval
where
eval :: Message -> Plugin (Env IO) ()
eval (IncomingMsg msg)
| IRC.msg_command msg == "PRIVMSG" = do
cmdArgs <- lift $ getCommand msg
case cmdArgs of
"exit":"help":_ -> answerMsg msg "exit hsbot."
"exit":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right
then lift $ setGlobalQuitMVar BotExit
else answerMsg msg "Only admins can do that."
"restart":"help":_ -> answerMsg msg "restart hsbot, reset the running state to config file directives."
"restart":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right
then lift . setGlobalQuitMVar $ BotRestart (getSender msg ++ " request", Nothing)
else answerMsg msg "Only admins can do that."
"reload":"help":_ -> answerMsg msg "reload hsbot, and try merge the new config file directives with actual running state)."
"reload":_ -> lift (hasAccess (IRC.msg_prefix msg) Admin) >>= \right -> if right
then lift . setGlobalQuitMVar . BotReload $ getSender msg ++ " request"
else answerMsg msg "Only admins can do that."
_ -> return ()
| otherwise = return ()
eval _ = return ()

84
Hsbot/Plugin/Duck.hs
View file

@ -1,7 +1,8 @@
{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-}
-- | This module is an IRC plugin that generates and kills ducks
module Hsbot.Plugin.Duck
( duck
( DuckArgs (..)
, duck
, theDuck
) where
@ -12,6 +13,7 @@ import Data.Acid
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.Ord ()
import Data.SafeCopy
import Data.Typeable
import qualified Network.IRC as IRC
@ -22,56 +24,43 @@ import Hsbot.Message
import Hsbot.Types
import Hsbot.Utils
-- | A user statistic
data Stat = Stat
{ statRounds :: Int
, statShot :: Int
, statKilled :: Int
} deriving (Show, Typeable)
-- | Default values for new stat
emptyStat :: Stat
emptyStat = Stat { statRounds = 0
, statShot = 0
, statKilled = 0 }
-- The statistics database
data StatDB = StatDB
{ nickStats :: M.Map String Stat
{ nickStats :: M.Map String Int
} deriving (Show, Typeable)
-- | Statistics database initial state
emptyStatDB :: StatDB
emptyStatDB = StatDB { nickStats = M.empty }
$(deriveSafeCopy 0 'base ''Stat)
$(deriveSafeCopy 0 'base ''StatDB)
-- | Statistics database transactions
scoreAction :: String -> Int -> Int -> Int -> Update StatDB ()
scoreAction sender rounds shots kills = do
updateScore :: String -> Int -> Update StatDB ()
updateScore sender score = do
statDB <- get
let stats = nickStats statDB
stat = fromMaybe emptyStat $ M.lookup sender stats
stat' = stat { statRounds = rounds + statRounds stat
, statShot = shots + statShot stat
, statKilled = kills + statKilled stat }
put statDB { nickStats = M.insert sender stat' stats }
stat = fromMaybe 0 $ M.lookup sender stats
put statDB { nickStats = M.insert sender (stat + score) stats }
getDuckStats :: Query StatDB StatDB
getDuckStats = ask
$(makeAcidic ''StatDB ['getDuckStats, 'scoreAction])
$(makeAcidic ''StatDB ['getDuckStats, 'updateScore])
-- | The duck plugin identity
duck :: PluginId
duck = PluginId
{ pluginName = "duck"
, pluginEp = theDuck "" 10 }
, pluginEp = theDuck DuckArgs { duckChannel = "", duckFreq = 10 } }
data DuckArgs = DuckArgs
{ duckChannel :: String
, duckFreq :: Int }
-- | An IRC plugin that generates and kills ducks
theDuck :: String -> Int -> Plugin (Env IO) ()
theDuck channel seconds = do
theDuck :: DuckArgs -> Plugin (Env IO) ()
theDuck (DuckArgs channel seconds) = do
baseDir <- liftIO $ System.Environment.XDG.BaseDir.getUserDataDir "hsbot"
statDB <- liftIO $ openAcidStateFrom (baseDir ++ "/duckDB/") emptyStatDB
ducksMVar <- liftIO newEmptyMVar
@ -85,21 +74,19 @@ theDuck channel seconds = do
-- First we kill the ducks that we find in the message
let kills = howManyDucksInThere . concat $ IRC.msg_params msg
when (kills /= "") $ answerMsg msg kills
-- Then we check if someone shot some duck
when (getDestination msg == channel) $ do
-- Then we check if someone shot some duck
let shots = howManyBulletFiredInThere . concat $ IRC.msg_params msg
when (shots > 0) $ do
_ <- update' statDB (ScoreAction (getSender msg) 0 shots 0)
noDucksToShoot <- liftIO $ isEmptyMVar ducksMVar
unless noDucksToShoot $ do
ducksWaitingForDeath <- liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x))
_ <- update' statDB (ScoreAction (getSender msg) 0 0 (min ducksWaitingForDeath shots))
when (shots >= ducksWaitingForDeath) $ do
_ <- liftIO $ takeMVar ducksMVar
time <- liftIO $ readMVar timeMVar
duckSpawner channel time ducksMVar
_ <- update' statDB (ScoreAction (getSender msg) 1 0 0)
return ()
empty <- liftIO $ isEmptyMVar ducksMVar
ducksWaitingForDeath <- if empty then return 0
else liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x))
_ <- update' statDB . UpdateScore (getSender msg) $ computeScore ducksWaitingForDeath shots
when (and [ ducksWaitingForDeath > 0, shots >= ducksWaitingForDeath ]) $ do
_ <- liftIO $ takeMVar ducksMVar
time <- liftIO $ readMVar timeMVar
duckSpawner channel time ducksMVar
return ()
-- Finally we check if we received some command
cmdArgs <- lift $ getCommand msg
case cmdArgs of
@ -113,6 +100,11 @@ theDuck channel seconds = do
_ -> return ()
| otherwise = return ()
eval _ _ _ _ = return ()
computeScore :: Int -> Int -> Int
computeScore ducksWaitingForDeath shots
| shots < ducksWaitingForDeath = shots - 1
| shots == ducksWaitingForDeath = shots + 1
| otherwise = negate shots
-- | Spawns ducks on a channel, just waiting to be shot
duckSpawner :: String -> Int -> MVar Int -> Plugin (Env IO) ()
@ -150,7 +142,7 @@ ducks = [ x : y : z | x <- ">=", y <- face, z <- ["__/", "_/"] ]
++ [ L.reverse $ x : y : z | x <- "<=", y <- face, z <- ["__\\", "_\\"] ]
where
face :: String
face = "oO°@©®ð*òôóø⊕ΩꙫꙩꙨ◔"
face = "oO°@©®ð*òôóø⊕ΩꙫꙩꙨ◔ȯõ⁰"
-- | Weapons can have different noises
bangs :: [String]
@ -160,11 +152,15 @@ bangs = [ "PAN", "PAN!" ]
printDuckStats :: String -> StatDB -> Plugin (Env IO) ()
printDuckStats channel statDB = do
sendLine "Duck slaughter simulator - Hall of Fame"
mapM_ (sendLine . buildLine) $ M.toList (nickStats statDB)
mapM_ (sendLine . buildLine) . reverse . L.sortBy scoreSort $ M.toList (nickStats statDB)
where
buildLine :: (String, Stat) -> String
buildLine (nick, stat) = concat [ nick, ": ", show $ statRounds stat, " rounds won, ", show $ statShot stat
, " shots fired, ", show $ statKilled stat, " ducks killed" ]
scoreSort :: (String, Int) -> (String, Int) -> Ordering
scoreSort (_, s1) (_,s2)
| s1 < s2 = LT
| s1 > s2 = GT
| otherwise = EQ
buildLine :: (String, Int) -> String
buildLine (nick, score) = concat [ nick, ": ", show score ]
sendLine :: String -> Plugin (Env IO) ()
sendLine msg = writeMsg . OutgoingMsg $ IRC.Message Nothing "PRIVMSG" [channel, msg]

3
Hsbot/Plugin/Ping.hs
View file

@ -11,12 +11,13 @@ import Prelude hiding (catch)
import Hsbot.Message
import Hsbot.Types
-- | The ping plugin identity
ping :: PluginId
ping = PluginId
{ pluginName = "ping"
, pluginEp = thePing }
-- | The IrcPlugin monad main function
-- | An IRC plugin that answer PING requests
thePing :: Plugin (Env IO) ()
thePing = forever $ readMsg >>= eval
where

17
Hsbot/Types.hs
View file

@ -1,5 +1,7 @@
module Hsbot.Types
( Bot
( AccessList (..)
, AccessRight (..)
, Bot
, BotState (..)
, BotStatus (..)
, BotEnv (..)
@ -40,6 +42,7 @@ type Bot = StateT BotState
data BotState = BotState
{ botPlugins :: M.Map String (PluginEnv, ThreadId)
, botAccess :: [AccessList]
, botHooks :: [Chan Message]
, botChannels :: [String]
, botNickname :: String
@ -63,7 +66,7 @@ data PluginId = PluginId
data Message = IncomingMsg IRC.Message
| OutgoingMsg IRC.Message
data BotStatus = BotContinue | BotExit | BotReload | BotRestart deriving (Show)
data BotStatus = BotExit | BotReload String | BotRestart (String, Maybe String) deriving (Read, Show)
-- Config
data Config = Config
@ -71,16 +74,22 @@ data Config = Config
, configTLS :: TLSConfig
, configAddress :: String
, configPort :: PortID
, configAccess :: [AccessList]
, configChannels :: [String]
, configNicknames :: [String]
, configRealname :: String
, configPlugins :: [PluginId]
}
data AccessRight = Admin | JoinPart | Kick | Say deriving (Eq, Show)
data AccessList = AccessList
{ accessMask :: IRC.Prefix
, accessList :: [AccessRight]
} deriving (Show)
data TLSConfig = TLSConfig
{ sslOn :: Bool
, sslCert :: String
, sslKey :: String
, sslVersions :: [Network.TLS.Version]
, sslCiphers :: [Network.TLS.Cipher]
, sslVerify :: Bool

88
Hsbot/Utils.hs
View file

@ -1,25 +1,21 @@
module Hsbot.Utils
( addThreadIdToQuitMVar
, delThreadIdFromQuitMVar
, hasAccess
, initTLSEnv
, readCertificate
, readPrivateKey
, sendStr
, setGlobalQuitMVar
) where
import Control.Concurrent
import Control.Exception (IOException, catch)
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 Data.Maybe
import Control.Monad.State
import qualified Data.ByteString.Lazy.UTF8 as L
import qualified Data.List as L
import qualified Network.IRC as IRC
import Network.TLS
import Prelude hiding (catch)
import System.IO
import Hsbot.Types
@ -33,61 +29,41 @@ addThreadIdToQuitMVar thrId = do
delThreadIdFromQuitMVar :: ThreadId -> Env IO ()
delThreadIdFromQuitMVar thrId = do
threadIdsMv <- asks envThreadIdsMv
liftIO $ modifyMVar_ threadIdsMv (return . delete thrId)
liftIO $ modifyMVar_ threadIdsMv (return . L.delete thrId)
setGlobalQuitMVar :: BotStatus -> Env IO ()
setGlobalQuitMVar status = do
quitMv <- asks envQuitMv
liftIO $ putMVar quitMv status
-- Access rights
hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO Bool
hasAccess Nothing _ = return False
hasAccess (Just mask) right = do
asks envBotState >>= liftIO . readMVar >>= evalStateT (fmap (any accessMatch) (gets botAccess))
where
accessMatch :: AccessList -> Bool
accessMatch (AccessList amask arights)
| mask == amask = or [Admin `L.elem` arights, right `L.elem` arights]
| otherwise = False
-- Helpers
sendStr :: Handle -> Maybe TLSCtx -> String -> IO ()
sendStr _ (Just ctx) msg = sendData ctx $ L.fromChunks [C.pack msg]
sendStr handle Nothing msg = hPutStrLn handle msg
sendStr :: BotEnv -> Handle -> Maybe TLSCtx -> String -> IO ()
sendStr env _ (Just ctx) msg = sendData ctx (L.fromString $ msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg)
sendStr env handle Nothing msg = hPutStrLn handle (msg ++ "\r\n") `catch` handleIOException env ("sendStr " ++ msg)
handleIOException :: BotEnv -> String -> IOException -> IO ()
handleIOException env msg ioException = do
runReaderT (setGlobalQuitMVar $ BotRestart (show ioException, Just msg)) env
myId <- myThreadId
killThread myId
return ()
-- TLS utils
initTLSEnv :: TLSConfig -> IO TLSParams
initTLSEnv ssl = do
let certFile = sslCert ssl
keyFile = sslKey ssl
versions = sslVersions ssl
let 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 = fromMaybe (error "no valid certificate section") $ parsePEMCert content
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
return $ defaultParams { pAllowedVersions = versions
, pCiphers = ciphers }

25
TODO
View file

@ -1,7 +1,7 @@
* owner rights
* better hooks?
* add help MVar
* add regexes support in accessList prefix
* exception handling on channel and MVar operations?
@ -9,34 +9,19 @@
:julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif
* Improve configuration file errors display
* fork process in background
* add a function to answer by /msg to somebody
* write the vote system for the quote module
* only the quote reporter should be able to edit it
* detect too identical quoting in a raw, or implement quote abort
* handle the case we attempt to quote on an empty database
* solve the multiquote problem about the quote owner (with a quoteElem data structure)
* find a better way to track who voted for what?
* find a better way to track who voted for what? - need authentication against the bot
* write the help module
* clean the plugin module
* clean cleaning for the quote module
* write a channel tracking plugin. Write the part chan command
* add a plugin for admin checks and tracking
* add the quoteadm command to the quote module
* add a plugin for admin rights checking and user tracking
* add a plugin for timer functionnalities other plugin could subscribe to (the troll plugin).
* add register for casual conversations for plugins?
* add a "I have stuff to save so don't kill me too hard" status for plugins
* Make the bot auto-reconnect (/!\ admin plugin!)
* discard all trace with a color param and replace those with functions info/warn/error/debug
* write a safe reload : try reload before unloading
* remove from Types.hs what can be removed from it
* Find a way to handle bot reloading threw exec
* Find a way to prevent the socket from being garbage collected, by writing a connection handler for example
* Find a way so that not a single message/information would be lost in the case of a reboot

4
hsbot.cabal
View file

@ -23,6 +23,7 @@ Library
Hsbot.Core
Hsbot.Message
Hsbot.Plugin
Hsbot.Plugin.Admin
Hsbot.Plugin.Duck
Hsbot.Plugin.Ping
Hsbot.Plugin.Quote
@ -43,9 +44,10 @@ Library
network,
random,
safecopy,
tls >= 0.6.1,
tls >= 0.7.1,
tls-extra >= 0.2.0,
time,
utf8-string,
xdg-basedir