Restructed and refactored

hask-irc-core/Network/IRC/Bot.hs

@@ -17,7 +17,7 @@ import qualified System.Log.Logger as HSL
 
 import ClassyPrelude
 import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay)
-import Control.Exception.Lifted  (mask_)
+import Control.Exception.Lifted  (mask_, mask)
 import Control.Monad.Reader      (ask)
 import Control.Monad.State       (get, put)
 import Data.Time                 (addUTCTime)
@@ -59,11 +59,11 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
       _       -> sendCommandLoop (commandChan, latch) bot
 
 readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
-readLineLoop = readLineLoop' []
+readLineLoop = go []
   where
     msgPartTimeout = 10
 
-    readLineLoop' !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
+    go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
       botStatus <- readMVar mvBotStatus
       case botStatus of
         Disconnected -> latchIt latch
@@ -76,31 +76,30 @@ readLineLoop = readLineLoop' []
             Right Nothing                 -> writeChan lineChan Timeout >> return msgParts
             Right (Just (Line time line)) -> do
               let (mmsg, msgParts') = parseLine botConfig time line msgParts
-              case mmsg of
+              whenJust mmsg $ writeChan lineChan . Msg
-                Nothing  -> return msgParts'
+              return msgParts'
-                Just msg -> writeChan lineChan (Msg 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
+            else mask $ \unmask -> do
-              line <- map initEx $ hGetLine socket
+              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 =

hask-irc-core/Network/IRC/Client.hs

@@ -5,19 +5,27 @@ module Network.IRC.Client (runBot) where
 import qualified System.Log.Logger as HSL
 
 import ClassyPrelude
-import Control.Concurrent.Lifted (fork, newChan, threadDelay)
+import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan)
-import Control.Exception.Lifted  (AsyncException (UserInterrupt))
+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 ()
+runBotIntenal :: BotConfig -> IO ()
-runBot botConfig' = withSocketsDo $ do
+runBotIntenal botConfig' = withSocketsDo $ do
-  hSetBuffering stdout LineBuffering
+  status <- run
-  debugM "Running with config:"
-  print botConfig
-  status <- runBot_
   case status of
-    Disconnected     -> debugM "Restarting .." >> runBot botConfig
+    Disconnected     -> debugM "Restarting .." >> runBotIntenal botConfig
-    Errored          -> debugM "Restarting .." >> runBot 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

hask-irc-core/Network/IRC/Protocol.hs

@@ -60,18 +60,18 @@ lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message ti
               | otherwise         -> ChannelMsg user message
     _         -> OtherMsg source command target message
   where
-    splits          = words line
+    splits      = words line
-    command         = splits !! 1
+    command     = splits !! 1
-    source          = drop 1 $ splits !! 0
+    source      = drop 1 $ splits !! 0
-    target          = splits !! 2
+    target      = splits !! 2
-    message         = strip . drop 1 . unwords . drop 3 $ splits
+    message     = strip . drop 1 . unwords . drop 3 $ splits
-    quitMessage     = strip . drop 1 . unwords . drop 2 $ splits
+    quitMessage = strip . drop 1 . unwords . drop 2 $ splits
-    user            = uncurry User . (Nick *** drop 1) . break (== '!') $ source
+    user        = uncurry User . (Nick *** drop 1) . break (== '!') $ source
-    mode            = splits !! 3
+    mode        = splits !! 3
-    modeArgs        = drop 4 splits
+    modeArgs    = drop 4 splits
-    kicked          = splits !! 3
+    kicked      = splits !! 3
-    kickReason      = drop 1 . unwords . drop 4 $ splits
+    kickReason  = drop 1 . unwords . drop 4 $ splits
-    isActionMsg     = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
+    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
+  NickCmd                         -> Just $ "NICK " ++ botNick'
-  UserCmd                         -> Just $ "USER " ++ nickToText botNick ++ " 0 * :" ++ nickToText 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

hask-irc-core/Network/IRC/Types.hs

@@ -27,17 +27,19 @@ module Network.IRC.Types
   , handleMessage
   , handleEvent
   , stopMsgHandler
-  , getHelp )
+  , getHelp
+  , MsgHandlerMaker )
 where
 
 import ClassyPrelude
