Browse Source

Added tell command handler

Abhinav Sarkar 8 years ago
parent
commit
651244834e

+ 2
- 2
hask-irc-core/Network/IRC/Bot.hs View File

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

+ 3
- 3
hask-irc-core/Network/IRC/Types.hs View File

@@ -172,7 +172,7 @@ class (MonadIO m, Applicative m, MonadReader BotConfig m, MonadBase IO m) => Mon
172 172
 instance MonadMsgHandler MsgHandlerT where
173 173
   msgHandler = id
174 174
 
175
-handleMessage :: MsgHandler -> BotConfig -> Message -> IO (Maybe Command)
175
+handleMessage :: MsgHandler -> BotConfig -> Message -> IO [Command]
176 176
 handleMessage MsgHandler { .. } botConfig =
177 177
   flip runReaderT botConfig . _runMsgHandler . onMessage
178 178
 
@@ -189,7 +189,7 @@ getHelp MsgHandler { .. } botConfig =
189 189
   flip runReaderT botConfig . _runMsgHandler $ onHelp
190 190
 
191 191
 data MsgHandler = MsgHandler {
192
-  onMessage :: !(forall m . MonadMsgHandler m => Message -> m (Maybe Command)),
192
+  onMessage :: !(forall m . MonadMsgHandler m => Message -> m [Command]),
193 193
   onStop    :: !(forall m . MonadMsgHandler m => m ()),
194 194
   onEvent   :: !(forall m . MonadMsgHandler m => SomeEvent -> m EventResponse),
195 195
   onHelp    :: !(forall m . MonadMsgHandler m => m (Map Text Text))
@@ -197,7 +197,7 @@ data MsgHandler = MsgHandler {
197 197
 
198 198
 newMsgHandler :: MsgHandler
199 199
 newMsgHandler = MsgHandler {
200
-  onMessage = const $ return Nothing,
200
+  onMessage = const $ return [],
201 201
   onStop    = return (),
202 202
   onEvent   = const $ return RespNothing,
203 203
   onHelp    = return mempty

+ 1
- 2
hask-irc-core/Network/IRC/Util.hs View File

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

+ 2
- 0
hask-irc-handlers/Network/IRC/Handlers.hs View File

@@ -8,6 +8,7 @@ import qualified Network.IRC.Handlers.Greet         as Greet
8 8
 import qualified Network.IRC.Handlers.MessageLogger as Logger
9 9
 import qualified Network.IRC.Handlers.NickTracker   as NickTracker
10 10
 import qualified Network.IRC.Handlers.SongSearch    as SongSearch
11
+import qualified Network.IRC.Handlers.Tell          as Tell
11 12
 
12 13
 import ClassyPrelude
13 14
 import Control.Concurrent.Lifted  (Chan)
@@ -32,4 +33,5 @@ mkMsgHandler botConfig eventChan name =
32 33
       , Logger.mkMsgHandler
33 34
       , NickTracker.mkMsgHandler
34 35
       , SongSearch.mkMsgHandler
36
+      , Tell.mkMsgHandler
35 37
       ]

+ 3
- 3
hask-irc-handlers/Network/IRC/Handlers/Auth.hs View File

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

+ 10
- 10
hask-irc-handlers/Network/IRC/Handlers/Core.hs View File

@@ -20,13 +20,13 @@ mkMsgHandler _ _ "help"     =
20 20
     helpMsg = "Get help. !help or !help <command>"
21 21
 mkMsgHandler _ _ _          = return Nothing
22 22
 
23
-pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
23
+pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Command]
24 24
 pingPong state Message { msgDetails = PingMsg { .. }, .. } = do
25 25
   io $ atomicWriteIORef state msgTime
26
-  return . Just $ PongCmd msg
26
+  return [PongCmd msg]
27 27
 pingPong state Message { msgDetails = PongMsg { .. }, .. } = do
28 28
   io $ atomicWriteIORef state msgTime
29
-  return Nothing
29
+  return []
30 30
 pingPong state Message { msgDetails = IdleMsg { .. }, .. }
31 31
   | even (convert msgTime :: Int) = do
32 32
     BotConfig { .. } <- ask
@@ -34,21 +34,21 @@ pingPong state Message { msgDetails = IdleMsg { .. }, .. }
34 34
     io $ do
35 35
       lastComm <- readIORef state
36 36
       if addUTCTime limit lastComm < msgTime
37
-        then return . Just . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
38
-        else return Nothing
37
+        then return [PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime]
38
+        else return []
39 39
 
40
-pingPong _ _ = return Nothing
40
+pingPong _ _ = return []
41 41
 
42
-help :: MonadMsgHandler m => Message -> m (Maybe Command)
42
+help :: MonadMsgHandler m => Message -> m [Command]
43 43
 help Message { msgDetails = ChannelMsg { .. }, .. }
44 44
   | "!help" == clean msg = do
45 45
       BotConfig { .. } <- ask
46 46
       let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
47
-      return . Just . ChannelMsgReply $ "I know these commands: " ++ unwords commands
47
+      return [ChannelMsgReply $ "I know these commands: " ++ unwords commands]
48 48
   | "!help" `isPrefixOf` msg = do
49 49
       BotConfig { .. } <- ask
50 50
       let command = cons '!'. dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
51 51
       let mHelp   = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo
52
-      return . Just . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp
52
+      return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
53 53
 
54
-help _ = return Nothing
54
+help _ = return []

+ 7
- 7
hask-irc-handlers/Network/IRC/Handlers/Greet.hs View File

@@ -12,22 +12,22 @@ mkMsgHandler _ _ "greeter"  = return . Just $ newMsgHandler { onMessage = greete
12 12
 mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
13 13
 mkMsgHandler _ _ _          = return Nothing
14 14
 
15
-greeter ::  MonadMsgHandler m => Message -> m (Maybe Command)
15
+greeter ::  MonadMsgHandler m => Message -> m [Command]
16 16
 greeter Message { msgDetails = ChannelMsg { .. }, .. } =
17
-  return . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
17
+  return . maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
18 18
     . find (== clean msg) $ greetings
19 19
   where
20 20
     greetings = [ "hi", "hello", "hey", "sup", "bye"
21 21
                 , "good morning", "good evening", "good night" ]
22
-greeter _ = return Nothing
22
+greeter _ = return []
23 23
 
24
-welcomer :: MonadMsgHandler m => Message -> m (Maybe Command)
24
+welcomer :: MonadMsgHandler m => Message -> m [Command]
25 25
 welcomer Message { msgDetails = JoinMsg { .. }, .. } = do
26 26
   BotConfig { .. } <- ask
27 27
   if userNick user /= botNick
28
-    then return . Just . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
29
-    else return Nothing
28
+    then return [ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)]
29
+    else return []
30 30
 
31
-welcomer _ = return Nothing
31
+welcomer _ = return []
32 32
 
33 33
 

+ 4
- 4
hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs View File

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

+ 27
- 19
hask-irc-handlers/Network/IRC/Handlers/NickTracker.hs View File

@@ -55,24 +55,24 @@ data NickTrackingState = NickTrackingState { acid            :: AcidState NickTr
55 55
                                            , onlineNicks     :: HashSet Nick
56 56
                                            , lastRefreshOn   :: UTCTime }
57 57
 
58
-nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message ->  m (Maybe Command)
58
+nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message ->  m [Command]
59 59
 nickTrackerMsg state message@Message { .. } = case msgDetails of
60 60
   ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands
61
-  ActionMsg { .. }  -> updateNickTrack state user msg msgTime >> return Nothing
62
-  JoinMsg { .. }    -> updateNickTrack state user "" msgTime  >> add user    >> return Nothing
63
-  PartMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
64
-  QuitMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return Nothing
61
+  ActionMsg { .. }  -> updateNickTrack state user msg msgTime >> return []
62
+  JoinMsg { .. }    -> updateNickTrack state user "" msgTime  >> add user    >> return []
63
+  PartMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return []
64
+  QuitMsg { .. }    -> updateNickTrack state user msg msgTime >> remove user >> return []
65 65
   NickMsg { .. }    ->
66
-    handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return Nothing
66
+    handleNickChange state user newNick msgTime >> swap (user, User newNick "") >> return []
67 67
   NamesMsg { .. }   -> do
68 68
     forM_ nicks $ \n -> updateNickTrack state (User n "") "" msgTime
69
-    refresh nicks >> updateRefreshTime >> return Nothing
69
+    refresh nicks >> updateRefreshTime >> return []
70 70
   IdleMsg { .. }    -> do
71 71
     NickTrackingState { .. } <- readIORef state
72 72
     if addUTCTime refreshInterval lastRefreshOn < msgTime
73
-      then updateRefreshTime >> return (Just NamesCmd)
74
-      else return Nothing
75
-  _                 -> return Nothing
73
+      then updateRefreshTime >> return [NamesCmd]
74
+      else return []
75
+  _                 -> return []
76 76
   where
77 77
     updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
78 78
 
@@ -89,7 +89,7 @@ nickTrackerMsg state message@Message { .. } = case msgDetails of
89 89
                , ("!forgetnicks", handleForgetNicksCommand)]
