Browse Source

Major refactoring

1. Unified Messages, Events and Commands
2. Switched to a single TChan based message bus for communication between modules
3. Each handler now has a dedicated thread in which it runs, ensuring sequentiality of messages
Abhinav Sarkar 6 years ago
parent
commit
757285f4fd

+ 14
- 7
hask-irc-core/Network/IRC.hs View File

@@ -1,8 +1,15 @@
1
-module Network.IRC
2
- (
3
-  module Network.IRC.Types,
4
-  module Network.IRC.Client
5
-  )where
1
+{-|
2
+Module      : Network.IRC
3
+Description : A simple and extensible IRC bot.
4
+Copyright   : (c) Abhinav Sarkar, 2014
5
+License     : Apache-2.0
6
+Maintainer  : abhinav@abhinavsarkar.net
7
+Stability   : experimental
8
+Portability : POSIX
9
+-}
6 10
 
7
-import Network.IRC.Types
8
-import Network.IRC.Client
11
+module Network.IRC (module IRC) where
12
+
13
+import Network.IRC.Types      as IRC
14
+import Network.IRC.Client     as IRC
15
+import Network.IRC.MessageBus as IRC

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

@@ -1,22 +1,17 @@
1 1
 {-# LANGUAGE TemplateHaskell #-}
2 2
 
3 3
 module Network.IRC.Bot
4
-  ( Line
5
-  , sendCommand
6
-  , sendMessage
7
-  , sendEvent
8
-  , readLine
4
+  ( In
9 5
   , sendCommandLoop
10
-  , readLineLoop
11
-  , messageProcessLoop
12
-  , eventProcessLoop )
6
+  , readMessageLoop
7
+  , messageProcessLoop )
13 8
 where
14 9
 
15 10
 import qualified Data.Text.Format  as TF
16 11
 import qualified System.Log.Logger as HSL
17 12
 
18 13
 import ClassyPrelude
19
-import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay)
14
+import Control.Concurrent.Lifted (threadDelay)
20 15
 import Control.Exception.Lifted  (mask_, mask)
21 16
 import Control.Monad.Reader      (ask)
22 17
 import Control.Monad.State       (get, put)
@@ -25,145 +20,108 @@ import System.IO                 (hIsEOF)
25 20
 import System.Timeout            (timeout)
26 21
 import System.Log.Logger.TH      (deriveLoggers)
27 22
 
23
+import Network.IRC.MessageBus
28 24
 import Network.IRC.Internal.Types
29 25
 import Network.IRC.Protocol
30 26
 import Network.IRC.Types
31 27
 import Network.IRC.Util
32 28
 
33
-$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR])
29
+$(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR])
34 30
 
35
-data Line = Timeout | EOF | Line !UTCTime !Text | Msg FullMessage deriving (Show, Eq)
31
+data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq)
32
+data In    = Timeout | EOD | Msg Message deriving (Show, Eq)
36 33
 
37
-sendCommand :: Chan Command -> Command -> IO ()
38
-sendCommand = writeChan
39
-
40
-sendMessage :: Chan Line -> FullMessage -> IO ()
41
-sendMessage = (. Msg) . writeChan
42
-
43
-sendEvent :: Chan Event -> Event -> IO ()
44
-sendEvent = writeChan
45
-
46
-readLine :: Chan Line -> IO Line
47
-readLine = readChan
48
-
49
-sendCommandLoop :: Channel Command -> Bot -> IO ()
50
-sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
51
-  cmd       <- readChan commandChan
52
-  let mline = formatCommand botConfig cmd
34
+sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
35
+sendCommandLoop commandChan bot@Bot { .. } = do
36
+  msg@(Message _ _ cmd) <- receiveMessage commandChan
37
+  let mline = formatCommand botConfig msg
53 38
   handle (\(e :: SomeException) ->
54
-            errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
39
+            errorM ("Error while writing to connection: " ++ show e) >> closeMessageChannel commandChan) $ do
55 40
     whenJust mline $ \line -> do
56 41
       TF.hprint botSocket "{}\r\n" $ TF.Only line
57 42
       infoM . unpack $ "> " ++ line
58
-    case fromCommand cmd of
59
-      Just QuitCmd -> latchIt latch
60
-      _            -> sendCommandLoop (commandChan, latch) bot
43
+    case fromMessage cmd of
44
+      Just QuitCmd -> closeMessageChannel commandChan
45
+      _            -> sendCommandLoop commandChan bot
61 46
 
62
-readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
63
-readLineLoop = go []
47
+readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
48
+readMessageLoop = go []
64 49
   where
65 50
     msgPartTimeout = 10
66 51
 
67
-    go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
52
+    go !msgParts mvBotStatus inChan bot@Bot { .. } timeoutDelay = do
68 53
       botStatus <- readMVar mvBotStatus
69 54
       case botStatus of
70
-        Disconnected -> latchIt latch
55
+        Disconnected -> closeMessageChannel inChan
71 56
         _            -> do
72 57
           mLine     <- try $ timeout timeoutDelay readLine'
73 58
           msgParts' <- case mLine of
74 59
             Left (e :: SomeException)     -> do
75 60
               errorM $ "Error while reading from connection: " ++ show e
76
-              writeChan lineChan EOF >> return msgParts
77
-            Right Nothing                 -> writeChan lineChan Timeout >> return msgParts
61
+              sendMessage inChan EOD >> return msgParts
62
+            Right Nothing                 -> sendMessage inChan Timeout >> return msgParts
78 63
             Right (Just (Line time line)) -> do
79 64
               let (mmsg, msgParts') = parseLine botConfig time line msgParts
80
-              whenJust mmsg $ writeChan lineChan . Msg
65
+              whenJust mmsg $ sendMessage inChan . Msg
81 66
               return msgParts'
82
-            Right (Just l)                -> writeChan lineChan l >> return msgParts
67
+            Right (Just EOS)              -> sendMessage inChan EOD >> return msgParts
83 68
 
84 69
           limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
85 70
           let msgParts'' = concat
86 71
                            . filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
87 72
                            . groupAllOn (msgPartParserId &&& msgPartTarget) $ msgParts'
88
-          go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
73
+          go msgParts'' mvBotStatus inChan bot timeoutDelay
89 74
       where
90 75
         readLine' = do
91 76
           eof <- hIsEOF botSocket
92 77
           if eof
93
-            then return EOF
78
+            then return EOS
94 79
             else mask $ \unmask -> do
95 80
               line <- map initEx . unmask $ hGetLine botSocket
96 81
               infoM . unpack $ "< " ++ line
97 82
               now <- getCurrentTime
98 83
               return $ Line now line
99 84
 
100
-messageProcessLoop :: Chan Line -> Chan Command -> IRC ()
85
+messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
101 86
 messageProcessLoop = go 0
102 87
   where
103
-    go !idleFor lineChan commandChan = do
104
-      status         <- get
105
-      bot@Bot { .. } <- ask
106
-      let nick       = botNick botConfig
88
+    go !idleFor inChan messageChan = do
89
+      status     <- get
90
+      Bot { .. } <- ask
91
+      let nick   = botNick botConfig
107 92
 
108 93
       nStatus <- io . mask_ $
109 94
         if idleFor >= (oneSec * botTimeout botConfig)
110 95
           then infoM "Timeout" >> return Disconnected
111 96
           else do
112 97
             when (status == Kicked) $
113
-              threadDelay (5 * oneSec) >> sendCommand commandChan (toCommand JoinCmd)
98
+              threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan
114 99
 
115
-            mLine <- readLine lineChan
116
-            case mLine of
117
-              Timeout      -> do
118
-                now <- getCurrentTime
119
-                dispatchHandlers bot (FullMessage now "" $ toMessage IdleMsg) >> return Idle
120
-              EOF          -> infoM "Connection closed" >> return Disconnected
121
-              Line _ _     -> error "This should never happen"
122
-              Msg (msg@FullMessage { .. }) -> do
100
+            mIn <- receiveMessage inChan
101
+            case mIn of
102
+              Timeout -> newMessage IdleMsg >>= sendMessage messageChan >> return Idle
103
+              EOD     -> infoM "Connection closed" >> return Disconnected
104
+              Msg (msg@Message { .. }) -> do
123 105
                 nStatus <- handleMsg nick message
124
-                dispatchHandlers bot msg
106
+                sendMessage messageChan msg
125 107
                 return nStatus
126 108
 
127 109
       put nStatus
128 110
       case nStatus of
129
-        Idle             -> go (idleFor + oneSec) lineChan commandChan
111
+        Idle             -> go (idleFor + oneSec) inChan messageChan
130 112
         Disconnected     -> return ()
131 113
         NickNotAvailable -> return ()
132
-        _                -> go 0 lineChan commandChan
114
+        _                -> go 0 inChan messageChan
133 115
 
134 116
       where
135
-        dispatchHandlers Bot { .. } message =
136
-          forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
137
-            handle (\(e :: SomeException) ->
138
-                      errorM $ "Exception while processing message: " ++ show e) $ do
139
-              cmds <- handleMessage msgHandler botConfig message
140
-              forM_ cmds (sendCommand commandChan)
141
-
142 117
         handleMsg nick message
143 118
           | Just (JoinMsg user)   <- fromMessage message, userNick user == nick =
144 119
               infoM "Joined" >> return Joined
145
-          | Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick =
120
+          | Just (KickMsg { .. }) <- fromMessage message, kickedNick == nick    =
146 121
               infoM "Kicked" >> return Kicked
147
-          | Just NickInUseMsg     <- fromMessage message =
148
-              infoM "Nick already in use"                 >> return NickNotAvailable
149
-          | Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self =
150
-              sendCommand commandChan (toCommand JoinCmd) >> return Connected
151
-          | otherwise = return Connected
152
-
153
-eventProcessLoop :: Channel Event -> Chan Line -> Chan Command -> Bot -> IO ()
154
-eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
155
-  event <- readChan eventChan
156
-  case fromEvent event of
157
-    Just (QuitEvent, _) -> latchIt latch
158
-    _                   -> do
159
-      debugM $ "Event: " ++ show event
160
-      forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
161
-        handle (\(ex :: SomeException) ->
162
-                  errorM $ "Exception while processing event: " ++ show ex) $ do
163
-          resp <- handleEvent msgHandler botConfig event
164
-          case resp of
165
-            RespMessage messages -> forM_ messages $ sendMessage lineChan
166
-            RespCommand commands -> forM_ commands $ sendCommand commandChan
167
-            RespEvent events     -> forM_ events $ sendEvent eventChan
168
-            _                    -> return ()
169
-      eventProcessLoop (eventChan, latch) lineChan commandChan bot
122
+          | Just NickInUseMsg     <- fromMessage message                        =
123
+              infoM "Nick already in use"                    >> return NickNotAvailable
124
+          | Just (ModeMsg { .. }) <- fromMessage message, modeUser == Self      =
125
+              newMessage JoinCmd >>= sendMessage messageChan >> return Connected
126
+          | otherwise                                                           =
127
+              return Connected

+ 80
- 55
hask-irc-core/Network/IRC/Client.hs View File

@@ -15,7 +15,7 @@ module Network.IRC.Client (runBot) where
15 15
 import qualified System.Log.Logger as HSL
16 16
 
17 17
 import ClassyPrelude
18
-import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan)
18
+import Control.Concurrent.Lifted (fork, threadDelay, myThreadId)
19 19
 import Control.Exception.Lifted  (throwTo, AsyncException (UserInterrupt))
20 20
 import Network                   (PortID (PortNumber), connectTo, withSocketsDo)
21 21
 import System.IO                 (hSetBuffering, BufferMode(..))
@@ -27,93 +27,103 @@ import System.Log.Logger         (Priority (..), updateGlobalLogger, rootLoggerN
27 27
 import System.Log.Logger.TH      (deriveLoggers)
28 28
 import System.Posix.Signals      (installHandler, sigINT, sigTERM, Handler (Catch))
29 29
 
30
-import qualified Network.IRC.Handlers.Core as Core
31
-
32 30
 import Network.IRC.Bot
33 31
 import Network.IRC.Internal.Types
32
+import Network.IRC.MessageBus
34 33
 import Network.IRC.Types
34
+import Network.IRC.Handlers.Core
35 35
 import Network.IRC.Util
36 36
 
37 37
 $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
38 38
 
39
-coreMsgHandlerNames :: [MsgHandlerName]
40
-coreMsgHandlerNames = ["pingpong", "help"]
39
+data ConnectionResource = ConnectionResource
40
+  { bot                :: Bot
41
+  , botStatus          :: MVar BotStatus
42
+  , inChannel          :: MessageChannel In
43
+  , mainMsgChannel     :: MessageChannel Message
44
+  , cmdMsgChannel      :: MessageChannel Message
45
+  , handlerMsgChannels :: [MessageChannel Message]
46
+  }
41 47
 
42
-connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event)
48
+connect :: BotConfig -> IO ConnectionResource
43 49
 connect botConfig@BotConfig { .. } = do
44 50
   debugM "Connecting ..."
45 51
   socket <- connectToWithRetry
46 52
   hSetBuffering socket LineBuffering
47 53
   debugM "Connected"
48 54
 
49
-  lineChan        <- newChannel
50
-  commandChan     <- newChannel
51
-  eventChan       <- newChannel
52
-  mvBotStatus     <- newMVar Connected
53
-  msgHandlers     <- loadMsgHandlers (fst eventChan)
54
-  msgHandlerInfo' <- foldM (\m (hn, h) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
55
-                       mempty (mapToList msgHandlers)
56
-  let botConfig'  = botConfig { msgHandlerInfo = msgHandlerInfo'}
57
-  return (Bot botConfig' socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
55
+  messageBus       <- newMessageBus
56
+  inBus            <- newMessageBus
57
+  mvBotStatus      <- newMVar Connected
58
+
59
+  inChannel        <- newMessageChannel inBus
60
+  mainMsgChannel   <- newMessageChannel messageBus
61
+  cmdMsgChannel    <- newMessageChannel messageBus
62
+
63
+  msgHandlersChans <- loadMsgHandlers messageBus
64
+  msgHandlerInfo'  <- foldM (\m (hn, (h, _)) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
65
+                        mempty (mapToList msgHandlersChans)
66
+
67
+  let botConfig'         = botConfig { msgHandlerInfo = msgHandlerInfo'}
68
+  let msgHandlerChannels = map snd (mapValues msgHandlersChans)
69
+  let msgHandlers        = map fst msgHandlersChans
70
+
71
+  return $ ConnectionResource
72
+            (Bot botConfig' socket msgHandlers) mvBotStatus
73
+            inChannel mainMsgChannel cmdMsgChannel msgHandlerChannels
58 74
   where
59
-    connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
75
+    connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
60 76
                            `catch` (\(e :: SomeException) -> do
61 77
                                       errorM ("Error while connecting: " ++ show e ++ ". Waiting.")
62 78
                                       threadDelay (5 * oneSec)
63 79
                                       connectToWithRetry)
64 80
 
65
-    newChannel = (,) <$> newChan <*> newEmptyMVar
81
+    mkMsgHandler name messageBus =
82
+      case lookup name msgHandlerMakers of
83
+        Nothing    -> return Nothing
84
+        Just maker -> do
85
+          messageChannel <- newMessageChannel messageBus
86
+          handler        <- msgHandlerMaker maker botConfig messageChannel
87
+          return $ Just (handler, messageChannel)
66 88
 
67
-    mkMsgHandler :: Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler)
68
-    mkMsgHandler eventChan name =
69
-      flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
70
-        case finalHandler of
71
-          Just _  -> return finalHandler
72
-          Nothing -> msgHandlerMaker handler botConfig eventChan name
73
-
74
-    loadMsgHandlers eventChan =
89
+    loadMsgHandlers messageBus =
75 90
       flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
76 91
         debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
77
-        mMsgHandler <- mkMsgHandler eventChan msgHandlerName
92
+        mMsgHandler <- mkMsgHandler msgHandlerName messageBus
78 93
         case mMsgHandler of
79
-          Nothing         -> do
94
+          Nothing                   -> do
80 95
             debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
81 96
             return hMap
82
-          Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
97
+          Just msgHandlerAndChannel -> return $ insertMap msgHandlerName msgHandlerAndChannel hMap
83 98
 
84
-disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel Event) -> IO ()
85
-disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
99
+disconnect :: ConnectionResource -> IO ()
100
+disconnect ConnectionResource { bot = Bot { .. }, .. } = do
86 101
   debugM "Disconnecting ..."
87
-  sendCommand commandChan $ toCommand QuitCmd
88
-  awaitLatch sendLatch
89
-  swapMVar mvBotStatus Disconnected
90
-  awaitLatch readLatch
91
-  sendEvent eventChan =<< toEvent QuitEvent
92
-  awaitLatch eventLatch
93
-
94
-  unloadMsgHandlers
102
+  sendMessage cmdMsgChannel =<< newMessage QuitCmd
103
+  awaitMessageChannel cmdMsgChannel
104
+
105
+  swapMVar botStatus Disconnected
106
+  awaitMessageChannel inChannel
107
+
108
+  forM_ handlerMsgChannels awaitMessageChannel
95 109
   handle (\(_ :: SomeException) -> return ()) $ hClose botSocket
96 110
   debugM "Disconnected"
97
-  where
98
-    unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
99
-      debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName
100
-      stopMsgHandler msgHandler botConfig
101 111
 
102 112
 runBotIntenal :: BotConfig -> IO ()
103 113
 runBotIntenal botConfig' = withSocketsDo $ do
104 114
   status <- run
105 115
   case status of
106
-    Disconnected     -> debugM "Restarting .." >> runBotIntenal botConfig
107
-    Errored          -> debugM "Restarting .." >> runBotIntenal botConfig
116
+    Disconnected     -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
117
+    Errored          -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
108 118
     Interrupted      -> return ()
109 119
     NickNotAvailable -> return ()
110 120
     _                -> error "Unsupported status"
111 121
   where
112
-    botConfig = botConfig' {
122
+    botConfigWithCore = botConfig' {
113 123
       msgHandlerInfo =
114 124
         foldl' (\m name -> insertMap name mempty m) mempty
115
-          (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ coreMsgHandlerNames),
116
-      msgHandlerMakers = ordNub $ Core.mkMsgHandler : msgHandlerMakers botConfig'
125
+          (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers),
126
+      msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
117 127
     }
118 128
 
119 129
     handleErrors :: SomeException -> IO BotStatus
@@ -121,18 +131,33 @@ runBotIntenal botConfig' = withSocketsDo $ do
121 131
         Just UserInterrupt -> debugM "User interrupt"          >> return Interrupted
122 132
         _                  -> debugM ("Exception! " ++ show e) >> return Errored
123 133
 
124
-    run = bracket (connect botConfig) disconnect $
125
-      \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) ->
134
+    runHandler botConfig ((msgHandlerName, handler), msgChannel) = receiveMessage msgChannel >>= go
135
+      where
136
+        go msg@Message { .. }
137
+          | Just QuitCmd <- fromMessage message = do
138
+              debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName
139
+              stopMsgHandler handler botConfig
140
+              closeMessageChannel msgChannel
141
+              return ()
142
+          | otherwise = do
143
+              resps <- handleMessage handler botConfig msg
144
+              forM_ resps $ sendMessage msgChannel
145
+              runHandler botConfig ((msgHandlerName, handler), msgChannel)
146
+
147
+    run = bracket (connect botConfigWithCore) disconnect $
148
+      \ConnectionResource { .. } ->
126 149
         handle handleErrors $ do
150
+          let Bot { .. } = bot
127 151
           debugM $ "Running with config:\n" ++ show botConfig
128 152
 
129
-          sendCommand commandChan $ toCommand NickCmd
130
-          sendCommand commandChan $ toCommand UserCmd
153
+          sendMessage cmdMsgChannel =<< newMessage NickCmd
154
+          sendMessage cmdMsgChannel =<< newMessage UserCmd
131 155
 
132
-          fork $ sendCommandLoop (commandChan, sendLatch) bot
133
-          fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
134
-          fork $ eventProcessLoop eventChannel lineChan commandChan bot
135
-          runIRC bot Connected (messageProcessLoop lineChan commandChan)
156
+          fork $ sendCommandLoop cmdMsgChannel bot
157
+          fork $ readMessageLoop botStatus inChannel bot oneSec
158
+          forM_ (zip (mapToList msgHandlers) handlerMsgChannels) $
159
+            void . fork . runHandler botConfig
160
+          runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel)
136 161
 
137 162
 -- | Creates and runs an IRC bot for given the config. This IO action runs forever.
138 163
 runBot :: BotConfig -- ^ The bot config used to create the bot.

+ 33
- 25
hask-irc-core/Network/IRC/Handlers/Core.hs View File

@@ -1,50 +1,57 @@
1
-module Network.IRC.Handlers.Core (mkMsgHandler) where
1
+module Network.IRC.Handlers.Core (coreMsgHandlerMakers) where
2 2
 
3 3
 import ClassyPrelude
4
-import Control.Monad.Reader       (ask)
5
-import Data.Convertible           (convert)
6
-import Data.Time                  (addUTCTime)
4
+import Control.Monad.Reader (ask)
5
+import Data.Convertible     (convert)
6
+import Data.Time            (addUTCTime)
7 7
 
8 8
 import Network.IRC.Types
9 9
 import Network.IRC.Util
10 10
 
11
-mkMsgHandler :: MsgHandlerMaker
12
-mkMsgHandler = MsgHandlerMaker "core" go
11
+coreMsgHandlerMakers :: Map MsgHandlerName MsgHandlerMaker
12
+coreMsgHandlerMakers = mapFromList [
13
+    ("pingpong", pingPongMsgHandlerMaker)
14
+  , ("help", helpMsgHandlerMaker)
15
+  ]
16
+
17
+pingPongMsgHandlerMaker :: MsgHandlerMaker
18
+pingPongMsgHandlerMaker = MsgHandlerMaker "pingpong" go
13 19
   where
14
-    go _ _ "pingpong" = do
15
-      state <- getCurrentTime >>= newIORef
16
-      return . Just $ newMsgHandler { onMessage = pingPong state }
17
-    go _ _ "help"     =
18
-        return . Just $ newMsgHandler { onMessage = help,
19
-                                        onHelp    = return $ singletonMap "!help" helpMsg }
20
-    go _ _ _          = return Nothing
20
+    go _ _ = do
21
+      state <- io $ getCurrentTime >>= newIORef
22
+      return $ newMsgHandler { onMessage = pingPong state }
21 23
 
24
+helpMsgHandlerMaker :: MsgHandlerMaker
25
+helpMsgHandlerMaker = MsgHandlerMaker "help" go
26
+  where
27
+    go _ _ = return $ newMsgHandler { onMessage = help
28
+                                    , handlerHelp  = return $ singletonMap "!help" helpMsg }
22 29
     helpMsg = "Get help. !help or !help <command>"
23 30
 
24
-pingPong :: MonadMsgHandler m => IORef UTCTime -> FullMessage -> m [Command]
25
-pingPong state FullMessage { .. }
31
+pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m [Message]
32
+pingPong state Message { .. }
26 33
   | Just (PingMsg msg) <- fromMessage message =
27
-      io (atomicWriteIORef state msgTime) >> return [toCommand $ PongCmd msg]
34
+      io (atomicWriteIORef state msgTime) >> map singleton (newMessage . PongCmd $ msg)
28 35
   | Just (PongMsg _)   <- fromMessage message =
29 36
       io (atomicWriteIORef state msgTime) >> return []
30 37
   | Just IdleMsg       <- fromMessage message
31 38
   , even (convert msgTime :: Int)             = do
32 39
       BotConfig { .. } <- ask
33 40
       let limit = fromIntegral $ botTimeout `div` 2
34
-      io $ do
35
-        lastComm <- readIORef state
36
-        return [toCommand . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
37
-                | addUTCTime limit lastComm < msgTime]
41
+      lastComm <- io $ readIORef state
42
+      if addUTCTime limit lastComm < msgTime
43
+        then map singleton . newMessage . PingCmd . pack . formatTime defaultTimeLocale "%s" $ msgTime
44
+        else return []
38 45
   | otherwise                                 = return []
39 46
 
40
-help :: MonadMsgHandler m => FullMessage -> m [Command]
41
-help FullMessage { .. } = case fromMessage message of
47
+help :: MonadMsgHandler m => Message -> m [Message]
48
+help Message { .. } = case fromMessage message of
42 49
   Just (ChannelMsg _ msg)