-import Control.Monad.Base      (MonadBase)
+import Control.Concurrent.Lifted (Chan)
-import Control.Monad.Reader    (ReaderT, MonadReader, runReaderT)
+import Control.Monad.Base        (MonadBase)
-import Control.Monad.State     (StateT, MonadState, execStateT)
+import Control.Monad.Reader      (ReaderT, MonadReader, runReaderT)
-import Data.Configurator.Types (Config)
+import Control.Monad.State       (StateT, MonadState, execStateT)
-import Data.Data               (Data)
+import Data.Configurator.Types   (Config)
-import Data.SafeCopy           (base, deriveSafeCopy)
+import Data.Data                 (Data)
-import Data.Typeable           (cast)
+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
+data BotConfig = BotConfig { server           :: !Text
-                           , port           :: !Int
+                           , port             :: !Int
-                           , channel        :: !Text
+                           , channel          :: !Text
-                           , botNick        :: !Nick
+                           , botNick          :: !Nick
-                           , botTimeout     :: !Int
+                           , botTimeout       :: !Int
-                           , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
+                           , msgHandlerInfo   :: !(Map MsgHandlerName (Map Text Text))
-                           , config         :: !Config }
+                           , 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
+data BotStatus =  Connected
-               | Disconnected
+                | Disconnected
-               | Joined
+                | Joined
-               | Kicked
+                | Kicked
-               | Errored
+                | Errored
-               | Idle
+                | Idle
-               | Interrupted
+                | Interrupted
-               | NickNotAvailable
+                | NickNotAvailable
-               deriving (Show, Eq)
+                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)

hask-irc-core/Network/IRC/Util.hs

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

hask-irc-core/hask-irc-core.cabal

@@ -54,22 +54,26 @@ library
                        DeriveDataTypeable
 
   build-depends:       base                 >=4.5     && <4.8,
-                       text                 >=0.11    && <0.12,
-                       mtl                  >=2.1     && <2.2,
-                       configurator         >=0.2     && <0.3,
-                       safecopy             >=0.8     && <0.9,
-                       time                 >=1.4     && <1.5,
                        classy-prelude       >=0.9     && <1.0,
-                       text-format          >=0.3     && <0.4,
+                       configurator         >=0.2     && <0.3,
-                       lifted-base          >=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
 

hask-irc-handlers/Network/IRC/Handlers.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
+module Network.IRC.Handlers (allMsgHandlerMakers) where
-
-module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) 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]
+allMsgHandlerMakers :: [MsgHandlerMaker]
-coreMsgHandlerNames = ["pingpong", "help"]
+allMsgHandlerMakers = [
-
+    Auth.mkMsgHandler
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
+  , Core.mkMsgHandler
-mkMsgHandler botConfig eventChan name =
+  , Greet.mkMsgHandler
-  flip (`foldM` Nothing) handlerMakers $ \finalHandler handler ->
+  , Logger.mkMsgHandler
-    case finalHandler of
+  , NickTracker.mkMsgHandler
-      Just _  -> return finalHandler
+  , SongSearch.mkMsgHandler
-      Nothing -> handler botConfig eventChan name
+  , Tell.mkMsgHandler
-
+  ]
-  where
-    handlerMakers = [
-        Auth.mkMsgHandler
-      , Core.mkMsgHandler
-      , Greet.mkMsgHandler
-      , Logger.mkMsgHandler
-      , NickTracker.mkMsgHandler
-      , SongSearch.mkMsgHandler
-      , Tell.mkMsgHandler
-      ]

hask-irc-handlers/Network/IRC/Handlers/Auth.hs

@@ -7,12 +7,11 @@ import qualified Data.UUID    as U
 import qualified Data.UUID.V4 as U
 
 import ClassyPrelude
-import Control.Concurrent.Lifted (Chan)
+import Control.Monad.Reader (asks)
-import Control.Monad.Reader      (asks)
+import Control.Monad.State  (get, put)
-import Control.Monad.State       (get, put)
+import Data.Acid            (AcidState, Query, Update, makeAcidic, query, update,
-import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
+                             openLocalState, createArchive)
-                                  openLocalState, createArchive)
+import Data.Acid.Local      (createCheckpointAndClose)
-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

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

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

hask-irc-handlers/Network/IRC/Handlers/Core.hs

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

hask-irc-handlers/Network/IRC/Handlers/Greet.hs

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

hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs

@@ -2,25 +2,24 @@
 
 module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where
 
-import qualified Data.Configurator       as C
+import qualified Data.Configurator       as CF
 import qualified Data.Text.Format        as TF
 import qualified Data.Text.Format.Params as TF
 
-import ClassyPrelude hiding      ((</>), (<.>), FilePath, log)
+import ClassyPrelude hiding     ((</>), (<.>), FilePath, log)
-import Control.Concurrent.Lifted (Chan)
+import Control.Exception.Lifted (mask_)
-import Control.Exception.Lifted  (mask_)
+import Control.Monad.Reader     (ask)
-import Control.Monad.Reader      (ask)
+import Data.Time                (diffDays)
-import Data.Time                 (diffDays)
+import System.Directory         (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
-import System.Directory          (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
+import System.FilePath          (FilePath, (</>), (<.>))
-import System.FilePath           (FilePath, (</>), (<.>))
+import System.IO                (openFile, IOMode(..), hSetBuffering, BufferMode(..))
-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"
 

hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs

@@ -8,16 +8,15 @@ import qualified Data.IxSet        as IS
 import qualified Data.UUID         as U
 import qualified Data.UUID.V4      as U
 
-import ClassyPrelude hiding      (swap)
+import ClassyPrelude hiding (swap)
-import Control.Concurrent.Lifted (Chan)
+import Control.Monad.Reader (ask)
-import Control.Monad.Reader      (ask)
+import Control.Monad.State  (get, put)
-import Control.Monad.State       (get, put)
+import Data.Acid            (AcidState, Query, Update, makeAcidic, query, update,
-import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
+                             openLocalState, createArchive)
-                                  openLocalState, createArchive)
+import Data.Acid.Local      (createCheckpointAndClose)
-import Data.Acid.Local           (createCheckpointAndClose)
+import Data.Convertible     (convert)
-import Data.Convertible          (convert)
+import Data.IxSet           (getOne, (@=))
-import Data.IxSet                (getOne, (@=))
+import Data.Time            (addUTCTime, NominalDiffTime)
-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

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

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

hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs

@@ -7,21 +7,20 @@ import qualified Data.Configurator as CF
 import qualified System.Log.Logger as HSL
 
 import ClassyPrelude
-import Control.Concurrent.Lifted (Chan)
+import Control.Exception.Lifted (evaluate)
-import Control.Exception.Lifted  (evaluate)
+import Control.Monad.Reader     (ask)
-import Control.Monad.Reader      (ask)
+import Data.Aeson               (FromJSON, parseJSON, Value (..), (.:))
-import Data.Aeson                (FromJSON, parseJSON, Value (..), (.:))
+import Data.Aeson.Types         (emptyArray)
-import Data.Aeson.Types          (emptyArray)
+import Data.Text                (strip)
-import Data.Text                 (strip)
+import Network.Curl.Aeson       (curlAesonGet, CurlAesonException)
-import Network.Curl.Aeson        (curlAesonGet, CurlAesonException)
+import Network.HTTP.Base        (urlEncode)
-import Network.HTTP.Base         (urlEncode)
+import System.Log.Logger.TH     (deriveLoggers)
-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 }

hask-irc-handlers/Network/IRC/Handlers/Tell.hs

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

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

@@ -1,13 +1,13 @@
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Network.IRC.Handlers.Tell.Types where
 
 import ClassyPrelude
-import Data.Data      (Data)
+import Control.Concurrent.Lifted (Chan, writeChan)
-import Data.IxSet     (IxSet, Indexable (..), ixSet, ixFun)
+import Data.Data                 (Data)
-import Data.SafeCopy  (base, deriveSafeCopy)
+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

hask-irc-handlers/hask-irc-handlers.cabal

@@ -55,24 +55,24 @@ library
 
   build-depends:       base                 >=4.5     && <4.8,
                        hask-irc-core        ==0.1.0,
-                       text                 >=0.11    && <0.12,
+                       acid-state           >=0.12    && <0.13,
-                       mtl                  >=2.1     && <2.2,
-                       configurator         >=0.2     && <0.3,
-                       time                 >=1.4     && <1.5,
-                       curl-aeson           >=0.0.3   && <0.1,
                        aeson                >=0.6.0.0 && <0.7,
-                       HTTP                 >=4000    && <5000,
                        classy-prelude       >=0.9     && <1.0,
-                       text-format          >=0.3     && <0.4,
+                       configurator         >=0.2     && <0.3,
-                       filepath             >=1.3     && <1.4,
-                       directory            >=1.2     && <1.3,
-                       lifted-base          >=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,

hask-irc-runner/Main.hs

@@ -1,8 +1,55 @@
+{-# LANGUAGE OverlappingInstances #-}
+
 module Main where
 
-import qualified Network.IRC.Runner as Runner
+import qualified Data.Configurator as CF
 
-import Prelude
+import ClassyPrelude hiding    (getArgs)
+import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
+import System.Environment      (getArgs, getProgName)
+import System.Exit             (exitFailure)
+
+import Network.IRC.Client
+import Network.IRC.Handlers
+import Network.IRC.Types
+
+instance Configured a => Configured [a] where
+  convert (List xs) = Just . mapMaybe convert $ xs
+  convert _ = Nothing
 
 main :: IO ()
-main = Runner.run
+main = do
+  -- get args
+  args <- getArgs
+  prog <- getProgName
+
+  when (length args < 1) $ do
+    putStrLn $ "Usage: " ++ pack prog ++ " <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

hask-irc-runner/Network/IRC/Runner.hs

@@ -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

hask-irc-runner/hask-irc-runner.cabal

@@ -63,13 +63,8 @@ executable hask-irc
   build-depends:       base                 >=4.5     && <4.8,
                        hask-irc-core        ==0.1.0,
                        hask-irc-handlers    ==0.1.0,
-                       configurator         >=0.2     && <0.3,
                        classy-prelude       >=0.9     && <1.0,
-                       network              >=2.3     && <2.5,
+                       configurator         >=0.2     && <0.3
-                       lifted-base          >=0.2     && <0.3,
-                       unix                 >=2.7     && <2.8,
-                       hslogger             >=1.2     && <1.3,
-                       hslogger-template    >=2.0     && <2.1
 
   -- 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