90 90
 
91 91
     handleCommands = case find ((`isPrefixOf` msg msgDetails) . fst) commands of
92
-      Nothing           -> return Nothing
92
+      Nothing           -> return []
93 93
       Just (_, handler) -> handler state message
94 94
 
95 95
 updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> User -> Text -> UTCTime -> m ()
@@ -127,26 +127,26 @@ newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
127 127
 
128 128
 withNickTracks :: MonadMsgHandler m
129 129
                => (Text -> [NickTrack] -> HashSet Nick -> IO Text) -> IORef NickTrackingState -> Message
130
-               -> m (Maybe Command)
130
+               -> m [Command]
131 131
 withNickTracks f state message = io $ do
132 132
   NickTrackingState { .. } <- readIORef state
133 133
   let nick = clean . unwords . drop 1 . words . msg . msgDetails $ message
134 134
   if nick == ""
135
-    then return Nothing
135
+    then return []
136 136
     else do
137 137
       mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
138
-      map (Just . ChannelMsgReply) $ case mcn of
138
+      map (singleton . ChannelMsgReply) $ case mcn of
139 139
         Nothing -> return $ "Unknown nick: " ++ nick
140 140
         Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
141 141
 
142
-handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
142
+handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
143 143
 handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
144 144
   let nicks = map ((\(Nick n) -> n) . nick) nickTracks
