diff options
Diffstat (limited to '')
| -rw-r--r-- | Hsbot/Plugin/Admin.hs | 45 | ||||
| -rw-r--r-- | Hsbot/Plugin/Duck.hs | 84 | ||||
| -rw-r--r-- | Hsbot/Plugin/Ping.hs | 3 |
3 files changed, 87 insertions, 45 deletions
diff --git a/Hsbot/Plugin/Admin.hs b/Hsbot/Plugin/Admin.hs new file mode 100644 index 0000000..cbec152 --- /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 (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 () + diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs index 187c62d..1044591 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 @@ -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] 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 |