diff options
| -rw-r--r-- | Hsbot/Plugin/Duck.hs | 96 | ||||
| -rw-r--r-- | hsbot.cabal | 9 |
2 files changed, 87 insertions, 18 deletions
diff --git a/Hsbot/Plugin/Duck.hs b/Hsbot/Plugin/Duck.hs index afc9fa3..353dff2 100644 --- a/Hsbot/Plugin/Duck.hs +++ b/Hsbot/Plugin/Duck.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-} -- | This module is an IRC plugin that generates and kills ducks module Hsbot.Plugin.Duck ( duck @@ -5,16 +6,65 @@ module Hsbot.Plugin.Duck ) where import Control.Concurrent -import qualified Data.List as L import Control.Monad.Reader +import Control.Monad.State +import Data.Acid +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe +import Data.SafeCopy +import Data.Typeable import qualified Network.IRC as IRC import Prelude hiding (catch) +import System.Environment.XDG.BaseDir import System.Random 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 + } 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 + 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 } + +getDuckStats :: Query StatDB StatDB +getDuckStats = ask + +-- This will define @ViewMessage@ and @AddMessage@ for us. +$(makeAcidic ''StatDB ['getDuckStats, 'scoreAction]) + -- | The duck plugin identity duck :: PluginId duck = PluginId @@ -24,35 +74,39 @@ duck = PluginId -- | An IRC plugin that generates and kills ducks theDuck :: String -> Int -> Plugin (Env IO) () theDuck channel seconds = do + baseDir <- liftIO $ System.Environment.XDG.BaseDir.getUserDataDir "hsbot" + statDB <- liftIO $ openAcidStateFrom (baseDir ++ "/duckDB/") emptyStatDB ducksMVar <- liftIO newEmptyMVar duckSpawner channel seconds ducksMVar - forever $ readMsg >>= eval ducksMVar + forever $ readMsg >>= eval statDB ducksMVar where - eval :: MVar Int -> Message -> Plugin (Env IO) () - eval ducksMVar (IncomingMsg msg) + eval :: AcidState StatDB -> MVar Int -> Message -> Plugin (Env IO) () + eval statDB ducksMVar (IncomingMsg msg) | IRC.msg_command msg == "PRIVMSG" = 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 let shots = howManyBulletFiredInThere . concat $ IRC.msg_params msg - noDucksToShot <- liftIO $ isEmptyMVar ducksMVar - when (and [getDestination msg == channel, not noDucksToShot, shots > 0]) $ do - -- TODO: score dead ducks (with a min (ducksWaitingForDeath, shots)) - ducksWaitingForDeath <- liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x)) - when (shots >= ducksWaitingForDeath) $ do - _ <- liftIO $ takeMVar ducksMVar - duckSpawner channel seconds ducksMVar - -- TODO : score lost bullets and round - return () + noDucksToShoot <- liftIO $ isEmptyMVar ducksMVar + when (shots > 0) $ do + _ <- update' statDB (ScoreAction (getSender msg) 0 shots 0) + when (and [getDestination msg == channel, not 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 + duckSpawner channel seconds ducksMVar + _ <- update' statDB (ScoreAction (getSender msg) 1 0 0) + return () -- Finally we check if we received some command cmdArgs <- lift $ getCommand msg case cmdArgs of - --"ducks":"stats":args -> TODO + "ducks":"stats":_ -> query' statDB GetDuckStats >>= printDuckStats channel "ducks":_ -> answerMsg msg "Invalid duck command." _ -> return () | otherwise = return () - eval _ _ = return () + eval _ _ _ = return () -- | Regularly spawns ducks on a channel, just waiting to be shot duckSpawner :: String -> Int -> MVar Int -> Plugin (Env IO) () @@ -98,3 +152,15 @@ ducks = [ x : y : z | x <- nose, y <- face, z <- ["__/", "_/", "/"] ] bangs :: [String] bangs = [ "PAN", "PAN!" ] +-- | Nicely prints duck statistics +printDuckStats :: String -> StatDB -> Plugin (Env IO) () +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" ] + sendLine :: String -> Plugin (Env IO) () + sendLine msg = writeMsg . OutgoingMsg $ IRC.Message Nothing "PRIVMSG" [channel, msg] + diff --git a/hsbot.cabal b/hsbot.cabal index de77b84..fbb1108 100644 --- a/hsbot.cabal +++ b/hsbot.cabal @@ -1,5 +1,5 @@ Name: hsbot -Version: 0.4.14 +Version: 0.4.15 Cabal-version: >=1.2 Synopsis: A multipurposes IRC bot Description: @@ -28,7 +28,8 @@ Library Hsbot.Types Hsbot.Utils Extensions: DeriveDataTypeable FlexibleContexts ScopedTypeVariables - Build-depends: base >= 4.1 && < 5, + Build-depends: acid-state, + base >= 4.1 && < 5, bytestring, certificate, containers, @@ -40,8 +41,10 @@ Library mtl, network, random, + safecopy, tls >= 0.6.1, - tls-extra >= 0.2.0 + tls-extra >= 0.2.0, + xdg-basedir Executable hsbot |