abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Some refactoring and reformatting

This commit is contained in:
Abhinav Sarkar 2014-05-20 02:40:08 +05:30
parent 8659c5f755
commit a3e4b145ec
7 changed files with 106 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Main.hs
View File

@ -14,7 +14,7 @@ import System.Environment
import System.Exit
import System.Posix.Signals
import Network.IRC.Types (BotConfig(BotConfig))
import Network.IRC.Types
import Network.IRC.Client
instance Configured a => Configured [a] where
@ -31,7 +31,7 @@ main = do
exitFailure
mainThreadId <- myThreadId
installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing
installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing
installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
let configFile = headEx args
@ -43,15 +43,15 @@ loadBotConfig configFile = do
case eCfg of
Left (ParseError _ _) -> error "Error while loading config"
Right cfg -> do
eBotConfig <- try $ do
server <- CF.require cfg "server"
port <- CF.require cfg "port"
channel <- CF.require cfg "channel"
botNick <- CF.require cfg "nick"
timeout <- CF.require cfg "timeout"
msghandlers <- CF.require cfg "msghandlers"
return $ BotConfig server port channel botNick timeout msghandlers cfg
eBotConfig <- try $ BotConfig <$>
CF.require cfg "server" <*>
CF.require cfg "port" <*>
CF.require cfg "channel" <*>
CF.require cfg "nick" <*>
CF.require cfg "timeout" <*>
CF.require cfg "msghandlers" <*>
pure cfg
case eBotConfig of
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
Right botConfig -> return botConfig
Right botConf -> return botConf

26
Network/IRC/Client.hs
View File

@ -44,11 +44,14 @@ data Line = Timeout | EOF | Line !Message deriving (Show, Eq)
sendCommandLoop :: EChannel Command -> Bot -> IO ()
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
cmd <- readChan commandChan
time <- getCurrentTime
let line = lineFromCommand botConfig cmd
TF.hprint socket "{}\r\n" $ TF.Only line
TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
cmd <- readChan commandChan
time <- getCurrentTime
let mline = lineFromCommand botConfig cmd
case mline of
Nothing -> return ()
Just line -> do
TF.hprint socket "{}\r\n" $ TF.Only line
TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
case cmd of
QuitCmd -> latchIt latch
_ -> sendCommandLoop (commandChan, latch) bot
@ -86,9 +89,9 @@ sendMessage = (. Line) . writeChan
listenerLoop :: Chan Line -> Chan Command -> Int -> IRC ()
listenerLoop lineChan commandChan !idleFor = do
status <- get
status <- get
bot@Bot { .. } <- ask
let nick = botNick botConfig
let nick = botNick botConfig
nStatus <- liftIO . mask_ $
if idleFor >= (oneSec * botTimeout botConfig)
@ -127,10 +130,9 @@ listenerLoop lineChan commandChan !idleFor = do
handle (\(e :: SomeException) -> debug $ "Exception! " ++ pack (show e)) $ do
mCmd <- runMsgHandler msgHandler botConfig message
case mCmd of
Nothing -> return ()
Just cmd -> case cmd of
MessageCmd msg -> sendMessage lineChan msg
_ -> sendCommand commandChan cmd
Nothing -> return ()
Just (MessageCmd msg) -> sendMessage lineChan msg
Just cmd -> sendCommand commandChan cmd
loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler)
loadMsgHandlers botConfig@BotConfig { .. } =
@ -202,7 +204,7 @@ run botConfig' = withSocketsDo $ do
handleErrors :: SomeException -> IO BotStatus
handleErrors e = case fromException e of
Just UserInterrupt -> debug "User interrupt" >> return Interrupted
Just UserInterrupt -> debug "User interrupt" >> return Interrupted
_ -> debug ("Exception! " ++ pack (show e)) >> return Errored
run_ = bracket (connect botConfig) disconnect $

36
Network/IRC/Handlers/MessageLogger.hs
View File

