Rewrote the whole architecture.

8 files changed, 233 insertions, 213 deletions

diff --git a/Config.hs b/Config.hs
index a2c5a39..bbef7ab 100644
--- a/Config.hs
+++ b/Config.hs
@@ -1,17 +1,22 @@
 module Config
     ( config
+    , defaultPlugins
     ) where
 
+import Network
+
 import Hsbot.Core
 
 -- | Imported plugins goes there
+defaultPlugins :: [String]
+defaultPlugins = [ "Ping" ]
 
 -- | User server
 kro :: IrcServer
 kro = IrcServer
     { address        = "kro.corp"
-    , port           = 6667
-    , channels       = ["#geek", "#shbot"]
+    , port           = PortNumber 6667
+    , channels       = ["#shbot"]
     , nickname       = "hsbot"
     , password       = ""
     , realname       = "The One True bot, with it's haskell soul."
@@ -22,6 +27,6 @@ kro = IrcServer
 config :: Config
 config = Config
     { commandPrefixes = ['@']
-    , ircServers         = [kro]
+    , ircServer       = kro
     }
 
diff --git a/Hsbot.hs b/Hsbot.hs
index f37527b..54cc226 100644
--- a/Hsbot.hs
+++ b/Hsbot.hs
@@ -4,6 +4,7 @@ module Hsbot
     , module Hsbot.IRC
     , module Hsbot.IRCParser
     , module Hsbot.Main
+    , module Hsbot.Plugin
     ) where
 
 import Config
@@ -11,4 +12,5 @@ import Hsbot.Core
 import Hsbot.IRC
 import Hsbot.IRCParser
 import Hsbot.Main
+import Hsbot.Plugin
 
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index fddcb72..41340ba 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -1,56 +1,163 @@
 module Hsbot.Core
     ( Bot(..)
+    , Channel(..)
     , Config(..)
     , IrcServer(..)
-    , isConnected
-    , newbot
-    , sendstr
-    , saveServersStates
+    , IrcBot
+    , IrcMsg(..)
+    , Plugin(..)
+    , connectServer
+    , disconnectServer
+    , inColor
+    , serializeIrcMsg
+    , traceM
+    , writeMsg
     ) where
 
-import qualified Data.Map as M
-import System.IO (Handle)
-import Text.Printf (hPrintf)
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Monad.State
+import Data.List
+import Network
+import System.IO
+import System.Plugins
+import System.Time (ClockTime, getClockTime)
 
