Added persistent statistics for the duck Module.

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 :: AcidState StatDB -> MVar Int -> Message -> Plugin (Env IO) ()
-    eval ducksMVar (IncomingMsg msg)
+    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
+            noDucksToShoot <- liftIO $ isEmptyMVar ducksMVar
-            when (and [getDestination msg == channel, not noDucksToShot, shots > 0]) $ do
+            when (shots > 0) $ do
-                -- TODO: score dead ducks (with a min (ducksWaitingForDeath, shots))
+                _ <- 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
-                    -- TODO : score lost bullets and round
+                        _ <- 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]
+

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