ircbot (empty) → 0.1.0
raw patch · 12 files changed
+698/−0 lines, 12 filesdep +basedep +filepathdep +ircsetup-changed
Dependencies added: base, filepath, irc, mtl, network, old-locale, parsec, random, time, unix
Files
- LICENSE +30/−0
- Network/IRC/Bot.hs +13/−0
- Network/IRC/Bot/BotMonad.hs +66/−0
- Network/IRC/Bot/Commands.hs +69/−0
- Network/IRC/Bot/Core.hs +190/−0
- Network/IRC/Bot/Log.hs +20/−0
- Network/IRC/Bot/Parsec.hs +125/−0
- Network/IRC/Bot/Part/Dice.hs +37/−0
- Network/IRC/Bot/Part/Ping.hs +9/−0
- Network/IRC/Bot/PosixLogger.hs +54/−0
- Setup.hs +3/−0
- ircbot.cabal +82/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Jeremy Shaw 2011++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Shaw nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/IRC/Bot.hs view
@@ -0,0 +1,13 @@+module Network.IRC.Bot+ ( module Network.IRC.Bot.BotMonad+ , module Network.IRC.Bot.Commands+ , module Network.IRC.Bot.Core+ , module Network.IRC.Bot.Log+ , module Network.IRC.Bot.Parsec+ ) where++import Network.IRC.Bot.BotMonad+import Network.IRC.Bot.Commands+import Network.IRC.Bot.Core+import Network.IRC.Bot.Log+import Network.IRC.Bot.Parsec
+ Network/IRC/Bot/BotMonad.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-}+module Network.IRC.Bot.BotMonad + ( BotPartT(..)+ , BotMonad(..)+ , BotEnv(..)+ , runBotPartT+ , mapBotPartT+ ) where++import Control.Applicative (Applicative, Alternative, (<$>))+import Control.Arrow (first)+import Control.Monad (MonadPlus(mplus, mzero), forever, replicateM, when)+import Control.Monad.Cont (MonadCont)+import Control.Monad.Error (MonadError)+import Control.Monad.Reader (MonadReader(ask, local), MonadTrans, ReaderT(runReaderT), mapReaderT)+import Control.Monad.Writer (MonadWriter)+import Control.Monad.State (MonadState)+import Control.Monad.RWS (MonadRWS)+import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Trans+import Network.IRC (Command, Message(Message, msg_prefix, msg_command, msg_params), Prefix(NickName), UserName, encode, decode, joinChan, nick, user)+import Network.IRC.Bot.Log++-- FIXME: add whoami?+class (Functor m, MonadPlus m, MonadIO m) => BotMonad m where+ askMessage :: m Message+ askOutChan :: m (Chan Message)+ localMessage :: (Message -> Message) -> m a -> m a+ sendMessage :: Message -> m ()+ logM :: LogLevel -> String -> m ()+ whoami :: m String++data BotEnv = BotEnv { message :: Message+ , outChan :: Chan Message+ , logFn :: Logger+ , botName :: String+ }+ +newtype BotPartT m a = BotPartT { unBotPartT :: ReaderT BotEnv m a }+ deriving (Applicative, Alternative, Functor, Monad, MonadFix, MonadPlus, MonadTrans, MonadIO, MonadWriter w, MonadState s, MonadError e, MonadCont)++instance (MonadReader r m) => MonadReader r (BotPartT m) where+ ask = BotPartT (lift ask)+ local f = BotPartT . mapReaderT (local f) . unBotPartT++instance (MonadRWS r w s m) => MonadRWS r w s (BotPartT m)+ +runBotPartT :: BotPartT m a -> BotEnv -> m a+runBotPartT botPartT = runReaderT (unBotPartT botPartT)+ +mapBotPartT :: (m a -> n b) -> BotPartT m a -> BotPartT n b+mapBotPartT f (BotPartT r) = BotPartT $ mapReaderT f r++instance (Functor m, MonadIO m, MonadPlus m) => BotMonad (BotPartT m) where+ askMessage = BotPartT (message <$> ask)+ askOutChan = BotPartT (outChan <$> ask)+ localMessage f (BotPartT r) = BotPartT (local (\e -> e { message = f (message e) }) r)+ sendMessage msg =+ BotPartT $ do out <- outChan <$> ask+ liftIO $ writeChan out msg+ return ()+ logM lvl msg =+ BotPartT $ do l <- logFn <$> ask+ liftIO $ l lvl msg+ whoami = BotPartT $ botName <$> ask
+ Network/IRC/Bot/Commands.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Network.IRC.Bot.Commands where++import Control.Applicative+import Control.Monad+import Data.Data+import Network (HostName, PortID(PortNumber))+import Network.IRC+import Network.IRC.Bot.BotMonad++-- * Commands+ +cmd :: (Functor m, MonadPlus m, BotMonad m) => Command -> m ()+cmd cmdName =+ do command <- msg_command <$> askMessage+ if cmdName == command+ then return ()+ else mzero++data Ping+ = Ping HostName+ deriving (Eq, Ord, Read, Show, Data, Typeable)+ +ping :: (Functor m, MonadPlus m, BotMonad m) => m Ping+ping = + do cmd "PING"+ params <- msg_params <$> askMessage+ case params of+ (hostName:_) -> return $ Ping hostName+ _ -> mzero+ + +data PrivMsg + = PrivMsg { prefix :: (Maybe Prefix) + , receivers :: [String] + , msg :: String+ }+ deriving (Eq, Read, Show)+ +privMsg :: (Functor m, MonadPlus m, BotMonad m) => m PrivMsg+privMsg =+ do msg <- askMessage+ maybe mzero return (toPrivMsg msg)+ +toPrivMsg :: Message -> Maybe PrivMsg +toPrivMsg msg =+ let cmd = msg_command msg+ params = msg_params msg+ prefix = msg_prefix msg+ in case cmd of+ "PRIVMSG" -> Just $ PrivMsg prefix (init params) (last params)+ _ -> Nothing+ +class ToMessage a where+ toMessage :: a -> Message+ +sendCommand :: (ToMessage c, BotMonad m, Functor m) => c -> m ()+sendCommand c = sendMessage (toMessage c)++data Pong+ = Pong HostName+ deriving (Eq, Ord, Read, Show, Data, Typeable)++instance ToMessage Pong where+ toMessage (Pong hostName) = Message Nothing "PONG" [hostName]++instance ToMessage PrivMsg where+ toMessage (PrivMsg prefix receivers msg) = Message prefix "PRIVMSG" (receivers ++ [msg])+
+ Network/IRC/Bot/Core.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}+module Network.IRC.Bot.Core + ( simpleBot+ , simpleBot'+ , BotConf(..)+ , nullBotConf+ , User(..)+ , nullUser+ ) where++import Control.Concurrent (ThreadId, forkIO, threadDelay)+import Control.Concurrent.Chan (Chan, dupChan, newChan, readChan, writeChan)+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)+import Control.Exception (IOException, catch)+import Control.Monad (mplus, forever, when)+import Data.Data (Data, Typeable)+import Data.Maybe (fromMaybe)+import Data.Time (UTCTime, addUTCTime, getCurrentTime)+import Network (HostName, PortID(PortNumber), connectTo)+import Network.IRC (Message, decode, encode, joinChan, nick, user)+import Network.IRC as I+import Network.IRC.Bot.Log (Logger, LogLevel(Normal, Debug), stdoutLogger)+import Network.IRC.Bot.BotMonad (BotMonad(logM), BotPartT, BotEnv(..), runBotPartT)+import Prelude hiding (catch)+import System.IO (BufferMode(LineBuffering), Handle, hClose, hGetLine, hPutStrLn, hSetBuffering)++-- |Bot configuration+data BotConf = + BotConf+ { channelLogger :: (Maybe (Chan Message -> IO ())) -- ^ optional channel logging function+ , logger :: Logger -- ^ app logging+ , host :: HostName -- ^ irc server to connect + , port :: Maybe PortID -- ^ irc port to connect to (usually, 'PortNumber 6667')+ , nick :: String -- ^ irc nick+ , user :: User -- ^ irc user info+ , channel :: String -- ^ channel to join+ }++nullBotConf :: BotConf+nullBotConf =+ BotConf { channelLogger = Nothing+ , logger = stdoutLogger Normal+ , host = ""+ , port = Nothing+ , nick = ""+ , user = nullUser+ , channel = ""+ }++data User = User+ { username :: String -- ^ username on client system+ , hostname :: HostName -- ^ hostname of client system+ , servername :: HostName -- ^ irc server client is connected to+ , realname :: String -- ^ client's real name+ }+ deriving (Data, Typeable, Eq, Ord, Read, Show)++nullUser :: User+nullUser = User { username = ""+ , hostname = ""+ , servername = ""+ , realname = ""+ }++-- | connect to irc server and send NICK and USER commands+ircConnect :: HostName -> PortID -> String -> User -> IO Handle+ircConnect host port n u =+ do h <- connectTo host port+ hSetBuffering h LineBuffering+ hPutStrLn h (encode (I.nick n))+ hPutStrLn h (encode (I.user (username u) (hostname u) (servername u) (realname u)))+ return h+ +partLoop :: Logger -> String -> Chan Message -> Chan Message -> (BotPartT IO ()) -> IO ()+partLoop logger botName incomingChan outgoingChan botPart =+ forever $ do msg <- readChan incomingChan+ runBotPartT botPart (BotEnv msg outgoingChan logger botName)+ +ircLoop :: Logger -> String -> Chan Message -> Chan Message -> [BotPartT IO ()] -> IO [ThreadId]+ircLoop logger botName incomingChan outgoingChan parts = mapM forkPart parts+ where+ forkPart botPart =+ do inChan <- dupChan incomingChan+ forkIO $ partLoop logger botName inChan outgoingChan (botPart `mplus` return ())+ +-- reconnect loop is still a bit buggy +-- if you try to write multiple lines, and the all fail, reconnect will be called multiple times..+-- something should be done so that this does not happen+connectionLoop :: Logger -> MVar UTCTime -> HostName -> PortID -> String -> User -> Chan Message -> Chan Message -> Maybe (Chan Message) -> IO () -> IO (ThreadId, ThreadId, IO ())+connectionLoop logger mv host port nick user outgoingChan incomingChan logChan onConnect =+ do hMVar <- newMVar (undefined :: Handle)+ doConnect logger host port nick user onConnect hMVar+ outgoingTid <- forkIO $ forever $+ do msg <- readChan outgoingChan+ writeMaybeChan logChan msg+ h <- readMVar hMVar+ hPutStrLn h (encode msg) `catch` (reconnect logger host port nick user onConnect hMVar)+ modifyMVar_ mv (const getCurrentTime) + incomingTid <- forkIO $ forever $+ do h <- readMVar hMVar+ msgStr <- (hGetLine h) `catch` (\e -> reconnect logger host port nick user onConnect hMVar e >> return "")+ modifyMVar_ mv (const getCurrentTime)+ case decode (msgStr ++ "\n") of+ Nothing -> logger Normal ("decode failed: " ++ msgStr)+ (Just msg) -> + do logger Debug (show msg)+ writeMaybeChan logChan msg+ writeChan incomingChan msg+ let forceReconnect = + do h <- readMVar hMVar+ hClose h+ return (outgoingTid, incomingTid, forceReconnect)++ +ircConnectLoop logger host port nick user =+ (ircConnect host port nick user) `catch` + (\e ->+ do logger Normal $ "irc connect failed ... retry in 60 seconds: " ++ show (e :: IOException)+ threadDelay (60 * 10^6)+ ircConnectLoop logger host port nick user)+ +doConnect logger host port nick user onConnect hMVar =+ do logger Normal $ showString "Connecting to " . showString host . showString " as " $ nick+ h <- ircConnectLoop logger host port nick user+ modifyMVar_ hMVar (const $ return h)+ logger Normal $ "Connected."+ onConnect+ return ()++reconnect :: Logger -> String -> PortID -> String -> User -> IO a -> MVar Handle -> IOException -> IO ()+reconnect logger host port nick user onConnect hMVar e = + do logger Normal $ "IRC Connection died: " ++ show e+ doConnect logger host port nick user onConnect hMVar++-- |simpleBot connects to the server and handles messages using the supplied BotPartTs+-- +-- the 'Chan Message' for the optional logging function will include+-- all received and sent messages. This means that the bots output+-- will be included in the logs.+simpleBot :: BotConf -- ^ Bot configuration+ -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', or equivalent)+ -> IO [ThreadId] -- ^ 'ThreadId' for all forked handler threads+simpleBot BotConf{..} parts =+ simpleBot' channelLogger logger host port nick user channel parts++-- |simpleBot' connects to the server and handles messages using the supplied BotPartTs+--+-- the 'Chan Message' for the optional logging function will include+-- all received and sent messages. This means that the bots output+-- will be included in the logs.+simpleBot' :: (Maybe (Chan Message -> IO ())) -- ^ optional logging function+ -> Logger -- ^ application logging+ -> HostName -- ^ irc server to connect + -> Maybe PortID -- ^ irc port to connect to (usually, 'PortNumber 6667')+ -> String -- ^ irc nick+ -> User -- ^ irc user info+ -> String -- ^ channel to join+ -> [BotPartT IO ()] -- ^ bot parts (must include 'pingPart', or equivalent)+ -> IO [ThreadId] -- ^ 'ThreadId' for all forked handler threads+simpleBot' mChanLogger logger host mPort nick user channel parts = + do (mLogTid, mLogChan) <- + case mChanLogger of+ Nothing -> return (Nothing, Nothing)+ (Just chanLogger) ->+ do logChan <- newChan :: IO (Chan Message)+ logTid <- forkIO $ chanLogger logChan+ return (Just logTid, Just logChan)+ -- message channels+ outgoingChan <- newChan :: IO (Chan Message)+ incomingChan <- newChan :: IO (Chan Message)+ mv <- newMVar =<< getCurrentTime+ (outgoingTid, incomingTid, forceReconnect) <- connectionLoop logger mv host (fromMaybe (PortNumber 6667) mPort) nick user outgoingChan incomingChan mLogChan (onConnect outgoingChan)+ watchDogTid <- forkIO $ forever $ + do let timeout = 5*60+ now <- getCurrentTime+ lastActivity <- readMVar mv+ when (now > addUTCTime (fromIntegral timeout) lastActivity) forceReconnect+ threadDelay (30*10^6) -- check every 30 seconds+ ircTids <- ircLoop logger nick incomingChan outgoingChan parts+ return $ maybe id (:) mLogTid $ (incomingTid : outgoingTid : watchDogTid : ircTids)+ where+ onConnect outgoingChan = + do logger Normal $ "joining channel " ++ channel+ writeChan outgoingChan (joinChan channel)+++-- | call 'writeChan' if 'Just'. Do nothing for Nothing.+writeMaybeChan :: Maybe (Chan a) -> a -> IO ()+writeMaybeChan Nothing _ = return () +writeMaybeChan (Just chan) a = writeChan chan a
+ Network/IRC/Bot/Log.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Network.IRC.Bot.Log where++import Data.Data++data LogLevel+ = Debug+ | Normal+ | Important+ deriving (Eq, Ord, Read, Show, Data, Typeable)++type Logger = LogLevel -> String -> IO ()++stdoutLogger :: LogLevel -> Logger+stdoutLogger minLvl msgLvl msg+ | msgLvl >= minLvl = putStrLn msg+ | otherwise = return ()++nullLogger :: Logger+nullLogger _ _ = return ()
+ Network/IRC/Bot/Parsec.hs view
@@ -0,0 +1,125 @@+module Network.IRC.Bot.Parsec where++{-++The parsec part is supposed to make it easy to use Parsec to parse the command arguments.++We would also like to be able to generate a help menu. But the help+menu should not be for only Parsec commands. Or do we? Maybe all interactive commands should be implementing through parsec part. ++Some commands like @seen (and @tell) are two part. There is the part that collects+the data. And there is the command itself. How would that integrate+with a parsec command master list?++We would like the parsec commands to be non-blocking.++Each top-level part is run in a separate thread. But if we only have one thread for all the parsecParts, then blocking could occur.++We could run every handler for every message, even though we only expect at most one command to match. That seems bogus. Do we really want to allow to different parts to respond to @foo ? ++Seems better to have each part register. ++data Part m = + Part { name :: String+ , description :: String+ , backgroundParts :: [BotPartT m ()]+ , command :: Maybe (String, String, BotPartT m ()) -- ^ (name, usage, handler)+ }++This is good, unless multiple plugins wanted to depend on some common backgroundParts+-}++import Control.Monad+import Control.Monad.Trans+import Data.Char (digitToInt)+import Data.List (intercalate, nub)+import Network.IRC.Bot.Log+import Network.IRC.Bot.BotMonad+import Network.IRC.Bot.Commands+import Text.Parsec+import Text.Parsec.Error (errorMessages, messageString)+-- import System.Log.Logger (Priority(DEBUG, INFO, ERROR), logM)+import qualified Text.Parsec.Error as P++instance (BotMonad m, Monad m) => BotMonad (ParsecT s u m) where+ askMessage = lift askMessage+ askOutChan = lift askOutChan+ localMessage f m = mapParsecT (localMessage f) m+ sendMessage = lift . sendMessage+ logM lvl msg = lift (logM lvl msg)+ whoami = lift whoami++mapParsecT :: (Monad m, Monad n) => (m (Consumed (m (Reply s u a))) -> n (Consumed (n (Reply s u b)))) -> ParsecT s u m a -> ParsecT s u n b+mapParsecT f p = mkPT $ \s -> f (runParsecT p s)++nat :: (Monad m) => ParsecT String () m Integer+nat =+ do digits <- many1 digit+ return $ foldl (\x d -> x * 10 + fromIntegral (digitToInt d)) 0 digits++botPrefix :: (MonadPlus m) => String -> ParsecT String () m ()+botPrefix name = + (try $ do string name+ string ": "+ return ())+ <|>+ lift mzero++-- parsecPart :: (Monad m, MonadPlus m, BotMonad m) => String -> ParsecT String () m a -> m a+parsecPart p = + do name <- whoami+ priv <- privMsg + logM Debug $ "I got a message: " ++ msg priv ++ " sent to " ++ show (receivers priv)+ ma <- runParserT (botPrefix name >> p (head (receivers priv))) () (msg priv) (msg priv)+ case ma of+ (Left e) -> + do logM Debug $ "Parse error: " ++ show e+ reportError (head (receivers priv)) e+ mzero+ (Right a) -> return a++reportError :: (BotMonad m) => String -> ParseError -> m ()+reportError target err =+ let errStrs = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages err)+ errStr = intercalate "; " errStrs+ in sendCommand (PrivMsg Nothing [target] errStr)++showErrorMessages ::+ String -> String -> String -> String -> String -> [P.Message] -> [String]+showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs+ | null msgs = [msgUnknown]+ | otherwise = clean $+ [showSysUnExpect,showUnExpect,showExpect,showMessages]+ where+ (sysUnExpect,msgs1) = span ((P.SysUnExpect "") ==) msgs+ (unExpect,msgs2) = span ((P.UnExpect "") ==) msgs1+ (expect,messages) = span ((P.Expect "") ==) msgs2++ showExpect = showMany msgExpecting expect+ showUnExpect = showMany msgUnExpected unExpect+ showSysUnExpect | not (null unExpect) ||+ null sysUnExpect = ""+ | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput+ | otherwise = msgUnExpected ++ " " ++ firstMsg+ where+ firstMsg = messageString (head sysUnExpect)++ showMessages = showMany "" messages++ -- helpers+ showMany pre msgs = case clean (map messageString msgs) of+ [] -> ""+ ms | null pre -> commasOr ms+ | otherwise -> pre ++ " " ++ commasOr ms++ commasOr [] = ""+ commasOr [m] = m+ commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms++ commaSep = seperate ", " . clean++ seperate _ [] = ""+ seperate _ [m] = m+ seperate sep (m:ms) = m ++ sep ++ seperate sep ms++ clean = nub . filter (not . null)
+ Network/IRC/Bot/Part/Dice.hs view
@@ -0,0 +1,37 @@+module Network.IRC.Bot.Part.Dice where++import Control.Monad+import Control.Monad.Trans+import Network.IRC.Bot.Log+import Network.IRC.Bot.BotMonad+import Network.IRC.Bot.Commands+import Network.IRC.Bot.Parsec+import System.Random (randomRIO)+import Text.Parsec+import Text.Parsec.Error (errorMessages, messageString)+import qualified Text.Parsec.Error as P++dicePart :: (BotMonad m) => m ()+dicePart = parsecPart diceCommand++diceCommand :: (BotMonad m) => String -> ParsecT String () m ()+diceCommand target =+ do try $ string "dice"+ (numDice, numSides, modifier) <- (do + skipMany1 space+ nd <- nat <|> return 1+ if nd > 100+ then fail "You can not roll more than 100 dice."+ else do+ char 'd'+ ns <- (do n <- nat+ if n > 0+ then return n+ else fail "The dice must have at least 1 side"+ )+ mod <- (do char '+' >> nat) <|> return 0+ return (nd, ns, mod)) <?> "dice <num-dice>d<num-sides>[+<modifier>]"+ rolls <- liftIO $ replicateM (fromIntegral numDice) $ randomRIO (1, numSides)+ let results = "You rolled " ++ show numDice ++ " " ++ show numSides ++ "-sided dice with a +" ++ show modifier ++ " modifier: " ++ show rolls ++ " => " ++ show (sum (modifier : rolls))+ sendCommand (PrivMsg Nothing [target] results)+ <|> return ()
+ Network/IRC/Bot/Part/Ping.hs view
@@ -0,0 +1,9 @@+module Network.IRC.Bot.Part.Ping where++import Network.IRC.Bot.BotMonad (BotMonad)+import Network.IRC.Bot.Commands (Ping(..), Pong(..), ping, sendCommand)++pingPart :: (BotMonad m) => m () +pingPart =+ do (Ping hostName) <- ping+ sendCommand (Pong hostName)
+ Network/IRC/Bot/PosixLogger.hs view
@@ -0,0 +1,54 @@+module Network.IRC.Bot.PosixLogger where++import Control.Concurrent.Chan+import Data.Time.Calendar (Day(..))+import Data.Time.Clock (UTCTime(..), addUTCTime, getCurrentTime)+import Data.Time.Format (formatTime)+import Network.IRC (Command, Message(Message, msg_prefix, msg_command, msg_params), Prefix(NickName), UserName, encode, decode, joinChan, nick, user)+import Network.IRC.Bot.Commands+import System.FilePath+import System.Locale+import System.Posix++-- TODO: This should be modified so that a formatting filter can be applied to the log messages+-- TODO: should be updated so that log file name matches channel+-- TODO: should support multiple channels+posixLogger :: Maybe FilePath -> String -> Chan Message -> IO ()+posixLogger mLogDir channel logChan =+ do now <- getCurrentTime+ let logDay = utctDay now+ logFd <- openLog now+ logLoop logDay logFd+ where+ openLog :: UTCTime -> IO (Maybe Fd)+ openLog now =+ case mLogDir of+ Nothing -> return Nothing+ (Just logDir) ->+ do let logPath = logDir </> (formatTime defaultTimeLocale ((dropWhile (== '#') channel) ++ "-%Y-%m-%d.txt") now)+ fd <- openFd logPath WriteOnly (Just 0o0644) (defaultFileFlags { append = True })+ return (Just fd)+ updateLogHandle :: UTCTime -> Day -> Maybe Fd -> IO (Day, Maybe Fd)+ updateLogHandle now logDay Nothing = return (logDay, Nothing)+ updateLogHandle now logDay (Just logFd)+ | logDay == (utctDay now) = return (logDay, Just logFd)+ | otherwise = do closeFd logFd+ nowHandle <- openLog now+ return (utctDay now, nowHandle)+ + logLoop :: Day -> Maybe Fd -> IO ()+ logLoop logDay mLogFd =+ do msg <- readChan logChan+ now <- getCurrentTime + (logDay', mLogFd') <- updateLogHandle now logDay mLogFd+ let mPrivMsg = toPrivMsg msg+ case mPrivMsg of+ (Just (PrivMsg (Just (NickName nick _user _server)) receivers msg)) | channel `elem` receivers ->+ do let logMsg = showString (formatTime defaultTimeLocale "%X " now) . showString "<" . showString nick . showString "> " $ msg+ case mLogFd' of+ Nothing -> return ()+ (Just logFd') -> fdWrite logFd' (logMsg ++ "\n") >> return ()+ return ()+ -- hPutStrLn logFd logMsg+ _ -> return ()+ logLoop logDay' mLogFd'
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ ircbot.cabal view
@@ -0,0 +1,82 @@+-- ircbot.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: ircbot++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.1.0++-- A short (one-line) description of the package.+Synopsis: A library for writing irc bots++-- A longer description of the package.+-- Description: ++-- URL for the project homepage or repository.+Homepage: http://src.seereason.com/ircbot++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Jeremy Shaw++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: jeremy@seereason.com++-- A copyright notice.+-- Copyright: ++-- Stability of the pakcage (experimental, provisional, stable...)+Stability: Experimental++Category: Network++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.2+++Library+ -- Modules exported by the library.+ Exposed-modules: + Network.IRC.Bot+ Network.IRC.Bot.BotMonad+ Network.IRC.Bot.Core+ Network.IRC.Bot.Commands+ Network.IRC.Bot.Log+ Network.IRC.Bot.Part.Dice+ Network.IRC.Bot.Part.Ping+ Network.IRC.Bot.Parsec+ Network.IRC.Bot.PosixLogger+ + -- Packages needed in order to build this package.+ Build-depends: base >= 4 && <5,+ filepath,+ irc,+ mtl,+ network,+ old-locale,+ parsec,+ time,+ unix,+ random++ -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +