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

Restructed and refactored

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-06-01 23:14:19 +05:30
parent 651244834e
commit 924e023e27
21 changed files with 285 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
hask-irc-core/Network/IRC/Bot.hs
View File

@ -17,7 +17,7 @@ import qualified System.Log.Logger as HSL
import ClassyPrelude
import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay)
import Control.Exception.Lifted (mask_)
import Control.Exception.Lifted (mask_, mask)
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.Time (addUTCTime)
@ -59,11 +59,11 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
_ -> sendCommandLoop (commandChan, latch) bot
readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
readLineLoop = readLineLoop' []
readLineLoop = go []
where
msgPartTimeout = 10
readLineLoop' !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
botStatus <- readMVar mvBotStatus
case botStatus of
Disconnected -> latchIt latch
@ -76,31 +76,30 @@ readLineLoop = readLineLoop' []
Right Nothing -> writeChan lineChan Timeout >> return msgParts
Right (Just (Line time line)) -> do
let (mmsg, msgParts') = parseLine botConfig time line msgParts
case mmsg of
Nothing -> return msgParts'
Just msg -> writeChan lineChan (Msg msg) >> return msgParts'
whenJust mmsg $ writeChan lineChan . Msg
return msgParts'
Right (Just l) -> writeChan lineChan l >> return msgParts
limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
let msgParts'' = concat
. filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
. groupAllOn (msgParserType &&& msgPartTarget) $ msgParts'
readLineLoop' msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
where
readLine' = do
eof <- hIsEOF socket
if eof
then return EOF
else do
line <- map initEx $ hGetLine socket
else mask $ \unmask -> do
line <- map initEx . unmask $ hGetLine socket
infoM . unpack $ "< " ++ line
now <- getCurrentTime
return $ Line now line
messageProcessLoop :: Chan Line -> Chan Command -> IRC ()
messageProcessLoop = messageProcessLoop' 0
messageProcessLoop = go 0
where
messageProcessLoop' !idleFor lineChan commandChan = do
go !idleFor lineChan commandChan = do
status <- get
bot@Bot { .. } <- ask
let nick = botNick botConfig
@ -133,10 +132,10 @@ messageProcessLoop = messageProcessLoop' 0
put nStatus
case nStatus of
Idle -> messageProcessLoop' (idleFor + oneSec) lineChan commandChan
Idle -> go (idleFor + oneSec) lineChan commandChan
Disconnected -> return ()
NickNotAvailable -> return ()
_ -> messageProcessLoop' 0 lineChan commandChan
_ -> go 0 lineChan commandChan
where
dispatchHandlers Bot { .. } message =

57
hask-irc-runner/Network/IRC/Client.hs → hask-irc-core/Network/IRC/Client.hs
View File

@ -5,19 +5,27 @@ module Network.IRC.Client (runBot) where
import qualified System.Log.Logger as HSL
import ClassyPrelude
import Control.Concurrent.Lifted (fork, newChan, threadDelay)
import Control.Exception.Lifted (AsyncException (UserInterrupt))
import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan)
import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt))
import Network (PortID (PortNumber), connectTo, withSocketsDo)
import System.IO (hSetBuffering, BufferMode(..))
import System.Log.Formatter (tfLogFormatter)
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple (streamHandler)
import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerName,
setHandlers, setLevel)
import System.Log.Logger.TH (deriveLoggers)
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
import Network.IRC.Bot
import Network.IRC.Handlers
import Network.IRC.Types
import Network.IRC.Util
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
coreMsgHandlerNames :: [MsgHandlerName]
coreMsgHandlerNames = ["pingpong", "help"]
connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent)
connect botConfig@BotConfig { .. } = do
debugM "Connecting ..."
@ -43,10 +51,17 @@ connect botConfig@BotConfig { .. } = do
newChannel = (,) <$> newChan <*> newEmptyMVar
mkMsgHandler :: Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler eventChan name =
flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
case finalHandler of
Just _ -> return finalHandler
Nothing -> handler botConfig eventChan name
loadMsgHandlers eventChan =
flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName
mMsgHandler <- mkMsgHandler eventChan msgHandlerName
case mMsgHandler of
Nothing -> do
debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
@ -71,15 +86,12 @@ disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (
debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName
stopMsgHandler msgHandler botConfig
runBot :: BotConfig -> IO ()
runBot botConfig' = withSocketsDo $ do
hSetBuffering stdout LineBuffering
debugM "Running with config:"
print botConfig
status <- runBot_
runBotIntenal :: BotConfig -> IO ()
runBotIntenal botConfig' = withSocketsDo $ do
status <- run
case status of
Disconnected -> debugM "Restarting .." >> runBot botConfig
Errored -> debugM "Restarting .." >> runBot botConfig
Disconnected -> debugM "Restarting .." >> runBotIntenal botConfig
Errored -> debugM "Restarting .." >> runBotIntenal botConfig
Interrupted -> return ()
NickNotAvailable -> return ()
_ -> error "Unsupported status"
@ -95,9 +107,11 @@ runBot botConfig' = withSocketsDo $ do
Just UserInterrupt -> debugM "User interrupt" >> return Interrupted
_ -> debugM ("Exception! " ++ show e) >> return Errored
runBot_ = bracket (connect botConfig) disconnect $
run = bracket (connect botConfig) disconnect $
\(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) ->
handle handleErrors $ do
debugM $ "Running with config:\n" ++ show botConfig
sendCommand commandChan NickCmd
sendCommand commandChan UserCmd
@ -105,3 +119,20 @@ runBot botConfig' = withSocketsDo $ do
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
fork $ eventProcessLoop eventChannel lineChan commandChan bot
runIRC bot Connected (messageProcessLoop lineChan commandChan)
runBot :: BotConfig -> IO ()
runBot botConfig = do
-- setup signal handling
mainThreadId <- myThreadId
installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing
installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
-- setup logging
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $
setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
-- run
runBotIntenal botConfig

30
hask-irc-core/Network/IRC/Protocol.hs
View File

@ -60,18 +60,18 @@ lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message ti
| otherwise -> ChannelMsg user message
_ -> OtherMsg source command target message
where
splits = words line
command = splits !! 1
source = drop 1 $ splits !! 0
target = splits !! 2
message = strip . drop 1 . unwords . drop 3 $ splits
quitMessage = strip . drop 1 . unwords . drop 2 $ splits
user = uncurry User . (Nick *** drop 1) . break (== '!') $ source
mode = splits !! 3
modeArgs = drop 4 splits
kicked = splits !! 3
kickReason = drop 1 . unwords . drop 4 $ splits
isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
splits = words line
command = splits !! 1
source = drop 1 $ splits !! 0
target = splits !! 2
message = strip . drop 1 . unwords . drop 3 $ splits
quitMessage = strip . drop 1 . unwords . drop 2 $ splits
user = uncurry User . (Nick *** drop 1) . break (== '!') $ source
mode = splits !! 3
modeArgs = drop 4 splits
kicked = splits !! 3
kickReason = drop 1 . unwords . drop 4 $ splits
isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
partitionMsgParts :: MessageParseType -> Text -> [MessagePart] -> ([MessagePart], [MessagePart])
partitionMsgParts parserType target =
@ -96,11 +96,13 @@ lineFromCommand :: BotConfig -> Command -> Maybe Text
lineFromCommand BotConfig { .. } command = case command of
PongCmd { .. } -> Just $ "PONG :" ++ rmsg
PingCmd { .. } -> Just $ "PING :" ++ rmsg
NickCmd -> Just $ "NICK " ++ nickToText botNick
UserCmd -> Just $ "USER " ++ nickToText botNick ++ " 0 * :" ++ nickToText botNick
NickCmd -> Just $ "NICK " ++ botNick'
UserCmd -> Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
JoinCmd -> Just $ "JOIN " ++ channel
QuitCmd -> Just "QUIT"
ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ rmsg
NamesCmd -> Just $ "NAMES " ++ channel
_ -> Nothing
where
botNick' = nickToText botNick

76
hask-irc-core/Network/IRC/Types.hs
View File

@ -27,17 +27,19 @@ module Network.IRC.Types
, handleMessage
, handleEvent
, stopMsgHandler
, getHelp )
, getHelp
, MsgHandlerMaker )
where
import ClassyPrelude
import Control.Monad.Base (MonadBase)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
import Control.Monad.State (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config)
import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Typeable (cast)
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Base (MonadBase)
import Control.Monad.Reader (ReaderT, MonadReader, runReaderT)
import Control.Monad.State (StateT, MonadState, execStateT)
import Data.Configurator.Types (Config)
import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Typeable (cast)
import Network.IRC.Util
@ -52,10 +54,10 @@ instance Show Nick where
$(deriveSafeCopy 0 'base ''Nick)
data User = Self | User { userNick :: !Nick, userServer :: !Text }
deriving (Show, Eq)
deriving (Show, Eq, Ord)
data Message = Message { msgTime :: !UTCTime, msgLine :: !Text, msgDetails :: MessageDetails}
deriving (Show, Eq)
deriving (Show, Eq, Ord)
data MessageDetails =
IdleMsg
@ -73,7 +75,7 @@ data MessageDetails =
| KickMsg { user :: !User, kickedNick :: !Nick, msg :: !Text }
| ModeMsg { user :: !User, msgTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
| OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
deriving (Show, Eq)
deriving (Show, Eq, Ord)
data Command =
PingCmd { rmsg :: !Text }
@ -85,11 +87,11 @@ data Command =
| JoinCmd
| QuitCmd
| NamesCmd
deriving (Show, Eq)
deriving (Show, Eq, Ord)
-- Internal events
-- Events
class (Typeable e, Show e) => Event e where
class (Typeable e, Show e, Eq e) => Event e where
toEvent :: e -> IO SomeEvent
toEvent e = SomeEvent <$> pure e <*> getCurrentTime
@ -98,30 +100,36 @@ class (Typeable e, Show e) => Event e where
ev <- cast e
return (ev, time)
data SomeEvent = forall e. Event e => SomeEvent e UTCTime deriving (Typeable)
data SomeEvent = forall e. (Event e, Typeable e) => SomeEvent e UTCTime deriving (Typeable)
instance Show SomeEvent where
show (SomeEvent e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
instance Eq SomeEvent where
SomeEvent e1 t1 == SomeEvent e2 t2 =
case cast e2 of
Just e2' -> e1 == e2' && t1 == t2
Nothing -> False
data QuitEvent = QuitEvent deriving (Show, Typeable)
data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable)
instance Event QuitEvent
data EventResponse = RespNothing
| RespEvent SomeEvent
| RespMessage Message
| RespCommand Command
deriving (Show)
deriving (Show, Eq)
-- Bot
type MsgHandlerName = Text
data BotConfig = BotConfig { server :: !Text
, port :: !Int
, channel :: !Text
, botNick :: !Nick
, botTimeout :: !Int
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
, config :: !Config }
data BotConfig = BotConfig { server :: !Text
, port :: !Int
, channel :: !Text
, botNick :: !Nick
, botTimeout :: !Int
, msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
, msgHandlerMakers :: ![MsgHandlerMaker]
, config :: !Config }
instance Show BotConfig where
show BotConfig { .. } = "server = " ++ show server ++ "\n" ++
@ -135,15 +143,15 @@ data Bot = Bot { botConfig :: !BotConfig
, socket :: !Handle
, msgHandlers :: !(Map MsgHandlerName MsgHandler) }
data BotStatus = Connected
| Disconnected
| Joined
| Kicked
| Errored
| Idle
| Interrupted
| NickNotAvailable
deriving (Show, Eq)
data BotStatus = Connected
| Disconnected
| Joined
| Kicked
| Errored
| Idle
| Interrupted
| NickNotAvailable
deriving (Show, Eq, Ord)
newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }
deriving ( Functor
@ -202,3 +210,5 @@ newMsgHandler = MsgHandler {
onEvent = const $ return RespNothing,
onHelp = return mempty
}
type MsgHandlerMaker = BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)

4
hask-irc-core/Network/IRC/Util.hs
View File

@ -2,13 +2,13 @@
module Network.IRC.Util where
import qualified Data.Text.Lazy as LzT
import qualified Data.Text.Format as TF
import ClassyPrelude
import Control.Arrow (Arrow)
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Base (MonadBase)
import Data.Convertible (convert)
import Data.Text (strip)
import Data.Time (diffUTCTime)
@ -49,7 +49,7 @@ atomicModIORef ref f = void . atomicModifyIORef' ref $ \v -> (f v, v)
-- | Display a time span as one time relative to another.
relativeTime :: UTCTime -> UTCTime -> Text
relativeTime t1 t2 =
maybe "unknown" (LzT.toStrict . format) $ find (\(s,_,_) -> abs period >= s) ranges
maybe "unknown" (convert . format) $ find (\(s,_,_) -> abs period >= s) ranges
where
minute = 60; hour = minute * 60; day = hour * 24;
week = day * 7; month = day * 30; year = month * 12

22
hask-irc-core/hask-irc-core.cabal
View File

@ -54,22 +54,26 @@ library
DeriveDataTypeable
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
configurator >=0.2 && <0.3,
safecopy >=0.8 && <0.9,
time >=1.4 && <1.5,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
lifted-base >=0.2 && <0.3,
configurator >=0.2 && <0.3,
convertible >=1.1 && <1.2,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
transformers-base >=0.4 && <0.5
lifted-base >=0.2 && <0.3,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
safecopy >=0.8 && <0.9,
text >=0.11 && <0.12,
text-format >=0.3 && <0.4,
time >=1.4 && <1.5,
transformers-base >=0.4 && <0.5,
unix >=2.7 && <2.8
exposed-modules: Network.IRC.Types,
Network.IRC.Protocol,
Network.IRC.Util,
Network.IRC.Bot
Network.IRC.Bot,
Network.IRC.Client
default-language: Haskell2010

37
hask-irc-handlers/Network/IRC/Handlers.hs
View File

@ -1,6 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where
module Network.IRC.Handlers (allMsgHandlerMakers) where
import qualified Network.IRC.Handlers.Auth as Auth
import qualified Network.IRC.Handlers.Core as Core
@ -10,28 +8,15 @@ import qualified Network.IRC.Handlers.NickTracker as NickTracker
import qualified Network.IRC.Handlers.SongSearch as SongSearch
import qualified Network.IRC.Handlers.Tell as Tell
import ClassyPrelude
import Control.Concurrent.Lifted (Chan)
import Network.IRC.Types
coreMsgHandlerNames :: [Text]
coreMsgHandlerNames = ["pingpong", "help"]
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler botConfig eventChan name =
flip (`foldM` Nothing) handlerMakers $ \finalHandler handler ->
case finalHandler of
Just _ -> return finalHandler
Nothing -> handler botConfig eventChan name
where
handlerMakers = [
Auth.mkMsgHandler
, Core.mkMsgHandler
, Greet.mkMsgHandler
, Logger.mkMsgHandler
, NickTracker.mkMsgHandler
, SongSearch.mkMsgHandler
, Tell.mkMsgHandler
]
allMsgHandlerMakers :: [MsgHandlerMaker]
allMsgHandlerMakers = [
Auth.mkMsgHandler
, Core.mkMsgHandler
, Greet.mkMsgHandler
, Logger.mkMsgHandler
, NickTracker.mkMsgHandler
, SongSearch.mkMsgHandler
, Tell.mkMsgHandler
]

13
hask-irc-handlers/Network/IRC/Handlers/Auth.hs
View File

@ -7,12 +7,11 @@ import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import ClassyPrelude
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Reader (asks)
import Control.Monad.State (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Control.Monad.Reader (asks)
import Control.Monad.State (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Network.IRC.Handlers.Auth.Types
import Network.IRC.Types
@ -66,7 +65,7 @@ authEvent state event = case fromEvent event of
return RespNothing
_ -> return RespNothing
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler :: MsgHandlerMaker
mkMsgHandler BotConfig { .. } _ "auth" = do
state <- io $ openLocalState emptyAuth >>= newIORef
return . Just $ newMsgHandler { onMessage = authMessage state

3
hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Handlers.Auth.Types where
@ -18,7 +17,7 @@ emptyAuth = Auth mempty
$(deriveSafeCopy 0 'base ''Auth)
data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable)
instance Event AuthEvent

11
hask-irc-handlers/Network/IRC/Handlers/Core.hs
View File

@ -1,7 +1,6 @@
module Network.IRC.Handlers.Core (mkMsgHandler) where
import ClassyPrelude
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Reader (ask)
import Data.Convertible (convert)
import Data.Time (addUTCTime)
@ -9,7 +8,7 @@ import Data.Time (addUTCTime)
import Network.IRC.Types
import Network.IRC.Util
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler :: MsgHandlerMaker
mkMsgHandler _ _ "pingpong" = do
state <- getCurrentTime >>= newIORef
return . Just $ newMsgHandler { onMessage = pingPong state }
@ -44,11 +43,13 @@ help Message { msgDetails = ChannelMsg { .. }, .. }
| "!help" == clean msg = do
BotConfig { .. } <- ask
let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
return [ChannelMsgReply $ "I know these commands: " ++ unwords commands]
return [ ChannelMsgReply $ "I know these commands: " ++ unwords commands
, ChannelMsgReply "Type !help <command> to know more about any command"]
| "!help" `isPrefixOf` msg = do
BotConfig { .. } <- ask
let command = cons '!'. dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
let mHelp = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo
let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
let mHelp = find ((\c -> c == command || c == cons '!' command) . fst)
. concatMap mapToList . mapValues $ msgHandlerInfo
return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
help _ = return []

5
hask-irc-handlers/Network/IRC/Handlers/Greet.hs
View File

@ -1,13 +1,12 @@
module Network.IRC.Handlers.Greet (mkMsgHandler) where
import ClassyPrelude
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Reader (ask)
import Control.Monad.Reader (ask)
import Network.IRC.Types
import Network.IRC.Util
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler :: MsgHandlerMaker
mkMsgHandler _ _ "greeter" = return . Just $ newMsgHandler { onMessage = greeter }
mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
mkMsgHandler _ _ _ = return Nothing

21
hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs
View File

@ -2,25 +2,24 @@
module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where
import qualified Data.Configurator as C
import qualified Data.Configurator as CF
import qualified Data.Text.Format as TF
import qualified Data.Text.Format.Params as TF
import ClassyPrelude hiding ((</>), (<.>), FilePath, log)
import Control.Concurrent.Lifted (Chan)
import Control.Exception.Lifted (mask_)
import Control.Monad.Reader (ask)
import Data.Time (diffDays)
import System.Directory (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
import System.FilePath (FilePath, (</>), (<.>))
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
import ClassyPrelude hiding ((</>), (<.>), FilePath, log)
import Control.Exception.Lifted (mask_)
import Control.Monad.Reader (ask)
import Data.Time (diffDays)
import System.Directory (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
import System.FilePath (FilePath, (</>), (<.>))
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
import Network.IRC.Types
import Network.IRC.Util
type LoggerState = Maybe (Handle, Day)
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler :: MsgHandlerMaker
mkMsgHandler botConfig _ "messagelogger" = do
state <- io $ newIORef Nothing
initMessageLogger botConfig state
@ -30,7 +29,7 @@ mkMsgHandler _ _ _ = return Nothing
getLogFilePath :: BotConfig -> IO FilePath
getLogFilePath BotConfig { .. } = do
logFileDir <- C.require config "messagelogger.logdir"
logFileDir <- CF.require config "messagelogger.logdir"
createDirectoryIfMissing True logFileDir
return $ logFileDir </> unpack (channel ++ "-" ++ nickToText botNick) <.> "log"

21
hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs
View File

@ -8,16 +8,15 @@ import qualified Data.IxSet as IS
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U
import ClassyPrelude hiding (swap)
import Control.Concurrent.Lifted (Chan)
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Data.Convertible (convert)
import Data.IxSet (getOne, (@=))
import Data.Time (addUTCTime, NominalDiffTime)
import ClassyPrelude hiding (swap)
import Control.Monad.Reader (ask)
import Control.Monad.State (get, put)
import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
openLocalState, createArchive)
import Data.Acid.Local (createCheckpointAndClose)
import Data.Convertible (convert)
import Data.IxSet (getOne, (@=))
import Data.Time (addUTCTime, NominalDiffTime)
import Network.IRC.Handlers.NickTracker.Types
import Network.IRC.Types
@ -187,7 +186,7 @@ stopNickTracker state = io $ do
createArchive acid
createCheckpointAndClose acid
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler :: MsgHandlerMaker
mkMsgHandler BotConfig { .. } _ "nicktracker" = do
state <- io $ do
now <- getCurrentTime

7
hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs
View File

@ -10,7 +10,8 @@ import Data.SafeCopy (base, deriveSafeCopy)
import Network.IRC.Types
newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable)
newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text }
deriving (Eq, Ord, Show, Data, Typeable)
newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
data NickTrack = NickTrack {
@ -37,7 +38,7 @@ $(deriveSafeCopy 0 'base ''NickTracking)
emptyNickTracking :: NickTracking
emptyNickTracking = NickTracking empty
data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Typeable)
data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable)
instance Event NickTrackRequest
@ -46,7 +47,7 @@ instance Show NickTrackRequest where
getCanonicalNick :: Chan SomeEvent -> Nick -> IO (Maybe CanonicalNick)
getCanonicalNick eventChan nick = do
reply <- newEmptyMVar
reply <- newEmptyMVar
request <- toEvent $ NickTrackRequest nick reply
writeChan eventChan request
map (map canonicalNick) $ takeMVar reply

19
hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs
View File

@ -7,21 +7,20 @@ import qualified Data.Configurator as CF
import qualified System.Log.Logger as HSL
import ClassyPrelude
import Control.Concurrent.Lifted (Chan)
import Control.Exception.Lifted (evaluate)
import Control.Monad.Reader (ask)
import Data.Aeson (FromJSON, parseJSON, Value (..), (.:))
import Data.Aeson.Types (emptyArray)
import Data.Text (strip)
import Network.Curl.Aeson (curlAesonGet, CurlAesonException)
import Network.HTTP.Base (urlEncode)
import System.Log.Logger.TH (deriveLoggers)
import Control.Exception.Lifted (evaluate)
import Control.Monad.Reader (ask)
import Data.Aeson (FromJSON, parseJSON, Value (..), (.:))
import Data.Aeson.Types (emptyArray)
import Data.Text (strip)
import Network.Curl.Aeson (curlAesonGet, CurlAesonException)
import Network.HTTP.Base (urlEncode)
import System.Log.Logger.TH (deriveLoggers)
import Network.IRC.Types
$(deriveLoggers "HSL" [HSL.ERROR])
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler :: MsgHandlerMaker
mkMsgHandler _ _ "songsearch" =
return . Just $ newMsgHandler { onMessage = songSearch,
onHelp = return $ singletonMap "!m" helpMsg }

25
hask-irc-handlers/Network/IRC/Handlers/Tell.hs
View File

@ -21,6 +21,8 @@ import Network.IRC.Handlers.Tell.Types
import Network.IRC.Types
import Network.IRC.Util
-- database
getUndeliveredTellsQ :: CanonicalNick -> Query Tells [Tell]
getUndeliveredTellsQ nick = do
Tells { .. } <- ask
@ -41,6 +43,8 @@ getUndeliveredTells acid = query acid . GetUndeliveredTellsQ
saveTell :: AcidState Tells -> Tell -> IO ()
saveTell acid = update acid . SaveTellQ
-- handler
newtype TellState = TellState { acid :: AcidState Tells }
tellMsg :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> Message -> m [Command]
@ -50,10 +54,9 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
, length args >= 2 = io $ do
TellState { .. } <- readIORef state
reps <- if "<" `isPrefixOf` headEx args
then do
then do -- multi tell
let (nicks, message) =
(parseNicks *** (strip . drop 1)) . break (== '>') . drop 1 . unwords $ args
if null message
then return []
else do
@ -63,7 +66,7 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
(if null passes then [] else
["Message noted and will be passed on to " ++ intercalate ", " passes])
return reps
else do
else do -- single tell
let nick = Nick . headEx $ args
let message = strip . unwords . drop 1 $ args
if null message
@ -91,7 +94,7 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
getTellsToDeliver = io $ do
TellState { .. } <- readIORef state
mcn <- getCanonicalNick eventChan $ userNick user
mcn <- getCanonicalNick eventChan $ userNick user
case mcn of
Nothing -> return []
Just canonicalNick -> do
@ -109,21 +112,29 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
tellMsg _ _ _ = return []
tellEvent :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> SomeEvent -> m EventResponse
tellEvent eventChan state event = case fromEvent event of
Just (TellRequest user message, evTime) -> do
tellMsg eventChan state . Message evTime "" $ ChannelMsg user message
return RespNothing
_ -> return RespNothing
stopTell :: MonadMsgHandler m => IORef TellState -> m ()
stopTell state = io $ do
TellState { .. } <- readIORef state
createArchive acid
createCheckpointAndClose acid
mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
mkMsgHandler :: MsgHandlerMaker
mkMsgHandler BotConfig { .. } eventChan "tells" = do
acid <- openLocalState emptyTells
acid <- openLocalState emptyTells
state <- newIORef (TellState acid)
return . Just $ newMsgHandler { onMessage = tellMsg eventChan state
, onEvent = tellEvent eventChan state
, onStop = stopTell state
, onHelp = return helpMsgs }
where
helpMsgs = mapFromList [
("!tell", "Publically passes a message to a user or a bunch of users. " ++
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>") ]
"!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>.") ]
mkMsgHandler _ _ _ = return Nothing

19
hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs
View File

@ -1,13 +1,13 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Handlers.Tell.Types where
import ClassyPrelude
import Data.Data (Data)
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
import Data.SafeCopy (base, deriveSafeCopy)
import Control.Concurrent.Lifted (Chan, writeChan)
import Data.Data (Data)
import Data.IxSet (IxSet, Indexable (..), ixSet, ixFun)
import Data.SafeCopy (base, deriveSafeCopy)
import Network.IRC.Handlers.NickTracker.Types
import Network.IRC.Types
@ -41,3 +41,14 @@ $(deriveSafeCopy 0 'base ''Tells)
emptyTells :: Tells
emptyTells = Tells (TellId 1) empty
data TellRequest = TellRequest User Text deriving (Eq, Typeable)
instance Event TellRequest
instance Show TellRequest where
show (TellRequest user tell) =
"TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]"
sendTell :: Chan SomeEvent -> User -> Text -> IO ()
sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan

22
hask-irc-handlers/hask-irc-handlers.cabal
View File

@ -55,24 +55,24 @@ library
build-depends: base >=4.5 && <4.8,
hask-irc-core ==0.1.0,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
configurator >=0.2 && <0.3,
time >=1.4 && <1.5,
curl-aeson >=0.0.3 && <0.1,
acid-state >=0.12 && <0.13,
aeson >=0.6.0.0 && <0.7,
HTTP >=4000 && <5000,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
filepath >=1.3 && <1.4,
directory >=1.2 && <1.3,
lifted-base >=0.2 && <0.3,
configurator >=0.2 && <0.3,
convertible >=1.1 && <1.2,
curl-aeson >=0.0.3 && <0.1,
directory >=1.2 && <1.3,
filepath >=1.3 && <1.4,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
HTTP >=4000 && <5000,
ixset >=1.0 && <1.1,
acid-state >=0.12 && <0.13,
lifted-base >=0.2 && <0.3,
mtl >=2.1 && <2.2,
safecopy >=0.8 && <0.9,
text >=0.11 && <0.12,
text-format >=0.3 && <0.4,
time >=1.4 && <1.5,
uuid >=1.3 && <1.4
exposed-modules: Network.IRC.Handlers,

53
hask-irc-runner/Main.hs
View File

@ -1,8 +1,55 @@
{-# LANGUAGE OverlappingInstances #-}
module Main where
import qualified Network.IRC.Runner as Runner
import qualified Data.Configurator as CF
import Prelude
import ClassyPrelude hiding (getArgs)
import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import Network.IRC.Client
import Network.IRC.Handlers
import Network.IRC.Types
instance Configured a => Configured [a] where
convert (List xs) = Just . mapMaybe convert $ xs
convert _ = Nothing
main :: IO ()
main = Runner.run
main = do
-- get args
args <- getArgs
prog <- getProgName
when (length args < 1) $ do
putStrLn $ "Usage: " ++ pack prog ++ " <config file path>"
exitFailure
-- load config and start the bot
let configFile = headEx args
loadBotConfig configFile >>= runBot
loadBotConfig :: String -> IO BotConfig
loadBotConfig configFile = do
eCfg <- try $ CF.load [CF.Required configFile]
case eCfg of
Left (ParseError _ _) -> error "Error while loading config"
Right cfg -> do
eBotConfig <- try $ do
handlers :: [Text] <- CF.require cfg "msghandlers"
let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
BotConfig <$>
CF.require cfg "server" <*>
CF.require cfg "port" <*>
CF.require cfg "channel" <*>
(Nick <$> CF.require cfg "nick") <*>
CF.require cfg "timeout" <*>
pure handlerInfo <*>
pure allMsgHandlerMakers <*>
pure cfg
case eBotConfig of
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
Right botConf -> return botConf

71
hask-irc-runner/Network/IRC/Runner.hs
View File

@ -1,71 +0,0 @@
{-# LANGUAGE OverlappingInstances #-}
module Network.IRC.Runner (run) where
import qualified Data.Configurator as CF
import ClassyPrelude hiding (getArgs)
import Control.Concurrent.Lifted (myThreadId)
import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt))
import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.Log.Formatter (tfLogFormatter)
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple (streamHandler)
import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerName,
setHandlers, setLevel)
import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
import Network.IRC.Types
import Network.IRC.Client
instance Configured a => Configured [a] where
convert (List xs) = Just . mapMaybe convert $ xs
convert _ = Nothing
run :: IO ()
run = do
-- get args
args <- getArgs
prog <- getProgName
when (length args < 1) $ do
putStrLn $ "Usage: " ++ pack prog ++ " <config file path>"
exitFailure
-- setup signal handling
mainThreadId <- myThreadId
installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing
installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
-- setup logging
stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $
setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
-- load config and start the bot
let configFile = headEx args
loadBotConfig configFile >>= runBot
loadBotConfig :: String -> IO BotConfig
loadBotConfig configFile = do
eCfg <- try $ CF.load [CF.Required configFile]
case eCfg of
Left (ParseError _ _) -> error "Error while loading config"
Right cfg -> do
eBotConfig <- try $ do
handlers :: [Text] <- CF.require cfg "msghandlers"
let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
BotConfig <$>
CF.require cfg "server" <*>
CF.require cfg "port" <*>
CF.require cfg "channel" <*>
(Nick <$> CF.require cfg "nick") <*>
CF.require cfg "timeout" <*>
pure handlerInfo <*>
pure cfg
case eBotConfig of
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
Right botConf -> return botConf

9
hask-irc-runner/hask-irc-runner.cabal
View File

@ -63,13 +63,8 @@ executable hask-irc
build-depends: base >=4.5 && <4.8,
hask-irc-core ==0.1.0,
hask-irc-handlers ==0.1.0,
configurator >=0.2 && <0.3,
classy-prelude >=0.9 && <1.0,
network >=2.3 && <2.5,
lifted-base >=0.2 && <0.3,
unix >=2.7 && <2.8,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1
configurator >=0.2 && <0.3
-- Directories containing source files.
-- hs-source-dirs:
@ -77,5 +72,5 @@ executable hask-irc
-- Base language which the package is written in.
default-language: Haskell2010
ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans
ghc-options: -O2 -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans