Major refactoring
1. Unified Messages, Events and Commands 2. Switched to a single TChan based message bus for communication between modules 3. Each handler now has a dedicated thread in which it runs, ensuring sequentiality of messages
This commit is contained in:
parent
e61cab74ed
commit
757285f4fd
@ -1,8 +1,15 @@
|
||||
module Network.IRC
|
||||
(
|
||||
module Network.IRC.Types,
|
||||
module Network.IRC.Client
|
||||
)where
|
||||
{-|
|
||||
Module : Network.IRC
|
||||
Description : A simple and extensible IRC bot.
|
||||
Copyright : (c) Abhinav Sarkar, 2014
|
||||
License : Apache-2.0
|
||||
Maintainer : abhinav@abhinavsarkar.net
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Client
|
||||
module Network.IRC (module IRC) where
|
||||
|
||||
import Network.IRC.Types as IRC
|
||||
import Network.IRC.Client as IRC
|
||||
import Network.IRC.MessageBus as IRC
|
||||
|
||||
@ -1,22 +1,17 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Network.IRC.Bot
|
||||
( Line
|
||||
, sendCommand
|
||||
, sendMessage
|
||||
, sendEvent
|
||||
, readLine
|
||||
( In
|
||||
, sendCommandLoop
|
||||
, readLineLoop
|
||||
, messageProcessLoop
|
||||
, eventProcessLoop )
|
||||
, readMessageLoop
|
||||
, messageProcessLoop )
|
||||
where
|
||||
|
||||
import qualified Data.Text.Format as TF
|
||||
import qualified System.Log.Logger as HSL
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay)
|
||||
import Control.Concurrent.Lifted (threadDelay)
|
||||
import Control.Exception.Lifted (mask_, mask)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Control.Monad.State (get, put)
|
||||
@ -25,145 +20,108 @@ import System.IO (hIsEOF)
|
||||
import System.Timeout (timeout)
|
||||
import System.Log.Logger.TH (deriveLoggers)
|
||||
|
||||
import Network.IRC.MessageBus
|
||||
import Network.IRC.Internal.Types
|
||||
import Network.IRC.Protocol
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Util
|
||||
|
||||
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR])
|
||||
$(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR])
|
||||
|
||||
data Line = Timeout | EOF | Line !UTCTime !Text | Msg FullMessage deriving (Show, Eq)
|
||||
data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq)
|
||||
data In = Timeout | EOD | Msg Message deriving (Show, Eq)
|
||||
|
||||
sendCommand :: Chan Command -> Command -> IO ()
|
||||
sendCommand = writeChan
|
||||
|
||||
sendMessage :: Chan Line -> FullMessage -> IO ()
|
||||
sendMessage = (. Msg) . writeChan
|
||||
|
||||
sendEvent :: Chan Event -> Event -> IO ()
|
||||
sendEvent = writeChan
|
||||
|
||||
readLine :: Chan Line -> IO Line
|
||||
readLine = readChan
|
||||
|
||||
sendCommandLoop :: Channel Command -> Bot -> IO ()
|
||||
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
||||
cmd <- readChan commandChan
|
||||
let mline = formatCommand botConfig cmd
|
||||
sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
|
||||
sendCommandLoop commandChan bot@Bot { .. } = do
|
||||
msg@(Message _ _ cmd) <- receiveMessage commandChan
|
||||
let mline = formatCommand botConfig msg
|
||||
handle (\(e :: SomeException) ->
|
||||
errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
|
||||
errorM ("Error while writing to connection: " ++ show e) >> closeMessageChannel commandChan) $ do
|
||||
whenJust mline $ \line -> do
|
||||
TF.hprint botSocket "{}\r\n" $ TF.Only line
|
||||
infoM . unpack $ "> " ++ line
|
||||
case fromCommand cmd of
|
||||
Just QuitCmd -> latchIt latch
|
||||
_ -> sendCommandLoop (commandChan, latch) bot
|
||||
case fromMessage cmd of
|
||||
Just QuitCmd -> closeMessageChannel commandChan
|
||||
_ -> sendCommandLoop commandChan bot
|
||||
|
||||
readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
|
||||
readLineLoop = go []
|
||||
readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
|
||||
readMessageLoop = go []
|
||||
where
|
||||
msgPartTimeout = 10
|
||||
|
||||
go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
||||
go !msgParts mvBotStatus inChan bot@Bot { .. } timeoutDelay = do
|
||||
botStatus <- readMVar mvBotStatus
|
||||
case botStatus of
|
||||
Disconnected -> latchIt latch
|
||||
Disconnected -> closeMessageChannel inChan
|
||||
_ -> do
|
||||
mLine <- try $ timeout timeoutDelay readLine'
|
||||
msgParts' <- case mLine of
|
||||
Left (e :: SomeException) -> do
|
||||
errorM $ "Error while reading from connection: " ++ show e
|
||||
writeChan lineChan EOF >> return msgParts
|
||||
Right Nothing -> writeChan lineChan Timeout >> return msgParts
|
||||
sendMessage inChan EOD >> return msgParts
|
||||
Right Nothing -> sendMessage inChan Timeout >> return msgParts
|
||||
Right (Just (Line time line)) -> do
|
||||
let (mmsg, msgParts') = parseLine botConfig time line msgParts
|
||||
whenJust mmsg $ writeChan lineChan . Msg
|
||||
whenJust mmsg $ sendMessage inChan . Msg
|
||||
return msgParts'
|
||||
Right (Just l) -> writeChan lineChan l >> return msgParts
|
||||
Right (Just EOS) -> sendMessage inChan EOD >> return msgParts
|
||||
|
||||
limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
|
||||
let msgParts'' = concat
|
||||
. filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
|
||||
. groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
|
||||
go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
|
||||
go msgParts'' mvBotStatus inChan bot timeoutDelay
|
||||
where
|
||||
readLine' = do
|
||||
eof <- hIsEOF botSocket
|
||||
if eof
|
||||
then return EOF
|
||||
then return EOS
|
||||
else mask $ \unmask -> do
|
||||
line <- map initEx . unmask $ hGetLine botSocket
|
||||
infoM . unpack $ "< " ++ line
|
||||
now <- getCurrentTime
|
||||
return $ Line now line
|
||||
|
||||
messageProcessLoop :: Chan Line -> Chan Command -> IRC ()
|
||||
messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
|
||||
messageProcessLoop = go 0
|
||||
where
|
||||
go !idleFor lineChan commandChan = do
|
||||
status <- get
|
||||
bot@Bot { .. } <- ask
|
||||
let nick = botNick botConfig
|
||||
go !idleFor inChan messageChan = do
|
||||
status <- get
|
||||
Bot { .. } <- ask
|
||||
let nick = botNick botConfig
|
||||
|
||||
nStatus <- io . mask_ $
|
||||
if idleFor >= (oneSec * botTimeout botConfig)
|
||||
then infoM "Timeout" >> return Disconnected
|
||||
else do
|
||||
when (status == Kicked) $
|
||||
threadDelay (5 * oneSec) >> sendCommand commandChan (toCommand JoinCmd)
|
||||
threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan
|
||||
|
||||
mLine <- readLine lineChan
|
||||
case mLine of
|
||||
Timeout -> do
|
||||
now <- getCurrentTime
|
||||
dispatchHandlers bot (FullMessage now "" $ toMessage IdleMsg) >> return Idle
|
||||
EOF -> infoM "Connection closed" >> return Disconnected
|
||||
Line _ _ -> error "This should never happen"
|
||||
Msg (msg@FullMessage { .. }) -> do
|
||||
mIn <- receiveMessage inChan
|
||||
case mIn of
|
||||
Timeout -> newMessage IdleMsg >>= sendMessage messageChan >> return Idle
|
||||
EOD -> infoM "Connection closed" >> return Disconnected
|
||||
Msg (msg@Message { .. }) -> do
|
||||
nStatus <- handleMsg nick message
|
||||
dispatchHandlers bot msg
|
||||
sendMessage messageChan msg
|
||||
return nStatus
|
||||
|
||||
put nStatus
|
||||
case nStatus of
|
||||
Idle -> go (idleFor + oneSec) lineChan commandChan
|
||||
Idle -> go (idleFor + oneSec) inChan messageChan
|
||||
Disconnected -> return ()
|
||||
NickNotAvailable -> return ()
|
||||
_ -> go 0 lineChan commandChan
|
||||
_ -> go 0 inChan messageChan
|
||||
|
||||
where
|
||||
dispatchHandlers Bot { .. } message =
|
||||
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
|
||||
handle (\(e :: SomeException) ->
|
||||
errorM $ "Exception while processing message: " ++ show e) $ do
|
||||
cmds <- handleMessage msgHandler botConfig message
|
||||
forM_ cmds (sendCommand commandChan)
|
||||
|
||||
handleMsg nick message
|
||||
| Just (JoinMsg user) <- fromMessage message, userNick user == nick =
|
||||
infoM "Joined" >> return Joined
|
||||
| Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick =
|
||||
| Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick =
|
||||
infoM "Kicked" >> return Kicked
|
||||
| Just NickInUseMsg <- fromMessage message =
|
||||
infoM "Nick already in use" >> return NickNotAvailable
|
||||
| Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self =
|
||||
sendCommand commandChan (toCommand JoinCmd) >> return Connected
|
||||
| otherwise = return Connected
|
||||
|
||||
eventProcessLoop :: Channel Event -> Chan Line -> Chan Command -> Bot -> IO ()
|
||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||
event <- readChan eventChan
|
||||
case fromEvent event of
|
||||
Just (QuitEvent, _) -> latchIt latch
|
||||
_ -> do
|
||||
debugM $ "Event: " ++ show event
|
||||
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
|
||||
handle (\(ex :: SomeException) ->
|
||||
errorM $ "Exception while processing event: " ++ show ex) $ do
|
||||
resp <- handleEvent msgHandler botConfig event
|
||||
case resp of
|
||||
RespMessage messages -> forM_ messages $ sendMessage lineChan
|
||||
RespCommand commands -> forM_ commands $ sendCommand commandChan
|
||||
RespEvent events -> forM_ events $ sendEvent eventChan
|
||||
_ -> return ()
|
||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot
|
||||
| Just NickInUseMsg <- fromMessage message =
|
||||
infoM "Nick already in use" >> return NickNotAvailable
|
||||
| Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self =
|
||||
newMessage JoinCmd >>= sendMessage messageChan >> return Connected
|
||||
| otherwise =
|
||||
return Connected
|
||||
|
||||
@ -15,7 +15,7 @@ module Network.IRC.Client (runBot) where
|
||||
import qualified System.Log.Logger as HSL
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan)
|
||||
import Control.Concurrent.Lifted (fork, threadDelay, myThreadId)
|
||||
import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt))
|
||||
import Network (PortID (PortNumber), connectTo, withSocketsDo)
|
||||
import System.IO (hSetBuffering, BufferMode(..))
|
||||
@ -27,93 +27,103 @@ import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerN
|
||||
import System.Log.Logger.TH (deriveLoggers)
|
||||
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
|
||||
|
||||
import qualified Network.IRC.Handlers.Core as Core
|
||||
|
||||
import Network.IRC.Bot
|
||||
import Network.IRC.Internal.Types
|
||||
import Network.IRC.MessageBus
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Handlers.Core
|
||||
import Network.IRC.Util
|
||||
|
||||
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
|
||||
|
||||
coreMsgHandlerNames :: [MsgHandlerName]
|
||||
coreMsgHandlerNames = ["pingpong", "help"]
|
||||
data ConnectionResource = ConnectionResource
|
||||
{ bot :: Bot
|
||||
, botStatus :: MVar BotStatus
|
||||
, inChannel :: MessageChannel In
|
||||
, mainMsgChannel :: MessageChannel Message
|
||||
, cmdMsgChannel :: MessageChannel Message
|
||||
, handlerMsgChannels :: [MessageChannel Message]
|
||||
}
|
||||
|
||||
connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event)
|
||||
connect :: BotConfig -> IO ConnectionResource
|
||||
connect botConfig@BotConfig { .. } = do
|
||||
debugM "Connecting ..."
|
||||
socket <- connectToWithRetry
|
||||
hSetBuffering socket LineBuffering
|
||||
debugM "Connected"
|
||||
|
||||
lineChan <- newChannel
|
||||
commandChan <- newChannel
|
||||
eventChan <- newChannel
|
||||
mvBotStatus <- newMVar Connected
|
||||
msgHandlers <- loadMsgHandlers (fst eventChan)
|
||||
msgHandlerInfo' <- foldM (\m (hn, h) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
|
||||
mempty (mapToList msgHandlers)
|
||||
let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'}
|
||||
return (Bot botConfig' socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
|
||||
messageBus <- newMessageBus
|
||||
inBus <- newMessageBus
|
||||
mvBotStatus <- newMVar Connected
|
||||
|
||||
inChannel <- newMessageChannel inBus
|
||||
mainMsgChannel <- newMessageChannel messageBus
|
||||
cmdMsgChannel <- newMessageChannel messageBus
|
||||
|
||||
msgHandlersChans <- loadMsgHandlers messageBus
|
||||
msgHandlerInfo' <- foldM (\m (hn, (h, _)) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
|
||||
mempty (mapToList msgHandlersChans)
|
||||
|
||||
let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'}
|
||||
let msgHandlerChannels = map snd (mapValues msgHandlersChans)
|
||||
let msgHandlers = map fst msgHandlersChans
|
||||
|
||||
return $ ConnectionResource
|
||||
(Bot botConfig' socket msgHandlers) mvBotStatus
|
||||
inChannel mainMsgChannel cmdMsgChannel msgHandlerChannels
|
||||
where
|
||||
connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
|
||||
connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
|
||||
`catch` (\(e :: SomeException) -> do
|
||||
errorM ("Error while connecting: " ++ show e ++ ". Waiting.")
|
||||
threadDelay (5 * oneSec)
|
||||
connectToWithRetry)
|
||||
|
||||
newChannel = (,) <$> newChan <*> newEmptyMVar
|
||||
mkMsgHandler name messageBus =
|
||||
case lookup name msgHandlerMakers of
|
||||
Nothing -> return Nothing
|
||||
Just maker -> do
|
||||
messageChannel <- newMessageChannel messageBus
|
||||
handler <- msgHandlerMaker maker botConfig messageChannel
|
||||
return $ Just (handler, messageChannel)
|
||||
|
||||
mkMsgHandler :: Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler)
|
||||
mkMsgHandler eventChan name =
|
||||
flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
|
||||
case finalHandler of
|
||||
Just _ -> return finalHandler
|
||||
Nothing -> msgHandlerMaker handler botConfig eventChan name
|
||||
|
||||
loadMsgHandlers eventChan =
|
||||
loadMsgHandlers messageBus =
|
||||
flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
|
||||
debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
|
||||
mMsgHandler <- mkMsgHandler eventChan msgHandlerName
|
||||
mMsgHandler <- mkMsgHandler msgHandlerName messageBus
|
||||
case mMsgHandler of
|
||||
Nothing -> do
|
||||
Nothing -> do
|
||||
debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
|
||||
return hMap
|
||||
Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
|
||||
Just msgHandlerAndChannel -> return $ insertMap msgHandlerName msgHandlerAndChannel hMap
|
||||
|
||||
disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event) -> IO ()
|
||||
disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
|
||||
disconnect :: ConnectionResource -> IO ()
|
||||
disconnect ConnectionResource { bot = Bot { .. }, .. } = do
|
||||
debugM "Disconnecting ..."
|
||||
sendCommand commandChan $ toCommand QuitCmd
|
||||
awaitLatch sendLatch
|
||||
swapMVar mvBotStatus Disconnected
|
||||
awaitLatch readLatch
|
||||
sendEvent eventChan =<< toEvent QuitEvent
|
||||
awaitLatch eventLatch
|
||||
sendMessage cmdMsgChannel =<< newMessage QuitCmd
|
||||
awaitMessageChannel cmdMsgChannel
|
||||
|
||||
unloadMsgHandlers
|
||||
swapMVar botStatus Disconnected
|
||||
awaitMessageChannel inChannel
|
||||
|
||||
forM_ handlerMsgChannels awaitMessageChannel
|
||||
handle (\(_ :: SomeException) -> return ()) $ hClose botSocket
|
||||
debugM "Disconnected"
|
||||
where
|
||||
unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
|
||||
debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName
|
||||
stopMsgHandler msgHandler botConfig
|
||||
|
||||
runBotIntenal :: BotConfig -> IO ()
|
||||
runBotIntenal botConfig' = withSocketsDo $ do
|
||||
status <- run
|
||||
case status of
|
||||
Disconnected -> debugM "Restarting .." >> runBotIntenal botConfig
|
||||
Errored -> debugM "Restarting .." >> runBotIntenal botConfig
|
||||
Disconnected -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
|
||||
Errored -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
|
||||
Interrupted -> return ()
|
||||
NickNotAvailable -> return ()
|
||||
_ -> error "Unsupported status"
|
||||
where
|
||||
botConfig = botConfig' {
|
||||
botConfigWithCore = botConfig' {
|
||||
msgHandlerInfo =
|
||||
foldl' (\m name -> insertMap name mempty m) mempty
|
||||
(hashNub $ mapKeys (msgHandlerInfo botConfig') ++ coreMsgHandlerNames),
|
||||
msgHandlerMakers = ordNub $ Core.mkMsgHandler : msgHandlerMakers botConfig'
|
||||
(hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers),
|
||||
msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
|
||||
}
|
||||
|
||||
handleErrors :: SomeException -> IO BotStatus
|
||||
@ -121,18 +131,33 @@ runBotIntenal botConfig' = withSocketsDo $ do
|
||||
Just UserInterrupt -> debugM "User interrupt" >> return Interrupted
|
||||
_ -> debugM ("Exception! " ++ show e) >> return Errored
|
||||
|
||||
run = bracket (connect botConfig) disconnect $
|
||||
\(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) ->
|
||||
runHandler botConfig ((msgHandlerName, handler), msgChannel) = receiveMessage msgChannel >>= go
|
||||
where
|
||||
go msg@Message { .. }
|
||||
| Just QuitCmd <- fromMessage message = do
|
||||
debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName
|
||||
stopMsgHandler handler botConfig
|
||||
closeMessageChannel msgChannel
|
||||
return ()
|
||||
| otherwise = do
|
||||
resps <- handleMessage handler botConfig msg
|
||||
forM_ resps $ sendMessage msgChannel
|
||||
runHandler botConfig ((msgHandlerName, handler), msgChannel)
|
||||
|
||||
run = bracket (connect botConfigWithCore) disconnect $
|
||||
\ConnectionResource { .. } ->
|
||||
handle handleErrors $ do
|
||||
let Bot { .. } = bot
|
||||
debugM $ "Running with config:\n" ++ show botConfig
|
||||
|
||||
sendCommand commandChan $ toCommand NickCmd
|
||||
sendCommand commandChan $ toCommand UserCmd
|
||||
sendMessage cmdMsgChannel =<< newMessage NickCmd
|
||||
sendMessage cmdMsgChannel =<< newMessage UserCmd
|
||||
|
||||
fork $ sendCommandLoop (commandChan, sendLatch) bot
|
||||
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
|
||||
fork $ eventProcessLoop eventChannel lineChan commandChan bot
|
||||
runIRC bot Connected (messageProcessLoop lineChan commandChan)
|
||||
fork $ sendCommandLoop cmdMsgChannel bot
|
||||
fork $ readMessageLoop botStatus inChannel bot oneSec
|
||||
forM_ (zip (mapToList msgHandlers) handlerMsgChannels) $
|
||||
void . fork . runHandler botConfig
|
||||
runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel)
|
||||
|
||||
-- | Creates and runs an IRC bot for given the config. This IO action runs forever.
|
||||
runBot :: BotConfig -- ^ The bot config used to create the bot.
|
||||
|
||||
@ -1,50 +1,57 @@
|
||||
module Network.IRC.Handlers.Core (mkMsgHandler) where
|
||||
module Network.IRC.Handlers.Core (coreMsgHandlerMakers) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Convertible (convert)
|
||||
import Data.Time (addUTCTime)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Convertible (convert)
|
||||
import Data.Time (addUTCTime)
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Util
|
||||
|
||||
mkMsgHandler :: MsgHandlerMaker
|
||||
mkMsgHandler = MsgHandlerMaker "core" go
|
||||
where
|
||||
go _ _ "pingpong" = do
|
||||
state <- getCurrentTime >>= newIORef
|
||||
return . Just $ newMsgHandler { onMessage = pingPong state }
|
||||
go _ _ "help" =
|
||||
return . Just $ newMsgHandler { onMessage = help,
|
||||
onHelp = return $ singletonMap "!help" helpMsg }
|
||||
go _ _ _ = return Nothing
|
||||
coreMsgHandlerMakers :: Map MsgHandlerName MsgHandlerMaker
|
||||
coreMsgHandlerMakers = mapFromList [
|
||||
("pingpong", pingPongMsgHandlerMaker)
|
||||
, ("help", helpMsgHandlerMaker)
|
||||
]
|
||||
|
||||
pingPongMsgHandlerMaker :: MsgHandlerMaker
|
||||
pingPongMsgHandlerMaker = MsgHandlerMaker "pingpong" go
|
||||
where
|
||||
go _ _ = do
|
||||
state <- io $ getCurrentTime >>= newIORef
|
||||
return $ newMsgHandler { onMessage = pingPong state }
|
||||
|
||||
helpMsgHandlerMaker :: MsgHandlerMaker
|
||||
helpMsgHandlerMaker = MsgHandlerMaker "help" go
|
||||
where
|
||||
go _ _ = return $ newMsgHandler { onMessage = help
|
||||
, handlerHelp = return $ singletonMap "!help" helpMsg }
|
||||
helpMsg = "Get help. !help or !help <command>"
|
||||
|
||||
pingPong :: MonadMsgHandler m => IORef UTCTime -> FullMessage -> m [Command]
|
||||
pingPong state FullMessage { .. }
|
||||
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Message]
|
||||
pingPong state Message { .. }
|
||||
| Just (PingMsg msg) <- fromMessage message =
|
||||
io (atomicWriteIORef state msgTime) >> return [toCommand $ PongCmd msg]
|
||||
io (atomicWriteIORef state msgTime) >> map singleton (newMessage . PongCmd $ msg)
|
||||
| Just (PongMsg _) <- fromMessage message =
|
||||
io (atomicWriteIORef state msgTime) >> return []
|
||||
| Just IdleMsg <- fromMessage message
|
||||
, even (convert msgTime :: Int) = do
|
||||
BotConfig { .. } <- ask
|
||||
let limit = fromIntegral $ botTimeout `div` 2
|
||||
io $ do
|
||||
lastComm <- readIORef state
|
||||
return [toCommand . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
|
||||
| addUTCTime limit lastComm < msgTime]
|
||||
lastComm <- io $ readIORef state
|
||||
if addUTCTime limit lastComm < msgTime
|
||||
then map singleton . newMessage . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
|
||||
else return []
|
||||
| otherwise = return []
|
||||
|
||||
help :: MonadMsgHandler m => FullMessage -> m [Command]
|
||||
help FullMessage { .. } = case fromMessage message of
|
||||
help :: MonadMsgHandler m => Message -> m [Message]
|
||||
help Message { .. } = case fromMessage message of
|
||||
Just (ChannelMsg _ msg)
|
||||
| "!help" == clean msg -> do
|
||||
BotConfig { .. } <- ask
|
||||
let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
|
||||
return . map (toCommand . ChannelMsgReply) $
|
||||
[ "I know these commands: " ++ unwords commands
|
||||
mapM (newMessage . ChannelMsgReply) [
|
||||
"I know these commands: " ++ unwords commands
|
||||
, "Type !help <command> to know more about any command"
|
||||
]
|
||||
| "!help" `isPrefixOf` msg -> do
|
||||
@ -52,5 +59,6 @@ help FullMessage { .. } = case fromMessage message of
|
||||
let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
|
||||
let mHelp = find ((\c -> c == command || c == cons '!' command) . fst)
|
||||
. concatMap mapToList . mapValues $ msgHandlerInfo
|
||||
return [toCommand . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
|
||||
map singleton . newMessage . ChannelMsgReply
|
||||
$ maybe ("No such command found: " ++ command) snd mHelp
|
||||
_ -> return []
|
||||
|
||||
@ -1,67 +0,0 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Network.IRC.Internal.Command.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Typeable (cast)
|
||||
|
||||
import Network.IRC.Internal.Message.Types
|
||||
|
||||
-- | The typeclass for IRC commands sent from the bot to the server.
|
||||
class (Typeable cmd, Show cmd, Eq cmd, Ord cmd) => CommandC cmd where
|
||||
toCommand :: cmd -> Command
|
||||
toCommand = Command
|
||||
|
||||
fromCommand :: Command -> Maybe cmd
|
||||
fromCommand (Command cmd) = cast cmd
|
||||
|
||||
-- | A wrapper over all types of IRC commands.
|
||||
data Command = forall m . CommandC m => Command m deriving (Typeable)
|
||||
|
||||
instance Show Command where
|
||||
show (Command m) = show m
|
||||
|
||||
instance Eq Command where
|
||||
Command m1 == Command m2 = case cast m1 of
|
||||
Just m1' -> m1' == m2
|
||||
_ -> False
|
||||
|
||||
-- | A /PING/ command. A 'PongMsg' is expected as a response to this.
|
||||
data PingCmd = PingCmd !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC PingCmd
|
||||
|
||||
-- | A /PONG/ command. Sent in response to a 'PingMsg'.
|
||||
data PongCmd = PongCmd !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC PongCmd
|
||||
|
||||
-- | A /PRIVMSG/ message sent to the channel.
|
||||
data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC ChannelMsgReply
|
||||
|
||||
-- | A /PRIVMSG/ message sent to a user.
|
||||
data PrivMsgReply = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC PrivMsgReply
|
||||
|
||||
-- | A /NICK/ command sent to set the bot's nick.
|
||||
data NickCmd = NickCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC NickCmd
|
||||
|
||||
-- | A /USER/ command sent to identify the bot.
|
||||
data UserCmd = UserCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC UserCmd
|
||||
|
||||
-- | A /JOIN/ command sent to join the channel.
|
||||
data JoinCmd = JoinCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC JoinCmd
|
||||
|
||||
-- | A /QUIT/ command sent to quit the server.
|
||||
data QuitCmd = QuitCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC QuitCmd
|
||||
|
||||
-- | A /NAMES/ command sent to ask for the nicks of the users in the channel.
|
||||
data NamesCmd = NamesCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance CommandC NamesCmd
|
||||
@ -1,57 +0,0 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Network.IRC.Internal.Event.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Typeable (cast)
|
||||
|
||||
import Network.IRC.Internal.Message.Types
|
||||
import Network.IRC.Internal.Command.Types
|
||||
|
||||
-- ** Events
|
||||
|
||||
-- | Events are used for communication between message handlers. To send events, write them to the
|
||||
-- event channel provided to the 'MsgHandler' when it is created. To receive events, provide
|
||||
-- an 'onEvent' function as a part of the message handler.
|
||||
class (Typeable e, Show e, Eq e) => EventC e where
|
||||
-- | Creates an event.
|
||||
toEvent :: e -> IO Event
|
||||
toEvent e = Event <$> pure e <*> getCurrentTime
|
||||
|
||||
-- | Extracts a received event.
|
||||
fromEvent :: Event -> Maybe (e, UTCTime)
|
||||
fromEvent (Event e time) = do
|
||||
ev <- cast e
|
||||
return (ev, time)
|
||||
|
||||
-- | A wrapper over all types of 'Event's to allow sending them over channel of same type.
|
||||
data Event = forall e. (EventC e, Typeable e) => Event e UTCTime deriving (Typeable)
|
||||
|
||||
instance Show Event where
|
||||
show (Event e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
|
||||
|
||||
instance Eq Event where
|
||||
Event e1 t1 == Event e2 t2 =
|
||||
case cast e2 of
|
||||
Just e2' -> e1 == e2' && t1 == t2
|
||||
Nothing -> False
|
||||
|
||||
-- | Response to an event received by a message handler.
|
||||
data EventResponse =
|
||||
-- | No response
|
||||
RespNothing
|
||||
-- | Events as the response. They will be sent to all message handlers like usual events.
|
||||
| RespEvent [Event]
|
||||
-- | Messages as the response. They will be sent to all message handlers like usual messages.
|
||||
| RespMessage [FullMessage]
|
||||
-- | Commands as the response. They will be sent to the server like usual commands.
|
||||
| RespCommand [Command]
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | An event signifying the bot quitting the server.
|
||||
data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable)
|
||||
instance EventC QuitEvent
|
||||
@ -8,15 +8,13 @@ module Network.IRC.Internal.Types where
|
||||
import qualified Data.Configurator as CF
|
||||
|
||||
import ClassyPrelude
|
||||
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 Control.Monad.Base (MonadBase)
|
||||
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
|
||||
import Control.Monad.State (StateT, MonadState, execStateT)
|
||||
import Data.Configurator.Types (Config)
|
||||
|
||||
import Network.IRC.Internal.Command.Types
|
||||
import Network.IRC.Internal.Event.Types
|
||||
import Network.IRC.Internal.Message.Types
|
||||
import Network.IRC.Message.Types
|
||||
import Network.IRC.MessageBus
|
||||
import Network.IRC.Util
|
||||
|
||||
-- ** Message Parsing
|
||||
@ -25,17 +23,17 @@ import Network.IRC.Util
|
||||
type MessageParserId = Text
|
||||
|
||||
-- | A part of a mutlipart message.
|
||||
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
|
||||
, msgPartTarget :: !Text
|
||||
, msgPartTime :: !UTCTime
|
||||
, msgPartLine :: !Text
|
||||
data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
|
||||
, msgPartTarget :: !Text
|
||||
, msgPartTime :: !UTCTime
|
||||
, msgPartLine :: !Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | The result of parsing a message line.
|
||||
data MessageParseResult =
|
||||
Done !FullMessage ![MessagePart] -- ^ A fully parsed message and leftover message parts.
|
||||
| Partial ![MessagePart] -- ^ A partial message with message parts received yet.
|
||||
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
|
||||
Done !Message ![MessagePart] -- ^ A fully parsed message and leftover message parts.
|
||||
| Partial ![MessagePart] -- ^ A partial message with message parts received yet.
|
||||
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | A message parser used for parsing text lines from the server to 'Message's.
|
||||
@ -47,7 +45,7 @@ data MessageParser = MessageParser
|
||||
-- ** Command Formatting
|
||||
|
||||
-- | A command formatter which optinally formats commands to texts which are then send to the server.
|
||||
type CommandFormatter = BotConfig -> Command -> Maybe Text
|
||||
type CommandFormatter = BotConfig -> Message -> Maybe Text
|
||||
|
||||
-- ** Bot
|
||||
|
||||
@ -58,11 +56,11 @@ type MsgHandlerName = Text
|
||||
data BotConfig = BotConfig
|
||||
{
|
||||
-- | The server to connect to.
|
||||
server :: !Text
|
||||
botServer :: !Text
|
||||
-- | The port to connect to.
|
||||
, port :: !Int
|
||||
, botPort :: !Int
|
||||
-- | The channel to join.
|
||||
, channel :: !Text
|
||||
, botChannel :: !Text
|
||||
-- | Nick of the bot.
|
||||
, botNick :: !Nick
|
||||
-- | The timeout in seconds after which bot automatically disconnects and tries to reconnect.
|
||||
@ -72,7 +70,7 @@ data BotConfig = BotConfig
|
||||
-- by that message handler to the help text of that command.
|
||||
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
|
||||
-- | A list of 'MsgHandlerMaker's which are used to create message handlers for the bot.
|
||||
, msgHandlerMakers :: ![MsgHandlerMaker]
|
||||
, msgHandlerMakers :: !(Map MsgHandlerName MsgHandlerMaker)
|
||||
-- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
|
||||
, msgParsers :: ![MessageParser]
|
||||
-- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
|
||||
@ -82,22 +80,23 @@ data BotConfig = BotConfig
|
||||
}
|
||||
|
||||
instance Show BotConfig where
|
||||
show BotConfig { .. } = "BotConfig[ server = " ++ show server ++ "\n" ++
|
||||
"port = " ++ show port ++ "\n" ++
|
||||
"channel = " ++ show channel ++ "\n" ++
|
||||
"nick = " ++ show botNick ++ "\n" ++
|
||||
"timeout = " ++ show botTimeout ++ "\n" ++
|
||||
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " ]"
|
||||
show BotConfig { .. } = "BotConfig {" ++ "\n" ++
|
||||
"server = " ++ show botServer ++ "\n" ++
|
||||
"port = " ++ show botPort ++ "\n" ++
|
||||
"channel = " ++ show botChannel ++ "\n" ++
|
||||
"nick = " ++ show botNick ++ "\n" ++
|
||||
"timeout = " ++ show botTimeout ++ "\n" ++
|
||||
"handlers = " ++ show (mapKeys msgHandlerInfo) ++ " }"
|
||||
|
||||
-- | Creates a new bot config with essential fields leaving rest fields empty.
|
||||
newBotConfig :: Text -- ^ server
|
||||
-> Int -- ^ port
|
||||
-> Text -- ^ channel
|
||||
-> Nick -- ^ botNick
|
||||
-> Int -- ^ botTimeout
|
||||
newBotConfig :: Text -- ^ server
|
||||
-> Int -- ^ port
|
||||
-> Text -- ^ channel
|
||||
-> Nick -- ^ botNick
|
||||
-> Int -- ^ botTimeout
|
||||
-> BotConfig
|
||||
newBotConfig server port channel botNick botTimeout =
|
||||
BotConfig server port channel botNick botTimeout mempty [] [] [] CF.empty
|
||||
BotConfig server port channel botNick botTimeout mempty mempty [] [] CF.empty
|
||||
|
||||
-- | The bot.
|
||||
data Bot = Bot
|
||||
@ -111,15 +110,15 @@ data Bot = Bot
|
||||
}
|
||||
|
||||
-- | The current status of the bot.
|
||||
data BotStatus = Connected -- ^ Connected to the server
|
||||
| Disconnected -- ^ Disconnected from the server.
|
||||
| Joined -- ^ Joined the channel.
|
||||
| Kicked -- ^ Kicked from the channel.
|
||||
| Errored -- ^ Some unhandled error happened.
|
||||
| Idle -- ^ No communication with the server. The bot is idle.
|
||||
-- If the bot stays idle for 'botTimeout' seconds, it disconnects.
|
||||
| Interrupted -- ^ Interrupted using external signals like SIGINT.
|
||||
| NickNotAvailable -- ^ Bot's nick already taken on the server.
|
||||
data BotStatus = Connected -- ^ Connected to the server
|
||||
| Disconnected -- ^ Disconnected from the server.
|
||||
| Joined -- ^ Joined the channel.
|
||||
| Kicked -- ^ Kicked from the channel.
|
||||
| Errored -- ^ Some unhandled error happened.
|
||||
| Idle -- ^ No communication with the server. The bot is idle.
|
||||
-- If the bot stays idle for 'botTimeout' seconds, it disconnects.
|
||||
| Interrupted -- ^ Interrupted using external signals like SIGINT.
|
||||
| NickNotAvailable -- ^ Bot's nick already taken on the server.
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | An IRC action to be run.
|
||||
@ -162,23 +161,21 @@ data MsgHandler = MsgHandler
|
||||
{
|
||||
-- | The action invoked when a message is received. It returns a list of commands in response
|
||||
-- to the message which the bot sends to the server.
|
||||
onMessage :: !(forall m . MonadMsgHandler m => FullMessage -> m [Command])
|
||||
-- | The action invoked when an event is triggered. It returns an event resonpse which the bot
|
||||
-- handles according to its type.
|
||||
, onEvent :: !(forall m . MonadMsgHandler m => Event -> m EventResponse)
|
||||
onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Message])
|
||||
|
||||
-- | The action invoked to stop the message handler.
|
||||
, onStop :: !(forall m . MonadMsgHandler m => m ())
|
||||
, onStop :: !(forall m . MonadMsgHandler m => m ())
|
||||
|
||||
-- | The action invoked to get the map of the commands supported by the message handler and their help messages.
|
||||
, onHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text))
|
||||
, handlerHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text))
|
||||
}
|
||||
|
||||
-- | Creates a new message handler which doesn't do anything.
|
||||
newMsgHandler :: MsgHandler
|
||||
newMsgHandler = MsgHandler
|
||||
{ onMessage = const $ return []
|
||||
, onStop = return ()
|
||||
, onEvent = const $ return RespNothing
|
||||
, onHelp = return mempty
|
||||
{ onMessage = const $ return mempty
|
||||
, onStop = return ()
|
||||
, handlerHelp = return mempty
|
||||
}
|
||||
|
||||
-- | A message handler maker which creates a new message handler.
|
||||
@ -187,7 +184,7 @@ data MsgHandlerMaker = MsgHandlerMaker
|
||||
-- | The name of the message handler.
|
||||
msgHandlerName :: !MsgHandlerName
|
||||
-- | The action which is invoked to create a new message handler.
|
||||
, msgHandlerMaker :: !(BotConfig -> Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler))
|
||||
, msgHandlerMaker :: !(BotConfig -> MessageChannel Message -> IO MsgHandler)
|
||||
}
|
||||
|
||||
instance Eq MsgHandlerMaker where
|
||||
@ -198,19 +195,11 @@ instance Ord MsgHandlerMaker where
|
||||
-- | Handles a message using a given message handler.
|
||||
handleMessage :: MsgHandler -- ^ The message handler.
|
||||
-> BotConfig -- ^ The bot config.
|
||||
-> FullMessage -- ^ The message to handle.
|
||||
-> IO [Command] -- ^ A list of commands to be sent to the server.
|
||||
-> Message -- ^ The message to handle.
|
||||
-> IO [Message] -- ^ A list of commands to be sent to the server.
|
||||
handleMessage MsgHandler { .. } botConfig =
|
||||
flip runReaderT botConfig . _runMsgHandler . onMessage
|
||||
|
||||
-- | Handles an event using a given message handler.
|
||||
handleEvent :: MsgHandler -- ^ The message handler.
|
||||
-> BotConfig -- ^ The bot config.
|
||||
-> Event -- ^ The event to handle.
|
||||
-> IO EventResponse -- ^ The event response which will be dispatched by the bot.
|
||||
handleEvent MsgHandler { .. } botConfig =
|
||||
flip runReaderT botConfig . _runMsgHandler . onEvent
|
||||
|
||||
-- | Stops a message handler.
|
||||
stopMsgHandler :: MsgHandler -- ^ The message handler.
|
||||
-> BotConfig -- ^ The bot config.
|
||||
@ -223,4 +212,4 @@ getHelp :: MsgHandler -- ^ The message handler.
|
||||
-> BotConfig -- ^ The bot config.
|
||||
-> IO (Map Text Text) -- ^ A map of the commands supported by this message handler to their help messages.
|
||||
getHelp MsgHandler { .. } botConfig =
|
||||
flip runReaderT botConfig . _runMsgHandler $ onHelp
|
||||
flip runReaderT botConfig . _runMsgHandler $ handlerHelp
|
||||
|
||||
@ -4,15 +4,14 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_HADDOCK hide #-}
|
||||
|
||||
module Network.IRC.Internal.Message.Types where
|
||||
module Network.IRC.Message.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Data (Data)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
import Data.Typeable (cast)
|
||||
|
||||
-- ** IRC Message
|
||||
import Data.Data (Data)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
import Data.Typeable (cast)
|
||||
|
||||
-- | An IRC nick.
|
||||
newtype Nick = Nick { nickToText :: Text }
|
||||
@ -34,31 +33,36 @@ data User
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
-- | An IRC message sent from the server to the bot.
|
||||
data FullMessage = FullMessage
|
||||
data Message = Message
|
||||
{ msgTime :: !UTCTime -- ^ The time when the message was received.
|
||||
, msgLine :: !Text -- ^ The raw message line.
|
||||
, message :: Message -- ^ The details of the parsed message.
|
||||
, message :: MessageW -- ^ The details of the parsed message.
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- | The typeclass for different types of IRC messages.
|
||||
class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
|
||||
toMessage :: msg -> Message
|
||||
toMessage = Message
|
||||
toMessage :: msg -> MessageW
|
||||
toMessage = MessageW
|
||||
|
||||
fromMessage :: Message -> Maybe msg
|
||||
fromMessage (Message msg) = cast msg
|
||||
fromMessage :: MessageW -> Maybe msg
|
||||
fromMessage (MessageW msg) = cast msg
|
||||
|
||||
-- | A wrapper over all types of IRC messages.
|
||||
data Message = forall m . MessageC m => Message m deriving (Typeable)
|
||||
data MessageW = forall m . MessageC m => MessageW m deriving (Typeable)
|
||||
|
||||
instance Show Message where
|
||||
show (Message m) = show m
|
||||
instance Show MessageW where
|
||||
show (MessageW m) = show m
|
||||
|
||||
instance Eq Message where
|
||||
Message m1 == Message m2 = case cast m1 of
|
||||
instance Eq MessageW where
|
||||
MessageW m1 == MessageW m2 = case cast m1 of
|
||||
Just m1' -> m1' == m2
|
||||
_ -> False
|
||||
|
||||
newMessage :: (MessageC msg, MonadIO m) => msg -> m Message
|
||||
newMessage msg = do
|
||||
t <- liftIO getCurrentTime
|
||||
return $ Message t "" (toMessage msg)
|
||||
|
||||
-- | The internal (non-IRC) message received when the bot is idle.
|
||||
data IdleMsg = IdleMsg deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC IdleMsg
|
||||
@ -121,3 +125,40 @@ instance MessageC ModeMsg
|
||||
data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
|
||||
deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC OtherMsg
|
||||
|
||||
|
||||
-- | A /PING/ command. A 'PongMsg' is expected as a response to this.
|
||||
data PingCmd = PingCmd !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC PingCmd
|
||||
|
||||
-- | A /PONG/ command. Sent in response to a 'PingMsg'.
|
||||
data PongCmd = PongCmd !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC PongCmd
|
||||
|
||||
-- | A /PRIVMSG/ message sent to the channel.
|
||||
data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC ChannelMsgReply
|
||||
|
||||
-- | A /PRIVMSG/ message sent to a user.
|
||||
data PrivMsgReply = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC PrivMsgReply
|
||||
|
||||
-- | A /NICK/ command sent to set the bot's nick.
|
||||
data NickCmd = NickCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC NickCmd
|
||||
|
||||
-- | A /USER/ command sent to identify the bot.
|
||||
data UserCmd = UserCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC UserCmd
|
||||
|
||||
-- | A /JOIN/ command sent to join the channel.
|
||||
data JoinCmd = JoinCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC JoinCmd
|
||||
|
||||
-- | A /QUIT/ command sent to quit the server.
|
||||
data QuitCmd = QuitCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC QuitCmd
|
||||
|
||||
-- | A /NAMES/ command sent to ask for the nicks of the users in the channel.
|
||||
data NamesCmd = NamesCmd deriving (Typeable, Show, Eq, Ord)
|
||||
instance MessageC NamesCmd
|
||||
58
hask-irc-core/Network/IRC/MessageBus.hs
Normal file
58
hask-irc-core/Network/IRC/MessageBus.hs
Normal file
@ -0,0 +1,58 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Network.IRC.MessageBus
|
||||
( MessageBus
|
||||
, newMessageBus
|
||||
, MessageChannel
|
||||
, newMessageChannel
|
||||
, sendMessage
|
||||
, receiveMessage
|
||||
, closeMessageChannel
|
||||
, awaitMessageChannel ) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
newtype Latch = Latch (MVar ())
|
||||
|
||||
newLatch :: IO Latch
|
||||
newLatch = liftM Latch newEmptyMVar
|
||||
|
||||
doLatch :: Latch -> IO ()
|
||||
doLatch (Latch mv) = putMVar mv ()
|
||||
|
||||
awaitLatch :: Latch -> IO ()
|
||||
awaitLatch (Latch mv) = void $ takeMVar mv
|
||||
|
||||
newtype MessageBus a = MessageBus (TChan a)
|
||||
|
||||
newMessageBus :: IO (MessageBus a)
|
||||
newMessageBus = MessageBus <$> newBroadcastTChanIO
|
||||
|
||||
data MessageChannel a = MessageChannel Latch (TChan a) (TChan a)
|
||||
|
||||
newMessageChannel ::MessageBus a -> IO (MessageChannel a)
|
||||
newMessageChannel (MessageBus wChan) = do
|
||||
latch <- newLatch
|
||||
rChan <- atomically $ dupTChan wChan
|
||||
return $ MessageChannel latch rChan wChan
|
||||
|
||||
sendMessageSTM :: MessageChannel a -> a -> STM ()
|
||||
sendMessageSTM (MessageChannel _ _ wChan) = writeTChan wChan
|
||||
|
||||
receiveMessageSTM :: MessageChannel a -> STM a
|
||||
receiveMessageSTM (MessageChannel _ rChan _) = readTChan rChan
|
||||
|
||||
sendMessage :: MessageChannel a -> a -> IO ()
|
||||
sendMessage chan = atomically . sendMessageSTM chan
|
||||
|
||||
receiveMessage :: MessageChannel a -> IO a
|
||||
receiveMessage = atomically . receiveMessageSTM
|
||||
|
||||
closeMessageChannel :: MessageChannel a -> IO ()
|
||||
closeMessageChannel (MessageChannel latch _ _) = doLatch latch
|
||||
|
||||
awaitMessageChannel :: MessageChannel a -> IO ()
|
||||
awaitMessageChannel (MessageChannel latch _ _) = awaitLatch latch
|
||||
@ -10,7 +10,7 @@ import Data.Text (strip)
|
||||
|
||||
import Network.IRC.Types
|
||||
|
||||
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart])
|
||||
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart])
|
||||
parseLine botConfig@BotConfig { .. } time line msgParts =
|
||||
fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } ->
|
||||
let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
|
||||
@ -25,7 +25,7 @@ pingParser :: MessageParser
|
||||
pingParser = MessageParser "ping" go
|
||||
where
|
||||
go _ time line _
|
||||
| "PING :" `isPrefixOf` line = Done (FullMessage time line . toMessage . PingMsg . drop 6 $ line) []
|
||||
| "PING :" `isPrefixOf` line = Done (Message time line . toMessage . PingMsg . drop 6 $ line) []
|
||||
| otherwise = Reject
|
||||
|
||||
parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
|
||||
@ -47,17 +47,17 @@ lineParser = MessageParser "line" go
|
||||
"QUIT" -> done $ toMessage $ QuitMsg user quitMessage
|
||||
"PART" -> done $ toMessage $ PartMsg user message
|
||||
"KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
|
||||
"MODE" -> done $ toMessage $ if Nick source == botNick
|
||||
"MODE" -> done $ toMessage $ if Nick target == botNick
|
||||
then ModeMsg Self target message []
|
||||
else ModeMsg user target mode modeArgs
|
||||
"NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
|
||||
"433" -> done $ toMessage NickInUseMsg
|
||||
"PRIVMSG" | target /= channel -> done $ toMessage $ PrivMsg user message
|
||||
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
|
||||
| otherwise -> done $ toMessage $ ChannelMsg user message
|
||||
"PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
|
||||
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
|
||||
| otherwise -> done $ toMessage $ ChannelMsg user message
|
||||
_ -> Reject
|
||||
where
|
||||
done = flip Done [] . FullMessage time line
|
||||
done = flip Done [] . Message time line
|
||||
|
||||
(splits, command, source, target, message) = parseMsgLine line
|
||||
quitMessage = strip . drop 1 . unwords . drop 2 $ splits
|
||||
@ -71,7 +71,7 @@ lineParser = MessageParser "line" go
|
||||
defaultParser :: MessageParser
|
||||
defaultParser = MessageParser "default" go
|
||||
where
|
||||
go _ time line _ = flip Done [] . FullMessage time line $
|
||||
go _ time line _ = flip Done [] . Message time line $
|
||||
toMessage $ OtherMsg source command target message
|
||||
where
|
||||
(_, command, source, target, message) = parseMsgLine line
|
||||
@ -85,7 +85,7 @@ namesParser = MessageParser "names" go
|
||||
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
|
||||
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
|
||||
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
|
||||
in Done (FullMessage time allLines . toMessage $ NamesMsg nicks) otherMsgParts
|
||||
in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
|
||||
_ -> Reject
|
||||
where
|
||||
(_ : command : target : _) = words line
|
||||
@ -94,23 +94,23 @@ namesParser = MessageParser "names" go
|
||||
map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
|
||||
|
||||
formatCommand :: CommandFormatter
|
||||
formatCommand botConfig@BotConfig { .. } command =
|
||||
msum . map (\formatter -> formatter botConfig command) $ defaultCommandFormatter : cmdFormatters
|
||||
formatCommand botConfig@BotConfig { .. } message =
|
||||
msum . map (\formatter -> formatter botConfig message) $ defaultCommandFormatter : cmdFormatters
|
||||
|
||||
defaultCommandFormatter :: CommandFormatter
|
||||
defaultCommandFormatter BotConfig { .. } command
|
||||
| Just (PongCmd msg) <- fromCommand command = Just $ "PONG :" ++ msg
|
||||
| Just (PingCmd msg) <- fromCommand command = Just $ "PING :" ++ msg
|
||||
| Just NickCmd <- fromCommand command = Just $ "NICK " ++ botNick'
|
||||
| Just UserCmd <- fromCommand command =
|
||||
defaultCommandFormatter BotConfig { .. } Message { .. }
|
||||
| Just (PongCmd msg) <- fromMessage message = Just $ "PONG :" ++ msg
|
||||
| Just (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg
|
||||
| Just NickCmd <- fromMessage message = Just $ "NICK " ++ botNick'
|
||||
| Just UserCmd <- fromMessage message =
|
||||
Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
|
||||
| Just JoinCmd <- fromCommand command = Just $ "JOIN " ++ channel
|
||||
| Just QuitCmd <- fromCommand command = Just "QUIT"
|
||||
| Just (ChannelMsgReply msg) <- fromCommand command =
|
||||
Just $ "PRIVMSG " ++ channel ++ " :" ++ msg
|
||||
| Just (PrivMsgReply (User { .. }) msg) <- fromCommand command =
|
||||
| Just JoinCmd <- fromMessage message = Just $ "JOIN " ++ botChannel
|
||||
| Just QuitCmd <- fromMessage message = Just "QUIT"
|
||||
| Just (ChannelMsgReply msg) <- fromMessage message =
|
||||
Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
|
||||
| Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =
|
||||
Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
|
||||
| Just NamesCmd <- fromCommand command = Just $ "NAMES " ++ channel
|
||||
| Just NamesCmd <- fromMessage message = Just $ "NAMES " ++ botChannel
|
||||
| otherwise = Nothing
|
||||
where
|
||||
botNick' = nickToText botNick
|
||||
|
||||
@ -14,8 +14,8 @@ module Network.IRC.Types
|
||||
Nick (..)
|
||||
, User (..)
|
||||
, MessageC (..)
|
||||
, Message
|
||||
, FullMessage (..)
|
||||
, Message (..)
|
||||
, newMessage
|
||||
, IdleMsg (..)
|
||||
, NickInUseMsg (..)
|
||||
, PingMsg (..)
|
||||
@ -32,8 +32,6 @@ module Network.IRC.Types
|
||||
, ModeMsg (..)
|
||||
, OtherMsg (..)
|
||||
-- * IRC Commands
|
||||
, CommandC (..)
|
||||
, Command
|
||||
, PingCmd (..)
|
||||
, PongCmd (..)
|
||||
, ChannelMsgReply (..)
|
||||
@ -50,11 +48,6 @@ module Network.IRC.Types
|
||||
, MessageParser (..)
|
||||
-- * Command Formatting
|
||||
, CommandFormatter
|
||||
-- * Events
|
||||
, EventC (..)
|
||||
, Event
|
||||
, EventResponse (..)
|
||||
, QuitEvent(..)
|
||||
-- * Bot
|
||||
, BotConfig (..)
|
||||
, newBotConfig
|
||||
@ -68,8 +61,5 @@ module Network.IRC.Types
|
||||
, MsgHandlerMaker (..)
|
||||
) where
|
||||
|
||||
import Network.IRC.Internal.Command.Types
|
||||
import Network.IRC.Internal.Event.Types
|
||||
import Network.IRC.Internal.Message.Types
|
||||
import Network.IRC.Message.Types
|
||||
import Network.IRC.Internal.Types
|
||||
|
||||
|
||||
@ -6,28 +6,17 @@ module Network.IRC.Util where
|
||||
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)
|
||||
import Control.Arrow (Arrow)
|
||||
import Control.Monad.Base (MonadBase)
|
||||
import Data.Convertible (convert)
|
||||
import Data.Text (strip)
|
||||
import Data.Time (diffUTCTime)
|
||||
|
||||
oneSec :: Int
|
||||
oneSec = 1000000
|
||||
|
||||
type Latch = MVar ()
|
||||
|
||||
latchIt :: Latch -> IO ()
|
||||
latchIt latch = putMVar latch ()
|
||||
|
||||
awaitLatch :: Latch -> IO ()
|
||||
awaitLatch latch = void $ takeMVar latch
|
||||
|
||||
type Channel a = (Chan a, Latch)
|
||||
|
||||
mapKeys :: IsMap map => map -> [ContainerKey map]
|
||||
mapKeys = map fst . mapToList
|
||||
mapKeys = map fst . mapToList
|
||||
|
||||
mapValues :: IsMap map => map -> [MapValue map]
|
||||
mapValues = map snd . mapToList
|
||||
@ -64,21 +53,21 @@ relativeTime t1 t2 =
|
||||
|
||||
period = t1 `diffUTCTime` t2
|
||||
|
||||
ranges = [(year*2, "{} years", year)
|
||||
,(year, "a year", 0)
|
||||
,(month*2, "{} months", month)
|
||||
,(month, "a month", 0)
|
||||
,(week*2, "{} weeks", week)
|
||||
,(week, "a week", 0)
|
||||
,(day*2, "{} days", day)
|
||||
,(day, "a day", 0)
|
||||
,(hour*4, "{} hours", hour)
|
||||
,(hour*3, "a few hours", 0)
|
||||
,(hour*2, "{} hours", hour)
|
||||
,(hour, "an hour", 0)
|
||||
,(minute*31, "{} minutes", minute)
|
||||
,(minute*30, "half an hour", 0)
|
||||
,(minute*2, "{} minutes", minute)
|
||||
,(minute, "a minute", 0)
|
||||
,(0, "{} seconds", 1)
|
||||
ranges = [ (year*2, "{} years", year)
|
||||
, (year, "a year", 0)
|
||||
, (month*2, "{} months", month)
|
||||
, (month, "a month", 0)
|
||||
, (week*2, "{} weeks", week)
|
||||
, (week, "a week", 0)
|
||||
, (day*2, "{} days", day)
|
||||
, (day, "a day", 0)
|
||||
, (hour*4, "{} hours", hour)
|
||||
, (hour*3, "a few hours", 0)
|
||||
, (hour*2, "{} hours", hour)
|
||||
, (hour, "an hour", 0)
|
||||
, (minute*31, "{} minutes", minute)
|
||||
, (minute*30, "half an hour", 0)
|
||||
, (minute*2, "{} minutes", minute)
|
||||
, (minute, "a minute", 0)
|
||||
, (0, "{} seconds", 1)
|
||||
]
|
||||
|
||||
@ -51,7 +51,7 @@ cabal-version: >=1.10
|
||||
library
|
||||
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
|
||||
BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving,
|
||||
DeriveDataTypeable
|
||||
DeriveDataTypeable, Trustworthy
|
||||
|
||||
build-depends: base >=4.5 && <4.8,
|
||||
classy-prelude >=0.9 && <1.0,
|
||||
@ -63,6 +63,7 @@ library
|
||||
mtl >=2.1 && <2.3,
|
||||
network >=2.5 && <2.6,
|
||||
safecopy >=0.8 && <0.9,
|
||||
stm >=2.4 && <2.5,
|
||||
text >=1.1 && <1.2,
|
||||
text-format >=0.3 && <0.4,
|
||||
time >=1.4 && <1.5,
|
||||
@ -70,14 +71,13 @@ library
|
||||
unix >=2.7 && <2.8
|
||||
|
||||
exposed-modules: Network.IRC,
|
||||
Network.IRC.MessageBus,
|
||||
Network.IRC.Types,
|
||||
Network.IRC.Client,
|
||||
Network.IRC.Util
|
||||
|
||||
other-modules: Network.IRC.Internal.Command.Types,
|
||||
Network.IRC.Internal.Event.Types,
|
||||
Network.IRC.Internal.Message.Types,
|
||||
Network.IRC.Internal.Types,
|
||||
other-modules: Network.IRC.Internal.Types,
|
||||
Network.IRC.Message.Types,
|
||||
Network.IRC.Protocol,
|
||||
Network.IRC.Bot,
|
||||
Network.IRC.Handlers.Core
|
||||
|
||||
@ -13,6 +13,7 @@ allMsgHandlerMakers :: [MsgHandlerMaker]
|
||||
allMsgHandlerMakers =
|
||||
[ authMsgHandlerMaker
|
||||
, greetMsgHandlerMaker
|
||||
, welcomeMsgHandlerMaker
|
||||
, messageLoggerMsgHandlerMaker
|
||||
, nickTrackerMsgHandlerMaker
|
||||
, songSearchMsgHandlerMaker
|
||||
|
||||
@ -13,8 +13,8 @@ import Data.Acid (AcidState, Query, Update, makeAcidic, query, update
|
||||
openLocalState, createArchive)
|
||||
import Data.Acid.Local (createCheckpointAndClose)
|
||||
|
||||
import Network.IRC
|
||||
import Network.IRC.Handlers.Auth.Types
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Util
|
||||
|
||||
-- database
|
||||
@ -42,12 +42,20 @@ issueToken acid user = do
|
||||
|
||||
-- handler
|
||||
|
||||
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> FullMessage -> m [Command]
|
||||
authMessage state FullMessage { .. }
|
||||
authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message -> m [Message]
|
||||
authMessage state Message { .. }
|
||||
| Just (PrivMsg user msg) <- fromMessage message
|
||||
, "token" `isPrefixOf` msg =
|
||||
map (singleton . toCommand . PrivMsgReply user) . io $ readIORef state >>= flip issueToken (userNick user)
|
||||
authMessage _ _ = return []
|
||||
, "token" `isPrefixOf` msg = do
|
||||
token <- io $ readIORef state >>= flip issueToken (userNick user)
|
||||
map singleton . newMessage $ PrivMsgReply user token
|
||||
| Just (AuthRequest user token reply) <- fromMessage message = io $ do
|
||||
acid <- readIORef state
|
||||
mt <- query acid (GetToken user)
|
||||
case mt of
|
||||
Just t -> putMVar reply (t == token)
|
||||
Nothing -> putMVar reply False
|
||||
return []
|
||||
| otherwise = return []
|
||||
|
||||
stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
|
||||
stopAuth state = io $ do
|
||||
@ -55,26 +63,13 @@ stopAuth state = io $ do
|
||||
createArchive acid
|
||||
createCheckpointAndClose acid
|
||||
|
||||
authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> Event -> m EventResponse
|
||||
authEvent state event = case fromEvent event of
|
||||
Just (AuthEvent user token reply, _) -> io $ do
|
||||
acid <- readIORef state
|
||||
mt <- query acid (GetToken user)
|
||||
case mt of
|
||||
Just t -> putMVar reply (t == token)
|
||||
Nothing -> putMVar reply False
|
||||
return RespNothing
|
||||
_ -> return RespNothing
|
||||
|
||||
authMsgHandlerMaker :: MsgHandlerMaker
|
||||
authMsgHandlerMaker = MsgHandlerMaker "auth" go
|
||||
where
|
||||
helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token"
|
||||
|
||||
go BotConfig { .. } _ "auth" = do
|
||||
go BotConfig { .. } _ = do
|
||||
state <- io $ openLocalState emptyAuth >>= newIORef
|
||||
return . Just $ newMsgHandler { onMessage = authMessage state
|
||||
, onEvent = authEvent state
|
||||
, onStop = stopAuth state
|
||||
, onHelp = return $ singletonMap "token" (helpMsg botNick) }
|
||||
go _ _ _ = return Nothing
|
||||
return $ newMsgHandler { onMessage = authMessage state
|
||||
, onStop = stopAuth state
|
||||
, handlerHelp = return $ singletonMap "token" (helpMsg botNick) }
|
||||
|
||||
@ -17,10 +17,13 @@ emptyAuth = Auth mempty
|
||||
|
||||
$(deriveSafeCopy 0 'base ''Auth)
|
||||
|
||||
data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable)
|
||||
data AuthRequest = AuthRequest Nick Token (MVar Bool) deriving (Eq, Typeable)
|
||||
|
||||
instance EventC AuthEvent
|
||||
instance MessageC AuthRequest
|
||||
|
||||
instance Show AuthEvent where
|
||||
show (AuthEvent nick token _) =
|
||||
"AuthEvent[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]"
|
||||
instance Show AuthRequest where
|
||||
show (AuthRequest nick token _) =
|
||||
"AuthRequest[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]"
|
||||
|
||||
instance Ord AuthRequest where
|
||||
(AuthRequest nick1 _ _) `compare` (AuthRequest nick2 _ _) = nick1 `compare` nick2
|
||||
|
||||
@ -1,34 +1,37 @@
|
||||
module Network.IRC.Handlers.Greet (greetMsgHandlerMaker) where
|
||||
module Network.IRC.Handlers.Greet (greetMsgHandlerMaker, welcomeMsgHandlerMaker) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Reader (ask)
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC
|
||||
import Network.IRC.Util
|
||||
|
||||
greetMsgHandlerMaker :: MsgHandlerMaker
|
||||
greetMsgHandlerMaker = MsgHandlerMaker "greeter" go
|
||||
where
|
||||
go _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter }
|
||||
go _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
|
||||
go _ _ _ = return Nothing
|
||||
greetMsgHandlerMaker =
|
||||
MsgHandlerMaker "greeter" $ \_ _ -> return $ newMsgHandler { onMessage = greeter }
|
||||
|
||||
greeter :: MonadMsgHandler m => FullMessage -> m [Command]
|
||||
greeter FullMessage { .. } = case fromMessage message of
|
||||
welcomeMsgHandlerMaker :: MsgHandlerMaker
|
||||
welcomeMsgHandlerMaker =
|
||||
MsgHandlerMaker "welcomer" $ \_ _ -> return $ newMsgHandler { onMessage = welcomer }
|
||||
|
||||
greeter :: MonadMsgHandler m => Message -> m [Message]
|
||||
greeter Message { .. } = case fromMessage message of
|
||||
Just (ChannelMsg user msg) ->
|
||||
return . maybeToList . map (toCommand . ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
|
||||
. find (== clean msg) $ greetings
|
||||
let reply = maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
|
||||
. find (== clean msg) $ greetings
|
||||
in mapM newMessage reply
|
||||
_ -> return []
|
||||
where
|
||||
greetings = [ "hi", "hello", "hey", "sup", "bye"
|
||||
, "good morning", "good evening", "good night" ]
|
||||
|
||||
welcomer :: MonadMsgHandler m => FullMessage -> m [Command]
|
||||
welcomer FullMessage { .. } = case fromMessage message of
|
||||
welcomer :: MonadMsgHandler m => Message -> m [Message]
|
||||
welcomer Message { .. } = case fromMessage message of
|
||||
Just (JoinMsg user) -> do
|
||||
BotConfig { .. } <- ask
|
||||
return [toCommand . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
|
||||
| userNick user /= botNick]
|
||||
if userNick user /= botNick
|
||||
then map singleton . newMessage . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
|
||||
else return []
|
||||
_ -> return []
|
||||
|
||||
|
||||
|
||||
@ -14,7 +14,7 @@ import System.Directory (createDirectoryIfMissing, getModificationTime,
|
||||
import System.FilePath (FilePath, (</>), (<.>))
|
||||
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC
|
||||
import Network.IRC.Util
|
||||
|
||||
type LoggerState = Maybe (Handle, Day)
|
||||
@ -22,18 +22,17 @@ type LoggerState = Maybe (Handle, Day)
|
||||
messageLoggerMsgHandlerMaker :: MsgHandlerMaker
|
||||
messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go
|
||||
where
|
||||
go botConfig _ "messagelogger" = do
|
||||
go botConfig _ = do
|
||||
state <- io $ newIORef Nothing
|
||||
initMessageLogger botConfig state
|
||||
return . Just $ newMsgHandler { onMessage = flip messageLogger state
|
||||
, onStop = exitMessageLogger state }
|
||||
go _ _ _ = return Nothing
|
||||
return $ newMsgHandler { onMessage = flip messageLogger state
|
||||
, onStop = exitMessageLogger state }
|
||||
|
||||
getLogFilePath :: BotConfig -> IO FilePath
|
||||
getLogFilePath BotConfig { .. } = do
|
||||
logFileDir <- CF.require config "messagelogger.logdir"
|
||||
createDirectoryIfMissing True logFileDir
|
||||
return $ logFileDir </> unpack (channel ++ "-" ++ nickToText botNick) <.> "log"
|
||||
return $ logFileDir </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
|
||||
|
||||
openLogFile :: FilePath -> IO Handle
|
||||
openLogFile logFilePath = do
|
||||
@ -51,7 +50,7 @@ initMessageLogger botConfig state = do
|
||||
exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
|
||||
exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
|
||||
|
||||
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Command]
|
||||
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Message]
|
||||
withLogFile action state = do
|
||||
botConfig <- ask
|
||||
io $ do
|
||||
@ -73,8 +72,8 @@ withLogFile action state = do
|
||||
|
||||
return []
|
||||
|
||||
messageLogger :: MonadMsgHandler m => FullMessage -> IORef LoggerState -> m [Command]
|
||||
messageLogger FullMessage { .. }
|
||||
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Message]
|
||||
messageLogger Message { .. }
|
||||
| Just (ChannelMsg user msg) <- fromMessage message =
|
||||
log "<{}> {}" [nick user, msg]
|
||||
| Just (ActionMsg user msg) <- fromMessage message =
|
||||
@ -91,7 +90,8 @@ messageLogger FullMessage { .. }
|
||||
log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
|
||||
| Just (NamesMsg nicks) <- fromMessage message =
|
||||
log "** USERS {}" [unwords . map nickToText $ nicks]
|
||||
| otherwise = const $ return []
|
||||
| otherwise =
|
||||
const $ return []
|
||||
where
|
||||
nick = nickToText . userNick
|
||||
|
||||
|
||||
@ -18,8 +18,8 @@ import Data.Convertible (convert)
|
||||
import Data.IxSet (getOne, (@=))
|
||||
import Data.Time (addUTCTime, NominalDiffTime)
|
||||
|
||||
import Network.IRC
|
||||
import Network.IRC.Handlers.NickTracker.Internal.Types
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Util
|
||||
|
||||
-- database
|
||||
@ -54,8 +54,8 @@ data NickTrackingState = NickTrackingState { acid :: AcidState NickTr
|
||||
, onlineNicks :: HashSet Nick
|
||||
, lastRefreshOn :: UTCTime }
|
||||
|
||||
nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> FullMessage -> m [Command]
|
||||
nickTrackerMsg state FullMessage { .. }
|
||||
nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Message]
|
||||
nickTrackerMsg state Message { .. }
|
||||
| Just (ChannelMsg (User { .. }) msg) <- fromMessage message =
|
||||
updateNickTrack state userNick msg msgTime >> handleCommands userNick msg
|
||||
| Just (ActionMsg (User { .. }) msg) <- fromMessage message =
|
||||
@ -68,15 +68,18 @@ nickTrackerMsg state FullMessage { .. }
|
||||
updateNickTrack state userNick msg msgTime >> remove userNick >> return []
|
||||
| Just (NickMsg (User { .. }) newNick) <- fromMessage message =
|
||||
handleNickChange state userNick newNick msgTime >> swap (userNick, newNick) >> return []
|
||||
| Just (NamesMsg nicks) <- fromMessage message = do
|
||||
| Just (NamesMsg nicks) <- fromMessage message = do
|
||||
forM_ nicks $ \n -> updateNickTrack state n "" msgTime
|
||||
refresh nicks >> updateRefreshTime >> return []
|
||||
| Just IdleMsg <- fromMessage message = do
|
||||
| Just IdleMsg <- fromMessage message = do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
if addUTCTime refreshInterval lastRefreshOn < msgTime
|
||||
then updateRefreshTime >> return [toCommand NamesCmd]
|
||||
then updateRefreshTime >> map singleton (newMessage NamesCmd)
|
||||
else return []
|
||||
| otherwise = return []
|
||||
| Just (NickTrackRequest nick reply) <- fromMessage message = io $ do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
getByNick acid nick >>= putMVar reply >> return []
|
||||
| otherwise = return []
|
||||
where
|
||||
updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
|
||||
|
||||
@ -96,8 +99,8 @@ nickTrackerMsg state FullMessage { .. }
|
||||
|
||||
updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> UTCTime -> m ()
|
||||
updateNickTrack state nck message msgTime = io $ do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
mnt <- getByNick acid nck
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
mnt <- getByNick acid nck
|
||||
(message', lastMessageOn', cn) <- case (message, mnt) of
|
||||
("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
|
||||
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
|
||||
@ -108,9 +111,9 @@ updateNickTrack state nck message msgTime = io $ do
|
||||
handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Nick -> UTCTime -> m ()
|
||||
handleNickChange state prevNick newNick msgTime = io $ do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
mpnt <- getByNick acid prevNick
|
||||
mnt <- getByNick acid newNick
|
||||
mInfo <- case (mpnt, mnt) of
|
||||
mpnt <- getByNick acid prevNick
|
||||
mnt <- getByNick acid newNick
|
||||
mInfo <- case (mpnt, mnt) of
|
||||
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
|
||||
(Just pnt, Nothing) ->
|
||||
return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
|
||||
@ -128,26 +131,27 @@ newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
|
||||
withNickTracks :: MonadMsgHandler m
|
||||
=> (Text -> [NickTrack] -> HashSet Nick -> IO Text)
|
||||
-> IORef NickTrackingState -> Nick -> Text
|
||||
-> m [Command]
|
||||
-> m [Message]
|
||||
withNickTracks f state _ msg = io $ do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
let nick = clean . unwords . drop 1 . words $ msg
|
||||
if nick == ""
|
||||
then return []
|
||||
else do
|
||||
mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
|
||||
map (singleton . toCommand . ChannelMsgReply) $ case mcn of
|
||||
mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
|
||||
reply <- case mcn of
|
||||
Nothing -> return $ "Unknown nick: " ++ nick
|
||||
Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
|
||||
map singleton . newMessage . ChannelMsgReply $ reply
|
||||
|
||||
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
|
||||
handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
|
||||
handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
|
||||
let nicks = map ((\(Nick n) -> n) . nick) nickTracks
|
||||
return . (nck ++) $ if length nicks == 1
|
||||
then " has only one nick"
|
||||
else "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
|
||||
|
||||
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
|
||||
handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
|
||||
handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
|
||||
let NickTrack { lastSeenOn = lastSeenOn'
|
||||
, nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
|
||||
@ -165,21 +169,14 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
|
||||
(if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
|
||||
" said: " ++ lastMessage')
|
||||
|
||||
handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
|
||||
handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
|
||||
handleForgetNicksCommand state nick _ = do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
io $ do
|
||||
Just nt <- getByNick acid nick
|
||||
cn <- newCanonicalNick
|
||||
saveNickTrack acid $ nt { canonicalNick = cn }
|
||||
return [toCommand . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick]
|
||||
|
||||
nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> Event -> m EventResponse
|
||||
nickTrackerEvent state event = case fromEvent event of
|
||||
Just (NickTrackRequest nick reply, _) -> io $ do
|
||||
NickTrackingState { .. } <- readIORef state
|
||||
getByNick acid nick >>= putMVar reply >> return RespNothing
|
||||
_ -> return RespNothing
|
||||
map singleton . newMessage . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick
|
||||
|
||||
stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
|
||||
stopNickTracker state = io $ do
|
||||
@ -195,14 +192,12 @@ nickTrackerMsgHandlerMaker = MsgHandlerMaker "nicktracker" go
|
||||
("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
|
||||
("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
|
||||
|
||||
go BotConfig { .. } _ "nicktracker" = do
|
||||
go BotConfig { .. } _ = do
|
||||
state <- io $ do
|
||||
now <- getCurrentTime
|
||||
refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int)
|
||||
acid <- openLocalState emptyNickTracking
|
||||
newIORef (NickTrackingState acid refreshInterval mempty now)
|
||||
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
|
||||
, onEvent = nickTrackerEvent state
|
||||
, onStop = stopNickTracker state
|
||||
, onHelp = return helpMsgs }
|
||||
go _ _ _ = return Nothing
|
||||
return $ newMsgHandler { onMessage = nickTrackerMsg state
|
||||
, onStop = stopNickTracker state
|
||||
, handlerHelp = return helpMsgs }
|
||||
|
||||
@ -3,24 +3,23 @@
|
||||
module Network.IRC.Handlers.NickTracker.Internal.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (Chan, writeChan)
|
||||
import Data.Data (Data)
|
||||
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
import Data.Data (Data)
|
||||
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC
|
||||
|
||||
newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text }
|
||||
deriving (Eq, Ord, Show, Data, Typeable)
|
||||
newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
data NickTrack = NickTrack {
|
||||
nick :: !Nick,
|
||||
canonicalNick :: !CanonicalNick,
|
||||
lastSeenOn :: !UTCTime,
|
||||
lastMessageOn :: !UTCTime,
|
||||
lastMessage :: !Text
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
data NickTrack = NickTrack
|
||||
{ nick :: !Nick
|
||||
, canonicalNick :: !CanonicalNick
|
||||
, lastSeenOn :: !UTCTime
|
||||
, lastMessageOn :: !UTCTime
|
||||
, lastMessage :: !Text
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
instance Indexable NickTrack where
|
||||
empty = ixSet [ ixFun $ (: []) . nick
|
||||
@ -40,14 +39,17 @@ emptyNickTracking = NickTracking empty
|
||||
|
||||
data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable)
|
||||
|
||||
instance EventC NickTrackRequest
|
||||
instance MessageC NickTrackRequest
|
||||
|
||||
instance Show NickTrackRequest where
|
||||
show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]"
|
||||
|
||||
getCanonicalNick :: Chan Event -> Nick -> IO (Maybe CanonicalNick)
|
||||
getCanonicalNick eventChan nick = do
|
||||
instance Ord NickTrackRequest where
|
||||
(NickTrackRequest nick1 _) `compare` (NickTrackRequest nick2 _) = nick1 `compare` nick2
|
||||
|
||||
getCanonicalNick :: MessageChannel Message -> Nick -> IO (Maybe CanonicalNick)
|
||||
getCanonicalNick messageChannel nick = do
|
||||
reply <- newEmptyMVar
|
||||
request <- toEvent $ NickTrackRequest nick reply
|
||||
writeChan eventChan request
|
||||
request <- newMessage $ NickTrackRequest nick reply
|
||||
sendMessage messageChannel request
|
||||
map (map canonicalNick) $ takeMVar reply
|
||||
|
||||
@ -16,7 +16,7 @@ import Network.Curl.Aeson (curlAesonGet, CurlAesonException)
|
||||
import Network.HTTP.Base (urlEncode)
|
||||
import System.Log.Logger.TH (deriveLoggers)
|
||||
|
||||
import Network.IRC.Types
|
||||
import Network.IRC
|
||||
|
||||
$(deriveLoggers "HSL" [HSL.ERROR])
|
||||
|
||||
@ -25,10 +25,9 @@ songSearchMsgHandlerMaker = MsgHandlerMaker "songsearch" go
|
||||
where
|
||||
helpMsg = "Search for song. !m <song> or !m <artist> - <song>"
|
||||
|
||||
go _ _ "songsearch" =
|
||||
return . Just $ newMsgHandler { onMessage = songSearch,
|
||||
onHelp = return $ singletonMap "!m" helpMsg }
|
||||
go _ _ _ = return Nothing
|
||||
go _ _ =
|
||||
return $ newMsgHandler { onMessage = songSearch
|
||||
, handlerHelp = return $ singletonMap "!m" helpMsg }
|
||||
|
||||
data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
|
||||
deriving (Show, Eq)
|
||||
@ -38,15 +37,15 @@ instance FromJSON Song where
|
||||
parseJSON a | a == emptyArray = return NoSong
|
||||
parseJSON _ = mempty
|
||||
|
||||
songSearch :: MonadMsgHandler m => FullMessage -> m [Command]
|
||||
songSearch FullMessage { .. }
|
||||
songSearch :: MonadMsgHandler m => Message -> m [Message]
|
||||
songSearch Message { .. }
|
||||
| Just (ChannelMsg _ msg) <- fromMessage message
|
||||
, "!m " `isPrefixOf` msg = do
|
||||
BotConfig { .. } <- ask
|
||||
liftIO $ do
|
||||
let query = strip . drop 3 $ msg
|
||||
mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
|
||||
map (singleton . toCommand . ChannelMsgReply) $ case mApiKey of
|
||||
mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
|
||||
reply <- map ChannelMsgReply $ case mApiKey of
|
||||
Nothing -> do
|
||||
errorM "tinysong api key not found in config"
|
||||
return $ "Error while searching for " ++ query
|
||||
@ -62,4 +61,5 @@ songSearch FullMessage { .. }
|
||||
Right song -> return $ case song of
|
||||
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
|
||||
NoSong -> "No song found for: " ++ query
|
||||
map singleton . newMessage $ reply
|
||||
| otherwise = return []
|
||||
|
||||
@ -6,19 +6,18 @@ module Network.IRC.Handlers.Tell (tellMsgHandlerMaker) where
|
||||
|
||||
import qualified Data.IxSet as IS
|
||||
|
||||
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.IxSet ((@=))
|
||||
import Data.Text (split, strip)
|
||||
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.IxSet ((@=))
|
||||
import Data.Text (split, strip)
|
||||
|
||||
import Network.IRC
|
||||
import Network.IRC.Handlers.NickTracker.Types
|
||||
import Network.IRC.Handlers.Tell.Internal.Types
|
||||
import Network.IRC.Types
|
||||
import Network.IRC.Util
|
||||
|
||||
-- database
|
||||
@ -47,8 +46,8 @@ saveTell acid = update acid . SaveTellQ
|
||||
|
||||
newtype TellState = TellState { acid :: AcidState Tells }
|
||||
|
||||
tellMsg :: MonadMsgHandler m => Chan Event -> IORef TellState -> FullMessage -> m [Command]
|
||||
tellMsg eventChan state FullMessage { .. }
|
||||
tellMsg :: MonadMsgHandler m => MessageChannel Message -> IORef TellState -> Message -> m [Message]
|
||||
tellMsg messageChannel state Message { .. }
|
||||
| Just (ChannelMsg (User { .. }) msg) <- fromMessage message
|
||||
, command msg == "!tell"
|
||||
, args <- drop 1 . words $ msg
|
||||
@ -61,7 +60,7 @@ tellMsg eventChan state FullMessage { .. }
|
||||
if null tell
|
||||
then return []
|
||||
else do
|
||||
res <- forM nicks $ \nick -> handleTell acid nick tell
|
||||
res <- forM nicks $ \nick -> handleTell acid userNick nick tell
|
||||
let (fails, passes) = partitionEithers res
|
||||
let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++
|
||||
(if null passes then [] else
|
||||
@ -73,22 +72,26 @@ tellMsg eventChan state FullMessage { .. }
|
||||
if null tell
|
||||
then return []
|
||||
else do
|
||||
res <- handleTell acid nick tell
|
||||
res <- handleTell acid userNick nick tell
|
||||
let rep = case res of
|
||||
Left _ -> "Unknown nick: " ++ nickToText nick
|
||||
Right _ -> "Message noted and will be passed on to " ++ nickToText nick
|
||||
return [rep]
|
||||
tells <- getTellsToDeliver userNick
|
||||
return . map (textToReply userNick) $ (reps ++ tells)
|
||||
| Just (ChannelMsg (User { .. }) _) <- fromMessage message =
|
||||
io $ map (map (textToReply userNick)) $ getTellsToDeliver userNick
|
||||
mapM (textToReply userNick) (reps ++ tells)
|
||||
| Just (ChannelMsg (User { .. }) _) <- fromMessage message = io $ do
|
||||
tells <- getTellsToDeliver userNick
|
||||
mapM (textToReply userNick) tells
|
||||
| Just (TellRequest user msg) <- fromMessage message = do
|
||||
tellMsg messageChannel state . Message msgTime "" . toMessage $ ChannelMsg user msg
|
||||
return []
|
||||
| otherwise = return []
|
||||
where
|
||||
command msg = clean . fromMaybe "" . headMay . words $ msg
|
||||
|
||||
parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',')
|
||||
|
||||
textToReply nick t = toCommand . ChannelMsgReply $ nickToText nick ++ ": " ++ t
|
||||
textToReply nick t = newMessage . ChannelMsgReply $ nickToText nick ++ ": " ++ t
|
||||
|
||||
tellToMsg Tell { .. } =
|
||||
relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent
|
||||
@ -97,7 +100,7 @@ tellMsg eventChan state FullMessage { .. }
|
||||
|
||||
getTellsToDeliver nick = io $ do
|
||||
TellState { .. } <- readIORef state
|
||||
mcn <- getCanonicalNick eventChan nick
|
||||
mcn <- getCanonicalNick messageChannel nick
|
||||
case mcn of
|
||||
Nothing -> return []
|
||||
Just canonicalNick -> do
|
||||
@ -106,19 +109,12 @@ tellMsg eventChan state FullMessage { .. }
|
||||
saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime }
|
||||
return . tellToMsg $ tell
|
||||
|
||||
handleTell acid nick tell = do
|
||||
mcn <- getCanonicalNick eventChan nick
|
||||
handleTell acid userNick nick tell = do
|
||||
mcn <- getCanonicalNick messageChannel nick
|
||||
case mcn of
|
||||
Nothing -> return . Left . nickToText $ nick
|
||||
Just canonicalNick ->
|
||||
saveTell acid (newTell nick canonicalNick tell) >> (return . Right . nickToText $ nick)
|
||||
|
||||
tellEvent :: MonadMsgHandler m => Chan Event -> IORef TellState -> Event -> m EventResponse
|
||||
tellEvent eventChan state event = case fromEvent event of
|
||||
Just (TellRequest user message, evTime) -> do
|
||||
tellMsg eventChan state . FullMessage evTime "" . toMessage $ ChannelMsg user message
|
||||
return RespNothing
|
||||
_ -> return RespNothing
|
||||
saveTell acid (newTell userNick canonicalNick tell) >> (return . Right . nickToText $ nick)
|
||||
|
||||
stopTell :: MonadMsgHandler m => IORef TellState -> m ()
|
||||
stopTell state = io $ do
|
||||
@ -129,15 +125,13 @@ stopTell state = io $ do
|
||||
tellMsgHandlerMaker :: MsgHandlerMaker
|
||||
tellMsgHandlerMaker = MsgHandlerMaker "tell" go
|
||||
where
|
||||
go BotConfig { .. } eventChan "tell" = do
|
||||
go BotConfig { .. } messageChannel = do
|
||||
acid <- openLocalState emptyTells
|
||||
state <- newIORef (TellState acid)
|
||||
return . Just $ newMsgHandler { onMessage = tellMsg eventChan state
|
||||
, onEvent = tellEvent eventChan state
|
||||
, onStop = stopTell state
|
||||
, onHelp = return helpMsgs }
|
||||
go _ _ _ = return Nothing
|
||||
return $ newMsgHandler { onMessage = tellMsg messageChannel state
|
||||
, onStop = stopTell state
|
||||
, handlerHelp = return helpMsgs }
|
||||
|
||||
helpMsgs = singletonMap "!tell" $
|
||||
"Publically passes a message to a user or a bunch of users. " ++
|
||||
"Publically pass a message to a user or a bunch of users. " ++
|
||||
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>."
|
||||
|
||||
@ -4,27 +4,26 @@
|
||||
module Network.IRC.Handlers.Tell.Internal.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent.Lifted (Chan, writeChan)
|
||||
import Data.Data (Data)
|
||||
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
import Data.Data (Data)
|
||||
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
|
||||
import Data.SafeCopy (base, deriveSafeCopy)
|
||||
|
||||
import Network.IRC
|
||||
import Network.IRC.Handlers.NickTracker.Types
|
||||
import Network.IRC.Types
|
||||
|
||||
newtype TellId = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num)
|
||||
data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
data Tell = Tell {
|
||||
tellId :: !TellId,
|
||||
tellFromNick :: !Nick,
|
||||
tellToNick :: !CanonicalNick,
|
||||
tellTopic :: !(Maybe Text),
|
||||
tellStatus :: !TellStatus,
|
||||
tellCreatedOn :: !UTCTime,
|
||||
tellDeliveredOn :: !(Maybe UTCTime),
|
||||
tellContent :: !Text
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
data Tell = Tell
|
||||
{ tellId :: !TellId
|
||||
, tellFromNick :: !Nick
|
||||
, tellToNick :: !CanonicalNick
|
||||
, tellTopic :: !(Maybe Text)
|
||||
, tellStatus :: !TellStatus
|
||||
, tellCreatedOn :: !UTCTime
|
||||
, tellDeliveredOn :: !(Maybe UTCTime)
|
||||
, tellContent :: !Text
|
||||
} deriving (Eq, Ord, Show, Data, Typeable)
|
||||
|
||||
instance Indexable Tell where
|
||||
empty = ixSet [ ixFun $ (: []) . tellId
|
||||
@ -42,13 +41,14 @@ $(deriveSafeCopy 0 'base ''Tells)
|
||||
emptyTells :: Tells
|
||||
emptyTells = Tells (TellId 1) empty
|
||||
|
||||
data TellRequest = TellRequest User Text deriving (Eq, Typeable)
|
||||
data TellRequest = TellRequest User Text deriving (Eq, Typeable, Ord)
|
||||
|
||||
instance EventC TellRequest
|
||||
instance MessageC TellRequest
|
||||
|
||||
instance Show TellRequest where
|
||||
show (TellRequest user tell) =
|
||||
"TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]"
|
||||
|
||||
sendTell :: Chan Event -> User -> Text -> IO ()
|
||||
sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan
|
||||
sendTell :: MessageChannel Message -> User -> Text -> IO ()
|
||||
sendTell messageChannel user tell =
|
||||
newMessage (TellRequest user tell) >>= sendMessage messageChannel
|
||||
|
||||
@ -4,7 +4,7 @@ import ClassyPrelude hiding (getArgs)
|
||||
import System.Environment (getArgs, getProgName)
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
import Network.IRC.Client
|
||||
import Network.IRC
|
||||
import Network.IRC.Config
|
||||
|
||||
main :: IO ()
|
||||
|
||||
@ -7,8 +7,8 @@ import qualified Data.Configurator as CF
|
||||
import ClassyPrelude
|
||||
import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
|
||||
|
||||
import Network.IRC
|
||||
import Network.IRC.Handlers
|
||||
import Network.IRC.Types
|
||||
|
||||
instance Configured a => Configured [a] where
|
||||
convert (List xs) = Just . mapMaybe convert $ xs
|
||||
@ -19,10 +19,14 @@ loadBotConfig configFile = do
|
||||
eConfig <- try $ CF.load [CF.Required configFile]
|
||||
case eConfig of
|
||||
Left (ParseError _ _) -> error "Error while loading config"
|
||||
Right config -> do
|
||||
Right config -> do
|
||||
eBotConfig <- try $ do
|
||||
handlers :: [Text] <- CF.require config "msghandlers"
|
||||
let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
|
||||
let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
|
||||
let handlerMakers = foldl' (\m maker -> insertMap (msgHandlerName maker) maker m) mempty
|
||||
. filter (\MsgHandlerMaker { .. } -> msgHandlerName `member` handlerInfo)
|
||||
$ allMsgHandlerMakers
|
||||
|
||||
botConfig <- newBotConfig <$>
|
||||
CF.require config "server" <*>
|
||||
CF.require config "port" <*>
|
||||
@ -30,7 +34,7 @@ loadBotConfig configFile = do
|
||||
(Nick <$> CF.require config "nick") <*>
|
||||
CF.require config "timeout"
|
||||
return botConfig { msgHandlerInfo = handlerInfo
|
||||
, msgHandlerMakers = allMsgHandlerMakers
|
||||
, msgHandlerMakers = handlerMakers
|
||||
, config = config
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user