diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index a62d887..ae9a47b 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index 5e02e76..148cbb2 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Util.hs b/hask-irc-core/Network/IRC/Util.hs index b402f4d..603d7d5 100644 --- a/hask-irc-core/Network/IRC/Util.hs +++ b/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 diff --git a/hask-irc-handlers/Network/IRC/Handlers.hs b/hask-irc-handlers/Network/IRC/Handlers.hs index 53a5979..f3de03a 100644 --- a/hask-irc-handlers/Network/IRC/Handlers.hs +++ b/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 ] diff --git a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs b/hask-irc-handlers/Network/IRC/Handlers/Auth.hs index f12cbc7..e9772c5 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Auth.hs +++ b/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 diff --git a/hask-irc-handlers/Network/IRC/Handlers/Core.hs b/hask-irc-handlers/Network/IRC/Handlers/Core.hs index be067f7..8038c4e 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Core.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/Core.hs @@ -20,13 +20,13 @@ mkMsgHandler _ _ "help" = helpMsg = "Get help. !help or !help " 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 [] diff --git a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs b/hask-irc-handlers/Network/IRC/Handlers/Greet.hs index 2ca7f68..7b354d2 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/Greet.hs +++ b/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 [] diff --git a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs index 3a45d58..c8a8077 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs +++ b/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 diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs index f2ec879..79b6bb8 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs +++ b/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 "), + ("!nicks", "Shows alternate nicks of the user. !nicks "), ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen "), ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ] mkMsgHandler _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs index 2529d4a..827fac1 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs +++ b/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 diff --git a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs b/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs index 79bad77..2850698 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs +++ b/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 [] diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell.hs new file mode 100644 index 0000000..3c9e4e5 --- /dev/null +++ b/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 or !tell < ...> ") ] +mkMsgHandler _ _ _ = return Nothing diff --git a/hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs b/hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs new file mode 100644 index 0000000..da8888a --- /dev/null +++ b/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 diff --git a/hask-irc-handlers/hask-irc-handlers.cabal b/hask-irc-handlers/hask-irc-handlers.cabal index 681fe76..cc8543f 100644 --- a/hask-irc-handlers/hask-irc-handlers.cabal +++ b/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