Added tell command handler

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

@@ -143,8 +143,8 @@ messageProcessLoop = messageProcessLoop' 0
           forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
             handle (\(e :: SomeException) ->
                       errorM $ "Exception while processing message: " ++ show e) $ do
-              mCmd <- handleMessage msgHandler botConfig message
-              whenJust mCmd (sendCommand commandChan)
+              cmds <- handleMessage msgHandler botConfig message
+              forM_ cmds (sendCommand commandChan)
 
 eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
 eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do

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

@@ -172,7 +172,7 @@ class (MonadIO m, Applicative m, MonadReader BotConfig m, MonadBase IO m) => Mon
 instance MonadMsgHandler MsgHandlerT where
   msgHandler = id
 
-handleMessage :: MsgHandler -> BotConfig -> Message -> IO (Maybe Command)
+handleMessage :: MsgHandler -> BotConfig -> Message -> IO [Command]
 handleMessage MsgHandler { .. } botConfig =
   flip runReaderT botConfig . _runMsgHandler . onMessage
 
@@ -189,7 +189,7 @@ getHelp MsgHandler { .. } botConfig =
   flip runReaderT botConfig . _runMsgHandler $ onHelp
 
 data MsgHandler = MsgHandler {
-  onMessage :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)),
+  onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Command]),
   onStop    :: !(forall m . MonadMsgHandler m => m ()),
   onEvent   :: !(forall m . MonadMsgHandler m => SomeEvent -> m EventResponse),
   onHelp    :: !(forall m . MonadMsgHandler m => m (Map Text Text))
@@ -197,7 +197,7 @@ data MsgHandler = MsgHandler {
 
 newMsgHandler :: MsgHandler
 newMsgHandler = MsgHandler {
-  onMessage = const $ return Nothing,
+  onMessage = const $ return [],
   onStop    = return (),
   onEvent   = const $ return RespNothing,
   onHelp    = return mempty

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

@@ -57,10 +57,9 @@ relativeTime t1 t2 =
     format range =
       (if period > 0 then "in " else "")
       ++ case range of
-          (0, _, _)      -> "moments"
           (_, str, 0)    -> pack str
           (_, str, base) -> TF.format (fromString str) $ TF.Only (abs $ round (period / base) :: Integer)
-      ++ (if period < 0 then " ago" else "")
+      ++ (if period <= 0 then " ago" else "")
 
     period = t1 `diffUTCTime` t2
 

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

@@ -8,6 +8,7 @@ import qualified Network.IRC.Handlers.Greet         as Greet
 import qualified Network.IRC.Handlers.MessageLogger as Logger
 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)
@@ -32,4 +33,5 @@ mkMsgHandler botConfig eventChan name =
       , Logger.mkMsgHandler
       , NickTracker.mkMsgHandler
       , SongSearch.mkMsgHandler
+      , Tell.mkMsgHandler
       ]

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

@@ -43,11 +43,11 @@ issueToken acid user = do
 
 -- handler
 
-authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message ->  m (Maybe Command)
+authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message ->  m [Command]
 authMessage state Message { msgDetails = PrivMsg { .. }, .. }
-  | "token" `isPrefixOf` msg = map (Just . PrivMsgReply user) . io $
+  | "token" `isPrefixOf` msg = map (singleton . PrivMsgReply user) . io $
       readIORef state >>= flip issueToken (userNick user)
-authMessage _ _ = return Nothing
+authMessage _ _ = return []
 
 stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
 stopAuth state = io $ do

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

@@ -20,13 +20,13 @@ mkMsgHandler _ _ "help"     =
     helpMsg = "Get help. !help or !help <command>"
 mkMsgHandler _ _ _          = return Nothing
 
-pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
+pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
 pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
   io $ atomicWriteIORef state msgTime
-  return . Just $ PongCmd msg
+  return [PongCmd msg]
 pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
   io $ atomicWriteIORef state msgTime
-  return Nothing
+  return []
 pingPong state Message { msgDetails = IdleMsg { .. }, .. }
   | even (convert msgTime :: Int) = do
     BotConfig { .. } <- ask
@@ -34,21 +34,21 @@ pingPong state Message { msgDetails = IdleMsg { .. }, .. }
     io $ do
       lastComm <- readIORef state
       if addUTCTime limit lastComm < msgTime
-        then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
-        else return Nothing
+        then return [PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime]
+        else return []
 
-pingPong _ _ = return Nothing
+pingPong _ _ = return []
 
-help :: MonadMsgHandler m => Message -> m (Maybe Command)
+help :: MonadMsgHandler m => Message -> m [Command]
 help Message { msgDetails = ChannelMsg { .. }, .. }
   | "!help" == clean msg = do
       BotConfig { .. } <- ask
       let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
-      return . Just . ChannelMsgReply $ "I know these commands: " ++ unwords commands
+      return [ChannelMsgReply $ "I know these commands: " ++ unwords commands]
   | "!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
-      return . Just . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp
+      return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
 
-help _ = return Nothing
+help _ = return []

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

@@ -12,22 +12,22 @@ mkMsgHandler _ _ "greeter"  = return . Just $ newMsgHandler { onMessage = greete
 mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
 mkMsgHandler _ _ _          = return Nothing
 
-greeter ::  MonadMsgHandler m => Message -> m (Maybe Command)
+greeter ::  MonadMsgHandler m => Message -> m [Command]
 greeter Message { msgDetails = ChannelMsg { .. }, .. } =
-  return . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
+  return . maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
     . find (== clean msg) $ greetings
   where
     greetings = [ "hi", "hello", "hey", "sup", "bye"
                 , "good morning", "good evening", "good night" ]
-greeter _ = return Nothing
+greeter _ = return []
 
-welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
+welcomer :: MonadMsgHandler m => Message -> m [Command]
 welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
   BotConfig { .. } <- ask
   if userNick user /= botNick
-    then return . Just . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
-    else return Nothing
+    then return [ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)]
+    else return []
 
-welcomer _ = return Nothing
+welcomer _ = return []
 
 

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

@@ -50,7 +50,7 @@ initMessageLogger botConfig state = do
 exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
 exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
 
-withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
+withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Command]
 withLogFile action state = do
   botConfig <- ask
   io $ do
@@ -70,9 +70,9 @@ withLogFile action state = do
     action logFileHandle'
     atomicWriteIORef state $ Just (logFileHandle', curDay)
 
-  return Nothing
+  return []
 
-messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
+messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Command]
 messageLogger Message { .. } = case msgDetails of
   ChannelMsg { .. } -> log "<{}> {}"                  [nick user, msg]
   ActionMsg { .. }  -> log "<{}> {} {}"               [nick user, nick user, msg]
@@ -82,7 +82,7 @@ messageLogger Message { .. } = case msgDetails of
   QuitMsg { .. }    -> log "** {} QUIT :{}"           [nick user, msg]
   NickMsg { .. }    -> log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
   NamesMsg { .. }   -> log "** USERS {}"              [unwords . map nickToText $ nicks]
-  _                 -> const $ return Nothing
+  _                 -> const $ return []
   where
     nick = nickToText . userNick
 

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

@@ -55,24 +55,24 @@ data NickTrackingState = NickTrackingState { acid            :: AcidState NickTr
                                            , onlineNicks     :: HashSet Nick
                                            , lastRefreshOn   :: UTCTime }
 
-nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message ->  m (Maybe Command)
+nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message ->  m [Command]
 nickTrackerMsg state message@Message { .. } = case msgDetails of
   ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands
-  ActionMsg { .. }  -> updateNickTrack state user msg msgTime >> return Nothing
-  JoinMsg { .. }    -> updateNickTrack state user "" msgTime  >> add user    >> return Nothing
-  PartMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
-  QuitMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
+  ActionMsg { .. }  -> updateNickTrack state user msg msgTime >> return []
+  JoinMsg { .. }    -> updateNickTrack state user "" msgTime  >> add user    >> return []
+  PartMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return []
+  QuitMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return []
   NickMsg { .. }    ->
