Moved files around as a preliminary for architectural changes.

5 files changed, 366 insertions, 0 deletions

diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs
new file mode 100644
index 0000000..114ced8
--- /dev/null
+++ b/HsbotIrcBot/Hsbot/Irc/Plugin/Core.hs
@@ -0,0 +1,66 @@
+module Hsbot.Irc.Plugin.Core
+    ( ircBotPluginCore
+    ) where
+
+import Control.Concurrent (Chan)
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin.Utils
+
+-- | The plugin's main entry point
+ircBotPluginCore :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginCore myChan masterChan = do
+    let plugin = IrcPluginState { ircPluginName       = "Core"
+                                , ircPluginChan       = myChan
+                                , ircPluginMasterChan = masterChan }
+    evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin
+    plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
+    evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin'
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = forever $ do
+    msg <- readMsg
+    eval msg
+  where
+    eval :: IrcBotMsg -> IrcPlugin ()
+    eval (IntIrcCmd intCmd) = do
+        let request = ircCmdBotMsg intCmd
+        case ircCmdCmd intCmd of
+            "RUN"    -> let stuff = words $ ircCmdMsg intCmd
+                        in case head stuff of
+                            "list"   -> listPlugins request
+                            "load"   -> loadPlugin $ tail stuff
+                            "reload" -> reloadPlugin $ tail stuff
+                            "unload" -> unloadPlugin $ tail stuff
+                            "reboot" -> rebootBot $ tail stuff
+                            _        -> return () -- TODO : help message
+            "ANSWER" -> let stuff = ircCmdMsg intCmd
+                        in answerMsg request ("Loaded plugins : " ++ stuff)
+            _        -> return ()
+    eval _ = return ()
+
+-- | The list command
+listPlugins :: IrcMsg -> IrcPlugin ()
+listPlugins request = do
+    sendCommandWithRequest "LIST" "CORE" (unwords []) request
+
+-- | The load command
+loadPlugin :: [String] -> IrcPlugin ()
+loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames
+
+-- | The reload command
+reloadPlugin :: [String] -> IrcPlugin ()
+reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames
+
+-- | The unload command
+unloadPlugin :: [String] -> IrcPlugin ()
+unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames
+
+-- | The reboot command
+rebootBot :: [String] -> IrcPlugin ()
+rebootBot stuff = sendCommand "REBOOT" "CORE" $ unwords stuff
+
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs
new file mode 100644
index 0000000..4e10644
--- /dev/null
+++ b/HsbotIrcBot/Hsbot/Irc/Plugin/Dummy.hs
@@ -0,0 +1,27 @@
+module Hsbot.Irc.Plugin.Dummy
+    ( ircBotPluginDummy
+    ) where
+
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin.Utils
+
+-- | The plugin's main entry point
+ircBotPluginDummy :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginDummy myChan masterChan = do
+    let plugin = IrcPluginState { ircPluginName       = "Dummy"
+                                , ircPluginChan       = myChan
+                                , ircPluginMasterChan = masterChan }
+    _ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
+    return ()
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = forever $ do
+    _ <- readMsg
+    return ()
+
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs
new file mode 100644
index 0000000..57418b3
--- /dev/null
+++ b/HsbotIrcBot/Hsbot/Irc/Plugin/Ping.hs
@@ -0,0 +1,33 @@
+module Hsbot.Irc.Plugin.Ping
+    ( ircBotPluginPing
+    ) where
+
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import Prelude hiding (catch)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin.Utils
+
+-- | The plugin's main entry point
+ircBotPluginPing :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginPing myChan masterChan = do
+    let plugin = IrcPluginState { ircPluginName       = "Ping"
+                                , ircPluginChan       = myChan
+                                , ircPluginMasterChan = masterChan }
+    _ <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin)
+    return ()
+
+-- | The IrcPlugin monad main function
+run :: IrcPlugin ()
+run = forever $ do
+    msg <- readMsg
+    eval msg
+  where
+    eval :: IrcBotMsg -> IrcPlugin ()
+    eval (InIrcMsg msg)
+        | (ircMsgCommand msg) == "PING" = writeMsg . OutIrcMsg $ IrcMsg Nothing "PONG" (ircMsgParameters msg)
+        | otherwise = return ()
+    eval _ = return ()
+
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs
new file mode 100644
index 0000000..0335d8b
--- /dev/null
+++ b/HsbotIrcBot/Hsbot/Irc/Plugin/Quote.hs
@@ -0,0 +1,174 @@
+module Hsbot.Irc.Plugin.Quote
+    ( ircBotPluginQuote
+    ) where
+
+import Control.Concurrent.Chan
+import Control.Exception
+import Control.Monad.State
+import qualified Data.Map as M
+import Data.Maybe(fromMaybe)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Data.Time
+import System.Directory
+import IO hiding (catch)
+import Prelude hiding (catch)
+import System.FilePath
+import System.Posix.Files
+import System.Random(randomRIO)
+
+import Hsbot.Irc.Message
+import Hsbot.Irc.Plugin.Utils
+
+-- | A quote element
+data QuoteElt = QuoteElt
+    { eltQuoter :: String
+    , eltQuote  :: String
+    } deriving (Read, Show)
+
+-- | A quote object
+data Quote = Quote
+    { quoter    :: String
+    , quote     :: [QuoteElt]
+    , quoteTime :: UTCTime
+    , votes     :: Int
+    } deriving (Read, Show)
+
+-- | A QuoteBot state
+data QuoteBotState = QuoteBotState
+    { nextQuoteId      :: Integer
+    , quoteBotDB       :: M.Map Integer Quote
+    , quotesInProgress :: M.Map Integer Quote
+    } deriving (Read, Show)
+
+-- | The QuoteBot monad
+type QuoteBot a = StateT QuoteBotState (StateT IrcPluginState IO) a
+
+-- | The plugin's main entry point
+ircBotPluginQuote :: Chan IrcBotMsg -> Chan IrcBotMsg -> IO ()
+ircBotPluginQuote myChan masterChan = do
+    -- First of all we restore the database
+    dir <- getAppUserDataDirectory "hsbot"
+    let dbfile = dir </> "quotedb.txt"
+    dbfileExists <- fileExist dbfile
+    if not dbfileExists
+      then
+        let quoteBot = QuoteBotState 0 M.empty M.empty
+        in TIO.writeFile dbfile (T.pack $ show quoteBot)
+      else
+        return ()
+    txtQuoteBot <- TIO.readFile $ dbfile
+    let quoteBot = read (T.unpack txtQuoteBot) :: QuoteBotState
+    -- The plugin main loop
+    let plugin = IrcPluginState { ircPluginName       = "Quote"
+                                , ircPluginChan       = myChan
+                                , ircPluginMasterChan = masterChan }
+    evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin
+    _ <- (evalStateT (run quoteBot) plugin) `catch` (\(_ :: AsyncException) -> return quoteBot)
+    evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin
+
+-- | The IrcPlugin monad main function
+run :: QuoteBotState -> IrcPlugin (QuoteBotState)
+run quoteBot = do
+    msg <- readMsg
+    quoteBot' <- eval msg
+    run quoteBot'
+  where
+    -- | evaluate what we just received
+    eval :: IrcBotMsg -> IrcPlugin (QuoteBotState)
+    eval (IntIrcCmd intCmd)
+      | ircCmdCmd intCmd == "RUN" = do
+          quoteBot' <- execStateT (runCommand intCmd) quoteBot
+          return quoteBot'
+      | otherwise = return quoteBot
+    eval (InIrcMsg _) = return (quoteBot)
+    eval (OutIrcMsg _) = return (quoteBot)
+
+-- | run a command we received
+runCommand :: IrcCmd -> QuoteBot ()
+runCommand intCmd
+  | theCommand == "quote" = runQuoteCommand
+  | otherwise = return ()
+  where
+    -- | the message is a quote command
+    runQuoteCommand :: QuoteBot ()
+      | length args == 0 = do
+          quoteDB <- gets quoteBotDB
+          x <- liftIO $ randomRIO (0, (length $ M.keys quoteDB) - 1)
+          if (length $ M.keys quoteDB) > 0
+            then
+              mapM_ (lift . answerMsg request) (formatQuote (M.keys quoteDB !! x) (M.elems quoteDB !! x))
+            else
+              lift $ answerMsg request "The quote database is empty."
+      | otherwise = do
+          dispatchQuoteCmd $ head args
+    -- | quote command dispatcher
+    dispatchQuoteCmd :: String -> QuoteBot ()
+    dispatchQuoteCmd cmd
+      | cmd == "start"  = do
+          quoteBot <- get
+          now <- liftIO $ getCurrentTime
+          let sender   = takeWhile (/= '!') $ fromMaybe "ARGH" (ircMsgPrefix request)
+              newQuote = Quote sender [(quoteElt stuff)] now 0
+              quoteId     = nextQuoteId quoteBot
+              quotesInProgress' = M.insert quoteId  newQuote (quotesInProgress quoteBot)
+          put $ quoteBot { nextQuoteId = quoteId + 1, quotesInProgress = quotesInProgress' }
+          lift $ answerMsg request ("New quoteId : " ++ show quoteId)
+          syncQuoteBot
+      | cmd == "append" = do
+          quoteBot <- get
+          case reads (head stuff) of
+              [(quoteId :: Integer,"")] -> do
+                  case M.lookup quoteId (quotesInProgress quoteBot) of
+                      Just theQuote -> do
+                          let newQuote = theQuote { quote = (quoteElt $ tail stuff) : (quote theQuote) }
+                              quotesInProgress'  = M.insert quoteId newQuote (quotesInProgress quoteBot)
+                          put $ quoteBot { quotesInProgress = quotesInProgress' }
+                          syncQuoteBot
+                      Nothing       -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
+              _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
+      | cmd == "commit" = do
+          quoteBot <- get
+          case reads (head stuff) of
+              [(quoteId :: Integer,"")] -> do
+                  case M.lookup quoteId (quotesInProgress quoteBot) of
+                      Just theQuote -> do
+                          let quoteBotDB'       = M.insert quoteId theQuote (quoteBotDB quoteBot)
+                              quotesInProgress' = M.delete quoteId (quotesInProgress quoteBot)
+                          put $ quoteBot { quoteBotDB = quoteBotDB', quotesInProgress = quotesInProgress' }
+                          syncQuoteBot
+                      Nothing       -> lift $ answerMsg request ("quoteId not found : " ++ (show quoteId))
+              _ -> lift $ answerMsg request ("Invalid quoteId : " ++ (head stuff))
+      -- | cmd == "abort"  = 
+      | otherwise = lift $ answerMsg request ("Invalid command : " ++ cmd)
+    -- | Gets the new QuoteElt
+    quoteElt :: [String] -> QuoteElt
+    quoteElt msg = do
+        let budy   = head $ msg
+            theQuote  = unwords . tail $ msg
+        QuoteElt budy theQuote
+    -- | utilities
+    params  = words . ircCmdMsg $ intCmd
+    theCommand = head params
+    args    = tail params
+    stuff   = tail args
+    request = ircCmdBotMsg intCmd
+
+-- | The function that sync the quoteDB on disk
+syncQuoteBot :: QuoteBot ()
+syncQuoteBot = do
+    dir <- liftIO $ getAppUserDataDirectory "hsbot"
+    let dbfile = dir </> "quotedb.txt"
+    file' <- liftIO $ openFile dbfile WriteMode
+    quoteBot <- get
+    liftIO . hPutStr file' $ show quoteBot
+    liftIO $ hClose file'
+
+formatQuote :: Integer -> Quote -> [String]
+formatQuote quoteId theQuote =
+    ("+---| " ++ (show quoteId) ++ " |-- Reported by " ++ (quoter theQuote) ++ " on " ++ (show $ quoteTime theQuote)) :
+    foldl (\acc x -> formatQuoteElt x : acc) ["`------------------------------------------"] (quote theQuote)
+  where
+    formatQuoteElt :: QuoteElt -> String
+    formatQuoteElt quoteElt = "| <" ++ (eltQuoter quoteElt) ++ "> " ++ (eltQuote quoteElt)
+
diff --git a/HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs b/HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs
new file mode 100644
index 0000000..1e54d3a
--- /dev/null
+++ b/HsbotIrcBot/Hsbot/Irc/Plugin/Utils.hs
@@ -0,0 +1,66 @@
+module Hsbot.Irc.Plugin.Utils
+    ( IrcPlugin
+    , IrcPluginState (..)
+    , answerMsg
+    , readMsg
+    , sendCommand
+    , sendCommandWithRequest
+    , sendRegisterCommand
+    , sendUnregisterCommand
+    , writeMsg
+    ) where
+
+import Control.Concurrent
+import Control.Concurrent.Chan ()
+import Control.Monad.State
+import Data.Maybe (fromMaybe)
+
+import Hsbot.Irc.Message
+
+-- | The IrcPlugin monad
+type IrcPlugin = StateT IrcPluginState IO
+
+-- | A plugin state
+data IrcPluginState = IrcPluginState
+    { ircPluginName       :: String         -- The plugin's name
+    , ircPluginChan       :: Chan IrcBotMsg -- The plugin chan
+    , ircPluginMasterChan :: Chan IrcBotMsg -- The master's chan
+    }
+
+--- | Basic input output for IrcPlugins
+readMsg :: IrcPlugin (IrcBotMsg)
+readMsg = do
+   chan  <- gets ircPluginChan
+   input <- liftIO $ readChan chan
+   return input
+
+writeMsg :: IrcBotMsg -> IrcPlugin ()
+writeMsg (OutIrcMsg msg) = do
+   chan <- gets ircPluginMasterChan
+   liftIO $ writeChan chan (OutIrcMsg msg)
+writeMsg _ = return ()
+
+answerMsg :: IrcMsg -> String -> IrcPlugin ()
+answerMsg request msg = do
+    let chanOrigin = head $ ircMsgParameters request
+        sender     = takeWhile (/= '!') $ fromMaybe "" (ircMsgPrefix request)
+    case head chanOrigin of
+        '#' -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg]
+        _   -> writeMsg . OutIrcMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg]
+
+-- | Command management
+sendCommand :: String -> String -> String -> IrcPlugin ()
+sendCommand cmd to params = sendCommandWithRequest cmd to params emptyIrcMsg
+
+sendCommandWithRequest :: String -> String -> String -> IrcMsg -> IrcPlugin ()
+sendCommandWithRequest cmd to params originalRequest = do
+    masterChan <- gets ircPluginMasterChan
+    from       <- gets ircPluginName
+    liftIO . writeChan masterChan . IntIrcCmd $ IrcCmd cmd from to params originalRequest
+
+sendRegisterCommand :: String -> IrcPlugin ()
+sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd
+
+sendUnregisterCommand :: String -> IrcPlugin ()
+sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd
+