141 lines
5.6 KiB
Haskell
141 lines
5.6 KiB
Haskell
{-# 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
|
|
|
|
-- database
|
|
|
|
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
|
|
|
|
-- handler
|
|
|
|
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 -- multi tell
|
|
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 -- single tell
|
|
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 []
|
|
|
|
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 :: MsgHandlerMaker
|
|
mkMsgHandler BotConfig { .. } eventChan "tells" = do
|
|
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>.") ]
|
|
mkMsgHandler _ _ _ = return Nothing
|