-    handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return Nothing
+    handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return []
   NamesMsg { .. }   -> do
     forM_ nicks $ \n -> updateNickTrack state (User n "") "" msgTime
-    refresh nicks >> updateRefreshTime >> return Nothing
+    refresh nicks >> updateRefreshTime >> return []
   IdleMsg { .. }    -> do
     NickTrackingState { .. } <- readIORef state
     if addUTCTime refreshInterval lastRefreshOn < msgTime
-      then updateRefreshTime >> return (Just NamesCmd)
-      else return Nothing
-  _                 -> return Nothing
+      then updateRefreshTime >> return [NamesCmd]
+      else return []
+  _                 -> return []
   where
     updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
 
@@ -89,7 +89,7 @@ nickTrackerMsg state message@Message { .. } = case msgDetails of
                , ("!forgetnicks", handleForgetNicksCommand)]
 
     handleCommands = case find ((`isPrefixOf` msg msgDetails) . fst) commands of
-      Nothing           -> return Nothing
+      Nothing           -> return []
       Just (_, handler) -> handler state message
 
 updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
@@ -127,26 +127,26 @@ newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
 
 withNickTracks :: MonadMsgHandler m
                => (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Message
-               -> m (Maybe Command)
+               -> m [Command]
 withNickTracks f state message = io $ do
   NickTrackingState { .. } <- readIORef state
   let nick = clean . unwords . drop 1 . words . msg . msgDetails $ message
   if nick == ""
-    then return Nothing
+    then return []
     else do
       mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
-      map (Just . ChannelMsgReply) $ case mcn of
+      map (singleton . ChannelMsgReply) $ case mcn of
         Nothing -> return $ "Unknown nick: " ++ nick
         Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
 
-handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
+handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
 handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
   let nicks = map ((\(Nick n) -> n) . nick) nickTracks
   if length nicks == 1
     then return $ nck ++ " has only one nick"
     else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
 
-handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
+handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
 handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
   let NickTrack { lastSeenOn = LastSeenOn lastSeenOn'
                 , nick       = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
@@ -164,7 +164,7 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
       (if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
       " said: " ++ lastMessage')
 
-handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
+handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
 handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } = do
   NickTrackingState { .. } <- readIORef state
   let nick = userNick user
@@ -172,7 +172,14 @@ handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } =
     Just nt <- getByNick acid nick
     cn      <- newCanonicalNick
     saveNickTrack acid $ nt { canonicalNick = cn }
-  return . Just . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick
+  return [ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick]
+
+nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> SomeEvent -> m EventResponse
+nickTrackerEvent state event = case fromEvent event of
+  Just (NickTrackRequest nick reply, _) -> io $ do
+    NickTrackingState { .. } <- readIORef state
+    getByNick acid nick >>= putMVar reply >> return RespNothing
+  _ -> return RespNothing
 
 stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
 stopNickTracker state = io $ do
@@ -188,11 +195,12 @@ mkMsgHandler BotConfig { .. } _ "nicktracker" = do
     acid            <- openLocalState emptyNickTracking
     newIORef (NickTrackingState acid refreshInterval mempty now)
   return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
+                                , onEvent   = nickTrackerEvent state
                                 , onStop    = stopNickTracker state
                                 , onHelp    = return helpMsgs }
   where
     helpMsgs = mapFromList [
-      ("!nicks", "Shows alternate nicks of the user. !nicks <user nick>"),
+      ("!nicks", "Shows alternate nicks of the user. !nicks <nick>"),
       ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
       ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
 mkMsgHandler _ _ _                            = return Nothing

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

@@ -3,9 +3,10 @@
 module Network.IRC.Handlers.NickTracker.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.Types
 
@@ -35,3 +36,17 @@ $(deriveSafeCopy 0 'base ''NickTracking)
 
 emptyNickTracking :: NickTracking
 emptyNickTracking = NickTracking empty
+
+data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Typeable)
+
+instance Event NickTrackRequest
+
+instance Show NickTrackRequest where
+  show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]"
+
+getCanonicalNick :: Chan SomeEvent -> Nick -> IO (Maybe CanonicalNick)
+getCanonicalNick eventChan nick = do
+  reply <- newEmptyMVar
+  request <- toEvent $ NickTrackRequest nick reply
+  writeChan eventChan request
+  map (map canonicalNick) $ takeMVar reply

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

