diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index ae9a47b..a17931d 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/hask-irc-core/Network/IRC/Bot.hs @@ -17,7 +17,7 @@ import qualified System.Log.Logger as HSL import ClassyPrelude import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay) -import Control.Exception.Lifted (mask_) +import Control.Exception.Lifted (mask_, mask) import Control.Monad.Reader (ask) import Control.Monad.State (get, put) import Data.Time (addUTCTime) @@ -59,11 +59,11 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do _ -> sendCommandLoop (commandChan, latch) bot readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO () -readLineLoop = readLineLoop' [] +readLineLoop = go [] where msgPartTimeout = 10 - readLineLoop' !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do + go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do botStatus <- readMVar mvBotStatus case botStatus of Disconnected -> latchIt latch @@ -76,31 +76,30 @@ readLineLoop = readLineLoop' [] Right Nothing -> writeChan lineChan Timeout >> return msgParts Right (Just (Line time line)) -> do let (mmsg, msgParts') = parseLine botConfig time line msgParts - case mmsg of - Nothing -> return msgParts' - Just msg -> writeChan lineChan (Msg msg) >> return msgParts' + whenJust mmsg $ writeChan lineChan . Msg + return msgParts' Right (Just l) -> writeChan lineChan l >> return msgParts limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime let msgParts'' = concat . filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime)) . groupAllOn (msgParserType &&& msgPartTarget) $ msgParts' - readLineLoop' msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay + go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay where readLine' = do eof <- hIsEOF socket if eof then return EOF - else do - line <- map initEx $ hGetLine socket + else mask $ \unmask -> do + line <- map initEx . unmask $ hGetLine socket infoM . unpack $ "< " ++ line now <- getCurrentTime return $ Line now line messageProcessLoop :: Chan Line -> Chan Command -> IRC () -messageProcessLoop = messageProcessLoop' 0 +messageProcessLoop = go 0 where - messageProcessLoop' !idleFor lineChan commandChan = do + go !idleFor lineChan commandChan = do status <- get bot@Bot { .. } <- ask let nick = botNick botConfig @@ -133,10 +132,10 @@ messageProcessLoop = messageProcessLoop' 0 put nStatus case nStatus of - Idle -> messageProcessLoop' (idleFor + oneSec) lineChan commandChan + Idle -> go (idleFor + oneSec) lineChan commandChan Disconnected -> return () NickNotAvailable -> return () - _ -> messageProcessLoop' 0 lineChan commandChan + _ -> go 0 lineChan commandChan where dispatchHandlers Bot { .. } message = diff --git a/hask-irc-runner/Network/IRC/Client.hs b/hask-irc-core/Network/IRC/Client.hs similarity index 67% rename from hask-irc-runner/Network/IRC/Client.hs rename to hask-irc-core/Network/IRC/Client.hs index a652398..af1d8ff 100644 --- a/hask-irc-runner/Network/IRC/Client.hs +++ b/hask-irc-core/Network/IRC/Client.hs @@ -5,19 +5,27 @@ module Network.IRC.Client (runBot) where import qualified System.Log.Logger as HSL import ClassyPrelude -import Control.Concurrent.Lifted (fork, newChan, threadDelay) -import Control.Exception.Lifted (AsyncException (UserInterrupt)) +import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan) +import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt)) import Network (PortID (PortNumber), connectTo, withSocketsDo) import System.IO (hSetBuffering, BufferMode(..)) +import System.Log.Formatter (tfLogFormatter) +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (streamHandler) +import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerName, + setHandlers, setLevel) import System.Log.Logger.TH (deriveLoggers) +import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch)) import Network.IRC.Bot -import Network.IRC.Handlers import Network.IRC.Types import Network.IRC.Util $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR]) +coreMsgHandlerNames :: [MsgHandlerName] +coreMsgHandlerNames = ["pingpong", "help"] + connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent) connect botConfig@BotConfig { .. } = do debugM "Connecting ..." @@ -43,10 +51,17 @@ connect botConfig@BotConfig { .. } = do newChannel = (,) <$> newChan <*> newEmptyMVar + mkMsgHandler :: Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) + mkMsgHandler eventChan name = + flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler -> + case finalHandler of + Just _ -> return finalHandler + Nothing -> handler botConfig eventChan name + loadMsgHandlers eventChan = flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do debugM . unpack $ "Loading msg handler: " ++ msgHandlerName - mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName + mMsgHandler <- mkMsgHandler eventChan msgHandlerName case mMsgHandler of Nothing -> do debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName @@ -71,15 +86,12 @@ disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), ( debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName stopMsgHandler msgHandler botConfig -runBot :: BotConfig -> IO () -runBot botConfig' = withSocketsDo $ do - hSetBuffering stdout LineBuffering - debugM "Running with config:" - print botConfig - status <- runBot_ +runBotIntenal :: BotConfig -> IO () +runBotIntenal botConfig' = withSocketsDo $ do + status <- run case status of - Disconnected -> debugM "Restarting .." >> runBot botConfig - Errored -> debugM "Restarting .." >> runBot botConfig + Disconnected -> debugM "Restarting .." >> runBotIntenal botConfig + Errored -> debugM "Restarting .." >> runBotIntenal botConfig Interrupted -> return () NickNotAvailable -> return () _ -> error "Unsupported status" @@ -95,9 +107,11 @@ runBot botConfig' = withSocketsDo $ do Just UserInterrupt -> debugM "User interrupt" >> return Interrupted _ -> debugM ("Exception! " ++ show e) >> return Errored - runBot_ = bracket (connect botConfig) disconnect $ + run = bracket (connect botConfig) disconnect $ \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) -> handle handleErrors $ do + debugM $ "Running with config:\n" ++ show botConfig + sendCommand commandChan NickCmd sendCommand commandChan UserCmd @@ -105,3 +119,20 @@ runBot botConfig' = withSocketsDo $ do fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec fork $ eventProcessLoop eventChannel lineChan commandChan bot runIRC bot Connected (messageProcessLoop lineChan commandChan) + +runBot :: BotConfig -> IO () +runBot botConfig = do + -- setup signal handling + mainThreadId <- myThreadId + installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing + installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing + + -- setup logging + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $ + setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg" + updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG) + + -- run + runBotIntenal botConfig diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index ce53605..4f44dac 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/hask-irc-core/Network/IRC/Protocol.hs @@ -60,18 +60,18 @@ lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message ti | otherwise -> ChannelMsg user message _ -> OtherMsg source command target message where - splits = words line - command = splits !! 1 - source = drop 1 $ splits !! 0 - target = splits !! 2 - message = strip . drop 1 . unwords . drop 3 $ splits - quitMessage = strip . drop 1 . unwords . drop 2 $ splits - user = uncurry User . (Nick *** drop 1) . break (== '!') $ source - mode = splits !! 3 - modeArgs = drop 4 splits - kicked = splits !! 3 - kickReason = drop 1 . unwords . drop 4 $ splits - isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message + splits = words line + command = splits !! 1 + source = drop 1 $ splits !! 0 + target = splits !! 2 + message = strip . drop 1 . unwords . drop 3 $ splits + quitMessage = strip . drop 1 . unwords . drop 2 $ splits + user = uncurry User . (Nick *** drop 1) . break (== '!') $ source + mode = splits !! 3 + modeArgs = drop 4 splits + kicked = splits !! 3 + kickReason = drop 1 . unwords . drop 4 $ splits + isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message partitionMsgParts :: MessageParseType -> Text -> [MessagePart] -> ([MessagePart], [MessagePart]) partitionMsgParts parserType target = @@ -96,11 +96,13 @@ lineFromCommand :: BotConfig -> Command -> Maybe Text lineFromCommand BotConfig { .. } command = case command of PongCmd { .. } -> Just $ "PONG :" ++ rmsg PingCmd { .. } -> Just $ "PING :" ++ rmsg - NickCmd -> Just $ "NICK " ++ nickToText botNick - UserCmd -> Just $ "USER " ++ nickToText botNick ++ " 0 * :" ++ nickToText botNick + NickCmd -> Just $ "NICK " ++ botNick' + UserCmd -> Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick' JoinCmd -> Just $ "JOIN " ++ channel QuitCmd -> Just "QUIT" ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ rmsg NamesCmd -> Just $ "NAMES " ++ channel _ -> Nothing + where + botNick' = nickToText botNick diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index 148cbb2..eba688a 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/hask-irc-core/Network/IRC/Types.hs @@ -27,17 +27,19 @@ module Network.IRC.Types , handleMessage , handleEvent , stopMsgHandler - , getHelp ) + , getHelp + , MsgHandlerMaker ) where import ClassyPrelude -import Control.Monad.Base (MonadBase) -import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) -import Control.Monad.State (StateT, MonadState, execStateT) -import Data.Configurator.Types (Config) -import Data.Data (Data) -import Data.SafeCopy (base, deriveSafeCopy) -import Data.Typeable (cast) +import Control.Concurrent.Lifted (Chan) +import Control.Monad.Base (MonadBase) +import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) +import Control.Monad.State (StateT, MonadState, execStateT) +import Data.Configurator.Types (Config) +import Data.Data (Data) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Typeable (cast) import Network.IRC.Util @@ -52,10 +54,10 @@ instance Show Nick where $(deriveSafeCopy 0 'base ''Nick) data User = Self | User { userNick :: !Nick, userServer :: !Text } - deriving (Show, Eq) + deriving (Show, Eq, Ord) data Message = Message { msgTime :: !UTCTime, msgLine :: !Text, msgDetails :: MessageDetails} - deriving (Show, Eq) + deriving (Show, Eq, Ord) data MessageDetails = IdleMsg @@ -73,7 +75,7 @@ data MessageDetails = | KickMsg { user :: !User, kickedNick :: !Nick, msg :: !Text } | ModeMsg { user :: !User, msgTarget :: !Text, mode :: !Text , modeArgs :: ![Text] } | OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text } - deriving (Show, Eq) + deriving (Show, Eq, Ord) data Command = PingCmd { rmsg :: !Text } @@ -85,11 +87,11 @@ data Command = | JoinCmd | QuitCmd | NamesCmd - deriving (Show, Eq) + deriving (Show, Eq, Ord) --- Internal events +-- Events -class (Typeable e, Show e) => Event e where +class (Typeable e, Show e, Eq e) => Event e where toEvent :: e -> IO SomeEvent toEvent e = SomeEvent <$> pure e <*> getCurrentTime @@ -98,30 +100,36 @@ class (Typeable e, Show e) => Event e where ev <- cast e return (ev, time) -data SomeEvent = forall e. Event e => SomeEvent e UTCTime deriving (Typeable) +data SomeEvent = forall e. (Event e, Typeable e) => SomeEvent e UTCTime deriving (Typeable) instance Show SomeEvent where show (SomeEvent e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e +instance Eq SomeEvent where + SomeEvent e1 t1 == SomeEvent e2 t2 = + case cast e2 of + Just e2' -> e1 == e2' && t1 == t2 + Nothing -> False -data QuitEvent = QuitEvent deriving (Show, Typeable) +data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable) instance Event QuitEvent data EventResponse = RespNothing | RespEvent SomeEvent | RespMessage Message | RespCommand Command - deriving (Show) + deriving (Show, Eq) -- Bot type MsgHandlerName = Text -data BotConfig = BotConfig { server :: !Text - , port :: !Int - , channel :: !Text - , botNick :: !Nick - , botTimeout :: !Int - , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) - , config :: !Config } +data BotConfig = BotConfig { server :: !Text + , port :: !Int + , channel :: !Text + , botNick :: !Nick + , botTimeout :: !Int + , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text)) + , msgHandlerMakers :: ![MsgHandlerMaker] + , config :: !Config } instance Show BotConfig where show BotConfig { .. } = "server = " ++ show server ++ "\n" ++ @@ -135,15 +143,15 @@ data Bot = Bot { botConfig :: !BotConfig , socket :: !Handle , msgHandlers :: !(Map MsgHandlerName MsgHandler) } -data BotStatus = Connected - | Disconnected - | Joined - | Kicked - | Errored - | Idle - | Interrupted - | NickNotAvailable - deriving (Show, Eq) +data BotStatus = Connected + | Disconnected + | Joined + | Kicked + | Errored + | Idle + | Interrupted + | NickNotAvailable + deriving (Show, Eq, Ord) newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } deriving ( Functor @@ -202,3 +210,5 @@ newMsgHandler = MsgHandler { onEvent = const $ return RespNothing, onHelp = return mempty } + +type MsgHandlerMaker = BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) diff --git a/hask-irc-core/Network/IRC/Util.hs b/hask-irc-core/Network/IRC/Util.hs index 603d7d5..a4dbeb3 100644 --- a/hask-irc-core/Network/IRC/Util.hs +++ b/hask-irc-core/Network/IRC/Util.hs @@ -2,13 +2,13 @@ module Network.IRC.Util where -import qualified Data.Text.Lazy as LzT import qualified Data.Text.Format as TF import ClassyPrelude import Control.Arrow (Arrow) import Control.Concurrent.Lifted (Chan) import Control.Monad.Base (MonadBase) +import Data.Convertible (convert) import Data.Text (strip) import Data.Time (diffUTCTime) @@ -49,7 +49,7 @@ atomicModIORef ref f = void . atomicModifyIORef' ref $ \v -> (f v, v) -- | Display a time span as one time relative to another. relativeTime :: UTCTime -> UTCTime -> Text relativeTime t1 t2 = - maybe "unknown" (LzT.toStrict . format) $ find (\(s,_,_) -> abs period >= s) ranges + maybe "unknown" (convert . format) $ find (\(s,_,_) -> abs period >= s) ranges where minute = 60; hour = minute * 60; day = hour * 24; week = day * 7; month = day * 30; year = month * 12 diff --git a/hask-irc-core/hask-irc-core.cabal b/hask-irc-core/hask-irc-core.cabal index 19dd353..ac16dd0 100644 --- a/hask-irc-core/hask-irc-core.cabal +++ b/hask-irc-core/hask-irc-core.cabal @@ -54,22 +54,26 @@ library DeriveDataTypeable build-depends: base >=4.5 && <4.8, - text >=0.11 && <0.12, - mtl >=2.1 && <2.2, - configurator >=0.2 && <0.3, - safecopy >=0.8 && <0.9, - time >=1.4 && <1.5, classy-prelude >=0.9 && <1.0, - text-format >=0.3 && <0.4, - lifted-base >=0.2 && <0.3, + configurator >=0.2 && <0.3, + convertible >=1.1 && <1.2, hslogger >=1.2 && <1.3, hslogger-template >=2.0 && <2.1, - transformers-base >=0.4 && <0.5 + lifted-base >=0.2 && <0.3, + mtl >=2.1 && <2.2, + network >=2.3 && <2.5, + safecopy >=0.8 && <0.9, + text >=0.11 && <0.12, + text-format >=0.3 && <0.4, + time >=1.4 && <1.5, + transformers-base >=0.4 && <0.5, + unix >=2.7 && <2.8 exposed-modules: Network.IRC.Types, Network.IRC.Protocol, Network.IRC.Util, - Network.IRC.Bot + Network.IRC.Bot, + Network.IRC.Client default-language: Haskell2010 diff --git a/hask-irc-handlers/Network/IRC/Handlers.hs b/hask-irc-handlers/Network/IRC/Handlers.hs index f3de03a..2feaf94 100644 --- a/hask-irc-handlers/Network/IRC/Handlers.hs +++ b/hask-irc-handlers/Network/IRC/Handlers.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where +module Network.IRC.Handlers (allMsgHandlerMakers) where import qualified Network.IRC.Handlers.Auth as Auth import qualified Network.IRC.Handlers.Core as Core @@ -10,28 +8,15 @@ import qualified Network.IRC.Handlers.NickTracker as NickTracker import qualified Network.IRC.Handlers.SongSearch as SongSearch import qualified Network.IRC.Handlers.Tell as Tell -import ClassyPrelude -import Control.Concurrent.Lifted (Chan) - import Network.IRC.Types -coreMsgHandlerNames :: [Text] -coreMsgHandlerNames = ["pingpong", "help"] - -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) -mkMsgHandler botConfig eventChan name = - flip (`foldM` Nothing) handlerMakers $ \finalHandler handler -> - case finalHandler of - Just _ -> return finalHandler - Nothing -> handler botConfig eventChan name - - where - handlerMakers = [ - Auth.mkMsgHandler - , Core.mkMsgHandler - , Greet.mkMsgHandler - , Logger.mkMsgHandler - , NickTracker.mkMsgHandler - , SongSearch.mkMsgHandler - , Tell.mkMsgHandler - ] +allMsgHandlerMakers :: [MsgHandlerMaker] +allMsgHandlerMakers = [ + Auth.mkMsgHandler + , Core.mkMsgHandler + , Greet.mkMsgHandler + , Logger.mkMsgHandler + , NickTracker.mkMsgHandler + , SongSearch.mkMsgHandler + , Tell.mkMsgHandler + ] diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs index e9772c5..6290201 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs @@ -7,12 +7,11 @@ import qualified Data.UUID as U import qualified Data.UUID.V4 as U import ClassyPrelude -import Control.Concurrent.Lifted (Chan) -import Control.Monad.Reader (asks) -import Control.Monad.State (get, put) -import Data.Acid (AcidState, Query, Update, makeAcidic, query, update, - openLocalState, createArchive) -import Data.Acid.Local (createCheckpointAndClose) +import Control.Monad.Reader (asks) +import Control.Monad.State (get, put) +import Data.Acid (AcidState, Query, Update, makeAcidic, query, update, + openLocalState, createArchive) +import Data.Acid.Local (createCheckpointAndClose) import Network.IRC.Handlers.Auth.Types import Network.IRC.Types @@ -66,7 +65,7 @@ authEvent state event = case fromEvent event of return RespNothing _ -> return RespNothing -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler :: MsgHandlerMaker mkMsgHandler BotConfig { .. } _ "auth" = do state <- io $ openLocalState emptyAuth >>= newIORef return . Just $ newMsgHandler { onMessage = authMessage state diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs index 265d1b1..4927f6e 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} module Network.IRC.Handlers.Auth.Types where @@ -18,7 +17,7 @@ emptyAuth = Auth mempty $(deriveSafeCopy 0 'base ''Auth) -data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable) +data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable) instance Event AuthEvent diff --git a/hask-irc-handlers/Network/IRC/Handlers/Core.hs b/hask-irc-handlers/Network/IRC/Handlers/Core.hs index 8038c4e..343e20d 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Core.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Core.hs @@ -1,7 +1,6 @@ module Network.IRC.Handlers.Core (mkMsgHandler) where import ClassyPrelude -import Control.Concurrent.Lifted (Chan) import Control.Monad.Reader (ask) import Data.Convertible (convert) import Data.Time (addUTCTime) @@ -9,7 +8,7 @@ import Data.Time (addUTCTime) import Network.IRC.Types import Network.IRC.Util -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler :: MsgHandlerMaker mkMsgHandler _ _ "pingpong" = do state <- getCurrentTime >>= newIORef return . Just $ newMsgHandler { onMessage = pingPong state } @@ -44,11 +43,13 @@ help Message { msgDetails = ChannelMsg { .. }, .. } | "!help" == clean msg = do BotConfig { .. } <- ask let commands = concatMap mapKeys . mapValues $ msgHandlerInfo - return [ChannelMsgReply $ "I know these commands: " ++ unwords commands] + return [ ChannelMsgReply $ "I know these commands: " ++ unwords commands + , ChannelMsgReply "Type !help to know more about any command"] | "!help" `isPrefixOf` msg = do BotConfig { .. } <- ask - let command = cons '!'. dropWhile (== '!') . clean . unwords . drop 1 . words $ msg - let mHelp = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo + let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg + let mHelp = find ((\c -> c == command || c == cons '!' command) . fst) + . concatMap mapToList . mapValues $ msgHandlerInfo return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp] help _ = return [] diff --git a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs index 7b354d2..0194971 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs @@ -1,13 +1,12 @@ module Network.IRC.Handlers.Greet (mkMsgHandler) where import ClassyPrelude -import Control.Concurrent.Lifted (Chan) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (ask) import Network.IRC.Types import Network.IRC.Util -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler :: MsgHandlerMaker mkMsgHandler _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter } mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer } mkMsgHandler _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs index c8a8077..67c476d 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs @@ -2,25 +2,24 @@ module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where -import qualified Data.Configurator as C +import qualified Data.Configurator as CF import qualified Data.Text.Format as TF import qualified Data.Text.Format.Params as TF -import ClassyPrelude hiding ((), (<.>), FilePath, log) -import Control.Concurrent.Lifted (Chan) -import Control.Exception.Lifted (mask_) -import Control.Monad.Reader (ask) -import Data.Time (diffDays) -import System.Directory (createDirectoryIfMissing, getModificationTime, copyFile, removeFile) -import System.FilePath (FilePath, (), (<.>)) -import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..)) +import ClassyPrelude hiding ((), (<.>), FilePath, log) +import Control.Exception.Lifted (mask_) +import Control.Monad.Reader (ask) +import Data.Time (diffDays) +import System.Directory (createDirectoryIfMissing, getModificationTime, copyFile, removeFile) +import System.FilePath (FilePath, (), (<.>)) +import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..)) import Network.IRC.Types import Network.IRC.Util type LoggerState = Maybe (Handle, Day) -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler :: MsgHandlerMaker mkMsgHandler botConfig _ "messagelogger" = do state <- io $ newIORef Nothing initMessageLogger botConfig state @@ -30,7 +29,7 @@ mkMsgHandler _ _ _ = return Nothing getLogFilePath :: BotConfig -> IO FilePath getLogFilePath BotConfig { .. } = do - logFileDir <- C.require config "messagelogger.logdir" + logFileDir <- CF.require config "messagelogger.logdir" createDirectoryIfMissing True logFileDir return $ logFileDir unpack (channel ++ "-" ++ nickToText botNick) <.> "log" diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs index 79b6bb8..65a0253 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs @@ -8,16 +8,15 @@ import qualified Data.IxSet as IS import qualified Data.UUID as U import qualified Data.UUID.V4 as U -import ClassyPrelude hiding (swap) -import Control.Concurrent.Lifted (Chan) -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -import Data.Acid (AcidState, Query, Update, makeAcidic, query, update, - openLocalState, createArchive) -import Data.Acid.Local (createCheckpointAndClose) -import Data.Convertible (convert) -import Data.IxSet (getOne, (@=)) -import Data.Time (addUTCTime, NominalDiffTime) +import ClassyPrelude hiding (swap) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.Acid (AcidState, Query, Update, makeAcidic, query, update, + openLocalState, createArchive) +import Data.Acid.Local (createCheckpointAndClose) +import Data.Convertible (convert) +import Data.IxSet (getOne, (@=)) +import Data.Time (addUTCTime, NominalDiffTime) import Network.IRC.Handlers.NickTracker.Types import Network.IRC.Types @@ -187,7 +186,7 @@ stopNickTracker state = io $ do createArchive acid createCheckpointAndClose acid -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler :: MsgHandlerMaker mkMsgHandler BotConfig { .. } _ "nicktracker" = do state <- io $ do now <- getCurrentTime diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs index 827fac1..c9818b2 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs @@ -10,7 +10,8 @@ import Data.SafeCopy (base, deriveSafeCopy) import Network.IRC.Types -newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable) +newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text } + deriving (Eq, Ord, Show, Data, Typeable) newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable) data NickTrack = NickTrack { @@ -37,7 +38,7 @@ $(deriveSafeCopy 0 'base ''NickTracking) emptyNickTracking :: NickTracking emptyNickTracking = NickTracking empty -data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Typeable) +data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable) instance Event NickTrackRequest @@ -46,7 +47,7 @@ instance Show NickTrackRequest where getCanonicalNick :: Chan SomeEvent -> Nick -> IO (Maybe CanonicalNick) getCanonicalNick eventChan nick = do - reply <- newEmptyMVar + reply <- newEmptyMVar request <- toEvent $ NickTrackRequest nick reply writeChan eventChan request map (map canonicalNick) $ takeMVar reply diff --git a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs b/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs index 2850698..3b7775b 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs @@ -7,21 +7,20 @@ import qualified Data.Configurator as CF import qualified System.Log.Logger as HSL import ClassyPrelude -import Control.Concurrent.Lifted (Chan) -import Control.Exception.Lifted (evaluate) -import Control.Monad.Reader (ask) -import Data.Aeson (FromJSON, parseJSON, Value (..), (.:)) -import Data.Aeson.Types (emptyArray) -import Data.Text (strip) -import Network.Curl.Aeson (curlAesonGet, CurlAesonException) -import Network.HTTP.Base (urlEncode) -import System.Log.Logger.TH (deriveLoggers) +import Control.Exception.Lifted (evaluate) +import Control.Monad.Reader (ask) +import Data.Aeson (FromJSON, parseJSON, Value (..), (.:)) +import Data.Aeson.Types (emptyArray) +import Data.Text (strip) +import Network.Curl.Aeson (curlAesonGet, CurlAesonException) +import Network.HTTP.Base (urlEncode) +import System.Log.Logger.TH (deriveLoggers) import Network.IRC.Types $(deriveLoggers "HSL" [HSL.ERROR]) -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler :: MsgHandlerMaker mkMsgHandler _ _ "songsearch" = return . Just $ newMsgHandler { onMessage = songSearch, onHelp = return $ singletonMap "!m" helpMsg } diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs index 3c9e4e5..6065b68 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs @@ -21,6 +21,8 @@ import Network.IRC.Handlers.Tell.Types import Network.IRC.Types import Network.IRC.Util +-- database + getUndeliveredTellsQ :: CanonicalNick -> Query Tells [Tell] getUndeliveredTellsQ nick = do Tells { .. } <- ask @@ -41,6 +43,8 @@ getUndeliveredTells acid = query acid . GetUndeliveredTellsQ saveTell :: AcidState Tells -> Tell -> IO () saveTell acid = update acid . SaveTellQ +-- handler + newtype TellState = TellState { acid :: AcidState Tells } tellMsg :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> Message -> m [Command] @@ -50,10 +54,9 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. } , length args >= 2 = io $ do TellState { .. } <- readIORef state reps <- if "<" `isPrefixOf` headEx args - then do + then do -- multi tell let (nicks, message) = (parseNicks *** (strip . drop 1)) . break (== '>') . drop 1 . unwords $ args - if null message then return [] else do @@ -63,7 +66,7 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. } (if null passes then [] else ["Message noted and will be passed on to " ++ intercalate ", " passes]) return reps - else do + else do -- single tell let nick = Nick . headEx $ args let message = strip . unwords . drop 1 $ args if null message @@ -91,7 +94,7 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. } getTellsToDeliver = io $ do TellState { .. } <- readIORef state - mcn <- getCanonicalNick eventChan $ userNick user + mcn <- getCanonicalNick eventChan $ userNick user case mcn of Nothing -> return [] Just canonicalNick -> do @@ -109,21 +112,29 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. } tellMsg _ _ _ = return [] +tellEvent :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> SomeEvent -> m EventResponse +tellEvent eventChan state event = case fromEvent event of + Just (TellRequest user message, evTime) -> do + tellMsg eventChan state . Message evTime "" $ ChannelMsg user message + return RespNothing + _ -> return RespNothing + stopTell :: MonadMsgHandler m => IORef TellState -> m () stopTell state = io $ do TellState { .. } <- readIORef state createArchive acid createCheckpointAndClose acid -mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler) +mkMsgHandler :: MsgHandlerMaker mkMsgHandler BotConfig { .. } eventChan "tells" = do - acid <- openLocalState emptyTells + acid <- openLocalState emptyTells state <- newIORef (TellState acid) return . Just $ newMsgHandler { onMessage = tellMsg eventChan state + , onEvent = tellEvent eventChan state , onStop = stopTell state , onHelp = return helpMsgs } where helpMsgs = mapFromList [ ("!tell", "Publically passes a message to a user or a bunch of users. " ++ - "!tell or !tell < ...> ") ] + "!tell or !tell < ...> .") ] mkMsgHandler _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs index da8888a..48ac2e5 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs @@ -1,13 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} module Network.IRC.Handlers.Tell.Types where import ClassyPrelude -import Data.Data (Data) -import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) -import Data.SafeCopy (base, deriveSafeCopy) +import Control.Concurrent.Lifted (Chan, writeChan) +import Data.Data (Data) +import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun) +import Data.SafeCopy (base, deriveSafeCopy) import Network.IRC.Handlers.NickTracker.Types import Network.IRC.Types @@ -41,3 +41,14 @@ $(deriveSafeCopy 0 'base ''Tells) emptyTells :: Tells emptyTells = Tells (TellId 1) empty + +data TellRequest = TellRequest User Text deriving (Eq, Typeable) + +instance Event TellRequest + +instance Show TellRequest where + show (TellRequest user tell) = + "TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]" + +sendTell :: Chan SomeEvent -> User -> Text -> IO () +sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan diff --git a/hask-irc-handlers/hask-irc-handlers.cabal b/hask-irc-handlers/hask-irc-handlers.cabal index cc8543f..57714c4 100644 --- a/hask-irc-handlers/hask-irc-handlers.cabal +++ b/hask-irc-handlers/hask-irc-handlers.cabal @@ -55,24 +55,24 @@ library build-depends: base >=4.5 && <4.8, hask-irc-core ==0.1.0, - text >=0.11 && <0.12, - mtl >=2.1 && <2.2, - configurator >=0.2 && <0.3, - time >=1.4 && <1.5, - curl-aeson >=0.0.3 && <0.1, + acid-state >=0.12 && <0.13, aeson >=0.6.0.0 && <0.7, - HTTP >=4000 && <5000, classy-prelude >=0.9 && <1.0, - text-format >=0.3 && <0.4, - filepath >=1.3 && <1.4, - directory >=1.2 && <1.3, - lifted-base >=0.2 && <0.3, + configurator >=0.2 && <0.3, convertible >=1.1 && <1.2, + curl-aeson >=0.0.3 && <0.1, + directory >=1.2 && <1.3, + filepath >=1.3 && <1.4, hslogger >=1.2 && <1.3, hslogger-template >=2.0 && <2.1, + HTTP >=4000 && <5000, ixset >=1.0 && <1.1, - acid-state >=0.12 && <0.13, + lifted-base >=0.2 && <0.3, + mtl >=2.1 && <2.2, safecopy >=0.8 && <0.9, + text >=0.11 && <0.12, + text-format >=0.3 && <0.4, + time >=1.4 && <1.5, uuid >=1.3 && <1.4 exposed-modules: Network.IRC.Handlers, diff --git a/hask-irc-runner/Main.hs b/hask-irc-runner/Main.hs index 40e3fd3..7882c4b 100644 --- a/hask-irc-runner/Main.hs +++ b/hask-irc-runner/Main.hs @@ -1,8 +1,55 @@ +{-# LANGUAGE OverlappingInstances #-} + module Main where -import qualified Network.IRC.Runner as Runner +import qualified Data.Configurator as CF -import Prelude +import ClassyPrelude hiding (getArgs) +import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..)) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) + +import Network.IRC.Client +import Network.IRC.Handlers +import Network.IRC.Types + +instance Configured a => Configured [a] where + convert (List xs) = Just . mapMaybe convert $ xs + convert _ = Nothing main :: IO () -main = Runner.run +main = do + -- get args + args <- getArgs + prog <- getProgName + + when (length args < 1) $ do + putStrLn $ "Usage: " ++ pack prog ++ " " + exitFailure + + -- load config and start the bot + let configFile = headEx args + loadBotConfig configFile >>= runBot + +loadBotConfig :: String -> IO BotConfig +loadBotConfig configFile = do + eCfg <- try $ CF.load [CF.Required configFile] + case eCfg of + Left (ParseError _ _) -> error "Error while loading config" + Right cfg -> do + eBotConfig <- try $ do + handlers :: [Text] <- CF.require cfg "msghandlers" + let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers + BotConfig <$> + CF.require cfg "server" <*> + CF.require cfg "port" <*> + CF.require cfg "channel" <*> + (Nick <$> CF.require cfg "nick") <*> + CF.require cfg "timeout" <*> + pure handlerInfo <*> + pure allMsgHandlerMakers <*> + pure cfg + + case eBotConfig of + Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k + Right botConf -> return botConf diff --git a/hask-irc-runner/Network/IRC/Runner.hs b/hask-irc-runner/Network/IRC/Runner.hs deleted file mode 100644 index f88858d..0000000 --- a/hask-irc-runner/Network/IRC/Runner.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE OverlappingInstances #-} - -module Network.IRC.Runner (run) where - -import qualified Data.Configurator as CF - -import ClassyPrelude hiding (getArgs) -import Control.Concurrent.Lifted (myThreadId) -import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt)) -import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..)) -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure) -import System.Log.Formatter (tfLogFormatter) -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple (streamHandler) -import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerName, - setHandlers, setLevel) -import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch)) - -import Network.IRC.Types -import Network.IRC.Client - -instance Configured a => Configured [a] where - convert (List xs) = Just . mapMaybe convert $ xs - convert _ = Nothing - -run :: IO () -run = do - -- get args - args <- getArgs - prog <- getProgName - - when (length args < 1) $ do - putStrLn $ "Usage: " ++ pack prog ++ " " - exitFailure - - -- setup signal handling - mainThreadId <- myThreadId - installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing - installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing - - -- setup logging - stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $ - setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg" - updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG) - - -- load config and start the bot - let configFile = headEx args - loadBotConfig configFile >>= runBot - -loadBotConfig :: String -> IO BotConfig -loadBotConfig configFile = do - eCfg <- try $ CF.load [CF.Required configFile] - case eCfg of - Left (ParseError _ _) -> error "Error while loading config" - Right cfg -> do - eBotConfig <- try $ do - handlers :: [Text] <- CF.require cfg "msghandlers" - let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers - BotConfig <$> - CF.require cfg "server" <*> - CF.require cfg "port" <*> - CF.require cfg "channel" <*> - (Nick <$> CF.require cfg "nick") <*> - CF.require cfg "timeout" <*> - pure handlerInfo <*> - pure cfg - - case eBotConfig of - Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k - Right botConf -> return botConf diff --git a/hask-irc-runner/hask-irc-runner.cabal b/hask-irc-runner/hask-irc-runner.cabal index eef36c8..98b0eda 100644 --- a/hask-irc-runner/hask-irc-runner.cabal +++ b/hask-irc-runner/hask-irc-runner.cabal @@ -63,13 +63,8 @@ executable hask-irc build-depends: base >=4.5 && <4.8, hask-irc-core ==0.1.0, hask-irc-handlers ==0.1.0, - configurator >=0.2 && <0.3, classy-prelude >=0.9 && <1.0, - network >=2.3 && <2.5, - lifted-base >=0.2 && <0.3, - unix >=2.7 && <2.8, - hslogger >=1.2 && <1.3, - hslogger-template >=2.0 && <2.1 + configurator >=0.2 && <0.3 -- Directories containing source files. -- hs-source-dirs: @@ -77,5 +72,5 @@ executable hask-irc -- Base language which the package is written in. default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans + ghc-options: -O2 -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans