From 066b27151074536d5598c8aedde5dc952c77ad68 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Sun, 5 Jun 2011 01:12:46 +0200
Subject: [PATCH 01/14] Simplified and greatly improved scoring for the duck
game.
---
Hsbot/Plugin/Duck.hs | 61 +++++++++++++++++---------------------------
1 file changed, 23 insertions(+), 38 deletions(-)
diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs
index 187c62d..4b05982 100644
--- a/Hsbot/Plugin/Duck.hs
+++ b/Hsbot/Plugin/Duck.hs
@@ -22,46 +22,29 @@ 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
@@ -85,21 +68,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 +94,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) ()
@@ -162,9 +148,8 @@ printDuckStats channel statDB = do
sendLine "Duck slaughter simulator - Hall of Fame"
mapM_ (sendLine . buildLine) $ 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" ]
+ 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]
From 336ec596894a41cb0fa55fd9e1a76f6f62c9364f Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Fri, 17 Jun 2011 13:07:25 +0200
Subject: [PATCH 02/14] Fixed a bug in command parsing
---
Hsbot/Message.hs | 15 +++++++++------
1 file changed, 9 insertions(+), 6 deletions(-)
diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs
index 14488a1..a34659d 100644
--- a/Hsbot/Message.hs
+++ b/Hsbot/Message.hs
@@ -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
From 8fae43453245bdc683e64957b9499423b8825e7b Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Fri, 17 Jun 2011 13:08:33 +0200
Subject: [PATCH 03/14] Improved the duck plugin arguments handling
---
Hsbot/Plugin/Duck.hs | 13 +++++++++----
1 file changed, 9 insertions(+), 4 deletions(-)
diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs
index 4b05982..7ba2146 100644
--- a/Hsbot/Plugin/Duck.hs
+++ b/Hsbot/Plugin/Duck.hs
@@ -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
@@ -50,11 +51,15 @@ $(makeAcidic ''StatDB ['getDuckStats, 'updateScore])
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
From 62a4220ce0c9b1b6c263a23f8871ab54dfe523a9 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Fri, 17 Jun 2011 13:09:09 +0200
Subject: [PATCH 04/14] Added some duck funny faces
---
Hsbot/Plugin/Duck.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs
index 7ba2146..946cb0c 100644
--- a/Hsbot/Plugin/Duck.hs
+++ b/Hsbot/Plugin/Duck.hs
@@ -141,7 +141,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]
From b666e543d0ae03f79ca8b8527c099ca6320f27b0 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Mon, 11 Jul 2011 22:35:41 +0200
Subject: [PATCH 05/14] Fixed TLS client implementation
---
Hsbot/Config.hs | 6 +----
Hsbot/Core.hs | 18 +++++++--------
Hsbot/Types.hs | 2 --
Hsbot/Utils.hs | 59 +++++--------------------------------------------
hsbot.cabal | 3 ++-
5 files changed, 18 insertions(+), 70 deletions(-)
diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs
index d51387b..8c85810 100644
--- a/Hsbot/Config.hs
+++ b/Hsbot/Config.hs
@@ -24,12 +24,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
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index 9c72771..11c8732 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -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
@@ -103,7 +103,7 @@ runHsbot = do
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
+ fmap L.toString (recvData ctx) >>= handleIncomingStr chan -- TODO exceptions
botReader handle Nothing chan fatherThreadId = forever $
hGetLine handle `catch` handleIOException >>= handleIncomingStr chan
where
@@ -118,9 +118,9 @@ 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,7 +134,7 @@ botLoop = forever $ do
env <- ask
let connhdl = envHandle env
tlsCtx = envTLSCtx env
- liftIO $ debugM "Ircd.Reader" $ "--> " ++ show outMsg
+ liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg
liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
terminateHsbot :: Env IO ()
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index c7331d3..7e340e3 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -79,8 +79,6 @@ data Config = Config
data TLSConfig = TLSConfig
{ sslOn :: Bool
- , sslCert :: String
- , sslKey :: String
, sslVersions :: [Network.TLS.Version]
, sslCiphers :: [Network.TLS.Cipher]
, sslVerify :: Bool
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index 6eec5c4..e56e9f7 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -2,23 +2,14 @@ module Hsbot.Utils
( addThreadIdToQuitMVar
, delThreadIdFromQuitMVar
, initTLSEnv
- , readCertificate
- , readPrivateKey
, sendStr
, 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 qualified Data.ByteString.Lazy.UTF8 as L
import Data.List
-import Data.Maybe
import Network.TLS
import System.IO
@@ -42,52 +33,14 @@ setGlobalQuitMVar status = do
-- 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 _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n"
+sendStr handle Nothing msg = hPutStrLn handle $ msg ++ "\r\n"
-- 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 }
diff --git a/hsbot.cabal b/hsbot.cabal
index ef9be31..96b9647 100644
--- a/hsbot.cabal
+++ b/hsbot.cabal
@@ -42,8 +42,9 @@ Library
network,
random,
safecopy,
- tls >= 0.6.1,
+ tls >= 0.7.1,
tls-extra >= 0.2.0,
+ utf8-string,
xdg-basedir
From e74094d5d9478c1f167c0ce4abc3c7e854af91c4 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Tue, 2 Aug 2011 23:08:52 +0200
Subject: [PATCH 06/14] Updated TODO list
---
TODO | 14 ++++----------
1 file changed, 4 insertions(+), 10 deletions(-)
diff --git a/TODO b/TODO
index 07ac952..89fd863 100644
--- a/TODO
+++ b/TODO
@@ -1,5 +1,7 @@
-* owner rights
+* add admin rights
+* add the hability to manage rights for plugins, as quote editing
* better hooks?
+* add help MVar
@@ -16,9 +18,7 @@
* 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
@@ -26,17 +26,11 @@
* 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 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
From 1c8cab09cb00abc3e3a0ee2e4a2d7bd6cf703d2f Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Mon, 8 Aug 2011 11:39:41 +0200
Subject: [PATCH 07/14] Added access controls to hsbot.
---
Hsbot/Config.hs | 1 +
Hsbot/Core.hs | 1 +
Hsbot/Types.hs | 13 ++++++++++++-
Hsbot/Utils.hs | 19 +++++++++++++++++--
TODO | 4 +---
5 files changed, 32 insertions(+), 6 deletions(-)
diff --git a/Hsbot/Config.hs b/Hsbot/Config.hs
index 8c85810..6053e9e 100644
--- a/Hsbot/Config.hs
+++ b/Hsbot/Config.hs
@@ -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."
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index 11c8732..eacbe63 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -76,6 +76,7 @@ runHsbot = do
mapM_ (liftIO . sendStr connhdl tlsCtx . IRC.encode . IRC.joinChan) channels
-- Finally we set the new bot state
asks envBotState >>= liftIO . flip putMVar BotState { botPlugins = M.empty
+ , botAccess = configAccess config
, botHooks = []
, botChannels = channels
, botNickname = nickname }
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index 7e340e3..8f84482 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -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
@@ -71,12 +74,20 @@ 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
, sslVersions :: [Network.TLS.Version]
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index e56e9f7..912e746 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -1,6 +1,7 @@
module Hsbot.Utils
( addThreadIdToQuitMVar
, delThreadIdFromQuitMVar
+ , hasAccess
, initTLSEnv
, sendStr
, setGlobalQuitMVar
@@ -8,8 +9,10 @@ module Hsbot.Utils
import Control.Concurrent
import Control.Monad.Reader
+import Control.Monad.State
import qualified Data.ByteString.Lazy.UTF8 as L
-import Data.List
+import qualified Data.List as L
+import qualified Network.IRC as IRC
import Network.TLS
import System.IO
@@ -24,13 +27,25 @@ 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
+ botMVar <- asks envBotState
+ liftIO (readMVar botMVar) >>= evalStateT (gets botAccess >>= return . or . map accessMatch)
+ where
+ accessMatch :: AccessList -> Bool
+ accessMatch (AccessList amask arights)
+ | mask == amask = or [L.elem Admin arights, L.elem right arights]
+ | otherwise = False
+
-- Helpers
sendStr :: Handle -> Maybe TLSCtx -> String -> IO ()
sendStr _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n"
diff --git a/TODO b/TODO
index 89fd863..cb32d7c 100644
--- a/TODO
+++ b/TODO
@@ -1,8 +1,6 @@
-* add admin rights
-* add the hability to manage rights for plugins, as quote editing
* better hooks?
* add help MVar
-
+* add regexes support in accessList prefix
From 4f50db840967c2409c9bf96c2d6525f99e39cdca Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Mon, 8 Aug 2011 13:03:31 +0200
Subject: [PATCH 08/14] Fixed bad comments and some cosmetics
---
Hsbot/Plugin/Duck.hs | 2 +-
Hsbot/Plugin/Ping.hs | 3 ++-
Hsbot/Utils.hs | 6 +++---
3 files changed, 6 insertions(+), 5 deletions(-)
diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs
index 946cb0c..b152685 100644
--- a/Hsbot/Plugin/Duck.hs
+++ b/Hsbot/Plugin/Duck.hs
@@ -51,7 +51,7 @@ $(makeAcidic ''StatDB ['getDuckStats, 'updateScore])
duck :: PluginId
duck = PluginId
{ pluginName = "duck"
- , pluginEp = theDuck $ DuckArgs { duckChannel = "", duckFreq = 10 } }
+ , pluginEp = theDuck DuckArgs { duckChannel = "", duckFreq = 10 } }
data DuckArgs = DuckArgs
{ duckChannel :: String
diff --git a/Hsbot/Plugin/Ping.hs b/Hsbot/Plugin/Ping.hs
index 6d28ef9..9105630 100644
--- a/Hsbot/Plugin/Ping.hs
+++ b/Hsbot/Plugin/Ping.hs
@@ -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
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index 912e746..2a8f58c 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -35,15 +35,15 @@ setGlobalQuitMVar status = do
liftIO $ putMVar quitMv status
-- Access rights
-hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO (Bool)
+hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO Bool
hasAccess Nothing _ = return False
hasAccess (Just mask) right = do
botMVar <- asks envBotState
- liftIO (readMVar botMVar) >>= evalStateT (gets botAccess >>= return . or . map accessMatch)
+ liftIO (readMVar botMVar) >>= evalStateT (fmap (any accessMatch) (gets botAccess))
where
accessMatch :: AccessList -> Bool
accessMatch (AccessList amask arights)
- | mask == amask = or [L.elem Admin arights, L.elem right arights]
+ | mask == amask = or [Admin `L.elem` arights, right `L.elem` arights]
| otherwise = False
-- Helpers
From fe1acc3db5bafdf0b3b336d70a4c19e343b09852 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Mon, 8 Aug 2011 13:05:25 +0200
Subject: [PATCH 09/14] Added Administrative plugin that will permit dynamic
reloading
---
Hsbot/Plugin/Admin.hs | 45 +++++++++++++++++++++++++++++++++++++++++++
hsbot.cabal | 1 +
2 files changed, 46 insertions(+)
create mode 100644 Hsbot/Plugin/Admin.hs
diff --git a/Hsbot/Plugin/Admin.hs b/Hsbot/Plugin/Admin.hs
new file mode 100644
index 0000000..7dba362
--- /dev/null
+++ b/Hsbot/Plugin/Admin.hs
@@ -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
+ 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
+ else answerMsg msg "Only admins can do that."
+ _ -> return ()
+ | otherwise = return ()
+ eval _ = return ()
+
diff --git a/hsbot.cabal b/hsbot.cabal
index 96b9647..0e5473d 100644
--- a/hsbot.cabal
+++ b/hsbot.cabal
@@ -23,6 +23,7 @@ Library
Hsbot.Core
Hsbot.Message
Hsbot.Plugin
+ Hsbot.Plugin.Admin
Hsbot.Plugin.Duck
Hsbot.Plugin.Ping
Hsbot.Types
From 3b914c1b7729f52ba96e51ad43424909acae681c Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Mon, 8 Aug 2011 20:56:20 +0200
Subject: [PATCH 10/14] Added exception handling, an autorestart when that
happens and output in case of restart/reload
---
Hsbot.hs | 30 +++++++++++++++++++++++++++---
Hsbot/Core.hs | 35 +++++++++++++++++------------------
Hsbot/Plugin/Admin.hs | 4 ++--
Hsbot/Types.hs | 2 +-
Hsbot/Utils.hs | 15 ++++++++++++---
TODO | 11 ++---------
6 files changed, 61 insertions(+), 36 deletions(-)
diff --git a/Hsbot.hs b/Hsbot.hs
index c02b2e5..08456bf 100644
--- a/Hsbot.hs
+++ b/Hsbot.hs
@@ -5,13 +5,19 @@ 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 qualified Network.IRC as IRC
import Hsbot.Core
import Hsbot.Types
+import Hsbot.Utils
+
+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 ()
@@ -19,16 +25,34 @@ startHsbot config = do
-- initialization
infoM "Hsbot" "Bot initializations"
hsbotEnv <- initHsbot config
+ -- Handle previous exit state if it exists
+ die_msgs <- 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, readon : " ++ reason, "additional information: " ++ info]
+ BotRestart (reason, Nothing) -> return ["hsbot restarted, readon : " ++ reason]
+ BotExit -> return []
+ _ -> return ["hsbot die_msg parsing error, this should not happen"]
+ Nothing -> return []
+ let connhdl = envHandle hsbotEnv
+ tlsCtx = envTLSCtx hsbotEnv
+ channels = configChannels config
+ mapM_ (infoM "Hsbot") die_msgs
+ mapM_ (\msg -> mapM_ (\channel -> sendStr hsbotEnv connhdl tlsCtx . IRC.encode $ IRC.Message Nothing "PRIVMSG" [channel, msg]) channels) die_msgs
-- 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
+ BotReload reason -> do
+ runReaderT terminateHsbot hsbotEnv
+ relaunchWithTextState (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 (M.singleton "die_msg" . show $ BotRestart reason) Nothing
hsbot :: Config -> IO ()
hsbot = Dyre.wrapMain $ Dyre.defaultParams
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index eacbe63..49f5f5d 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -70,10 +70,10 @@ 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
-- Finally we set the new bot state
asks envBotState >>= liftIO . flip putMVar BotState { botPlugins = M.empty
, botAccess = configAccess config
@@ -88,9 +88,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
@@ -102,18 +101,18 @@ runHsbot = do
-- TODO : kill plugin threads
return code
-botReader :: Handle -> Maybe TLSCtx -> Chan Message -> ThreadId -> IO ()
-botReader _ (Just ctx) chan _ = forever $
- fmap L.toString (recvData ctx) >>= handleIncomingStr chan -- 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 =
@@ -136,7 +135,7 @@ botLoop = forever $ do
let connhdl = envHandle env
tlsCtx = envTLSCtx env
liftIO $ debugM "Hsbot.Loop" $ "--> " ++ show outMsg
- liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg
+ liftIO . sendStr env connhdl tlsCtx $ IRC.encode outMsg
terminateHsbot :: Env IO ()
terminateHsbot = do
diff --git a/Hsbot/Plugin/Admin.hs b/Hsbot/Plugin/Admin.hs
index 7dba362..cbec152 100644
--- a/Hsbot/Plugin/Admin.hs
+++ b/Hsbot/Plugin/Admin.hs
@@ -33,11 +33,11 @@ theAdmin = forever $ readMsg >>= eval
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
+ 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
+ then lift . setGlobalQuitMVar . BotReload $ getSender msg ++ " request"
else answerMsg msg "Only admins can do that."
_ -> return ()
| otherwise = return ()
diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs
index 8f84482..7ca9ee0 100644
--- a/Hsbot/Types.hs
+++ b/Hsbot/Types.hs
@@ -66,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
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index 2a8f58c..043037d 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -8,12 +8,14 @@ module Hsbot.Utils
) where
import Control.Concurrent
+import Control.Exception (IOException, catch)
import Control.Monad.Reader
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
@@ -47,9 +49,16 @@ hasAccess (Just mask) right = do
| otherwise = False
-- Helpers
-sendStr :: Handle -> Maybe TLSCtx -> String -> IO ()
-sendStr _ (Just ctx) msg = sendData ctx . L.fromString $ msg ++ "\r\n"
-sendStr handle Nothing msg = hPutStrLn handle $ msg ++ "\r\n"
+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
diff --git a/TODO b/TODO
index cb32d7c..92d1f3e 100644
--- a/TODO
+++ b/TODO
@@ -1,7 +1,7 @@
* better hooks?
* add help MVar
* add regexes support in accessList prefix
-
+* exception handling on channel and MVar operations?
@@ -9,7 +9,6 @@
: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
@@ -18,16 +17,10 @@
* detect too identical quoting in a raw, or implement quote abort
* 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 a plugin for admin rights checking and user tracking
* add a plugin for timer functionnalities other plugin could subscribe to (the troll plugin).
-* add a "I have stuff to save so don't kill me too hard" status for plugins
-
-* Make the bot auto-reconnect (/!\ admin plugin!)
* 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
From d933088dcb7d9b7ed05e0fbeb478472e0dae5a7a Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Mon, 8 Aug 2011 21:11:01 +0200
Subject: [PATCH 11/14] cosmetic
---
Hsbot/Utils.hs | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs
index 043037d..2ea1a49 100644
--- a/Hsbot/Utils.hs
+++ b/Hsbot/Utils.hs
@@ -40,8 +40,7 @@ setGlobalQuitMVar status = do
hasAccess :: Maybe IRC.Prefix -> AccessRight -> Env IO Bool
hasAccess Nothing _ = return False
hasAccess (Just mask) right = do
- botMVar <- asks envBotState
- liftIO (readMVar botMVar) >>= evalStateT (fmap (any accessMatch) (gets botAccess))
+ asks envBotState >>= liftIO . readMVar >>= evalStateT (fmap (any accessMatch) (gets botAccess))
where
accessMatch :: AccessList -> Bool
accessMatch (AccessList amask arights)
From 98a1debf03cd0b5145578f823b025d2315394503 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Tue, 9 Aug 2011 23:48:15 +0200
Subject: [PATCH 12/14] Moved to death messages IRC output around, because
those were sent too soon
---
Hsbot.hs | 22 ++++++++--------------
Hsbot/Core.hs | 6 ++++--
2 files changed, 12 insertions(+), 16 deletions(-)
diff --git a/Hsbot.hs b/Hsbot.hs
index 08456bf..33cfa45 100644
--- a/Hsbot.hs
+++ b/Hsbot.hs
@@ -7,11 +7,9 @@ import Config.Dyre.Relaunch
import Control.Monad.Reader
import qualified Data.Map as M
import System.Log.Logger
-import qualified Network.IRC as IRC
import Hsbot.Core
import Hsbot.Types
-import Hsbot.Utils
data State = State (M.Map String String) deriving (Read, Show)
@@ -22,27 +20,23 @@ startHsbot config = do
case configErrors config of
Nothing -> return ()
Just em -> putStrLn $ "Error: " ++ em
- -- initialization
- infoM "Hsbot" "Bot initializations"
- hsbotEnv <- initHsbot config
-- Handle previous exit state if it exists
- die_msgs <- case M.lookup "die_msg" buffer of
+ 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, readon : " ++ reason, "additional information: " ++ info]
- BotRestart (reason, Nothing) -> return ["hsbot restarted, readon : " ++ 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 []
- let connhdl = envHandle hsbotEnv
- tlsCtx = envTLSCtx hsbotEnv
- channels = configChannels config
- mapM_ (infoM "Hsbot") die_msgs
- mapM_ (\msg -> mapM_ (\channel -> sendStr hsbotEnv connhdl tlsCtx . IRC.encode $ IRC.Message Nothing "PRIVMSG" [channel, msg]) channels) die_msgs
+ 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
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index 49f5f5d..4dc1e92 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -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
@@ -74,6 +74,8 @@ runHsbot = do
liftIO . sendStr env connhdl tlsCtx . IRC.encode $ IRC.user nickname hostname "*" (configRealname config)
-- Then we join 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
From f698fd218375a0bfebd466a1cdc043427c2379b6 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Tue, 9 Aug 2011 23:55:03 +0200
Subject: [PATCH 13/14] Fixed mistake that prevented death message to be parsed
upon restarting
---
Hsbot.hs | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/Hsbot.hs b/Hsbot.hs
index 33cfa45..e2e771e 100644
--- a/Hsbot.hs
+++ b/Hsbot.hs
@@ -43,10 +43,10 @@ startHsbot config = do
BotExit -> runReaderT terminateHsbot hsbotEnv
BotReload reason -> do
runReaderT terminateHsbot hsbotEnv
- relaunchWithTextState (M.singleton "die_msg" . show $ BotReload reason) Nothing -- TODO find a way to properly implement that, then insert necessary information in this MVar
+ 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 (M.singleton "die_msg" . show $ BotRestart reason) Nothing
+ relaunchWithTextState (State $ M.singleton "die_msg" . show $ BotRestart reason) Nothing
hsbot :: Config -> IO ()
hsbot = Dyre.wrapMain $ Dyre.defaultParams
From f1ce0cfee09c5ba316abe437befa8ad75b3a5aa6 Mon Sep 17 00:00:00 2001
From: Julien Dessaux <judessaux@gmail.com>
Date: Fri, 2 Sep 2011 16:38:27 +0200
Subject: [PATCH 14/14] Added score sorting for the duck module
---
Hsbot/Plugin/Duck.hs | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs
index b152685..1044591 100644
--- a/Hsbot/Plugin/Duck.hs
+++ b/Hsbot/Plugin/Duck.hs
@@ -13,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
@@ -151,8 +152,13 @@ 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
+ 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) ()