@@ -37,14 +37,14 @@ instance FromJSON Song where
     parseJSON a | a == emptyArray = return NoSong
     parseJSON _                   = mempty
 
-songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
+songSearch :: MonadMsgHandler m => Message -> m [Command]
 songSearch Message { msgDetails = 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
+        map (singleton . ChannelMsgReply) $ case mApiKey of
           Nothing     -> do
             errorM "tinysong api key not found in config"
             return $ "Error while searching for " ++ query
@@ -58,5 +58,5 @@ songSearch Message { msgDetails = ChannelMsg { .. }, .. }
               Right song                     -> case song of
                 Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
                 NoSong      -> "No song found for: " ++ query
-  | otherwise              = return Nothing
-songSearch _ = return Nothing
+  | otherwise              = return []
+songSearch _ = return []

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

@@ -0,0 +1,129 @@
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Network.IRC.Handlers.Tell (mkMsgHandler) where
+
+import qualified Data.IxSet as IS
+
+import ClassyPrelude hiding      (swap)
+import Control.Concurrent.Lifted (Chan)
+import Control.Monad.Reader      (ask)
+import Control.Monad.State       (get, put)
+import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
+                                  openLocalState, createArchive)
+import Data.Acid.Local           (createCheckpointAndClose)
+import Data.IxSet                ((@=))
+import Data.Text                 (split, strip)
+
+import Network.IRC.Handlers.NickTracker.Types
+import Network.IRC.Handlers.Tell.Types
+import Network.IRC.Types
+import Network.IRC.Util
+
+getUndeliveredTellsQ :: CanonicalNick -> Query Tells [Tell]
+getUndeliveredTellsQ nick = do
+  Tells { .. } <- ask
+  return . sortBy (comparing tellCreatedOn) . IS.toList $ tells @= nick @= NewTell
+
+saveTellQ :: Tell -> Update Tells ()
+saveTellQ tell@Tell { .. } = do
+  Tells { .. } <- get
+  if tellId == -1
+    then put $ Tells (nextTellId + 1) (IS.updateIx nextTellId tell{ tellId = nextTellId } tells)
+    else put $ Tells nextTellId (IS.updateIx tellId tell tells)
+
+$(makeAcidic ''Tells ['getUndeliveredTellsQ, 'saveTellQ])
+
+getUndeliveredTells :: AcidState Tells -> CanonicalNick -> IO [Tell]
+getUndeliveredTells acid = query acid . GetUndeliveredTellsQ
+
+saveTell :: AcidState Tells -> Tell -> IO ()
+saveTell acid = update acid . SaveTellQ
+
+newtype TellState = TellState { acid :: AcidState Tells }
+
+tellMsg :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> Message ->  m [Command]
+tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
+  | command == "!tell"
+  , args <- drop 1 . words $ msg
+  , length args >= 2             = io $ do
+      TellState { .. } <- readIORef state
+      reps <- if "<" `isPrefixOf` headEx args
+        then do
+          let (nicks, message) =
+                (parseNicks *** (strip . drop 1)) . break (== '>') . drop 1 . unwords $ args
+
+          if null message
+            then return []
+            else do
+              res <- forM nicks $ \nick -> handleTell acid nick message
+              let (fails, passes) = partitionEithers res
+              let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++
+                           (if null passes then [] else
+                              ["Message noted and will be passed on to " ++ intercalate ", " passes])
+              return reps
+        else do
+          let nick = Nick . headEx $ args
+          let message = strip . unwords . drop 1 $ args
+          if null message
+            then return []
+            else do
+              res <- handleTell acid nick message
+              let rep = case res of
+                          Left _  -> "Unknown nick: " ++ nickToText nick
+                          Right _ -> "Message noted and will be passed on to " ++ nickToText nick
+              return [rep]
+      tells <- getTellsToDeliver
+      return . map textToReply $ (reps ++ tells)
+  | otherwise                    = io $ map (map textToReply) getTellsToDeliver
+  where
+    command = clean . fromMaybe "" $ headMay . words $ msg
+
+    parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',')
+
+    textToReply t = ChannelMsgReply $ nickToText (userNick user) ++ ": " ++ t
+
+    tellToMsg Tell { .. } =
+      relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent
+
+    newTell canonicalNick = Tell (-1) (userNick user) canonicalNick Nothing NewTell msgTime Nothing
+
+    getTellsToDeliver = io $ do
+      TellState { .. } <- readIORef state
+      mcn <- getCanonicalNick eventChan $ userNick user
+      case mcn of
+        Nothing            -> return []
+        Just canonicalNick -> do
+          tells <- getUndeliveredTells acid canonicalNick
+          forM tells $ \tell -> do
+            saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime }
+            return . tellToMsg $ tell
+
+    handleTell acid nick message = do
+      mcn <- getCanonicalNick eventChan nick
+      case mcn of
+        Nothing            -> return . Left . nickToText $ nick
+        Just canonicalNick ->
+          saveTell acid (newTell canonicalNick message) >> (return . Right . nickToText $ nick)
+
+tellMsg _ _ _ = return []
+
+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 BotConfig { .. } eventChan "tells" = do
+  acid <- openLocalState emptyTells
+  state <- newIORef (TellState acid)
+  return . Just $ newMsgHandler { onMessage = tellMsg 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>") ]
+mkMsgHandler _ _ _                            = return Nothing

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

@@ -0,0 +1,43 @@
+{-# 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 Network.IRC.Handlers.NickTracker.Types
+import Network.IRC.Types
+
+newtype TellId  = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num)
+data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable)
+
+data Tell = Tell {
+  tellId          :: !TellId,
+  tellFromNick    :: !Nick,
+  tellToNick      :: !CanonicalNick,
+  tellTopic       :: !(Maybe Text),
+  tellStatus      :: !TellStatus,
+  tellCreatedOn   :: !UTCTime,
+  tellDeliveredOn :: !(Maybe UTCTime),
+  tellContent     :: !Text
+} deriving (Eq, Ord, Show, Data, Typeable)
+
+instance Indexable Tell where
+  empty = ixSet [ ixFun $ (: []) . tellId
+                , ixFun $ (: []) . tellToNick
+                , ixFun $ (: []) . tellStatus ]
+
+data Tells = Tells { nextTellId :: TellId, tells :: IxSet Tell }
+             deriving (Eq, Ord, Show, Data, Typeable)
+
+$(deriveSafeCopy 0 'base ''TellId)
+$(deriveSafeCopy 0 'base ''TellStatus)
+$(deriveSafeCopy 0 'base ''Tell)
+$(deriveSafeCopy 0 'base ''Tells)
+
+emptyTells :: Tells
+emptyTells = Tells (TellId 1) empty

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

@@ -83,7 +83,9 @@ library
                        Network.IRC.Handlers.MessageLogger,
                        Network.IRC.Handlers.NickTracker,
                        Network.IRC.Handlers.NickTracker.Types,
-                       Network.IRC.Handlers.SongSearch
+                       Network.IRC.Handlers.SongSearch,
+                       Network.IRC.Handlers.Tell,
+                       Network.IRC.Handlers.Tell.Types
 
   default-language:    Haskell2010