@ -28,7 +28,7 @@ mkMsgHandler botConfig "messagelogger" = do
initMessageLogger botConfig state
return . Just $ newMsgHandler { msgHandlerRun = flip messageLogger state
, msgHandlerStop = exitMessageLogger state }
mkMsgHandler _ _ = return Nothing
mkMsgHandler _ _ = return Nothing
getLogFilePath :: BotConfig -> IO FilePath
getLogFilePath BotConfig { .. } = do
@ -46,25 +46,24 @@ initMessageLogger :: BotConfig -> IORef LoggerState -> IO ()
initMessageLogger botConfig state = do
logFilePath <- getLogFilePath botConfig
logFileHandle <- openLogFile logFilePath
time <- getModificationTime logFilePath
time <- getModificationTime logFilePath
atomicWriteIORef state $ Just (logFileHandle, utctDay time)
exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
exitMessageLogger state = liftIO $ do
mHandle <- readIORef state
case mHandle of
Nothing -> return ()
Just (logFileHandle, _ :: Day) -> hClose logFileHandle
Nothing -> return ()
Just (logFileHandle, _) -> hClose logFileHandle
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
withLogFile action state = do
botConfig <- ask
liftIO $ do
Just (logFileHandle, prevDay) <- readIORef state
curDay <- map utctDay getCurrentTime
let diff = diffDays curDay prevDay
logFileHandle' <- if diff >= 1
curDay <- map utctDay getCurrentTime
let diff = diffDays curDay prevDay
logFileHandle' <- if diff >= 1
then do
hClose logFileHandle
logFilePath <- getLogFilePath botConfig
@ -80,18 +79,17 @@ withLogFile action state = do
return Nothing
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
messageLogger message = go message
messageLogger message = case message of
ChannelMsg { .. } -> log "<{}> {}" [userNick user, msg]
ActionMsg { .. } -> log "<{}> {} {}" [userNick user, userNick user, msg]
KickMsg { .. } -> log "** {} KICKED {} :{}" [userNick user, kickedNick, msg]
JoinMsg { .. } -> log "** {} JOINED" [userNick user]
PartMsg { .. } -> log "** {} PARTED :{}" [userNick user, msg]
QuitMsg { .. } -> log "** {} QUIT :{}" [userNick user, msg]
NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [userNick user, nick]
NamesMsg { .. } -> log "** USERS {}" [unwords nicks]
_ -> const $ return Nothing
where
go ChannelMsg { .. } = log "<{}> {}" [userNick user, msg]
go ActionMsg { .. } = log "<{}> {} {}" [userNick user, userNick user, msg]
go KickMsg { .. } = log "** {} KICKED {} :{}" [userNick user, kickedNick, msg]
go JoinMsg { .. } = log "** {} JOINED" [userNick user]
go PartMsg { .. } = log "** {} PARTED :{}" [userNick user, msg]
go QuitMsg { .. } = log "** {} QUIT :{}" [userNick user, msg]
go NickMsg { .. } = log "** {} CHANGED NICK TO {}" [userNick user, nick]
go NamesMsg { .. } = log "** USERS {}" [unwords nicks]
go _ = const $ return Nothing
log format args = withLogFile $ \logFile ->
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args)

40
Network/IRC/Handlers/SongSearch.hs
View File

@ -21,7 +21,7 @@ import Network.IRC.Types
mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler _ "songsearch" = return . Just $ newMsgHandler { msgHandlerRun = songSearch }
mkMsgHandler _ _ = return Nothing
mkMsgHandler _ _ = return Nothing
data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
deriving (Show, Eq)
@ -32,24 +32,24 @@ instance FromJSON Song where
parseJSON _ = mempty
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
Nothing -> -- do log "tinysong api key not found in config"
return $ "Error while searching for " ++ query
Just apiKey -> do
let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)
++ "?format=json&key=" ++ apiKey
songSearch ChannelMsg { .. }
| "!m " `isPrefixOf` msg = do
BotConfig { .. } <- ask
liftIO $ do
let query = strip . drop 3 $ msg
mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
map (Just . ChannelMsgReply) $ case mApiKey of
Nothing -> -- do log "tinysong api key not found in config"
return $ "Error while searching for " ++ query
Just apiKey -> do
let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)
++ "?format=json&key=" ++ apiKey
result <- try $ curlAesonGet apiUrl >>= evaluate
return $ case result of
Left (_ :: CurlAesonException) -> "Error while searching for " ++ query
Right song -> case song of
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
NoSong -> "No song found for: " ++ query
else return Nothing
result <- try $ curlAesonGet apiUrl >>= evaluate
return $ case result of
Left (_ :: CurlAesonException) -> "Error while searching for " ++ query
Right song -> case song of
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
NoSong -> "No song found for: " ++ query
| otherwise = return Nothing
songSearch _ = return Nothing

38
Network/IRC/Protocol.hs
View File

