Changed msg handler design to make them stateful, added core IRC msg handlers
parent
964d2fbb35
commit
74be6dd162
|
|
@ -5,3 +5,4 @@ cabal.sandbox.config
|
|||
dist
|
||||
config.cfg
|
||||
*sublime*
|
||||
logs
|
||||
|
|
|
|||
4
Main.hs
4
Main.hs
|
|
@ -41,8 +41,8 @@ loadBotConfig configFile = do
|
|||
channel <- CF.require cfg "channel"
|
||||
botNick <- CF.require cfg "nick"
|
||||
timeout <- CF.require cfg "timeout"
|
||||
handlers <- CF.require cfg "handlers"
|
||||
return $ BotConfig server port channel botNick timeout handlers cfg
|
||||
msghandlers <- CF.require cfg "msghandlers"
|
||||
return $ BotConfig server port channel botNick timeout msghandlers cfg
|
||||
|
||||
case eBotConfig of
|
||||
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
|
||||
|
|
|
|||
|
|
@ -5,10 +5,11 @@ module Network.IRC.Client (run) where
|
|||
import qualified Data.Text.Format as TF
|
||||
import qualified Data.Text.Format.Params as TF
|
||||
|
||||
import ClassyPrelude hiding (log)
|
||||
import ClassyPrelude
|
||||
import Control.Concurrent
|
||||
import Control.Monad.Reader hiding (forM_)
|
||||
import Control.Monad.State hiding (forM_)
|
||||
import Control.Monad.Reader hiding (forM_, foldM)
|
||||
import Control.Monad.State hiding (forM_, foldM)
|
||||
import Data.Maybe (fromJust)
|
||||
import Network
|
||||
import System.IO (hSetBuffering, BufferMode(..))
|
||||
import System.Timeout
|
||||
|
|
@ -20,14 +21,17 @@ import Network.IRC.Types
|
|||
oneSec :: Int
|
||||
oneSec = 1000000
|
||||
|
||||
log :: Text -> IO ()
|
||||
log msg = getCurrentTime >>= \t -> TF.print "[{}] ** {}\n" $ TF.buildParams (t, msg)
|
||||
debug :: Text -> IO ()
|
||||
debug msg = do
|
||||
time <- getCurrentTime
|
||||
TF.print "[{}] {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, msg)
|
||||
|
||||
sendCommand :: Bot -> Command -> IO ()
|
||||
sendCommand Bot { .. } reply = do
|
||||
time <- getCurrentTime
|
||||
let line = lineFromCommand botConfig reply
|
||||
TF.hprint socket "{}\r\n" $ TF.Only line
|
||||
TF.print "> {}\n" $ TF.Only line
|
||||
TF.print "[{}} > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
|
||||
|
||||
listen :: IRC ()
|
||||
listen = do
|
||||
|
|
@ -44,64 +48,92 @@ listen = do
|
|||
Nothing -> return Disconnected
|
||||
Just line -> do
|
||||
now <- getCurrentTime
|
||||
TF.print "[{}] {}\n" $ TF.buildParams (now, line)
|
||||
debug $ "< " ++ line
|
||||
|
||||
let message = msgFromLine botConfig now line
|
||||
case message of
|
||||
JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined
|
||||
KickMsg { .. } | kicked == nick -> log "Kicked" >> return Kicked
|
||||
_ -> do
|
||||
forkIO $ case message of
|
||||
Ping { .. } -> sendCommand bot $ Pong msg
|
||||
ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd
|
||||
msg -> forM_ (handlers botConfig) $ \handlerName -> forkIO $ do
|
||||
let mHandler = getHandler handlerName
|
||||
case mHandler of
|
||||
Nothing -> log $ "No handler found with name: " ++ handlerName
|
||||
Just handler -> do
|
||||
mCmd <- runHandler handler botConfig msg
|
||||
case mCmd of
|
||||
Nothing -> return ()
|
||||
Just cmd -> sendCommand bot cmd
|
||||
return status
|
||||
JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined
|
||||
KickMsg { .. } | kicked == nick -> debug "Kicked" >> return Kicked
|
||||
ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return status
|
||||
_ -> return status
|
||||
|
||||
forM_ (msgHandlers botConfig) $ \msgHandlerName -> forkIO $ do
|
||||
let mMsgHandler = getMsgHandler msgHandlerName
|
||||
case mMsgHandler of
|
||||
Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName
|
||||
Just msgHandler -> do
|
||||
let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates
|
||||
mCmd <- runMsgHandler msgHandler botConfig msgHandlerState message
|
||||
case mCmd of
|
||||
Nothing -> return ()
|
||||
Just cmd -> sendCommand bot cmd
|
||||
return status
|
||||
|
||||
put nStatus
|
||||
when (nStatus /= Disconnected) listen
|
||||
|
||||
connect :: BotConfig -> IO Bot
|
||||
connect botConfig@BotConfig { .. } = do
|
||||
log "Connecting ..."
|
||||
debug "Connecting ..."
|
||||
socket <- connectToWithRetry
|
||||
hSetBuffering socket LineBuffering
|
||||
hSetBuffering stdout LineBuffering
|
||||
log "Connected"
|
||||
return $ Bot botConfig socket
|
||||
msgHandlerStates <- loadMsgHandlers botConfig
|
||||
debug "Connected"
|
||||
return $ Bot botConfig socket msgHandlerStates
|
||||
where
|
||||
connectToWithRetry = connectTo server (PortNumber (fromIntegral port))
|
||||
connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
|
||||
`catch` (\(e :: SomeException) -> do
|
||||
log ("Error while connecting: " ++ pack (show e) ++ ". Waiting.")
|
||||
debug ("Error while connecting: " ++ pack (show e) ++ ". Waiting.")
|
||||
threadDelay (5 * oneSec)
|
||||
connectToWithRetry)
|
||||
|
||||
loadMsgHandlers :: BotConfig -> IO MsgHandlerStates
|
||||
loadMsgHandlers botConfig@BotConfig { .. } =
|
||||
flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do
|
||||
debug $ "Loading msg handler: " ++ msgHandlerName
|
||||
let mMsgHandler = getMsgHandler msgHandlerName
|
||||
case mMsgHandler of
|
||||
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap
|
||||
Just msgHandler -> do
|
||||
msgHandlerState <- initMsgHandler msgHandler botConfig
|
||||
return $ insertMap msgHandlerName msgHandlerState hMap
|
||||
|
||||
unloadMsgHandlers :: Bot -> IO ()
|
||||
unloadMsgHandlers Bot { .. } =
|
||||
forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> do
|
||||
debug $ "Unloading msg handler: " ++ msgHandlerName
|
||||
let mMsgHandler = getMsgHandler msgHandlerName
|
||||
case mMsgHandler of
|
||||
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName)
|
||||
Just msgHandler -> exitMsgHandler msgHandler botConfig msgHandlerState
|
||||
|
||||
|
||||
disconnect :: Bot -> IO ()
|
||||
disconnect bot = do
|
||||
log "Disconnecting ..."
|
||||
hClose . socket $ bot
|
||||
log "Disconnected"
|
||||
disconnect bot@Bot { .. } = do
|
||||
debug "Disconnecting ..."
|
||||
unloadMsgHandlers bot
|
||||
hClose socket
|
||||
debug "Disconnected"
|
||||
|
||||
addCoreMsgHandlers :: BotConfig -> BotConfig
|
||||
addCoreMsgHandlers botConfig =
|
||||
botConfig { msgHandlers = hashNub $ msgHandlers botConfig ++ coreMsgHandlerNames }
|
||||
|
||||
run :: BotConfig -> IO ()
|
||||
run botConfig = withSocketsDo $ do
|
||||
log "Running with config:"
|
||||
run botConfig' = withSocketsDo $ do
|
||||
hSetBuffering stdout LineBuffering
|
||||
debug "Running with config:"
|
||||
print botConfig
|
||||
status <- run_
|
||||
case status of
|
||||
Disconnected -> log "Connection timed out" >> run botConfig
|
||||
Disconnected -> debug "Connection timed out" >> run botConfig
|
||||
Errored -> return ()
|
||||
_ -> error "Unsupported status"
|
||||
where
|
||||
botConfig = addCoreMsgHandlers botConfig'
|
||||
run_ = bracket (connect botConfig) disconnect $ \bot ->
|
||||
go bot `catch` \(e :: SomeException) -> do
|
||||
log $ "Exception! " ++ pack (show e)
|
||||
debug $ "Exception! " ++ pack (show e)
|
||||
return Errored
|
||||
|
||||
go bot = do
|
||||
|
|
|
|||
|
|
@ -1,33 +1,44 @@
|
|||
{-# LANGUAGE RecordWildCards, OverloadedStrings, NoImplicitPrelude #-}
|
||||
{-# LANGUAGE RecordWildCards, OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
|
||||
|
||||
module Network.IRC.Handlers (getHandler) where
|
||||
module Network.IRC.Handlers (coreMsgHandlerNames, getMsgHandler) where
|
||||
|
||||
import qualified Network.IRC.Handlers.Core as C
|
||||
import qualified Network.IRC.Handlers.SongSearch as SS
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Reader
|
||||
import Data.Text (strip)
|
||||
|
||||
import Network.IRC.Handlers.SongSearch
|
||||
import Network.IRC.Types
|
||||
|
||||
clean :: Text -> Text
|
||||
clean = toLower . strip
|
||||
|
||||
getHandler :: HandlerName -> Maybe Handler
|
||||
getHandler "greeter" = Just $ Handler greeter
|
||||
getHandler "welcomer" = Just $ Handler welcomer
|
||||
getHandler "songsearch" = Just $ Handler songSearch
|
||||
getHandler _ = Nothing
|
||||
coreMsgHandlerNames :: [Text]
|
||||
coreMsgHandlerNames = ["pingpong", "messagelogger"]
|
||||
|
||||
greeter :: Monad m => BotConfig -> Message -> m (Maybe Command)
|
||||
greeter _ ChannelMsg { .. } = case find (== clean msg) greetings of
|
||||
getMsgHandler :: MsgHandlerName -> Maybe MsgHandler
|
||||
getMsgHandler "greeter" = Just $ newMsgHandler { msgHandlerRun = greeter }
|
||||
getMsgHandler "welcomer" = Just $ newMsgHandler { msgHandlerRun = welcomer }
|
||||
getMsgHandler name = listToMaybe $ mapMaybe (\f -> f name)
|
||||
[C.getMsgHandler, SS.getMsgHandler]
|
||||
|
||||
|
||||
greeter :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
greeter ChannelMsg { .. } = case find (== clean msg) greetings of
|
||||
Nothing -> return Nothing
|
||||
Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user
|
||||
where
|
||||
greetings = ["hi", "hello", "hey", "sup", "bye"
|
||||
, "good morning", "good evening", "good night"
|
||||
, "ohayo", "oyasumi"]
|
||||
greeter _ _ = return Nothing
|
||||
greeter _ = return Nothing
|
||||
|
||||
welcomer :: Monad m => BotConfig -> Message -> m (Maybe Command)
|
||||
welcomer BotConfig { .. } JoinMsg { .. }
|
||||
| userNick user /= botNick = return . Just . ChannelMsgReply $ "welcome back " ++ userNick user
|
||||
welcomer _ _ = return Nothing
|
||||
welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
welcomer JoinMsg { .. } = do
|
||||
BotConfig { .. } <- ask
|
||||
if userNick user /= botNick
|
||||
then return . Just . ChannelMsgReply $ "welcome back " ++ userNick user
|
||||
else return Nothing
|
||||
|
||||
welcomer _ = return Nothing
|
||||
|
|
|
|||
|
|
@ -0,0 +1,55 @@
|
|||
{-# LANGUAGE RecordWildCards, NoImplicitPrelude, OverloadedStrings, FlexibleContexts #-}
|
||||
|
||||
module Network.IRC.Handlers.Core (getMsgHandler) where
|
||||
|
||||
import qualified Data.Configurator as C
|
||||
import qualified Data.Text.Format as TF
|
||||
import qualified Data.Text.Format.Params as TF
|
||||
|
||||
import ClassyPrelude hiding (try, (</>), (<.>))
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Dynamic
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
|
||||
import Network.IRC.Types
|
||||
|
||||
getMsgHandler :: MsgHandlerName -> Maybe MsgHandler
|
||||
getMsgHandler "pingpong" = Just $ newMsgHandler { msgHandlerRun = pingPong }
|
||||
getMsgHandler "messagelogger" = Just $ newMsgHandler { msgHandlerInit = initMessageLogger
|
||||
, msgHandlerRun = messageLogger
|
||||
, msgHandlerExit = exitMessageLogger }
|
||||
getMsgHandler _ = Nothing
|
||||
|
||||
pingPong :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
pingPong Ping { .. } = return . Just $ Pong msg
|
||||
pingPong _ = return Nothing
|
||||
|
||||
initMessageLogger :: MonadMsgHandler m => m ()
|
||||
initMessageLogger = do
|
||||
BotConfig { .. } <- ask
|
||||
logFileHandle <- liftIO $ do
|
||||
logFileDir <- C.require config "messagelogger.logdir"
|
||||
createDirectoryIfMissing True logFileDir
|
||||
let logFilePath = logFileDir </> unpack botNick <.> "log"
|
||||
logFileHandle <- openFile logFilePath AppendMode
|
||||
hSetBuffering logFileHandle LineBuffering
|
||||
return logFileHandle
|
||||
put $ toDyn logFileHandle
|
||||
|
||||
exitMessageLogger :: MonadMsgHandler m => m ()
|
||||
exitMessageLogger = do
|
||||
mHandle <- map fromDynamic get
|
||||
case mHandle of
|
||||
Nothing -> return ()
|
||||
Just logFileHandle -> liftIO $ hClose logFileHandle
|
||||
|
||||
messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
messageLogger ChannelMsg { .. } = do
|
||||
logFileHandle <- map (`fromDyn` error "No log file set") get
|
||||
let time = formatTime defaultTimeLocale "%F %T" msgTime
|
||||
liftIO $ TF.hprint logFileHandle "[{}] {}: {}\n" $ TF.buildParams (time, userNick user, msg)
|
||||
return Nothing
|
||||
messageLogger _ = return Nothing
|
||||
|
|
@ -1,11 +1,12 @@
|
|||
{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude #-}
|
||||
{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude, FlexibleContexts #-}
|
||||
|
||||
module Network.IRC.Handlers.SongSearch (songSearch) where
|
||||
module Network.IRC.Handlers.SongSearch (getMsgHandler) where
|
||||
|
||||
import qualified Data.Configurator as CF
|
||||
|
||||
import ClassyPrelude hiding (try)
|
||||
import Control.Exception
|
||||
import Control.Monad.Reader
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types (emptyArray)
|
||||
import Data.Text (strip)
|
||||
|
|
@ -14,6 +15,10 @@ import Network.HTTP.Base
|
|||
|
||||
import Network.IRC.Types
|
||||
|
||||
getMsgHandler :: MsgHandlerName -> Maybe MsgHandler
|
||||
getMsgHandler "songsearch" = Just $ newMsgHandler { msgHandlerRun = songSearch }
|
||||
getMsgHandler _ = Nothing
|
||||
|
||||
data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
|
@ -22,9 +27,11 @@ instance FromJSON Song where
|
|||
parseJSON a | a == emptyArray = return NoSong
|
||||
parseJSON _ = mempty
|
||||
|
||||
songSearch :: MonadIO m => BotConfig -> Message -> m (Maybe Command)
|
||||
songSearch BotConfig { .. } ChannelMsg { .. }
|
||||
| "!m " `isPrefixOf` msg = liftIO $ do
|
||||
songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||
songSearch ChannelMsg { .. } = if "!m " `isPrefixOf` msg
|
||||
then do
|
||||
BotConfig { .. } <- ask
|
||||
liftIO $ do
|
||||
let query = strip . drop 3 $ msg
|
||||
mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
|
||||
map (Just . ChannelMsgReply) $ case mApiKey of
|
||||
|
|
@ -40,5 +47,5 @@ songSearch BotConfig { .. } ChannelMsg { .. }
|
|||
Right song -> case song of
|
||||
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
|
||||
NoSong -> "No song found for: " ++ query
|
||||
| otherwise = return Nothing
|
||||
songSearch _ _ = return Nothing
|
||||
else return Nothing
|
||||
songSearch _ = return Nothing
|
||||
|
|
|
|||
|
|
@ -10,20 +10,20 @@ import Network.IRC.Types
|
|||
|
||||
msgFromLine :: BotConfig -> UTCTime -> Text -> Message
|
||||
msgFromLine (BotConfig { .. }) time line
|
||||
| "PING :" `isPrefixOf` line = Ping time . drop 6 $ line
|
||||
| "PING :" `isPrefixOf` line = Ping time (drop 6 line) line
|
||||
| otherwise = case command of
|
||||
"JOIN" -> JoinMsg time user
|
||||
"QUIT" -> QuitMsg time user message
|
||||
"PART" -> PartMsg time user message
|
||||
"KICK" -> KickMsg time user kicked kickReason
|
||||
"JOIN" -> JoinMsg time user line
|
||||
"QUIT" -> QuitMsg time user message line
|
||||
"PART" -> PartMsg time user message line
|
||||
"KICK" -> KickMsg time user kicked kickReason line
|
||||
"MODE" -> if source == botNick
|
||||
then ModeMsg time Self target message []
|
||||
else ModeMsg time user target mode modeArgs
|
||||
"NICK" -> NickMsg time user (drop 1 target)
|
||||
then ModeMsg time Self target message [] line
|
||||
else ModeMsg time user target mode modeArgs line
|
||||
"NICK" -> NickMsg time user (drop 1 target) line
|
||||
"PRIVMSG" -> if target == channel
|
||||
then ChannelMsg time user message
|
||||
else PrivMsg time user message
|
||||
_ -> OtherMsg time source command target message
|
||||
then ChannelMsg time user message line
|
||||
else PrivMsg time user message line
|
||||
_ -> OtherMsg time source command target message line
|
||||
where
|
||||
isSpc = (== ' ')
|
||||
isNotSpc = not . isSpc
|
||||
|
|
@ -46,4 +46,3 @@ lineFromCommand (BotConfig { .. }) reply = case reply of
|
|||
JoinCmd -> "JOIN " ++ channel
|
||||
ChannelMsgReply { .. } -> "PRIVMSG " ++ channel ++ " :" ++ rmsg
|
||||
PrivMsgReply (User { .. }) rmsg -> "PRIVMSG " ++ botNick ++ " :" ++ rmsg
|
||||
|
||||
|
|
|
|||
|
|
@ -1,53 +1,60 @@
|
|||
{-# LANGUAGE RecordWildCards, RankNTypes, GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
|
||||
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleContexts #-}
|
||||
|
||||
module Network.IRC.Types where
|
||||
module Network.IRC.Types
|
||||
(Channel, Nick, MsgHandlerName,
|
||||
User (..), Message (..), Command (..),
|
||||
BotConfig (..), BotStatus (..), Bot (..),
|
||||
IRC, runIRC,
|
||||
MonadMsgHandler, runMsgHandler, initMsgHandler, exitMsgHandler,
|
||||
MsgHandlerState, MsgHandlerStates, MsgHandler (..), newMsgHandler)
|
||||
where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Configurator.Types
|
||||
import Data.Dynamic
|
||||
|
||||
type Channel = Text
|
||||
type Nick = Text
|
||||
type HandlerName = Text
|
||||
type Channel = Text
|
||||
type Nick = Text
|
||||
type MsgHandlerName = Text
|
||||
|
||||
newtype Handler = Handler {
|
||||
runHandler :: forall m . (MonadIO m) => BotConfig -> Message -> m (Maybe Command)
|
||||
}
|
||||
|
||||
data User = Self | User { userNick :: Nick, userServer :: Text }
|
||||
data User = Self | User { userNick :: !Nick, userServer :: !Text }
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Message =
|
||||
ChannelMsg { time :: UTCTime, user :: User, msg :: Text }
|
||||
| PrivMsg { time :: UTCTime, user :: User, msg :: Text }
|
||||
| Ping { time :: UTCTime, msg :: Text }
|
||||
| JoinMsg { time :: UTCTime, user :: User }
|
||||
| ModeMsg { time :: UTCTime, user :: User, target :: Text , mode :: Text, modeArgs :: [Text] }
|
||||
| NickMsg { time :: UTCTime, user :: User, nick :: Text }
|
||||
| QuitMsg { time :: UTCTime, user :: User, msg :: Text }
|
||||
| PartMsg { time :: UTCTime, user :: User, msg :: Text }
|
||||
| KickMsg { time :: UTCTime, user :: User, kicked :: Text , msg :: Text }
|
||||
| OtherMsg { time :: UTCTime, source :: Text, command :: Text , target :: Text, msg :: Text }
|
||||
ChannelMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
|
||||
| PrivMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
|
||||
| Ping { msgTime :: !UTCTime, msg :: !Text, msgLine :: !Text }
|
||||
| JoinMsg { msgTime :: !UTCTime, user :: !User, msgLine :: !Text }
|
||||
| ModeMsg { msgTime :: !UTCTime, user :: !User, target :: !Text, mode :: !Text
|
||||
, modeArgs :: ![Text], msgLine :: !Text }
|
||||
| NickMsg { msgTime :: !UTCTime, user :: !User, nick :: !Text, msgLine :: !Text }
|
||||
| QuitMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
|
||||
| PartMsg { msgTime :: !UTCTime, user :: !User, msg :: !Text, msgLine :: !Text }
|
||||
| KickMsg { msgTime :: !UTCTime, user :: !User, kicked :: !Text, msg :: !Text
|
||||
, msgLine :: !Text }
|
||||
| OtherMsg { msgTime :: !UTCTime, source :: !Text, command :: !Text, target :: !Text
|
||||
, msg :: !Text, msgLine :: !Text }
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Command =
|
||||
Pong { rmsg :: Text }
|
||||
| ChannelMsgReply { rmsg :: Text }
|
||||
| PrivMsgReply { ruser :: User, rmsg :: Text }
|
||||
Pong { rmsg :: !Text }
|
||||
| ChannelMsgReply { rmsg :: !Text }
|
||||
| PrivMsgReply { ruser :: !User, rmsg :: !Text }
|
||||
| NickCmd
|
||||
| UserCmd
|
||||
| JoinCmd
|
||||
deriving (Show, Eq)
|
||||
|
||||
data BotConfig = BotConfig { server :: String
|
||||
, port :: Int
|
||||
, channel :: Text
|
||||
, botNick :: Text
|
||||
, botTimeout :: Int
|
||||
, handlers :: [HandlerName]
|
||||
, config :: Config }
|
||||
data BotConfig = BotConfig { server :: !Text
|
||||
, port :: !Int
|
||||
, channel :: !Text
|
||||
, botNick :: !Text
|
||||
, botTimeout :: !Int
|
||||
, msgHandlers :: ![MsgHandlerName]
|
||||
, config :: !Config }
|
||||
|
||||
instance Show BotConfig where
|
||||
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
|
||||
|
|
@ -55,15 +62,62 @@ instance Show BotConfig where
|
|||
"channel = " ++ show channel ++ "\n" ++
|
||||
"nick = " ++ show botNick ++ "\n" ++
|
||||
"timeout = " ++ show botTimeout ++ "\n" ++
|
||||
"handlers = " ++ show handlers ++ "\n"
|
||||
"handlers = " ++ show msgHandlers
|
||||
|
||||
data Bot = Bot { botConfig :: BotConfig, socket :: Handle } deriving (Show)
|
||||
type MsgHandlerStates = Map MsgHandlerName MsgHandlerState
|
||||
|
||||
data Bot = Bot { botConfig :: !BotConfig
|
||||
, socket :: !Handle
|
||||
, msgHandlerStates :: !MsgHandlerStates}
|
||||
|
||||
data BotStatus = Connected | Disconnected | Joined | Kicked | Errored
|
||||
deriving (Show, Eq)
|
||||
|
||||
newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }
|
||||
deriving (Functor, Monad, MonadIO, MonadReader Bot, MonadState BotStatus)
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadReader Bot
|
||||
, MonadState BotStatus)
|
||||
|
||||
runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus
|
||||
runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC
|
||||
|
||||
type MsgHandlerState = Dynamic
|
||||
|
||||
newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: StateT MsgHandlerState (ReaderT BotConfig IO) a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadState MsgHandlerState
|
||||
, MonadReader BotConfig)
|
||||
|
||||
class ( MonadIO m, Applicative m
|
||||
, MonadState MsgHandlerState m, MonadReader BotConfig m) => MonadMsgHandler m where
|
||||
msgHandler :: MsgHandlerT a -> m a
|
||||
|
||||
instance MonadMsgHandler MsgHandlerT where
|
||||
msgHandler = id
|
||||
|
||||
runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command)
|
||||
runMsgHandler MsgHandler { .. } botConfig msgHandlerState =
|
||||
flip runReaderT botConfig . flip evalStateT msgHandlerState . _runMsgHandler . msgHandlerRun
|
||||
|
||||
initMsgHandler :: MsgHandler -> BotConfig -> IO MsgHandlerState
|
||||
initMsgHandler MsgHandler { .. } botConfig =
|
||||
flip runReaderT botConfig . flip execStateT (toDyn ()) . _runMsgHandler $ msgHandlerInit
|
||||
|
||||
exitMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> IO ()
|
||||
exitMsgHandler MsgHandler { .. } botConfig msgHandlerState =
|
||||
flip runReaderT botConfig . flip evalStateT msgHandlerState . _runMsgHandler $ msgHandlerExit
|
||||
|
||||
data MsgHandler = MsgHandler { msgHandlerInit :: !(forall m . MonadMsgHandler m => m ())
|
||||
, msgHandlerRun :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command))
|
||||
, msgHandlerExit :: !(forall m . MonadMsgHandler m => m ()) }
|
||||
|
||||
newMsgHandler :: MsgHandler
|
||||
newMsgHandler = MsgHandler { msgHandlerInit = return ()
|
||||
, msgHandlerRun = const $ return Nothing
|
||||
, msgHandlerExit = return () }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ server = "irc.freenode.net"
|
|||
port = 6667
|
||||
channel = "#testtesttest"
|
||||
nick = "haskman"
|
||||
handlers = ["greeter", "welcomer", "songsearch"]
|
||||
msghandlers = ["greeter", "welcomer", "songsearch"]
|
||||
|
||||
songsearch {
|
||||
tinysong_apikey = "xxxyyyzzz"
|
||||
|
|
|
|||
|
|
@ -52,14 +52,14 @@ library
|
|||
build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2,
|
||||
network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0,
|
||||
curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3,
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2
|
||||
|
||||
exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
|
||||
Network.IRC.Handlers, Network.IRC.Client
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind -O2 -funbox-strict-fields
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind -O2 -funbox-strict-fields -fno-warn-orphans
|
||||
|
||||
|
||||
executable hask-irc
|
||||
|
|
@ -76,7 +76,7 @@ executable hask-irc
|
|||
build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2,
|
||||
network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0,
|
||||
curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3,
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1
|
||||
classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2
|
||||
|
||||
-- Directories containing source files.
|
||||
-- hs-source-dirs:
|
||||
|
|
@ -84,5 +84,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
|
||||
ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue