A simple IRC bot written in Haskell
Nevar pievienot vairāk kā 25 tēmas Tēmai ir jāsākas ar burtu vai ciparu, tā var saturēt domu zīmes ('-') un var būt līdz 35 simboliem gara.

NickTracker.hs 9.6KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202
  1. {-# LANGUAGE TemplateHaskell #-}
  2. {-# LANGUAGE TypeFamilies #-}
  3. module Network.IRC.Handlers.NickTracker (nickTrackerMsgHandlerMaker) where
  4. import qualified Data.IxSet as IS
  5. import qualified Data.UUID as U
  6. import qualified Data.UUID.V4 as U
  7. import ClassyPrelude hiding (swap)
  8. import Control.Monad.State.Strict (get, put)
  9. import Data.Acid (AcidState, Query, Update, makeAcidic, query, update,
  10. openLocalState, createArchive)
  11. import Data.Acid.Local (createCheckpointAndClose)
  12. import Data.Convertible (convert)
  13. import Data.IxSet (getOne, (@=))
  14. import Data.Time (addUTCTime, NominalDiffTime)
  15. import qualified Network.IRC.Configuration as CF
  16. import Network.IRC
  17. import Network.IRC.Handlers.NickTracker.Internal.Types
  18. import Network.IRC.Util
  19. -- database
  20. getByNickQ :: Nick -> Query NickTracking (Maybe NickTrack)
  21. getByNickQ nick = do
  22. NickTracking { .. } <- ask
  23. return . getOne $ nickTracking @= nick
  24. getByCanonicalNickQ :: CanonicalNick -> Query NickTracking [NickTrack]
  25. getByCanonicalNickQ canonicalNick = do
  26. NickTracking { .. } <- ask
  27. return . IS.toList $ nickTracking @= canonicalNick
  28. saveNickTrackQ :: NickTrack -> Update NickTracking ()
  29. saveNickTrackQ nt = do
  30. NickTracking { .. } <- get
  31. put . NickTracking $ IS.updateIx (nick nt) nt nickTracking
  32. $(makeAcidic ''NickTracking ['getByNickQ, 'getByCanonicalNickQ, 'saveNickTrackQ])
  33. getByNick :: AcidState NickTracking -> Nick -> IO (Maybe NickTrack)
  34. getByNick acid = query acid . GetByNickQ
  35. saveNickTrack :: AcidState NickTracking -> NickTrack -> IO ()
  36. saveNickTrack acid = update acid . SaveNickTrackQ
  37. -- handler
  38. data NickTrackingState = NickTrackingState { acid :: AcidState NickTracking
  39. , refreshInterval :: NominalDiffTime
  40. , onlineNicks :: HashSet Nick
  41. , lastRefreshOn :: UTCTime }
  42. nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Message]
  43. nickTrackerMsg state Message { .. }
  44. | Just (ChannelMsg (User { .. }) msg) <- fromMessage message =
  45. updateNickTrack state userNick msg msgTime >> handleCommands userNick msg
  46. | Just (ActionMsg (User { .. }) msg) <- fromMessage message =
  47. updateNickTrack state userNick msg msgTime >> return []
  48. | Just (JoinMsg (User { .. })) <- fromMessage message =
  49. updateNickTrack state userNick "" msgTime >> add userNick >> return []
  50. | Just (PartMsg (User { .. }) msg) <- fromMessage message =
  51. updateNickTrack state userNick msg msgTime >> remove userNick >> return []
  52. | Just (QuitMsg (User { .. }) msg) <- fromMessage message =
  53. updateNickTrack state userNick msg msgTime >> remove userNick >> return []
  54. | Just (NickMsg (User { .. }) newNick) <- fromMessage message =
  55. handleNickChange state userNick newNick msgTime >> swap (userNick, newNick) >> return []
  56. | Just (NamesMsg nicks) <- fromMessage message = do
  57. forM_ nicks $ \n -> updateNickTrack state n "" msgTime
  58. refresh nicks >> updateRefreshTime >> return []
  59. | Just IdleMsg <- fromMessage message = do
  60. NickTrackingState { .. } <- readIORef state
  61. if addUTCTime refreshInterval lastRefreshOn < msgTime
  62. then updateRefreshTime >> map singleton (newMessage NamesCmd)
  63. else return []
  64. | Just (NickTrackRequest nick reply) <- fromMessage message = io $ do
  65. NickTrackingState { .. } <- readIORef state
  66. getByNick acid nick >>= putMVar reply >> return []
  67. | otherwise = return []
  68. where
  69. updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
  70. modifyOnlineNicks f = atomicModIORef state $ \s -> s { onlineNicks = f . onlineNicks $ s }
  71. add = modifyOnlineNicks . insertSet
  72. remove = modifyOnlineNicks . deleteSet
  73. swap (oNick, nNick) = modifyOnlineNicks $ deleteSet oNick . insertSet nNick
  74. refresh = modifyOnlineNicks . const . setFromList
  75. commands = [ ("!nicks", handleNickCommand)
  76. , ("!seen", handleSeenCommand)
  77. , ("!forgetnicks", handleForgetNicksCommand)]
  78. handleCommands nick msg = case find ((`isPrefixOf` msg) . fst) commands of
  79. Nothing -> return []
  80. Just (_, handler) -> handler state nick msg
  81. updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> UTCTime -> m ()
  82. updateNickTrack state nck message msgTime = io $ do
  83. NickTrackingState { .. } <- readIORef state
  84. mnt <- getByNick acid nck
  85. (message', lastMessageOn', cn) <- case (message, mnt) of
  86. ("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
  87. (_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
  88. _ -> newCanonicalNick >>= \cn -> return (message, msgTime, cn)
  89. saveNickTrack acid $ NickTrack nck cn msgTime lastMessageOn' message'
  90. handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Nick -> UTCTime -> m ()
  91. handleNickChange state prevNick newNick msgTime = io $ do
  92. NickTrackingState { .. } <- readIORef state
  93. mpnt <- getByNick acid prevNick
  94. mnt <- getByNick acid newNick
  95. mInfo <- case (mpnt, mnt) of
  96. (Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
  97. (Just pnt, Nothing) ->
  98. return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
  99. (Just pnt, Just nt) | canonicalNick pnt == canonicalNick nt -> do
  100. let nt' = maximumByEx (comparing lastMessageOn) [pnt, nt]
  101. return $ Just (lastMessage nt', canonicalNick nt', lastMessageOn nt')
  102. _ -> return Nothing
  103. whenJust mInfo $ \(message, cn, lastMessageOn') ->
  104. saveNickTrack acid $ NickTrack newNick cn msgTime lastMessageOn' message
  105. newCanonicalNick :: IO CanonicalNick
  106. newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
  107. withNickTracks :: MonadMsgHandler m
  108. => (Text -> [NickTrack] -> HashSet Nick -> IO Text)
  109. -> IORef NickTrackingState -> Nick -> Text
  110. -> m [Message]
  111. withNickTracks f state _ msg = io $ do
  112. NickTrackingState { .. } <- readIORef state
  113. let nick = clean . unwords . drop 1 . words $ msg
  114. if nick == ""
  115. then return []
  116. else do
  117. mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
  118. reply <- case mcn of
  119. Nothing -> return $ "Unknown nick: " ++ nick
  120. Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
  121. map singleton . newMessage . ChannelMsgReply $ reply
  122. handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
  123. handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
  124. let nicks = map ((\(Nick n) -> n) . nick) nickTracks
  125. return . (nck ++) $ if length nicks == 1
  126. then " has only one nick"
  127. else "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
  128. handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
  129. handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
  130. let NickTrack { lastSeenOn = lastSeenOn'
  131. , nick = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
  132. let NickTrack { lastMessageOn = lastMessageOn'
  133. , lastMessage = lastMessage'
  134. , nick = Nick lastMessageAs } = maximumByEx (comparing lastMessageOn) nickTracks
  135. now <- io getCurrentTime
  136. return . (nck ++) $
  137. (if any (`member` onlineNicks) . map nick $ nickTracks
  138. then " is online now"
  139. else " was last seen " ++ relativeTime lastSeenOn' now) ++
  140. (if nck /= lastSeenAs then " as " ++ lastSeenAs else "") ++
  141. (if clean lastMessage' == "" then "" else
  142. " and " ++ relativeTime lastMessageOn' now ++ " " ++ nck ++
  143. (if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
  144. " said: " ++ lastMessage')
  145. handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
  146. handleForgetNicksCommand state nick _ = do
  147. NickTrackingState { .. } <- readIORef state
  148. io $ do
  149. Just nt <- getByNick acid nick
  150. cn <- newCanonicalNick
  151. saveNickTrack acid $ nt { canonicalNick = cn }
  152. map singleton . newMessage . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick
  153. stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
  154. stopNickTracker state = io $ do
  155. NickTrackingState { .. } <- readIORef state
  156. createArchive acid
  157. createCheckpointAndClose acid
  158. nickTrackerMsgHandlerMaker :: MsgHandlerMaker
  159. nickTrackerMsgHandlerMaker = MsgHandlerMaker "nicktracker" go
  160. where
  161. helpMsgs = mapFromList [
  162. ("!nicks", "Shows alternate nicks of the user. !nicks <nick>"),
  163. ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
  164. ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
  165. go BotConfig { .. } _ = do
  166. state <- io $ do
  167. now <- getCurrentTime
  168. let refreshInterval = convert (CF.lookupDefault "nicktracker.refresh_interval" config 60 :: Int)
  169. acid <- openLocalState emptyNickTracking
  170. newIORef (NickTrackingState acid refreshInterval mempty now)
  171. return $ newMsgHandler { onMessage = nickTrackerMsg state
  172. , onStop = stopNickTracker state
  173. , handlerHelp = return helpMsgs }