145 145
   if length nicks == 1
146 146
     then return $ nck ++ " has only one nick"
147 147
     else return $ nck ++ "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
148 148
 
149
-handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
149
+handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
150 150
 handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
151 151
   let NickTrack { lastSeenOn = LastSeenOn lastSeenOn'
152 152
                 , nick       = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
@@ -164,7 +164,7 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
164 164
       (if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
165 165
       " said: " ++ lastMessage')
166 166
 
167
-handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m (Maybe Command)
167
+handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Message -> m [Command]
168 168
 handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } = do
169 169
   NickTrackingState { .. } <- readIORef state
170 170
   let nick = userNick user
@@ -172,7 +172,14 @@ handleForgetNicksCommand state Message { msgDetails = ~ChannelMsg { .. }, .. } =
172 172
     Just nt <- getByNick acid nick
173 173
     cn      <- newCanonicalNick
174 174
     saveNickTrack acid $ nt { canonicalNick = cn }
175
-  return . Just . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick
175
+  return [ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick]
176
+
177
+nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> SomeEvent -> m EventResponse
178
+nickTrackerEvent state event = case fromEvent event of
179
+  Just (NickTrackRequest nick reply, _) -> io $ do
180
+    NickTrackingState { .. } <- readIORef state
181
+    getByNick acid nick >>= putMVar reply >> return RespNothing
182
+  _ -> return RespNothing
176 183
 
177 184
 stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
178 185
 stopNickTracker state = io $ do
@@ -188,11 +195,12 @@ mkMsgHandler BotConfig { .. } _ "nicktracker" = do
188 195
     acid            <- openLocalState emptyNickTracking
189 196
     newIORef (NickTrackingState acid refreshInterval mempty now)
190 197
   return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
198
+                                , onEvent   = nickTrackerEvent state
191 199
                                 , onStop    = stopNickTracker state
192 200
                                 , onHelp    = return helpMsgs }
193 201
   where
194 202
     helpMsgs = mapFromList [
195
-      ("!nicks", "Shows alternate nicks of the user. !nicks <user nick>"),
203
+      ("!nicks", "Shows alternate nicks of the user. !nicks <nick>"),
196 204
       ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
197 205
       ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
198 206
 mkMsgHandler _ _ _                            = return Nothing

+ 18
- 3
hask-irc-handlers/Network/IRC/Handlers/NickTracker/Types.hs View File

@@ -3,9 +3,10 @@
3 3
 module Network.IRC.Handlers.NickTracker.Types where
4 4
 
5 5
 import ClassyPrelude
6
-import Data.Data     (Data)
7
-import Data.IxSet    (IxSet, Indexable (..), ixSet, ixFun)
8
-import Data.SafeCopy (base, deriveSafeCopy)
6
+import Control.Concurrent.Lifted (Chan, writeChan)
7
+import Data.Data                 (Data)
8
+import Data.IxSet                (IxSet, Indexable (..), ixSet, ixFun)
9
+import Data.SafeCopy             (base, deriveSafeCopy)
9 10
 
10 11
 import Network.IRC.Types
11 12
 
@@ -35,3 +36,17 @@ $(deriveSafeCopy 0 'base ''NickTracking)
35 36
 
36 37
 emptyNickTracking :: NickTracking
37 38
 emptyNickTracking = NickTracking empty
39
+
40
+data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Typeable)
41
+
42
+instance Event NickTrackRequest
43
+
44
+instance Show NickTrackRequest where
45
+  show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]"
46
+
47
+getCanonicalNick :: Chan SomeEvent -> Nick -> IO (Maybe CanonicalNick)
48
+getCanonicalNick eventChan nick = do
49
+  reply <- newEmptyMVar
50
+  request <- toEvent $ NickTrackRequest nick reply
51
+  writeChan eventChan request
52
+  map (map canonicalNick) $ takeMVar reply

+ 4
- 4
hask-irc-handlers/Network/IRC/Handlers/SongSearch.hs View File

@@ -37,14 +37,14 @@ instance FromJSON Song where
37 37
     parseJSON a | a == emptyArray = return NoSong
38 38
     parseJSON _                   = mempty
39 39
 
40
-songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
40
+songSearch :: MonadMsgHandler m => Message -> m [Command]
41 41
 songSearch Message { msgDetails = ChannelMsg { .. }, .. }
42 42
   | "!m " `isPrefixOf` msg = do
43 43
       BotConfig { .. } <- ask
44 44
       liftIO $ do
45 45
         let query = strip . drop 3 $ msg
46 46
         mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
47
-        map (Just . ChannelMsgReply) $ case mApiKey of
47
+        map (singleton . ChannelMsgReply) $ case mApiKey of
48 48
           Nothing     -> do
49 49
             errorM "tinysong api key not found in config"
50 50
             return $ "Error while searching for " ++ query
@@ -58,5 +58,5 @@ songSearch Message { msgDetails = ChannelMsg { .. }, .. }
58 58
               Right song                     -> case song of
59 59
                 Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
60 60
                 NoSong      -> "No song found for: " ++ query
61
-  | otherwise              = return Nothing
62
-songSearch _ = return Nothing
61
+  | otherwise              = return []
62
+songSearch _ = return []

+ 129
- 0
hask-irc-handlers/Network/IRC/Handlers/Tell.hs View File

