Merge branch 'master' into quoteModule

Conflicts:
	hsbot.cabal

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 ()
+

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]
 

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