43 50
     | "!help" == clean msg     -> do
44 51
         BotConfig { .. } <- ask
45 52
         let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
46
-        return . map (toCommand . ChannelMsgReply) $
47
-          [ "I know these commands: " ++ unwords commands
53
+        mapM (newMessage . ChannelMsgReply) [
54
+            "I know these commands: " ++ unwords commands
48 55
           , "Type !help <command> to know more about any command"
49 56
           ]
50 57
     | "!help" `isPrefixOf` msg -> do
@@ -52,5 +59,6 @@ help FullMessage { .. } = case fromMessage message of
52 59
         let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
53 60
         let mHelp   = find ((\c -> c == command || c == cons '!' command) . fst)
54 61
                       . concatMap mapToList . mapValues $ msgHandlerInfo
55
-        return [toCommand . ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
62
+        map singleton . newMessage . ChannelMsgReply
63
+          $ maybe ("No such command found: " ++ command) snd mHelp
56 64
   _                            -> return []

+ 0
- 56
hask-irc-core/Network/IRC/Internal/Command/Types.hs View File

@@ -1,67 +0,0 @@
1
-{-# LANGUAGE DeriveDataTypeable #-}
2
-{-# LANGUAGE ExistentialQuantification #-}
3
-{-# LANGUAGE FlexibleContexts #-}
4
-{-# LANGUAGE MultiParamTypeClasses #-}
5
-{-# LANGUAGE RankNTypes #-}
6
-
7
-module Network.IRC.Internal.Command.Types where
8
-
9
-import ClassyPrelude
10
-import Data.Typeable             (cast)
11
-
12
-import Network.IRC.Internal.Message.Types
13
-
14
-class (Typeable cmd, Show cmd, Eq cmd, Ord cmd) => CommandC cmd where
15
-  toCommand :: cmd -> Command
16
-  toCommand = Command
17
-
18
-  fromCommand :: Command -> Maybe cmd
19
-  fromCommand (Command cmd) = cast cmd
20
-
21
-data Command = forall m . CommandC m => Command m deriving (Typeable)
22
-
23
-instance Show Command where
24
-  show (Command m) = show m
25
-
26
-instance Eq Command where
27
-  Command m1 == Command m2 = case cast m1 of
28
-    Just m1' -> m1' == m2
29
-    _        -> False
30
-
31
-data PingCmd         = PingCmd !Text deriving (Typeable, Show, Eq, Ord)
32
-instance CommandC PingCmd
33
-
34
-data PongCmd         = PongCmd !Text deriving (Typeable, Show, Eq, Ord)
35
-instance CommandC PongCmd
36
-
37
-data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord)
38
-instance CommandC ChannelMsgReply
39
-
40
-data PrivMsgReply    = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord)
41
-instance CommandC PrivMsgReply
42
-
43
-data NickCmd         = NickCmd deriving (Typeable, Show, Eq, Ord)
44
-instance CommandC NickCmd
45
-
46
-data UserCmd         = UserCmd deriving (Typeable, Show, Eq, Ord)
47
-instance CommandC UserCmd
48
-
49
-data JoinCmd         = JoinCmd deriving (Typeable, Show, Eq, Ord)
50
-instance CommandC JoinCmd
51
-
52
-data QuitCmd         = QuitCmd deriving (Typeable, Show, Eq, Ord)
53
-instance CommandC QuitCmd
54
-
55
-data NamesCmd        = NamesCmd deriving (Typeable, Show, Eq, Ord)
56
-instance CommandC NamesCmd

+ 0
- 50
hask-irc-core/Network/IRC/Internal/Event/Types.hs View File

@@ -1,57 +0,0 @@
1
-{-# LANGUAGE DeriveDataTypeable #-}
2
-{-# LANGUAGE ExistentialQuantification #-}
3
-{-# LANGUAGE FlexibleContexts #-}
4
-{-# LANGUAGE MultiParamTypeClasses #-}
5
-{-# LANGUAGE RankNTypes #-}
6
-
7
-module Network.IRC.Internal.Event.Types where
8
-
9
-import ClassyPrelude
10
-import Data.Typeable             (cast)
11
-
12
-import Network.IRC.Internal.Message.Types
13
-import Network.IRC.Internal.Command.Types
14
-
15
-
16
-class (Typeable e, Show e, Eq e) => EventC e where
17
-  -- | Creates an event.
18
-  toEvent :: e -> IO Event
19
-  toEvent e = Event <$> pure e <*> getCurrentTime
20
-
21
-  -- | Extracts a received event.
22
-  fromEvent :: Event -> Maybe (e, UTCTime)
23
-  fromEvent (Event e time) = do
24
-    ev <- cast e
25
-    return (ev, time)
26
-
27
-data Event = forall e. (EventC e, Typeable e) => Event e UTCTime deriving (Typeable)
28
-
29
-instance Show Event where
30
-  show (Event e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
31
-
32
-instance Eq Event where
33
-  Event e1 t1 == Event e2 t2 =
34
-    case cast e2 of
35
-      Just e2' -> e1 == e2' && t1 == t2
36
-      Nothing  -> False
37
-
38
-data EventResponse =
39
-  -- | No response
40
-    RespNothing
41
-  -- | Events as the response. They will be sent to all message handlers like usual events.
42
-  | RespEvent [Event]
43
-  -- | Messages as the response. They will be sent to all message handlers like usual messages.
44
-  | RespMessage [FullMessage]
45
-  -- | Commands as the response. They will be sent to the server like usual commands.
46
-  | RespCommand [Command]
47
-  deriving (Show, Eq)
48
-
49
-data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable)
50
-instance EventC QuitEvent

+ 53
- 63
hask-irc-core/Network/IRC/Internal/Types.hs View File

@@ -8,15 +8,13 @@ module Network.IRC.Internal.Types where
8 8
 import qualified Data.Configurator as CF
9 9
 
10 10
 import ClassyPrelude
11
-import Control.Concurrent.Lifted (Chan)
12
-import Control.Monad.Base        (MonadBase)
13
-import Control.Monad.Reader      (ReaderT, MonadReader, runReaderT)
14
-import Control.Monad.State       (StateT, MonadState, execStateT)
15
-import Data.Configurator.Types   (Config)
16
-
17
-import Network.IRC.Internal.Command.Types
18
-import Network.IRC.Internal.Event.Types
19
-import Network.IRC.Internal.Message.Types
11
+import Control.Monad.Base      (MonadBase)
12
+import Control.Monad.Reader    (ReaderT, MonadReader, runReaderT)
13
+import Control.Monad.State     (StateT, MonadState, execStateT)
14
+import Data.Configurator.Types (Config)
15
+
16
+import Network.IRC.Message.Types
17
+import Network.IRC.MessageBus
20 18
 import Network.IRC.Util
21 19
 
22 20
 -- ** Message Parsing
@@ -25,17 +23,17 @@ import Network.IRC.Util
25 23
 type MessageParserId = Text
26 24
 
27 25
 -- | A part of a mutlipart message.
28
-data MessagePart = MessagePart { msgPartParserId   :: !MessageParserId
29
-                               , msgPartTarget     :: !Text
30
-                               , msgPartTime       :: !UTCTime
31
-                               , msgPartLine       :: !Text
26
+data MessagePart = MessagePart { msgPartParserId :: !MessageParserId
27
+                               , msgPartTarget   :: !Text
28
+                               , msgPartTime     :: !UTCTime
29
+                               , msgPartLine     :: !Text
32 30
                                } deriving (Eq, Show)
33 31
 
34 32
 -- | The result of parsing a message line.
35 33
 data MessageParseResult =
36
-    Done !FullMessage ![MessagePart] -- ^ A fully parsed message and leftover message parts.
37
-  | Partial ![MessagePart]           -- ^ A partial message with message parts received yet.
38
-  | Reject                           -- ^ Returned if a message line cannot be parsed by a particular parser.
34
+    Done !Message ![MessagePart]  -- ^ A fully parsed message and leftover message parts.
35
+  | Partial ![MessagePart]        -- ^ A partial message with message parts received yet.
36
+  | Reject                        -- ^ Returned if a message line cannot be parsed by a particular parser.
39 37
   deriving (Eq, Show)
40 38
 
41 39
 -- | A message parser used for parsing text lines from the server to 'Message's.
@@ -47,7 +45,7 @@ data MessageParser = MessageParser
47 45
 -- ** Command Formatting
48 46
 
49 47
 -- | A command formatter which optinally formats commands to texts which are then send to the server.
50
-type CommandFormatter = BotConfig -> Command -> Maybe Text
48
+type CommandFormatter = BotConfig -> Message -> Maybe Text
51 49
 
52 50
 -- ** Bot
53 51
 
@@ -58,11 +56,11 @@ type MsgHandlerName = Text
58 56
 data BotConfig = BotConfig
59 57
   {
60 58
   -- | The server to connect to.
61
-    server           :: !Text
59
+    botServer        :: !Text
62 60
   -- | The port to connect to.
63
-  , port             :: !Int
61
+  , botPort          :: !Int
64 62
   -- | The channel to join.
65
-  , channel          :: !Text
63
+  , botChannel       :: !Text
66 64
   -- | Nick of the bot.
67 65
   , botNick          :: !Nick
68 66
   -- | The timeout in seconds after which bot automatically disconnects and tries to reconnect.
@@ -72,7 +70,7 @@ data BotConfig = BotConfig
72 70
   -- by that message handler to the help text of that command.
73 71
   , msgHandlerInfo   :: !(Map MsgHandlerName (Map Text Text))
74 72
   -- | A list of 'MsgHandlerMaker's which are used to create message handlers for the bot.
75
-  , msgHandlerMakers :: ![MsgHandlerMaker]
73
+  , msgHandlerMakers :: !(Map MsgHandlerName MsgHandlerMaker)
76 74
   -- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
77 75
   , msgParsers       :: ![MessageParser]
78 76
   -- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
@@ -82,22 +80,23 @@ data BotConfig = BotConfig
82 80
   }
83 81
 
84 82
 instance Show BotConfig where
85
-  show BotConfig { .. } = "BotConfig[ server = "   ++ show server     ++ "\n" ++
86
-                                     "port = "     ++ show port       ++ "\n" ++
87
-                                     "channel = "  ++ show channel    ++ "\n" ++
88
-                                     "nick = "     ++ show botNick    ++ "\n" ++
89
-                                     "timeout = "  ++ show botTimeout ++ "\n" ++
90
-                                     "handlers = " ++ show (mapKeys msgHandlerInfo) ++ " ]"
83
+  show BotConfig { .. } = "BotConfig {"                                  ++ "\n" ++
84
+                          "server = "   ++ show botServer                ++ "\n" ++
85
+                          "port = "     ++ show botPort                  ++ "\n" ++
86
+                          "channel = "  ++ show botChannel               ++ "\n" ++
87
+                          "nick = "     ++ show botNick                  ++ "\n" ++
88
+                          "timeout = "  ++ show botTimeout               ++ "\n" ++
89
+                          "handlers = " ++ show (mapKeys msgHandlerInfo) ++ " }"
91 90
 
92 91
 -- | Creates a new bot config with essential fields leaving rest fields empty.
93
-newBotConfig :: Text                               -- ^ server
94
-             -> Int                                -- ^ port
95
-             -> Text                               -- ^ channel
96
-             -> Nick                               -- ^ botNick
97
-             -> Int                                -- ^ botTimeout
92
+newBotConfig :: Text       -- ^ server
93
+             -> Int        -- ^ port
94
+             -> Text       -- ^ channel
95
+             -> Nick       -- ^ botNick
96
+             -> Int        -- ^ botTimeout
98 97
              -> BotConfig
99 98
 newBotConfig server port channel botNick botTimeout =
100
-  BotConfig server port channel botNick botTimeout mempty [] [] [] CF.empty
99
+  BotConfig server port channel botNick botTimeout mempty mempty [] [] CF.empty
101 100
 
102 101
 -- | The bot.
103 102
 data Bot = Bot
@@ -111,15 +110,15 @@ data Bot = Bot
111 110
   }
112 111
 
113 112
 -- | The current status of the bot.
114
-data BotStatus = Connected                -- ^ Connected to the server
115
-               | Disconnected             -- ^ Disconnected from the server.
116
-               | Joined                   -- ^ Joined the channel.
117
-               | Kicked                   -- ^ Kicked from the channel.
118
-               | Errored                  -- ^ Some unhandled error happened.
119
-               | Idle                     -- ^ No communication with the server. The bot is idle.
120
-                                          -- If the bot stays idle for 'botTimeout' seconds, it disconnects.
121
-               | Interrupted              -- ^ Interrupted using external signals like SIGINT.
122
-               | NickNotAvailable         -- ^ Bot's nick already taken on the server.
113
+data BotStatus = Connected               -- ^ Connected to the server
114
+               | Disconnected            -- ^ Disconnected from the server.
115
+               | Joined                  -- ^ Joined the channel.
116
+               | Kicked                  -- ^ Kicked from the channel.
117
+               | Errored                 -- ^ Some unhandled error happened.
118
+               | Idle                    -- ^ No communication with the server. The bot is idle.
119
+                                         -- If the bot stays idle for 'botTimeout' seconds, it disconnects.
120
+               | Interrupted             -- ^ Interrupted using external signals like SIGINT.
121
+               | NickNotAvailable        -- ^ Bot's nick already taken on the server.
123 122
                deriving (Show, Eq, Ord)
124 123
 
125 124
 -- | An IRC action to be run.
@@ -162,23 +161,21 @@ data MsgHandler = MsgHandler
162 161
   {
163 162
   -- | The action invoked when a message is received. It returns a list of commands in response
164 163
   -- to the message which the bot sends to the server.
165
-    onMessage :: !(forall m . MonadMsgHandler m => FullMessage -> m [Command])
166
-  -- | The action invoked when an event is triggered. It returns an event resonpse which the bot
167
-  -- handles according to its type.
168
-  , onEvent   :: !(forall m . MonadMsgHandler m => Event -> m EventResponse)
164
+    onMessage   :: !(forall m . MonadMsgHandler m => Message -> m [Message])
165
+
169 166
   -- | The action invoked to stop the message handler.
170
-  , onStop    :: !(forall m . MonadMsgHandler m => m ())
167
+  , onStop      :: !(forall m . MonadMsgHandler m => m ())
168
+
171 169
   -- | The action invoked to get the map of the commands supported by the message handler and their help messages.
172
-  , onHelp    :: !(forall m . MonadMsgHandler m => m (Map Text Text))
170
+  , handlerHelp :: !(forall m . MonadMsgHandler m => m (Map Text Text))
173 171
   }
174 172
 
175 173
 -- | Creates a new message handler which doesn't do anything.
176 174
 newMsgHandler :: MsgHandler
177 175
 newMsgHandler = MsgHandler
178
-  { onMessage = const $ return []
179
-  , onStop    = return ()
180
-  , onEvent   = const $ return RespNothing
181
-  , onHelp    = return mempty
176
+  { onMessage   = const $ return mempty
177
+  , onStop      = return ()
178
+  , handlerHelp = return mempty
182 179
   }
183 180
 
184 181
 -- | A message handler maker which creates a new message handler.
@@ -187,7 +184,7 @@ data MsgHandlerMaker = MsgHandlerMaker
187 184
   -- | The name of the message handler.
188 185
     msgHandlerName  :: !MsgHandlerName
189 186
   -- | The action which is invoked to create a new message handler.
190
-  , msgHandlerMaker :: !(BotConfig -> Chan Event -> MsgHandlerName -> IO (Maybe MsgHandler))
187
+  , msgHandlerMaker :: !(BotConfig -> MessageChannel Message -> IO MsgHandler)
191 188
   }
192 189
 
193 190
 instance Eq MsgHandlerMaker where
@@ -198,19 +195,11 @@ instance Ord MsgHandlerMaker where
198 195
 -- | Handles a message using a given message handler.
199 196
 handleMessage :: MsgHandler    -- ^ The message handler.
200 197
               -> BotConfig     -- ^ The bot config.
201
-              -> FullMessage   -- ^ The message to handle.
202
-              -> IO [Command]  -- ^ A list of commands to be sent to the server.
198
+              -> Message   -- ^ The message to handle.
199
+              -> IO [Message]  -- ^ A list of commands to be sent to the server.
203 200
 handleMessage MsgHandler { .. } botConfig =
204 201
   flip runReaderT botConfig . _runMsgHandler . onMessage
205 202
 
206
-handleEvent :: MsgHandler        -- ^ The message handler.
207
-            -> BotConfig         -- ^ The bot config.
208
-            -> Event             -- ^ The event to handle.
209
-            -> IO EventResponse  -- ^ The event response which will be dispatched by the bot.
210
-handleEvent MsgHandler { .. } botConfig =
211
-  flip runReaderT botConfig . _runMsgHandler . onEvent
212
-
213 203
 -- | Stops a message handler.
214 204
 stopMsgHandler :: MsgHandler    -- ^ The message handler.
215 205
                -> BotConfig     -- ^ The bot config.
@@ -223,4 +212,4 @@ getHelp :: MsgHandler          -- ^ The message handler.
223 212
         -> BotConfig           -- ^ The bot config.
224 213
         -> IO (Map Text Text)  -- ^ A map of the commands supported by this message handler  to their help messages.
225 214
 getHelp MsgHandler { .. } botConfig =
226
-  flip runReaderT botConfig . _runMsgHandler $ onHelp
215
+  flip runReaderT botConfig . _runMsgHandler $ handlerHelp

hask-irc-core/Network/IRC/Internal/Message/Types.hs → hask-irc-core/Network/IRC/Message/Types.hs View File

@@ -4,15 +4,14 @@
4 4
 {-# LANGUAGE MultiParamTypeClasses #-}
5 5
 {-# LANGUAGE RankNTypes #-}
6 6
 {-# LANGUAGE TemplateHaskell #-}
7
+{-# OPTIONS_HADDOCK hide #-}
7 8
 
8
-module Network.IRC.Internal.Message.Types where
9
+module Network.IRC.Message.Types where
9 10
 
10 11
 import ClassyPrelude
11
-import Data.Data                 (Data)
12
-import Data.SafeCopy             (base, deriveSafeCopy)
13
-import Data.Typeable             (cast)
14
-
12
+import Data.Data     (Data)
13
+import Data.SafeCopy (base, deriveSafeCopy)
14
+import Data.Typeable (cast)
15 15
 
16 16
 -- | An IRC nick.
17 17
 newtype Nick = Nick { nickToText :: Text }
@@ -34,31 +33,36 @@ data User
34 33
   } deriving (Show, Eq, Ord)
35 34
 
36 35
 -- | An IRC message sent from the server to the bot.
37
-data FullMessage = FullMessage
36
+data Message = Message
38 37
   { msgTime :: !UTCTime  -- ^ The time when the message was received.
39 38
   , msgLine :: !Text     -- ^ The raw message line.
40
-  , message :: Message   -- ^ The details of the parsed message.
39
+  , message :: MessageW   -- ^ The details of the parsed message.
41 40
   } deriving (Show, Eq)
42 41
 
43 42
 -- | The typeclass for different types of IRC messages.
44 43
 class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
45
-  toMessage :: msg -> Message
46
-  toMessage = Message
44
+  toMessage :: msg -> MessageW
45
+  toMessage = MessageW
47 46
 
48
-  fromMessage :: Message -> Maybe msg
49
-  fromMessage (Message msg) = cast msg
47
+  fromMessage :: MessageW -> Maybe msg
48
+  fromMessage (MessageW msg) = cast msg
50 49
 
51 50
 -- | A wrapper over all types of IRC messages.
52
-data Message = forall m . MessageC m => Message m deriving (Typeable)
51
+data MessageW = forall m . MessageC m => MessageW m deriving (Typeable)
53 52
 
54
-instance Show Message where
55
-  show (Message m) = show m
53
+instance Show MessageW where
54
+  show (MessageW m) = show m
56 55
 
57
-instance Eq Message where
58
-  Message m1 == Message m2 = case cast m1 of
56
+instance Eq MessageW where
57
+  MessageW m1 == MessageW m2 = case cast m1 of
59 58
     Just m1' -> m1' == m2
60 59
     _        -> False
61 60
 
61
+newMessage :: (MessageC msg, MonadIO m) => msg -> m Message
62
+newMessage msg = do
63
+  t <- liftIO getCurrentTime
64
+  return $ Message t "" (toMessage msg)
65
+
62 66
 -- | The internal (non-IRC) message received when the bot is idle.
63 67
 data IdleMsg      = IdleMsg deriving (Typeable, Show, Eq, Ord)
64 68
 instance MessageC IdleMsg
@@ -121,3 +125,40 @@ instance MessageC ModeMsg
121 125
 data OtherMsg     = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
122 126
                     deriving (Typeable, Show, Eq, Ord)
123 127
 instance MessageC OtherMsg
128
+
129
+
130
+-- | A /PING/ command. A 'PongMsg' is expected as a response to this.
131
+data PingCmd         = PingCmd !Text deriving (Typeable, Show, Eq, Ord)
132
+instance MessageC PingCmd
133
+
134
+-- | A /PONG/ command. Sent in response to a 'PingMsg'.
135
+data PongCmd         = PongCmd !Text deriving (Typeable, Show, Eq, Ord)
136
+instance MessageC PongCmd
137
+
138
+-- | A /PRIVMSG/ message sent to the channel.
139
+data ChannelMsgReply = ChannelMsgReply !Text deriving (Typeable, Show, Eq, Ord)
140
+instance MessageC ChannelMsgReply
141
+
142
+-- | A /PRIVMSG/ message sent to a user.
143
+data PrivMsgReply    = PrivMsgReply !User !Text deriving (Typeable, Show, Eq, Ord)
144
+instance MessageC PrivMsgReply
145
+
146
+-- | A /NICK/ command sent to set the bot's nick.
147
+data NickCmd         = NickCmd deriving (Typeable, Show, Eq, Ord)
148
+instance MessageC NickCmd
149
+
150
+-- | A /USER/ command sent to identify the bot.
151
+data UserCmd         = UserCmd deriving (Typeable, Show, Eq, Ord)
152
+instance MessageC UserCmd
153
+
154
+-- | A /JOIN/ command sent to join the channel.
155
+data JoinCmd         = JoinCmd deriving (Typeable, Show, Eq, Ord)
156
+instance MessageC JoinCmd
157
+
158
+-- | A /QUIT/ command sent to quit the server.
159
+data QuitCmd         = QuitCmd deriving (Typeable, Show, Eq, Ord)
160
+instance MessageC QuitCmd
161
+
162
+-- | A /NAMES/ command sent to ask for the nicks of the users in the channel.
163
+data NamesCmd        = NamesCmd deriving (Typeable, Show, Eq, Ord)
164
+instance MessageC NamesCmd

+ 58
- 0
hask-irc-core/Network/IRC/MessageBus.hs View File

@@ -0,0 +1,58 @@
1
+{-# LANGUAGE ExistentialQuantification #-}
2
+{-# LANGUAGE FlexibleContexts #-}
3
+{-# LANGUAGE MultiParamTypeClasses #-}
4
+{-# LANGUAGE RankNTypes #-}
5
+
6
+module Network.IRC.MessageBus
7
+  ( MessageBus
8
+  , newMessageBus
9
+  , MessageChannel
10
+  , newMessageChannel
11
+  , sendMessage
12
+  , receiveMessage
13
+  , closeMessageChannel
14
+  , awaitMessageChannel ) where
15
+
16
+import ClassyPrelude
17
+
18
+newtype Latch = Latch (MVar ())
19
+
20
+newLatch :: IO Latch
21
+newLatch = liftM Latch newEmptyMVar
22
+
23
+doLatch :: Latch -> IO ()
24
+doLatch (Latch mv) = putMVar mv ()
25
+
26
+awaitLatch :: Latch -> IO ()
27
+awaitLatch (Latch mv) = void $ takeMVar mv
28
+
29
+newtype MessageBus a = MessageBus (TChan a)
30
+
31
+newMessageBus :: IO (MessageBus a)
32
+newMessageBus = MessageBus <$> newBroadcastTChanIO
33
+
34
+data MessageChannel a = MessageChannel Latch (TChan a) (TChan a)
35
+
36
+newMessageChannel ::MessageBus a -> IO (MessageChannel a)
37
+newMessageChannel (MessageBus wChan) = do
38
+  latch <- newLatch
39
+  rChan <- atomically $ dupTChan wChan
40
+  return $ MessageChannel latch rChan wChan
41
+
42
+sendMessageSTM :: MessageChannel a -> a -> STM ()
43
+sendMessageSTM (MessageChannel _ _ wChan) = writeTChan wChan
44
+
45
+receiveMessageSTM :: MessageChannel a -> STM a
46
+receiveMessageSTM (MessageChannel _ rChan _) = readTChan rChan
47
+
48
+sendMessage :: MessageChannel a -> a -> IO ()
49
+sendMessage chan = atomically . sendMessageSTM chan
50
+
51
+receiveMessage :: MessageChannel a -> IO a
52
+receiveMessage = atomically . receiveMessageSTM
53
+
54
+closeMessageChannel :: MessageChannel a -> IO ()
55
+closeMessageChannel (MessageChannel latch _ _) = doLatch latch
56
+
57
+awaitMessageChannel :: MessageChannel a -> IO ()
58
+awaitMessageChannel (MessageChannel latch _ _) = awaitLatch latch

+ 22
- 22
hask-irc-core/Network/IRC/Protocol.hs View File

@@ -10,7 +10,7 @@ import Data.Text     (strip)
10 10
 
11 11
 import Network.IRC.Types
12 12
 
13
-parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart])
13
+parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart])
14 14
 parseLine botConfig@BotConfig { .. } time line msgParts =
15 15
   fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } ->
16 16
     let (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
@@ -25,7 +25,7 @@ pingParser :: MessageParser
25 25
 pingParser = MessageParser "ping" go
26 26
   where
27 27
     go _ time line _
28
-      | "PING :" `isPrefixOf` line = Done (FullMessage time line . toMessage . PingMsg . drop 6 $ line) []
28
+      | "PING :" `isPrefixOf` line = Done (Message time line . toMessage . PingMsg . drop 6 $ line) []
29 29
       | otherwise                  = Reject
30 30
 
31 31
 parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
@@ -47,17 +47,17 @@ lineParser = MessageParser "line" go
47 47
         "QUIT"    -> done $ toMessage $ QuitMsg user quitMessage
48 48
         "PART"    -> done $ toMessage $ PartMsg user message
49 49
         "KICK"    -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
50
-        "MODE"    -> done $ toMessage $ if Nick source == botNick
50
+        "MODE"    -> done $ toMessage $ if Nick target == botNick
51 51
                        then ModeMsg Self target message []
52 52
                        else ModeMsg user target mode modeArgs
53 53
         "NICK"    -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
54 54
         "433"     -> done $ toMessage NickInUseMsg
55
-        "PRIVMSG" | target /= channel -> done $ toMessage $ PrivMsg user message
56
-                  | isActionMsg       -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
57
-                  | otherwise         -> done $ toMessage $ ChannelMsg user message
55
+        "PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
56
+                  | isActionMsg          -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
57
+                  | otherwise            -> done $ toMessage $ ChannelMsg user message
58 58
         _         -> Reject
59 59
       where
60
-        done = flip Done [] . FullMessage time line
60
+        done = flip Done [] . Message time line
61 61
 
62 62
         (splits, command, source, target, message) = parseMsgLine line
63 63
         quitMessage = strip . drop 1 . unwords . drop 2 $ splits
@@ -71,7 +71,7 @@ lineParser = MessageParser "line" go
71 71
 defaultParser :: MessageParser
72 72
 defaultParser = MessageParser "default" go
73 73
   where
74
-    go _ time line _ = flip Done [] . FullMessage time line $
74
+    go _ time line _ = flip Done [] . Message time line $
75 75
       toMessage $ OtherMsg source command target message
76 76
       where
77 77
         (_, command, source, target, message) = parseMsgLine line
@@ -85,7 +85,7 @@ namesParser = MessageParser "names" go
85 85
         (myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
86 86
         (nicks, allLines) =  concat *** intercalate "\r\n" . (++ [line])
87 87
           $ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
88
-        in Done (FullMessage time allLines . toMessage $ NamesMsg nicks) otherMsgParts
88
+        in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
89 89
       _     -> Reject
90 90
       where
91 91
         (_ : command : target : _) = words line
@@ -94,23 +94,23 @@ namesParser = MessageParser "names" go
94 94
           map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
95 95
 
96 96
 formatCommand :: CommandFormatter
97
-formatCommand botConfig@BotConfig { .. } command =
98
-  msum . map (\formatter -> formatter botConfig command) $ defaultCommandFormatter : cmdFormatters
97
+formatCommand botConfig@BotConfig { .. } message =
98
+  msum . map (\formatter -> formatter botConfig message) $ defaultCommandFormatter : cmdFormatters
99 99
 
100 100
 defaultCommandFormatter :: CommandFormatter
101
-defaultCommandFormatter BotConfig { .. } command
102
-  | Just (PongCmd msg)                    <- fromCommand command = Just $ "PONG :" ++ msg
103
-  | Just (PingCmd msg)                    <- fromCommand command = Just $ "PING :" ++ msg
104
-  | Just NickCmd                          <- fromCommand command = Just $ "NICK " ++ botNick'
105
-  | Just UserCmd                          <- fromCommand command =
101
+defaultCommandFormatter BotConfig { .. } Message { .. }
102
+  | Just (PongCmd msg)                    <- fromMessage message = Just $ "PONG :" ++ msg
103
+  | Just (PingCmd msg)                    <- fromMessage message = Just $ "PING :" ++ msg
104
+  | Just NickCmd                          <- fromMessage message = Just $ "NICK " ++ botNick'
105
+  | Just UserCmd                          <- fromMessage message =
106 106
       Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
107
-  | Just JoinCmd                          <- fromCommand command = Just $ "JOIN " ++ channel
108
-  | Just QuitCmd                          <- fromCommand command = Just "QUIT"
109
-  | Just (ChannelMsgReply msg)            <- fromCommand command =
110
-      Just $ "PRIVMSG " ++ channel ++ " :" ++ msg
111
-  | Just (PrivMsgReply (User { .. }) msg) <- fromCommand command =
107
+  | Just JoinCmd                          <- fromMessage message = Just $ "JOIN " ++ botChannel
108
+  | Just QuitCmd                          <- fromMessage message = Just "QUIT"
109
+  | Just (ChannelMsgReply msg)            <- fromMessage message =
110
+      Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
111
+  | Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =
112 112
       Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
113
-  | Just NamesCmd                         <- fromCommand command = Just $ "NAMES " ++ channel
113
+  | Just NamesCmd                         <- fromMessage message = Just $ "NAMES " ++ botChannel
114 114
   | otherwise                                                    = Nothing
115 115
   where
116 116
     botNick' = nickToText botNick

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

@@ -14,8 +14,8 @@ module Network.IRC.Types
14 14
     Nick (..)
15 15
   , User (..)
16 16
   , MessageC (..)
17
-  , Message
18
-  , FullMessage (..)
17
+  , Message (..)
18
+  , newMessage
19 19
   , IdleMsg (..)
20 20
   , NickInUseMsg (..)
21 21
   , PingMsg (..)
@@ -32,8 +32,6 @@ module Network.IRC.Types
32 32
   , ModeMsg (..)
33 33
   , OtherMsg (..)
34 34
   -- * IRC Commands
35
-  , CommandC (..)
36
-  , Command
37 35
   , PingCmd (..)
38 36
   , PongCmd (..)
39 37
   , ChannelMsgReply (..)
@@ -50,11 +48,6 @@ module Network.IRC.Types
50 48
   , MessageParser (..)
51 49
   -- * Command Formatting
52 50
   , CommandFormatter
53
-  -- * Events
54
-  , EventC (..)
55
-  , Event
56
-  , EventResponse (..)
57
-  , QuitEvent(..)
58 51
   -- * Bot
59 52
   , BotConfig (..)
60 53
   , newBotConfig
@@ -68,8 +61,5 @@ module Network.IRC.Types
68 61
   , MsgHandlerMaker (..)
69 62
   ) where
70 63
 
71
-import Network.IRC.Internal.Command.Types
72
-import Network.IRC.Internal.Event.Types
73
-import Network.IRC.Internal.Message.Types
64
+import Network.IRC.Message.Types
74 65
 import Network.IRC.Internal.Types
75
-

+ 23
- 34
hask-irc-core/Network/IRC/Util.hs View File

@@ -6,28 +6,17 @@ module Network.IRC.Util where
6 6
 import qualified Data.Text.Format        as TF
7 7
 
8 8
 import ClassyPrelude
9
-import Control.Arrow             (Arrow)
10
-import Control.Concurrent.Lifted (Chan)
11
-import Control.Monad.Base        (MonadBase)
12
-import Data.Convertible          (convert)
13
-import Data.Text                 (strip)
14
-import Data.Time                 (diffUTCTime)
9
+import Control.Arrow      (Arrow)
10
+import Control.Monad.Base (MonadBase)
11
+import Data.Convertible   (convert)
12
+import Data.Text          (strip)
13
+import Data.Time          (diffUTCTime)
15 14
 
16 15
 oneSec :: Int
17 16
 oneSec = 1000000
18 17
 
19
-type Latch = MVar ()
20
-
21
-latchIt :: Latch -> IO ()
22
-latchIt latch = putMVar latch ()
23
-
24
-awaitLatch :: Latch -> IO ()
25
-awaitLatch latch = void $ takeMVar latch
26
-
27
-type Channel a = (Chan a, Latch)
28
-
29 18
 mapKeys :: IsMap map => map -> [ContainerKey map]
30
-mapKeys   = map fst . mapToList
19
+mapKeys = map fst . mapToList
31 20
 
32 21
 mapValues :: IsMap map => map -> [MapValue map]
33 22
 mapValues = map snd . mapToList
@@ -64,21 +53,21 @@ relativeTime t1 t2 =
64 53
 
65 54
     period = t1 `diffUTCTime` t2
66 55
 
67
-    ranges = [(year*2,    "{} years",     year)
68
-             ,(year,      "a year",       0)
69
-             ,(month*2,   "{} months",    month)
70
-             ,(month,     "a month",      0)
71
-             ,(week*2,    "{} weeks",     week)
72
-             ,(week,      "a week",       0)
73
-             ,(day*2,     "{} days",      day)
74
-             ,(day,       "a day",        0)
75
-             ,(hour*4,    "{} hours",     hour)
76
-             ,(hour*3,    "a few hours",  0)
77
-             ,(hour*2,    "{} hours",     hour)
78
-             ,(hour,      "an hour",      0)
79
-             ,(minute*31, "{} minutes",   minute)
80
-             ,(minute*30, "half an hour", 0)
81
-             ,(minute*2,  "{} minutes",   minute)
82
-             ,(minute,    "a minute",     0)
83
-             ,(0,         "{} seconds",   1)
56
+    ranges = [ (year*2,    "{} years",     year)
57
+             , (year,      "a year",       0)
58
+             , (month*2,   "{} months",    month)
59
+             , (month,     "a month",      0)
60
+             , (week*2,    "{} weeks",     week)
61
+             , (week,      "a week",       0)
62
+             , (day*2,     "{} days",      day)
63
+             , (day,       "a day",        0)
64
+             , (hour*4,    "{} hours",     hour)
65
+             , (hour*3,    "a few hours",  0)
66
+             , (hour*2,    "{} hours",     hour)
67
+             , (hour,      "an hour",      0)
68
+             , (minute*31, "{} minutes",   minute)
69
+             , (minute*30, "half an hour", 0)
70
+             , (minute*2,  "{} minutes",   minute)
71
+             , (minute,    "a minute",     0)
72
+             , (0,         "{} seconds",   1)
84 73
              ]

+ 5
- 5
hask-irc-core/hask-irc-core.cabal View File

@@ -51,7 +51,7 @@ cabal-version:       >=1.10
51 51
 library
52 52
   default-extensions:  NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
53 53
                        BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving,
54
-                       DeriveDataTypeable
54
+                       DeriveDataTypeable, Trustworthy
55 55
 
56 56
   build-depends:       base                 >=4.5     && <4.8,
57 57
                        classy-prelude       >=0.9     && <1.0,
@@ -63,6 +63,7 @@ library
63 63
                        mtl                  >=2.1     && <2.3,
64 64
                        network              >=2.5     && <2.6,
65 65
                        safecopy             >=0.8     && <0.9,
66
+                       stm                  >=2.4     && <2.5,
66 67
                        text                 >=1.1     && <1.2,
67 68
                        text-format          >=0.3     && <0.4,
68 69
                        time                 >=1.4     && <1.5,
@@ -70,14 +71,13 @@ library
70 71
                        unix                 >=2.7     && <2.8
71 72
 
72 73
   exposed-modules:     Network.IRC,
74
+                       Network.IRC.MessageBus,
73 75
                        Network.IRC.Types,
74 76
                        Network.IRC.Client,
75 77
                        Network.IRC.Util
76 78
 
77
-  other-modules:       Network.IRC.Internal.Command.Types,
78
-                       Network.IRC.Internal.Event.Types,
79
-                       Network.IRC.Internal.Message.Types,
80
-                       Network.IRC.Internal.Types,
79
+  other-modules:       Network.IRC.Internal.Types,
80
+                       Network.IRC.Message.Types,
81 81
                        Network.IRC.Protocol,
82 82
                        Network.IRC.Bot,
83 83
                        Network.IRC.Handlers.Core

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

@@ -13,6 +13,7 @@ allMsgHandlerMakers :: [MsgHandlerMaker]
13 13
 allMsgHandlerMakers =
14 14
   [ authMsgHandlerMaker
15 15
   , greetMsgHandlerMaker
16
+  , welcomeMsgHandlerMaker
16 17
   , messageLoggerMsgHandlerMaker
17 18
   , nickTrackerMsgHandlerMaker
18 19
   , songSearchMsgHandlerMaker

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

@@ -13,8 +13,8 @@ import Data.Acid            (AcidState, Query, Update, makeAcidic, query, update
13 13
                              openLocalState, createArchive)
14 14
 import Data.Acid.Local      (createCheckpointAndClose)
15 15
 
16
+import Network.IRC
16 17
 import Network.IRC.Handlers.Auth.Types
17
-import Network.IRC.Types
18 18
 import Network.IRC.Util
19 19
 
20 20
 -- database
@@ -42,12 +42,20 @@ issueToken acid user = do
42 42
 
43 43
 -- handler
44 44
 
45
-authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> FullMessage ->  m [Command]
46
-authMessage state FullMessage { .. }
45
+authMessage :: MonadMsgHandler m => IORef (AcidState Auth) -> Message ->  m [Message]
46
+authMessage state Message { .. }
47 47
   | Just (PrivMsg user msg) <- fromMessage message
48
-  , "token" `isPrefixOf` msg =
49
-      map (singleton . toCommand . PrivMsgReply user) . io $ readIORef state >>= flip issueToken (userNick user)
50
-authMessage _ _ = return []
48
+  , "token" `isPrefixOf` msg = do
49
+      token <- io $ readIORef state >>= flip issueToken (userNick user)
50
+      map singleton . newMessage $ PrivMsgReply user token
51
+  | Just (AuthRequest user token reply) <- fromMessage message = io $ do
52
+      acid <- readIORef state
53
+      mt   <- query acid (GetToken user)
54
+      case mt of
55
+        Just t  -> putMVar reply (t == token)
56
+        Nothing -> putMVar reply False
57
+      return []
58
+  | otherwise = return []
51 59
 
52 60
 stopAuth :: MonadMsgHandler m => IORef (AcidState Auth) -> m ()
53 61
 stopAuth state = io $ do
@@ -55,26 +63,13 @@ stopAuth state = io $ do
55 63
   createArchive acid
56 64
   createCheckpointAndClose acid
57 65
 
58
-authEvent :: MonadMsgHandler m => IORef (AcidState Auth) -> Event -> m EventResponse
59
-authEvent state event = case fromEvent event of
60
-  Just (AuthEvent user token reply, _) -> io $ do
61
-    acid <- readIORef state
62
-    mt   <- query acid (GetToken user)
63
-    case mt of
64
-      Just t  -> putMVar reply (t == token)
65
-      Nothing -> putMVar reply False
66
-    return RespNothing
67
-  _                                    -> return RespNothing
68
-
69 66
 authMsgHandlerMaker :: MsgHandlerMaker
70 67
 authMsgHandlerMaker = MsgHandlerMaker "auth" go
71 68
   where
72 69
     helpMsg botNick = "Send a PM to get a new auth token. /msg " ++ nickToText botNick ++ " token"
73 70
 
74
-    go BotConfig { .. } _ "auth" = do
71
+    go BotConfig { .. } _ = do
75 72
       state <- io $ openLocalState emptyAuth >>= newIORef
76
-      return . Just $ newMsgHandler { onMessage = authMessage state
77
-                                    , onEvent   = authEvent state
78
-                                    , onStop    = stopAuth state
79
-                                    , onHelp    = return $ singletonMap "token" (helpMsg botNick) }
80
-    go _ _ _                     = return Nothing
73
+      return $ newMsgHandler { onMessage    = authMessage state
74
+                             , onStop      = stopAuth state
75
+                             , handlerHelp = return $ singletonMap "token" (helpMsg botNick) }

+ 8
- 5
hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs View File

@@ -17,10 +17,13 @@ emptyAuth = Auth mempty
17 17
 
18 18
 $(deriveSafeCopy 0 'base ''Auth)
19 19
 
20
-data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable)
20
+data AuthRequest = AuthRequest Nick Token (MVar Bool) deriving (Eq, Typeable)
21 21
 
22
-instance EventC AuthEvent
22
+instance MessageC AuthRequest
23 23
 
24
-instance Show AuthEvent where
25
-  show (AuthEvent nick token _) =
26
-    "AuthEvent[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]"
24
+instance Show AuthRequest where
25
+  show (AuthRequest nick token _) =
26
+    "AuthRequest[" ++ unpack (nickToText nick) ++ ", " ++ unpack token ++ "]"
27
+
28
+instance Ord AuthRequest where
29
+  (AuthRequest nick1 _ _) `compare` (AuthRequest nick2 _ _) = nick1 `compare` nick2

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

@@ -1,34 +1,37 @@
1
-module Network.IRC.Handlers.Greet (greetMsgHandlerMaker) where
1
+module Network.IRC.Handlers.Greet (greetMsgHandlerMaker, welcomeMsgHandlerMaker) where
2 2
 
3 3
 import ClassyPrelude
4 4
 import Control.Monad.Reader (ask)
5 5
 
6
-import Network.IRC.Types
6
+import Network.IRC
7 7
 import Network.IRC.Util
8 8
 
9 9
 greetMsgHandlerMaker :: MsgHandlerMaker
10
-greetMsgHandlerMaker = MsgHandlerMaker "greeter" go
11
-  where
12
-    go _ _ "greeter"  = return . Just $ newMsgHandler { onMessage = greeter }
13
-    go _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
14
-    go _ _ _          = return Nothing
10
+greetMsgHandlerMaker =
11
+  MsgHandlerMaker "greeter" $ \_ _ -> return $ newMsgHandler { onMessage = greeter }
12
+
13
+welcomeMsgHandlerMaker :: MsgHandlerMaker
14
+welcomeMsgHandlerMaker =
15
+  MsgHandlerMaker "welcomer" $ \_ _ -> return $ newMsgHandler { onMessage = welcomer }
15 16
 
16
-greeter ::  MonadMsgHandler m => FullMessage -> m [Command]
17
-greeter FullMessage { .. } = case fromMessage message of
17
+greeter ::  MonadMsgHandler m => Message -> m [Message]
18
+greeter Message { .. } = case fromMessage message of
18 19
   Just (ChannelMsg user msg) ->
19
-    return . maybeToList . map (toCommand . ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
20
-      . find (== clean msg) $ greetings
20
+    let reply = maybeToList . map (ChannelMsgReply . (++ nickToText (userNick user)) . (++ " "))
21
+                . find (== clean msg) $ greetings
22
+    in mapM newMessage reply
21 23
   _                          -> return []
22 24
   where
23 25
     greetings = [ "hi", "hello", "hey", "sup", "bye"
24 26
                 , "good morning", "good evening", "good night" ]
25 27
 
26
-welcomer :: MonadMsgHandler m => FullMessage -> m [Command]
27
-welcomer FullMessage { .. } = case fromMessage message of
28
+welcomer :: MonadMsgHandler m => Message -> m [Message]
29
+welcomer Message { .. } = case fromMessage message of
28 30
   Just (JoinMsg user) -> do
29 31
     BotConfig { .. } <- ask
30
-    return [toCommand . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
31
-            | userNick user /= botNick]
32
+    if userNick user /= botNick
33
+      then map singleton . newMessage . ChannelMsgReply $ "welcome back " ++ nickToText (userNick user)
34
+      else return []
32 35
   _                   -> return []
33 36
 
34 37
 

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

@@ -14,7 +14,7 @@ import System.Directory         (createDirectoryIfMissing, getModificationTime,
14 14
 import System.FilePath          (FilePath, (</>), (<.>))
15 15
 import System.IO                (openFile, IOMode(..), hSetBuffering, BufferMode(..))
16 16
 
17
-import Network.IRC.Types
17
+import Network.IRC
18 18
 import Network.IRC.Util
19 19
 
20 20
 type LoggerState = Maybe (Handle, Day)
@@ -22,18 +22,17 @@ type LoggerState = Maybe (Handle, Day)
22 22
 messageLoggerMsgHandlerMaker :: MsgHandlerMaker
23 23
 messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go
24 24
   where
25
-    go botConfig _ "messagelogger" = do
25
+    go botConfig _ = do
26 26
       state <- io $ newIORef Nothing
27 27
       initMessageLogger botConfig state
28
-      return . Just $ newMsgHandler { onMessage = flip messageLogger state
29
-                                    , onStop    = exitMessageLogger state }
30
-    go _ _ _                       = return Nothing
28
+      return $ newMsgHandler { onMessage = flip messageLogger state
29
+                             , onStop    = exitMessageLogger state }
31 30
 
32 31
 getLogFilePath :: BotConfig -> IO FilePath
33 32
 getLogFilePath BotConfig { .. } = do
34 33
   logFileDir <- CF.require config "messagelogger.logdir"
35 34
   createDirectoryIfMissing True logFileDir
36
-  return $ logFileDir </> unpack (channel ++ "-" ++ nickToText botNick) <.> "log"
35
+  return $ logFileDir </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
37 36
 
38 37
 openLogFile :: FilePath -> IO Handle
39 38
 openLogFile logFilePath = do
@@ -51,7 +50,7 @@ initMessageLogger botConfig state = do
51 50
 exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m ()
52 51
 exitMessageLogger state = io $ readIORef state >>= flip whenJust (hClose . fst)
53 52
 
54
-withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Command]
53
+withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m [Message]
55 54
 withLogFile action state = do
56 55
   botConfig <- ask
57 56
   io $ do
@@ -73,8 +72,8 @@ withLogFile action state = do
73 72
 
74 73
   return []
75 74
 
76
-messageLogger :: MonadMsgHandler m => FullMessage -> IORef LoggerState -> m [Command]
77
-messageLogger FullMessage { .. }
75
+messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m [Message]
76
+messageLogger Message { .. }
78 77
   | Just (ChannelMsg user msg)         <- fromMessage message =
79 78
       log "<{}> {}" [nick user, msg]
80 79
   | Just (ActionMsg user msg)          <- fromMessage message =
@@ -91,7 +90,8 @@ messageLogger FullMessage { .. }
91 90
       log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
92 91
   | Just (NamesMsg nicks)              <- fromMessage message =
93 92
       log "** USERS {}" [unwords . map nickToText $ nicks]
94
-  | otherwise = const $ return []
93
+  | otherwise                                                 =
94
+      const $ return []
95 95
   where
96 96
     nick = nickToText . userNick
97 97
 

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

@@ -18,8 +18,8 @@ import Data.Convertible     (convert)
18 18
 import Data.IxSet           (getOne, (@=))
19 19
 import Data.Time            (addUTCTime, NominalDiffTime)
20 20
 
21
+import Network.IRC
21 22
 import Network.IRC.Handlers.NickTracker.Internal.Types
22
-import Network.IRC.Types
23 23
 import Network.IRC.Util
24 24
 
25 25
 -- database
@@ -54,8 +54,8 @@ data NickTrackingState = NickTrackingState { acid            :: AcidState NickTr
54 54
                                            , onlineNicks     :: HashSet Nick
55 55
                                            , lastRefreshOn   :: UTCTime }
56 56
 
57
-nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> FullMessage ->  m [Command]
58
-nickTrackerMsg state FullMessage { .. }
57
+nickTrackerMsg :: MonadMsgHandler m => IORef NickTrackingState -> Message ->  m [Message]
58
+nickTrackerMsg state Message { .. }
59 59
   | Just (ChannelMsg (User { .. }) msg)  <- fromMessage message =
60 60
       updateNickTrack state userNick msg msgTime >> handleCommands userNick msg
61 61
   | Just (ActionMsg (User { .. }) msg)   <- fromMessage message =
@@ -68,15 +68,18 @@ nickTrackerMsg state FullMessage { .. }
68 68
       updateNickTrack state userNick msg msgTime >> remove userNick >> return []
69 69
   | Just (NickMsg (User { .. }) newNick) <- fromMessage message =
70 70
       handleNickChange state userNick newNick msgTime >> swap (userNick, newNick) >> return []
71
-  | Just (NamesMsg nicks) <- fromMessage message       = do
71
+  | Just (NamesMsg nicks)                <- fromMessage message = do
72 72
       forM_ nicks $ \n -> updateNickTrack state n "" msgTime
73 73
       refresh nicks >> updateRefreshTime >> return []
74
-  | Just IdleMsg                <- fromMessage message = do
74
+  | Just IdleMsg                         <- fromMessage message = do
75 75
       NickTrackingState { .. } <- readIORef state
76 76
       if addUTCTime refreshInterval lastRefreshOn < msgTime
77
-        then updateRefreshTime >> return [toCommand NamesCmd]
77
+        then updateRefreshTime >> map singleton (newMessage NamesCmd)
78 78
         else return []
79
-  | otherwise                                          = return []
79
+  | Just (NickTrackRequest nick reply)   <- fromMessage message = io $ do
80
+      NickTrackingState { .. } <- readIORef state
81
+      getByNick acid nick >>= putMVar reply >> return []
82
+  | otherwise                                                   = return []
80 83
   where
81 84
     updateRefreshTime = atomicModIORef state $ \ s -> s { lastRefreshOn = msgTime }
82 85
 
@@ -96,8 +99,8 @@ nickTrackerMsg state FullMessage { .. }
96 99
 
97 100
 updateNickTrack :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> UTCTime -> m ()
98 101
 updateNickTrack state nck message msgTime = io $ do
99
-  NickTrackingState { .. } <- readIORef state
100
-  mnt     <- getByNick acid nck
102
+  NickTrackingState { .. }       <- readIORef state
103
+  mnt                            <- getByNick acid nck
101 104
   (message', lastMessageOn', cn) <- case (message, mnt) of
102 105
     ("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
103 106
     (_, Just (NickTrack { .. }))  -> return (message, msgTime, canonicalNick)
@@ -108,9 +111,9 @@ updateNickTrack state nck message msgTime = io $ do
108 111
 handleNickChange :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Nick -> UTCTime -> m ()
109 112
 handleNickChange state prevNick newNick msgTime = io $ do
110 113
   NickTrackingState { .. } <- readIORef state
111
-  mpnt         <- getByNick acid prevNick
112
-  mnt          <- getByNick acid newNick
113
-  mInfo        <- case (mpnt, mnt) of
114
+  mpnt                     <- getByNick acid prevNick
115
+  mnt                      <- getByNick acid newNick
116
+  mInfo                    <- case (mpnt, mnt) of
114 117
     (Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
115 118
     (Just pnt, Nothing) ->
116 119
       return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
@@ -128,26 +131,27 @@ newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
128 131
 withNickTracks :: MonadMsgHandler m
129 132
                => (Text -> [NickTrack] -> HashSet Nick -> IO Text)
130 133
                -> IORef NickTrackingState -> Nick -> Text
131
-               -> m [Command]
134
+               -> m [Message]
132 135
 withNickTracks f state _ msg = io $ do
133 136
   NickTrackingState { .. } <- readIORef state
134 137
   let nick = clean . unwords . drop 1 . words $ msg
135 138
   if nick == ""
136 139
     then return []
137 140
     else do
138
-      mcn <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
139
-      map (singleton . toCommand . ChannelMsgReply) $ case mcn of
141
+      mcn   <- liftM (map canonicalNick) . getByNick acid . Nick $ nick
142
+      reply <- case mcn of
140 143
         Nothing -> return $ "Unknown nick: " ++ nick
141 144
         Just cn -> io $ query acid (GetByCanonicalNickQ cn) >>= \nts -> f nick nts onlineNicks
145
+      map singleton . newMessage . ChannelMsgReply $ reply
142 146
 
143
-handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
147
+handleNickCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
144 148
 handleNickCommand = withNickTracks $ \nck nickTracks _ -> do
145 149
   let nicks = map ((\(Nick n) -> n) . nick) nickTracks
146 150
   return . (nck ++) $ if length nicks == 1
147 151
     then " has only one nick"
148 152
     else "'s other nicks are: " ++ intercalate ", " (filter (/= nck) nicks)
149 153
 
150
-handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
154
+handleSeenCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
151 155
 handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
152 156
   let NickTrack { lastSeenOn = lastSeenOn'
153 157
                 , nick       = Nick lastSeenAs } = maximumByEx (comparing lastSeenOn) nickTracks
@@ -165,21 +169,14 @@ handleSeenCommand = withNickTracks $ \nck nickTracks onlineNicks -> do
165 169
       (if nck /= lastMessageAs then " as " ++ lastMessageAs else "") ++
166 170
       " said: " ++ lastMessage')
167 171
 
168
-handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Command]
172
+handleForgetNicksCommand :: MonadMsgHandler m => IORef NickTrackingState -> Nick -> Text -> m [Message]
169 173
 handleForgetNicksCommand state nick _ = do
170 174
   NickTrackingState { .. } <- readIORef state
171 175
   io $ do
172 176
     Just nt <- getByNick acid nick
173 177
     cn      <- newCanonicalNick
174 178
     saveNickTrack acid $ nt { canonicalNick = cn }
175
-  return [toCommand . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick]
176
-
177
-nickTrackerEvent :: MonadMsgHandler m => IORef NickTrackingState -> Event -> 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
179
+  map singleton . newMessage . ChannelMsgReply $ "Forgot all alternate nicks of " ++ nickToText nick
183 180
 
184 181
 stopNickTracker :: MonadMsgHandler m => IORef NickTrackingState -> m ()
185 182
 stopNickTracker state = io $ do
@@ -195,14 +192,12 @@ nickTrackerMsgHandlerMaker = MsgHandlerMaker "nicktracker" go
195 192
       ("!seen", "Lets you know when a user was last seen online and last spoke in the channel. !seen <user nick>"),
196 193
       ("!forgetnicks", "Forgets all your alternate nicks. !forgetnicks") ]
197 194
 
198
-    go BotConfig { .. } _ "nicktracker" = do
195
+    go BotConfig { .. } _ = do
199 196
       state <- io $ do
200 197
         now             <- getCurrentTime
201 198
         refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int)
202 199
         acid            <- openLocalState emptyNickTracking
203 200
         newIORef (NickTrackingState acid refreshInterval mempty now)
204
-      return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
205
-                                    , onEvent   = nickTrackerEvent state
206
-                                    , onStop    = stopNickTracker state
207
-                                    , onHelp    = return helpMsgs }
208
-    go _ _ _                            = return Nothing
201
+      return $ newMsgHandler { onMessage   = nickTrackerMsg state
202
+                             , onStop      = stopNickTracker state
203
+                             , handlerHelp = return helpMsgs }

+ 19
- 17
hask-irc-handlers/Network/IRC/Handlers/NickTracker/Internal/Types.hs View File

@@ -3,24 +3,23 @@
3 3
 module Network.IRC.Handlers.NickTracker.Internal.Types where
4 4
 
5 5
 import ClassyPrelude
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)
6
+import Data.Data     (Data)
7
+import Data.IxSet    (IxSet, Indexable (..), ixSet, ixFun)
8
+import Data.SafeCopy (base, deriveSafeCopy)
10 9
 
11
-import Network.IRC.Types
10
+import Network.IRC
12 11
 
13 12
 newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text }
14 13
                         deriving (Eq, Ord, Show, Data, Typeable)
15 14
 newtype LastSeenOn    = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
16 15
 
17
-data NickTrack = NickTrack {
18
-  nick          :: !Nick,
19
-  canonicalNick :: !CanonicalNick,
20
-  lastSeenOn    :: !UTCTime,
21
-  lastMessageOn :: !UTCTime,
22
-  lastMessage   :: !Text
23
-} deriving (Eq, Ord, Show, Data, Typeable)
16
+data NickTrack = NickTrack
17
+  { nick          :: !Nick
18
+  , canonicalNick :: !CanonicalNick
19
+  , lastSeenOn    :: !UTCTime
20
+  , lastMessageOn :: !UTCTime
21
+  , lastMessage   :: !Text
22
+  } deriving (Eq, Ord, Show, Data, Typeable)
24 23
 
25 24
 instance Indexable NickTrack where
26 25
   empty = ixSet [ ixFun $ (: []) . nick
@@ -40,14 +39,17 @@ emptyNickTracking = NickTracking empty
40 39
 
41 40
 data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable)
42 41
 
43
-instance EventC NickTrackRequest
42
+instance MessageC NickTrackRequest
44 43
 
45 44
 instance Show NickTrackRequest where
46 45
   show (NickTrackRequest nick _) = "NickTrackRequest[" ++ unpack (nickToText nick) ++ "]"
47 46
 
48
-getCanonicalNick :: Chan Event -> Nick -> IO (Maybe CanonicalNick)
49
-getCanonicalNick eventChan nick = do
47
+instance Ord NickTrackRequest where
48
+  (NickTrackRequest nick1 _) `compare` (NickTrackRequest nick2 _) = nick1 `compare` nick2
49
+
50
+getCanonicalNick :: MessageChannel Message -> Nick -> IO (Maybe CanonicalNick)
51
+getCanonicalNick messageChannel nick = do
50 52
   reply   <- newEmptyMVar
51
-  request <- toEvent $ NickTrackRequest nick reply
52
-  writeChan eventChan request
53
+  request <- newMessage $ NickTrackRequest nick reply
54
+  sendMessage messageChannel request
53 55
   map (map canonicalNick) $ takeMVar reply

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

@@ -16,7 +16,7 @@ import Network.Curl.Aeson       (curlAesonGet, CurlAesonException)
16 16
 import Network.HTTP.Base        (urlEncode)
17 17
 import System.Log.Logger.TH     (deriveLoggers)
18 18
 
19
-import Network.IRC.Types
19
+import Network.IRC
20 20
 
21 21
 $(deriveLoggers "HSL" [HSL.ERROR])
22 22
 
@@ -25,10 +25,9 @@ songSearchMsgHandlerMaker = MsgHandlerMaker "songsearch" go
25 25
   where
26 26
     helpMsg = "Search for song. !m <song> or !m <artist> - <song>"
27 27
 
28
-    go _ _ "songsearch" =
29
-      return . Just $ newMsgHandler { onMessage = songSearch,
30
-                                      onHelp    = return $ singletonMap "!m" helpMsg }
31
-    go _ _ _            = return Nothing
28
+    go _ _ =
29
+      return $ newMsgHandler { onMessage   = songSearch
30
+                             , handlerHelp = return $ singletonMap "!m" helpMsg }
32 31
 
33 32
 data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
34 33
             deriving (Show, Eq)
@@ -38,15 +37,15 @@ instance FromJSON Song where
38 37
     parseJSON a | a == emptyArray = return NoSong
39 38
     parseJSON _                   = mempty
40 39
 
41
-songSearch :: MonadMsgHandler m => FullMessage -> m [Command]
42
-songSearch FullMessage { .. }
40
+songSearch :: MonadMsgHandler m => Message -> m [Message]
41
+songSearch Message { .. }
43 42
   | Just (ChannelMsg _ msg) <- fromMessage message
44 43
   , "!m " `isPrefixOf` msg = do
45 44
       BotConfig { .. } <- ask
46 45
       liftIO $ do
47 46
         let query = strip . drop 3 $ msg
48
-        mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
49
-        map (singleton . toCommand . ChannelMsgReply) $ case mApiKey of
47
+        mApiKey   <- CF.lookup config "songsearch.tinysong_apikey"
48
+        reply     <- map ChannelMsgReply $ case mApiKey of
50 49
           Nothing     -> do
51 50
             errorM "tinysong api key not found in config"
52 51
             return $ "Error while searching for " ++ query
@@ -62,4 +61,5 @@ songSearch FullMessage { .. }
62 61
               Right song                     -> return $ case song of
63 62
                 Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
64 63
                 NoSong      -> "No song found for: " ++ query
64
+        map singleton . newMessage $ reply
65 65
   | otherwise              = return []

+ 31
- 37
hask-irc-handlers/Network/IRC/Handlers/Tell.hs View File

@@ -6,19 +6,18 @@ module Network.IRC.Handlers.Tell (tellMsgHandlerMaker) where
6 6
 
7 7
 import qualified Data.IxSet as IS
8 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
-
9
+import ClassyPrelude hiding (swap)
10
+import Control.Monad.Reader (ask)
11
+import Control.Monad.State  (get, put)
12
+import Data.Acid            (AcidState, Query, Update, makeAcidic, query, update,
13
+                             openLocalState, createArchive)
14
+import Data.Acid.Local      (createCheckpointAndClose)
15
+import Data.IxSet           ((@=))
16
+import Data.Text            (split, strip)
17
+
18
+import Network.IRC
19 19
 import Network.IRC.Handlers.NickTracker.Types
20 20
 import Network.IRC.Handlers.Tell.Internal.Types
21
-import Network.IRC.Types
22 21
 import Network.IRC.Util
23 22
 
24 23
 -- database
@@ -47,8 +46,8 @@ saveTell acid = update acid . SaveTellQ
47 46
 
48 47
 newtype TellState = TellState { acid :: AcidState Tells }
49 48
 
50
-tellMsg :: MonadMsgHandler m => Chan Event -> IORef TellState -> FullMessage ->  m [Command]
51
-tellMsg eventChan state FullMessage { .. }
49
+tellMsg :: MonadMsgHandler m => MessageChannel Message -> IORef TellState -> Message ->  m [Message]
50
+tellMsg messageChannel state Message { .. }
52 51
   | Just (ChannelMsg (User { .. }) msg) <- fromMessage message
53 52
   , command msg == "!tell"
54 53
   , args <- drop 1 . words $ msg
@@ -61,7 +60,7 @@ tellMsg eventChan state FullMessage { .. }
61 60
           if null tell
62 61
             then return []
63 62
             else do
64
-              res <- forM nicks $ \nick -> handleTell acid nick tell
63
+              res <- forM nicks $ \nick -> handleTell acid userNick nick tell
65 64
               let (fails, passes) = partitionEithers res
66 65
               let reps = (if null fails then [] else ["Unknown nicks: " ++ intercalate ", " fails]) ++
67 66
                            (if null passes then [] else
@@ -73,22 +72,26 @@ tellMsg eventChan state FullMessage { .. }
73 72
           if null tell
74 73
             then return []
75 74
             else do
76
-              res <- handleTell acid nick tell
75
+              res <- handleTell acid userNick nick tell
77 76
               let rep = case res of
78 77
                           Left _  -> "Unknown nick: " ++ nickToText nick
79 78
                           Right _ -> "Message noted and will be passed on to " ++ nickToText nick
80 79
               return [rep]
81 80
       tells <- getTellsToDeliver userNick
82
-      return . map (textToReply userNick) $ (reps ++ tells)
83
-  | Just (ChannelMsg (User { .. }) _) <- fromMessage message =
84
-      io $ map (map (textToReply userNick)) $ getTellsToDeliver userNick
81
+      mapM (textToReply userNick) (reps ++ tells)
82
+  | Just (ChannelMsg (User { .. }) _) <- fromMessage message = io $ do
83
+      tells <- getTellsToDeliver userNick
84
+      mapM (textToReply userNick) tells
85
+  | Just (TellRequest user msg) <- fromMessage message = do
86
+      tellMsg messageChannel state . Message msgTime "" . toMessage $ ChannelMsg user msg
87
+      return []
85 88
   | otherwise = return []
86 89
   where
87 90
     command msg = clean . fromMaybe "" . headMay . words $ msg
88 91
 
89 92
     parseNicks = ordNub . map Nick . filter (not . null) . split (\x -> x == ' ' || x == ',')
90 93
 
91
-    textToReply nick t = toCommand . ChannelMsgReply $ nickToText nick ++ ": " ++ t
94
+    textToReply nick t = newMessage . ChannelMsgReply $ nickToText nick ++ ": " ++ t
92 95
 
93 96
     tellToMsg Tell { .. } =
94 97
       relativeTime tellCreatedOn msgTime ++ " " ++ nickToText tellFromNick ++ " said: " ++ tellContent
@@ -97,7 +100,7 @@ tellMsg eventChan state FullMessage { .. }
97 100
 
98 101
     getTellsToDeliver nick = io $ do
99 102
       TellState { .. } <- readIORef state
100
-      mcn              <- getCanonicalNick eventChan nick
103
+      mcn              <- getCanonicalNick messageChannel nick
101 104
       case mcn of
102 105
         Nothing            -> return []
103 106
         Just canonicalNick -> do
@@ -106,19 +109,12 @@ tellMsg eventChan state FullMessage { .. }
106 109
             saveTell acid tell{ tellStatus = DeliveredTell, tellDeliveredOn = Just msgTime }
107 110
             return . tellToMsg $ tell
108 111
 
109
-    handleTell acid nick tell = do
110
-      mcn <- getCanonicalNick eventChan nick
112
+    handleTell acid userNick nick tell = do
113
+      mcn <- getCanonicalNick messageChannel nick
111 114
       case mcn of
112 115
         Nothing            -> return . Left . nickToText $ nick
113 116
         Just canonicalNick ->
114
-          saveTell acid (newTell nick canonicalNick tell) >> (return . Right . nickToText $ nick)
115
-
116
-tellEvent :: MonadMsgHandler m => Chan Event -> IORef TellState -> Event -> m EventResponse
117
-tellEvent eventChan state event = case fromEvent event of
118
-  Just (TellRequest user message, evTime) -> do
119
-    tellMsg eventChan state . FullMessage evTime "" . toMessage $ ChannelMsg user message
120
-    return RespNothing
121
-  _                                       -> return RespNothing
117
+          saveTell acid (newTell userNick canonicalNick tell) >> (return . Right . nickToText $ nick)
122 118
 
123 119
 stopTell :: MonadMsgHandler m => IORef TellState -> m ()
124 120
 stopTell state = io $ do
@@ -129,15 +125,13 @@ stopTell state = io $ do
129 125
 tellMsgHandlerMaker :: MsgHandlerMaker
130 126
 tellMsgHandlerMaker = MsgHandlerMaker "tell" go
131 127
   where
132
-    go BotConfig { .. } eventChan "tell" = do
128
+    go BotConfig { .. } messageChannel = do
133 129
       acid  <- openLocalState emptyTells
134 130
       state <- newIORef (TellState acid)
135
-      return . Just $ newMsgHandler { onMessage = tellMsg eventChan state
136
-                                    , onEvent   = tellEvent eventChan state
137
-                                    , onStop    = stopTell state
138
-                                    , onHelp    = return helpMsgs }
139
-    go _ _ _                            = return Nothing
131
+      return $ newMsgHandler { onMessage   = tellMsg messageChannel state
132
+                             , onStop      = stopTell state
133
+                             , handlerHelp = return helpMsgs }
140 134
 
141 135
     helpMsgs = singletonMap "!tell" $
142
-      "Publically passes a message to a user or a bunch of users. " ++
136
+      "Publically pass a message to a user or a bunch of users. " ++
143 137
       "!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>."

+ 19
- 19
hask-irc-handlers/Network/IRC/Handlers/Tell/Internal/Types.hs View File

@@ -4,27 +4,26 @@
4 4
 module Network.IRC.Handlers.Tell.Internal.Types where
5 5
 
6 6
 import ClassyPrelude
7
-import Control.Concurrent.Lifted (Chan, writeChan)
8
-import Data.Data                 (Data)
9
-import Data.IxSet                (IxSet, Indexable (..), ixSet, ixFun)
10
-import Data.SafeCopy             (base, deriveSafeCopy)
7
+import Data.Data     (Data)
8
+import Data.IxSet    (IxSet, Indexable (..), ixSet, ixFun)
9
+import Data.SafeCopy (base, deriveSafeCopy)
11 10
 
11
+import Network.IRC
12 12
 import Network.IRC.Handlers.NickTracker.Types
13
-import Network.IRC.Types
14 13
 
15 14
 newtype TellId  = TellId Int deriving (Eq, Ord, Show, Data, Typeable, Num)
16 15
 data TellStatus = NewTell | DeliveredTell deriving (Eq, Ord, Show, Data, Typeable)
17 16
 
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)
17
+data Tell = Tell
18
+  { tellId          :: !TellId
19
+  , tellFromNick    :: !Nick
20
+  , tellToNick      :: !CanonicalNick
21
+  , tellTopic       :: !(Maybe Text)
22
+  , tellStatus      :: !TellStatus
23
+  , tellCreatedOn   :: !UTCTime
24
+  , tellDeliveredOn :: !(Maybe UTCTime)
25
+  , tellContent     :: !Text
26
+  } deriving (Eq, Ord, Show, Data, Typeable)
28 27
 
29 28
 instance Indexable Tell where
30 29
   empty = ixSet [ ixFun $ (: []) . tellId
@@ -42,13 +41,14 @@ $(deriveSafeCopy 0 'base ''Tells)
42 41
 emptyTells :: Tells
43 42
 emptyTells = Tells (TellId 1) empty
44 43
 
45
-data TellRequest = TellRequest User Text deriving (Eq, Typeable)
44
+data TellRequest = TellRequest User Text deriving (Eq, Typeable, Ord)
46 45
 
47
-instance EventC TellRequest
46
+instance MessageC TellRequest
48 47
 
49 48
 instance Show TellRequest where
50 49
   show (TellRequest user tell) =
51 50
     "TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]"
52 51
 
53
-sendTell :: Chan Event -> User -> Text -> IO ()
54
-sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan
52
+sendTell :: MessageChannel Message -> User -> Text -> IO ()
53
+sendTell messageChannel user tell =
54
+  newMessage (TellRequest user tell) >>= sendMessage messageChannel

+ 1
- 1
hask-irc-runner/Main.hs View File

@@ -4,7 +4,7 @@ import ClassyPrelude hiding    (getArgs)
4 4
 import System.Environment      (getArgs, getProgName)
5 5
 import System.Exit             (exitFailure)
6 6
 
7
-import Network.IRC.Client
7
+import Network.IRC
8 8
 import Network.IRC.Config
9 9
 
10 10
 main :: IO ()

+ 8
- 4
hask-irc-runner/Network/IRC/Config.hs View File

@@ -7,8 +7,8 @@ import qualified Data.Configurator as CF
7 7
 import ClassyPrelude
8 8
 import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
9 9
 
10
+import Network.IRC
10 11
 import Network.IRC.Handlers
11
-import Network.IRC.Types
12 12
 
13 13
 instance Configured a => Configured [a] where
14 14
   convert (List xs) = Just . mapMaybe convert $ xs
@@ -19,10 +19,14 @@ loadBotConfig configFile = do
19 19
   eConfig <- try $ CF.load [CF.Required configFile]
20 20
   case eConfig of
21 21
     Left (ParseError _ _) -> error "Error while loading config"
22
-    Right config             -> do
22
+    Right config          -> do
23 23
       eBotConfig <- try $ do
24 24
         handlers :: [Text] <- CF.require config "msghandlers"
25
-        let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
25
+        let handlerInfo    = foldl' (\m h -> insertMap h mempty m) mempty handlers
26
+        let handlerMakers  = foldl' (\m maker -> insertMap (msgHandlerName maker) maker m) mempty
27
+                             . filter (\MsgHandlerMaker { .. } -> msgHandlerName `member` handlerInfo)
28
+                             $ allMsgHandlerMakers
29
+
26 30
         botConfig <- newBotConfig                          <$>
27 31
                        CF.require config "server"          <*>
28 32
                        CF.require config "port"            <*>
@@ -30,7 +34,7 @@ loadBotConfig configFile = do
30 34
                        (Nick <$> CF.require config "nick") <*>
31 35
                        CF.require config "timeout"
32 36
         return botConfig { msgHandlerInfo   = handlerInfo
33
-                         , msgHandlerMakers = allMsgHandlerMakers
37
+                         , msgHandlerMakers = handlerMakers
34 38
                          , config           = config
35 39
                          }
36 40
 

Loading…
Cancel
Save