@ -20,16 +20,14 @@ msgFromLine (BotConfig { .. }) time line
"PART" -> PartMsg time user message line
"KICK" -> KickMsg time user kicked kickReason line
"MODE" -> if source == botNick
then ModeMsg time Self target message [] line
else ModeMsg time user target mode modeArgs line
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 if "\x01" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
then ActionMsg time user (initDef . drop 8 $ message) line
else ChannelMsg time user message line
else PrivMsg time user message line
"353" -> NamesMsg time namesNicks
"433" -> NickInUseMsg time line
"PRIVMSG" | target /= channel -> PrivMsg time user message line
| isActionMsg -> ActionMsg time user (initDef . drop 8 $ message) line
| otherwise -> ChannelMsg time user message line
_ -> OtherMsg time source command target message line
where
isSpc = (== ' ')
@ -51,15 +49,17 @@ msgFromLine (BotConfig { .. }) time line
namesNicks = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits
stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack
lineFromCommand :: BotConfig -> Command -> Text
lineFromCommand (BotConfig { .. }) command = case command of
PongCmd { .. } -> "PONG :" ++ rmsg
PingCmd { .. } -> "PING :" ++ rmsg
NickCmd -> "NICK " ++ botNick
UserCmd -> "USER " ++ botNick ++ " 0 * :" ++ botNick
JoinCmd -> "JOIN " ++ channel
QuitCmd -> "QUIT"
ChannelMsgReply { .. } -> "PRIVMSG " ++ channel ++ " :" ++ rmsg
PrivMsgReply (User { .. }) rmsg -> "PRIVMSG " ++ botNick ++ " :" ++ rmsg
NamesCmd -> "NAMES " ++ channel
_ -> error $ "Unsupported command " ++ show command
isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
lineFromCommand :: BotConfig -> Command -> Maybe Text
lineFromCommand BotConfig { .. } command = case command of
PongCmd { .. } -> Just $ "PONG :" ++ rmsg
PingCmd { .. } -> Just $ "PING :" ++ rmsg
NickCmd -> Just $ "NICK " ++ botNick
UserCmd -> Just $ "USER " ++ botNick ++ " 0 * :" ++ botNick
JoinCmd -> Just $ "JOIN " ++ channel
QuitCmd -> Just "QUIT"
ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ botNick ++ " :" ++ rmsg
NamesCmd -> Just $ "NAMES " ++ channel
_ -> Nothing

31
Network/IRC/Types.hs
View File

@ -8,9 +8,22 @@
{-# LANGUAGE RecordWildCards #-}
module Network.IRC.Types
(Channel, Nick, MsgHandlerName, User (..), Message (..), Command (..),
BotConfig (..), BotStatus (..), Bot (..), IRC, runIRC,
MsgHandler (..), MonadMsgHandler, newMsgHandler, runMsgHandler, stopMsgHandler)
( Channel
, Nick
, MsgHandlerName
, User (..)
, Message (..)
, Command (..)
, BotConfig (..)
, BotStatus (..)
, Bot (..)
, IRC
, runIRC
, MsgHandler (..)
, MonadMsgHandler
, newMsgHandler
, runMsgHandler
, stopMsgHandler)
where
import ClassyPrelude
@ -68,11 +81,11 @@ data BotConfig = BotConfig { server :: !Text
, config :: !Config }
instance Show BotConfig where
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
"port = " ++ show port ++ "\n" ++
"channel = " ++ show channel ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
"port = " ++ show port ++ "\n" ++
"channel = " ++ show channel ++ "\n" ++
"nick = " ++ show botNick ++ "\n" ++
"timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show msgHandlerNames
data Bot = Bot { botConfig :: !BotConfig
@ -107,7 +120,7 @@ newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a }
, MonadIO
, MonadReader BotConfig )
class ( MonadIO m, Applicative m, MonadReader BotConfig m ) => MonadMsgHandler m where
class (MonadIO m, Applicative m, MonadReader BotConfig m) => MonadMsgHandler m where
msgHandler :: MsgHandlerT a -> m a
instance MonadMsgHandler MsgHandlerT where

4
hask-irc.cabal
View File

@ -49,6 +49,8 @@ build-type: Simple
cabal-version: >=1.10
library
other-extensions: Safe
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
@ -83,7 +85,7 @@ executable hask-irc
-- other-modules:
-- LANGUAGE extensions used by modules in this package.
other-extensions: RecordWildCards, OverloadedStrings, ScopedTypeVariables, OverlappingInstances
other-extensions: Safe
-- Other library packages from which modules are imported.
build-depends: base >=4.5 && <4.8,