summaryrefslogtreecommitdiff
path: root/Hsbot/Plugin
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--Hsbot/Plugin/Admin.hs45
-rw-r--r--Hsbot/Plugin/Duck.hs84
-rw-r--r--Hsbot/Plugin/Ping.hs3
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-23 18:40:17 +0000