@@ -0,0 +1,129 @@
1
+{-# LANGUAGE PatternGuards #-}
2
+{-# LANGUAGE TemplateHaskell #-}
3
+{-# LANGUAGE TypeFamilies #-}
4
+
5
+module Network.IRC.Handlers.Tell (mkMsgHandler) where
6
+
7
+import qualified Data.IxSet as IS
8
+
9
+import ClassyPrelude hiding      (swap)
10
+import Control.Concurrent.Lifted (Chan)
11
+import Control.Monad.Reader      (ask)
12
+import Control.Monad.State       (get, put)
13
+import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
14
+                                  openLocalState, createArchive)
15
+import Data.Acid.Local           (createCheckpointAndClose)
16
+import Data.IxSet                ((@=))
17
+import Data.Text                 (split, strip)
18
+
19
+import Network.IRC.Handlers.NickTracker.Types
20
+import Network.IRC.Handlers.Tell.Types
21
+import Network.IRC.Types
22
+import Network.IRC.Util
23
+
24
+getUndeliveredTellsQ :: CanonicalNick -> Query Tells [Tell]
25
+getUndeliveredTellsQ nick = do
26
+  Tells { .. } <- ask
27
+  return . sortBy (comparing tellCreatedOn) . IS.toList $ tells @= nick @= NewTell
28
+
29
+saveTellQ :: Tell -> Update Tells ()
30
+saveTellQ tell@Tell { .. } = do
31
+  Tells { .. } <- get
32
+  if tellId == -1
33
+    then put $ Tells (nextTellId + 1) (IS.updateIx nextTellId tell{ tellId = nextTellId } tells)
34
+    else put $ Tells nextTellId (IS.updateIx tellId tell tells)
35
+
36
+$(makeAcidic ''Tells ['getUndeliveredTellsQ, 'saveTellQ])
37
+
38
+getUndeliveredTells :: AcidState Tells -> CanonicalNick -> IO [Tell]
39
+getUndeliveredTells acid = query acid . GetUndeliveredTellsQ
40
+
41
+saveTell :: AcidState Tells -> Tell -> IO ()
42
+saveTell acid = update acid . SaveTellQ
43
+
44
+newtype TellState = TellState { acid :: AcidState Tells }
45
+
46
+tellMsg :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> Message ->  m [Command]
47
+tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
48
+  | command == "!tell"
49
+  , args <- drop 1 . words $ msg
50
+  , length args >= 2             = io $ do
51
+      TellState { .. } <- readIORef state
52
+      reps <- if "<" `isPrefixOf` headEx args
53
+        then do
54
+          let (nicks, message) =
55
+                (parseNicks *** (strip . drop 1)) . break (== '>') . drop 1 . unwords $ args
56
+
57
+          if null message
58
+            then return []
59
+            else do
60
+              res <- forM nicks $ \nick -> handleTell acid nick message
61
+              let (fails, passes) = partitionEithers res
62
+              let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++
63
+                           (if null passes then [] else
64
+                              ["Message noted and will be passed on to " ++ intercalate ", " passes])
65
+              return reps
66
+        else do
67
+          let nick = Nick . headEx $ args
68
+          let message = strip . unwords . drop 1 $ args
69
+          if null message
70
+            then return []
71
+            else do
72
+              res <- handleTell acid nick message
73
+              let rep = case res of
74
+                          Left _  -> "Unknown nick: " ++ nickToText nick
75
+                          Right _ -> "Message noted and will be passed on to " ++ nickToText nick
76
+              return [rep]
77
+      tells <- getTellsToDeliver
78
+      return . map textToReply $ (reps ++ tells)
79
+  | otherwise                    = io $ map (map textToReply) getTellsToDeliver
80
+  where
81
+    command = clean . fromMaybe "" $ headMay . words $ msg
82
+
83
+    parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',')
84
+
85
+    textToReply t = ChannelMsgReply $ nickToText (userNick user) ++ ": " ++ t
86
+
87
+    tellToMsg Tell { .. } =
88
+      relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent
89
+
90
+    newTell canonicalNick = Tell (-1) (userNick user) canonicalNick Nothing NewTell msgTime Nothing
91
+
92
+    getTellsToDeliver = io $ do
93
+      TellState { .. } <- readIORef state
94
+      mcn <- getCanonicalNick eventChan $ userNick user
95
+      case mcn of
96
+        Nothing            -> return []
97
+        Just canonicalNick -> do
98
+          tells <- getUndeliveredTells acid canonicalNick
99
+          forM tells $ \tell -> do
100
+            saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime }
101
+            return . tellToMsg $ tell
102
+
103
+    handleTell acid nick message = do
104
+      mcn <- getCanonicalNick eventChan nick
105
+      case mcn of
106
+        Nothing            -> return . Left . nickToText $ nick
107
+        Just canonicalNick ->
108
+          saveTell acid (newTell canonicalNick message) >> (return . Right . nickToText $ nick)
109
+
110
+tellMsg _ _ _ = return []
111
+
112
+stopTell :: MonadMsgHandler m => IORef TellState -> m ()
113
+stopTell state = io $ do
114
+  TellState { .. } <- readIORef state
115
+  createArchive acid
116
+  createCheckpointAndClose acid
117
+
118
+mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
119
+mkMsgHandler BotConfig { .. } eventChan "tells" = do
120
+  acid <- openLocalState emptyTells
121
+  state <- newIORef (TellState acid)
122
+  return . Just $ newMsgHandler { onMessage = tellMsg eventChan state
123
+                                , onStop    = stopTell state
124
+                                , onHelp    = return helpMsgs }
125
+  where
126
+    helpMsgs = mapFromList [
127
+      ("!tell", "Publically passes a message to a user or a bunch of users. " ++
128
+                "!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>") ]
129
+mkMsgHandler _ _ _                            = return Nothing