--- | An IRC Bot server state (socket handles)
-data Bot = Bot
-    { joinedServers :: M.Map IrcServer Handle -- servers we are connected to
-    } deriving (Eq, Show)
+-- | TODO : a monad for a channel, and a monad for a server, all together driven by a Bot?
 
 -- | Configuration data type
 data Config = Config {
    commandPrefixes :: String,   -- command prefixes, for example @[\'>\',\'@\',\'?\']@
-   ircServers      :: [IrcServer]  -- list of 'Server's to connect to
-} deriving (Eq,Show)
+   ircServer       :: IrcServer -- list of 'Server's to connect to
+} deriving (Show)
 
 -- | An IRC server
 data IrcServer = IrcServer
     { address        :: String   -- the server's address
-    , port           :: Int      -- the server's port
+    , port           :: PortID   -- the server's port
     , channels       :: [String] -- a list of channels to join
     , nickname       :: String   -- the hsbot's nickname
     , password       :: String   -- the hsbot's password, optional
     , realname       :: String   -- the hsbot's real name, optional
     , administrators :: [String] -- bot admins nicknames
-    } deriving (Eq, Ord, Show)
+    }
+
+instance Show IrcServer where
+    show (IrcServer a p c n pa r ad) = (show a)
+                                        ++ (case p of
+                                            PortNumber num -> show num
+                                            Service s      -> show s
+                                            UnixSocket u   -> show u)
+                                        ++ (show c) ++ (show n) ++ (show pa) ++ (show r) ++ (show ad)
+
+-- instance Show PortID where
+--     show (PortNumber n) = show n
+--     show (Service s)    = show s
+--     show (UnixSocket g) = show g
+
+-- | The IrcBot monad
+type IrcBot a = StateT Bot IO a
+
+-- | An IRC Bot server state
+data Bot = Bot
+    { serverConfig   :: IrcServer   -- original server config we are connected to
+    , startTime      :: ClockTime   -- the bot's uptime
+    , botHandle      :: Handle      -- the socket/handle
+    , chans          :: [Channel]   -- the list of channels we have joined
+    , botPlugins     :: [Plugin]    -- The list of loaded plugins
+    , serverChannel  :: Chan IrcMsg -- The bot's communication channel
+    , serverThreadId :: ThreadId    -- The bot's thread ID
+    }
+
+instance Show Bot where
+    show (Bot _ s h c p _ _) = (show s) ++ (show h) ++ (show c) ++ (show p)
+
+-- | A channel connection
+data Channel = Channel
+    { channelName   :: String   -- the channel's name
+    , channelNick   :: String   -- our nickname
+    , channelAdmins :: [String] -- the bot administrators
+    } deriving (Show)
+
+-- |An IRC message.
+data IrcMsg = IrcMsg
+    { prefix     :: Maybe String -- the message prefix
+    , command    :: String       -- the message command
+    , parameters :: [String]     -- the message parameters
+    } deriving (Show)
+
+-- | A plugin definition
+data Plugin = Plugin
+    { pluginName     :: String      -- The plugin's name
+    , pluginModule   :: Module      -- The plugin himself
+    , pluginThreadId :: ThreadId    -- The plugin thread
+    , pluginChannel  :: Chan IrcMsg -- The plugin channel
+    }
+
+instance Show Plugin where
+    show (Plugin name _ _ _) = show name
+
+-- Connect to the server and return the initial bot state
+connectServer :: IrcServer -> IO Bot
+connectServer server = do
+    let name  = address server
+    starttime <- getClockTime
+    putStr $ "Connecting to " ++ name ++ "... "
+    handle <- connectTo name $ port server
+    hSetBuffering handle NoBuffering
+    putStrLn "done."
+    putStr $ "Opening server communication channel... "
+    chan <- newChan :: IO (Chan IrcMsg)
+    threadId <- forkIO $ botWriter handle chan
+    putStrLn "done."
+    return (Bot server starttime handle [] [] chan threadId)
+
+-- | Disconnect from the server
+disconnectServer :: Bot -> IO ()    -- IO Bot ?
+disconnectServer bot = do
+    killThread $ serverThreadId bot
+    hClose $ botHandle bot
+    return ()
+
+-- | Processing loop
+botWriter :: Handle -> Chan IrcMsg -> IO ()
+botWriter handle chan = forever $ do
+    input <- readChan chan :: IO IrcMsg
+    sendstr handle (serializeIrcMsg input)
+
+-- | Write an IRC message to the bot's writer
+writeMsg :: IrcMsg -> IrcBot ()
+writeMsg msg = do
+    chan <- gets serverChannel
+    liftIO $ writeChan chan msg
 
--- | Returns a new, empty bot
-newbot :: Bot
-newbot = Bot (M.empty)
+-- |Serialize an IRC message to a string.
+serializeIrcMsg :: IrcMsg -> String
+serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr
+    where pfxStr = case pfx of
+                        Nothing  -> ""
+                        Just pfx' -> ":" ++ pfx' ++ " "
+          paramStr = concat (map paramToStr (init params)
+                             ++ [lastParamToStr (last params)])
+          paramToStr p = " " ++ p
+          lastParamToStr p = " :" ++ p
 
 -- | Send a string over handle
 sendstr :: Handle -> String -> IO ()
-sendstr handle str = hPrintf handle "%s\r\n" str
+sendstr handle str = do
+    trace $ inColor ("--> " ++ str) [33]
+    hPutStr handle (str ++ "\r\n")
 
--- | Are we already connected to this server?
-isConnected :: Bot -> IrcServer -> Bool
-isConnected (Bot bot) ircServer = ircServer `M.member` bot
+-- | Log a message string
+trace :: String -> IO ()
+trace msg = putStrLn msg
 
-saveServerState :: Handle -> IrcServer -> Bot -> Bot
-saveServerState handle ircServer x@(Bot bot) = 
-    if ircServer `M.member` bot then x
-      else (Bot $ M.insert ircServer handle bot)
+-- | Log a message string
+traceM :: String -> IrcBot ()
+traceM msg = liftIO $ putStrLn msg
 