+ 43
- 0
hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs View File

@@ -0,0 +1,43 @@
1
+{-# LANGUAGE DeriveDataTypeable #-}
2
+{-# LANGUAGE NoImplicitPrelude #-}
3
+{-# LANGUAGE TemplateHaskell #-}
4
+
5
+module Network.IRC.Handlers.Tell.Types where
6
+
7
+import ClassyPrelude
8
+import Data.Data      (Data)
9
+import Data.IxSet     (IxSet, Indexable (..), ixSet, ixFun)
10
+import Data.SafeCopy  (base, deriveSafeCopy)
11
+
12
+import Network.IRC.Handlers.NickTracker.Types
13
+import Network.IRC.Types
14
+
15
+newtype TellId  = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num)
16
+data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable)
17
+
18
+data Tell = Tell {
19
+  tellId          :: !TellId,
20
+  tellFromNick    :: !Nick,
21
+  tellToNick      :: !CanonicalNick,
22
+  tellTopic       :: !(Maybe Text),
23
+  tellStatus      :: !TellStatus,
24
+  tellCreatedOn   :: !UTCTime,
25
+  tellDeliveredOn :: !(Maybe UTCTime),
26
+  tellContent     :: !Text
27
+} deriving (Eq, Ord, Show, Data, Typeable)
28
+
29
+instance Indexable Tell where
30
+  empty = ixSet [ ixFun $ (: []) . tellId
31
+                , ixFun $ (: []) . tellToNick
32
+                , ixFun $ (: []) . tellStatus ]
33
+
34
+data Tells = Tells { nextTellId :: TellId, tells :: IxSet Tell }
35
+             deriving (Eq, Ord, Show, Data, Typeable)
36
+
37
+$(deriveSafeCopy 0 'base ''TellId)
38
+$(deriveSafeCopy 0 'base ''TellStatus)
39
+$(deriveSafeCopy 0 'base ''Tell)
40
+$(deriveSafeCopy 0 'base ''Tells)
41
+
42
+emptyTells :: Tells
43
+emptyTells = Tells (TellId 1) empty

+ 3
- 1
hask-irc-handlers/hask-irc-handlers.cabal View File

@@ -83,7 +83,9 @@ library
83 83
                        Network.IRC.Handlers.MessageLogger,
84 84
                        Network.IRC.Handlers.NickTracker,
85 85
                        Network.IRC.Handlers.NickTracker.Types,
86
-                       Network.IRC.Handlers.SongSearch
86
+                       Network.IRC.Handlers.SongSearch,
87
+                       Network.IRC.Handlers.Tell,
88
+                       Network.IRC.Handlers.Tell.Types
87 89
 
88 90
   default-language:    Haskell2010
89 91
 

Loading…
Cancel
Save