-saveServersStates :: [(IrcServer, Handle)] -> Bot -> Bot
-saveServersStates liste bot = foldl (\bot' (ircServer, handle) -> saveServerState handle ircServer bot') bot liste
+-- |Wrap a string with ANSI escape sequences.
+inColor :: String -> [Int] -> String
+inColor str vals = "\ESC[" ++ valstr ++ "m" ++ str ++ "\ESC[0m"
+    where valstr = concat $ intersperse ";" $ map show vals
 
diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs
index 76853e2..d3a3114 100644
--- a/Hsbot/IRC.hs
+++ b/Hsbot/IRC.hs
@@ -1,82 +1,63 @@
 module Hsbot.IRC
-    ( IrcLine(..)
-    , connectServer
-    , initServer
-    , parseIrcMsg
-    , ping
-    , pong
-    , sendPrivmsg
-    )where
+    ( initServer
+    , runServer
+    ) where
 
-import Control.Monad
-import Data.List(isPrefixOf)
-import Data.Maybe
-import Network
-import qualified Network.IRC as IRC
+import Control.Concurrent.Chan
+import Control.Monad.State
 import System.IO
 
 import Hsbot.Core
 import Hsbot.IRCParser
 
-type User    = String
-type Channel = String
-type Command = String
-type Args    = [String]
-
--- | An IRC line
-data IrcLine = Privmsg (String, [String])   -- statement (chan, sentence...)
-               | Quit (IrcServer, Handle)   -- a quit message from a server
-               | Join (IrcServer, Channel)  -- joined a channel
-               | Part (IrcServer, Channel)  -- parted the channel
-               | Ping (String)              -- pinged by the server
-               | Reboot                     -- reboot message sent
-               | Nil                        -- signifies thread death, only happens after reboot
-    deriving (Eq,Show)
-
--- | Parses an IrcInput
-parseIrcMsg :: String -> IrcLine
-parseIrcMsg str = 
-    case (ircParser str) of
-        Left err -> Nil
-        Right x  -> eval x
-    where
-        eval :: IrcMsg -> IrcLine
-        eval x@(IrcMsg statement cmd stuff)
-            | cmd == "PING" = Ping $ head stuff
-            | cmd == "PRIVMSG" =
-		    case statement of
-		        Nothing -> Nil
-			Just statement' -> if stuff!!1 == "reboot" then Reboot
-                                              else  Privmsg $ (statement', stuff)
-            | otherwise = Nil
-
--- | Connects to a server
-connectServer :: IrcServer -> IO (IrcServer, Handle)
-connectServer server = do
-    let name  = address server
-        port_number = port server
-    handle <- connectTo name (PortNumber $ fromIntegral port_number)
-    hSetBuffering handle NoBuffering
-    return (server, handle)
-
 -- | Setup a newly connected server by sending nick and join stuff
-initServer :: (IrcServer, Handle) -> IO ()
-initServer (server, handle) = do
-    sendstr handle (IRC.encode . IRC.nick $ nickname server)
-    sendstr handle (IRC.encode $ IRC.user (nickname server) "0" "*" (realname server))
+initServer :: IrcBot ()
+initServer = do
+    server <- gets serverConfig
+    writeMsg $ IrcMsg Nothing "NICK" [(nickname server)]
+    writeMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)]
     when (not . null $ password server) $ do
-        sendstr handle (IRC.encode $ IRC.privmsg "nickserv" ("identify" ++ (password server)))
-    mapM_ (sendstr handle . IRC.encode . IRC.joinChan) (channels server)
+        writeMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)]
+    joinChans
     return ()
 
--- | Check if a message is a PING
-ping :: String -> Bool
-ping = isPrefixOf "PING :"
-
--- | Send a pong message given a ping message
-pong :: Handle -> String -> IO ()
-pong handle str = sendstr handle $ "PONG " ++ (drop 5 str)
-
-sendPrivmsg :: (IrcServer, Handle) -> [String] -> IO ()
-sendPrivmsg (server, handle) stuff' = sendstr handle (IRC.encode $ IRC.privmsg (head stuff') (unwords . tail $ stuff'))
+-- | Run a server
+runServer :: IrcBot ()
+runServer = do
+    handle <- gets botHandle
+    plugins <- gets botPlugins
+    str <- liftIO $ hGetLine handle
+    traceM $ inColor ("<-- " ++ str) [33]
+    let msg = parseIrcMsg str
+    case msg of
+        Right msg' -> do
+            mapM_ (sendPlugin msg') plugins
+            return ()
+        _ -> do
+            return ()
+    traceM $ show msg
+    runServer
+
+sendPlugin :: IrcMsg -> Plugin -> IrcBot ()
+sendPlugin msg plugin = do
+    let chan = pluginChannel plugin
+    liftIO $ writeChan chan msg
+
+-- | Join chans
+joinChans :: IrcBot ()
+joinChans = do
+    server <- gets serverConfig
+    mapM_ joinChan (channels server)
+
+-- | Joins a chan
+joinChan :: String -> IrcBot ()
+joinChan name = do
+    bot <- get
+    let oldChannels = chans bot
+        newChannel  = Channel name
+                              (nickname $ serverConfig bot)
+                              (administrators $ serverConfig bot)
+    traceM $ "  Joining " ++ name
+    writeMsg $ IrcMsg Nothing "JOIN" [name]
+    put $ bot { chans = newChannel : oldChannels }
 
diff --git a/Hsbot/IRCParser.hs b/Hsbot/IRCParser.hs
index a76e22a..5c1034e 100644
--- a/Hsbot/IRCParser.hs
+++ b/Hsbot/IRCParser.hs
@@ -1,36 +1,40 @@
 module Hsbot.IRCParser
-    ( IrcMsg (..)
-    , ircParser
+    ( ParseError
+    , parseIrcMsg
     ) where
 
---import Text.Parsec
-import Text.ParserCombinators.Parsec
+import Control.Monad.Identity
+-- import Data.List
+import Text.Parsec
 
--- |An IRC message.
-data IrcMsg = IrcMsg (Maybe String) String [String] -- (Maybe first statement) cmd [chan, params/sentence]
-    deriving (Show)
+import Hsbot.Core
 
---ircParser :: String -> IrcInput
-ircParser :: String -> Either ParseError IrcMsg
-ircParser str = parse pMsg "" str
+-- | Parses an IrcInput
+parseIrcMsg :: String -> Either ParseError IrcMsg
+parseIrcMsg line = parse pMsg "" line
 
+pMsg :: ParsecT String u Identity IrcMsg
 pMsg = do
     pfx <- optionMaybe pPrefix
     cmd <- pCommand
     params <- many (char ' ' >> (pLongParam <|> pShortParam))
-    char '\r'
+    --char '\r'
     eof
     return $ IrcMsg pfx cmd params
 
+pPrefix :: ParsecT String u Identity [Char]
 pPrefix = do
     char ':'
     pfx <- many1 (noneOf " ")
     space
     return pfx
 
+pCommand :: ParsecT String u Identity [Char]
 pCommand = count 3 digit <|> many1 upper
 
+pLongParam :: ParsecT String u Identity [Char]
 pLongParam = char ':' >> (many1 (noneOf "\r"))
 
+pShortParam :: ParsecT String u Identity [Char]
 pShortParam = many1 (noneOf " \r")
 
diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs
index 8972022..3cb0ce5 100644
--- a/Hsbot/Main.hs
+++ b/Hsbot/Main.hs
@@ -1,71 +1,26 @@
 module Hsbot.Main
     ( imain
-    , imain'
     ) where
 
-import Control.Concurrent
-import Control.Concurrent.Chan
-import Control.Monad
-import qualified Data.Map as M
+import Control.Monad.State
 import System.IO
-import System.Plugins
 
-import qualified Config as C
+import Config
 import Hsbot.Core
 import Hsbot.IRC
-
-type Reboot = (Module -> Bot -> (Chan IrcLine) -> IO ())
-
--- | Bot's first main entry point
-imain :: Module -> Reboot -> IO ()
-imain modul' reboot = do
-    chan <- newChan :: IO (Chan IrcLine)
-    imain' modul' reboot newbot chan
+import Hsbot.Plugin
 
 -- | Bot's main entry point
-imain' :: Module -> Reboot -> Bot -> (Chan IrcLine) -> IO ()
-imain' modul' reboot bot chan = do
-    -- The chan passing to reboot (or another way to keep it) is still missing
-    let newServers = filter (not . isConnected bot) (ircServers C.config)
-    putStrLn $ "Connecting servers : " ++ show (map address newServers)
-    newServers' <- mapM connectServer newServers
-    putStrLn $ "Joining channels : " ++ show (map channels newServers) 
-    mapM_ initServer newServers'
-    putStrLn "Spawning threads..."
-    let bot'  = saveServersStates newServers' bot
-        Bot x = bot'
-    mapM_ (forkIO . listener chan) newServers' -- (M.toList x)
-    bot'' <- monitor chan bot'
-    reboot modul' bot'' chan
-
--- | Bot main loop, monitors the threads states and handle reboot
-monitor :: (Chan IrcLine) -> Bot -> IO Bot
-monitor chan bot = do
-    loop bot
-    where
-        loop bot' = do
-            input <- readChan chan :: IO IrcLine
-            case input of
-                 Reboot  -> do
-                        putStrLn "Got reboot message, rebooting"
-                        return bot'
-                 _       -> loop bot'
-
--- | Thread entry point for socket listeners
-listener :: (Chan IrcLine) -> (IrcServer, Handle) -> IO ()
-listener chan (server, handle) = forever $ do
-    str <- hGetLine handle
-    let msg = parseIrcMsg str
-    writeChan chan msg
-    eval msg
-    where
-        eval :: IrcLine -> IO ()
-        eval (Privmsg (statement, stuff')) = sendPrivmsg (server, handle) stuff'
-        eval (Quit (ircServer, handle')) = return ()
-        eval (Join (ircServer, handle')) = return ()
-        eval (Part (ircServer, handle')) = return ()
-        eval (Ping (string)) = do pong handle string
-        eval stuff' = case stuff' of
-                        Reboot -> return ()
-                        Nil    -> return ()
+imain :: IO ()
+imain = do
+    bot <- connectServer $ ircServer config
+    (runStateT run bot) `catch` (const $ return ((), bot))
+    disconnectServer bot
+
+-- | The Bot monad main function
+run :: IrcBot ()
+run = do
+    initServer
+    mapM_ loadPlugin defaultPlugins
+    runServer
 
diff --git a/Main.hs b/Main.hs
index 617468a..982c699 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,48 +1,9 @@
 module Main where
 
-import System.Exit
-import System.Plugins
-
-ghcargs :: [String]
-ghcargs = ["-XPatternGuards"] 
+import Hsbot
 
 -- | Dynamic launching function
 main :: IO ()
 main = do
-    putStrLn "hsbot starting..."
-    m <- makeAll "Hsbot.hs" ghcargs
-    (modul', imain) <- case m of
-        MakeSuccess _ _ -> do
-            ldstat <- load_ "Hsbot/Main.o" [".","Hsbot","Hsbot/Plugins"] "imain"
-            case ldstat of
-                LoadSuccess v m' -> return (v,m')
-                LoadFailure e -> do
-                    putStrLn "Couldn't load Hsbot.Main.imain:"
-                    mapM_ putStrLn e
-                    exitWith $ ExitFailure 127
-        MakeFailure e -> do
-            putStrLn "FATAL: Couldn't compile Hsbot.hs:"
-            mapM_ putStrLn e
-            exitWith $ ExitFailure 127
-    putStrLn "Compiled & Loaded Hsbot.Main.imain..."
-    imain modul' reboot
-
--- | Dynamic rebooting function
-reboot :: Module -> a -> b -> IO ()
-reboot modul' state chan = do
-    mkstat <- makeAll "Hsbot.hs" ghcargs
-    case mkstat of
-        MakeSuccess _ _ -> do
-            unloadAll modul'
-            ldstat <- load_ "Hsbot/Main.o" [".","Hsbot","Hsbot/Plugins"] "imain'"
-            case ldstat of
-                LoadSuccess modul'' imain' -> do
-                    putStrLn "REBOOT: Successful recompilation & reloading, rebooting..."
-                    imain' modul'' reboot state chan
-                LoadFailure e -> fatality e
-        MakeFailure e -> fatality e
-    where
-        fatality errs = do
-            putStrLn $ "REBOOT: FATAL: Couldn't reboot thread, err:"
-            mapM_ putStrLn errs
+    imain
 
diff --git a/README b/README
index e69de29..33619ee 100644
--- a/README
+++ b/README
@@ -0,0 +1,5 @@
+Dependances :
+-------------
+hs-plugin
+haskell-irc
+