Browse Source

Refactoring, reformatting and logging.

Abhinav Sarkar 5 years ago
parent
commit
ab26dd9f6a

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

@@ -13,7 +13,7 @@ import qualified System.Log.Logger as HSL
13 13
 import ClassyPrelude
14 14
 import Control.Concurrent.Lifted  (threadDelay)
15 15
 import Control.Exception.Lifted   (evaluate)
16
-import Control.Monad.State.Strict (get, put, evalStateT)
16
+import Control.Monad.State.Strict (get, put)
17 17
 import Data.Time                  (addUTCTime)
18 18
 import System.IO                  (hIsEOF)
19 19
 import System.Timeout             (timeout)
@@ -56,18 +56,17 @@ parseLine botConfig@BotConfig { .. } time line msgParts =
56 56
 sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
57 57
 sendCommandLoop commandChan bot@Bot { .. } = do
58 58
   msg@(Message _ _ cmd) <- receiveMessage commandChan
59
-  (exs, lines_) <- formatCommand botConfig msg
59
+  (exs, lines_)         <- formatCommand botConfig msg
60 60
 
61 61
   forM_ exs $ \(ex :: SomeException) ->
62 62
     errorM ("Error while formatting command: " ++ show cmd ++ "\nError: " ++ show ex)
63 63
 
64
-  unless (null lines_) $
64
+  forM_ lines_ $ \line -> do
65 65
     handle (\(e :: SomeException) -> do
66 66
               errorM ("Error while writing to connection: " ++ show e)
67
-              closeMessageChannel commandChan) $
68
-      forM_ lines_ $ \line -> do
69
-        TF.hprint botSocket "{}\r\n" $ TF.Only line
70
-        infoM . unpack $ "> " ++ line
67
+              closeMessageChannel commandChan) $ do
68
+      TF.hprint botSocket "{}\r\n" $ TF.Only line
69
+      infoM . unpack $ "> " ++ line
71 70
 
72 71
   commandChanClosed <- isClosedMessageChannel commandChan
73 72
   unless commandChanClosed $
@@ -76,12 +75,11 @@ sendCommandLoop commandChan bot@Bot { .. } = do
76 75
       _            -> sendCommandLoop commandChan bot
77 76
 
78 77
 readMessageLoop :: MVar BotStatus -> MessageChannel In -> Bot -> Int -> IO ()
79
-readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mempty
78
+readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = loop mempty
80 79
   where
81 80
     msgPartTimeout = 10
82 81
 
83
-    loop = do
84
-      msgParts  <- get
82
+    loop msgParts = do
85 83
       botStatus <- readMVar mvBotStatus
86 84
       case botStatus of
87 85
         Disconnected -> io $ closeMessageChannel inChan
@@ -104,25 +102,26 @@ readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mem
104 102
               Right (Just EOS)              -> sendMessage inChan EOD >> return msgParts
105 103
 
106 104
           limit <- io $ map (addUTCTime (- msgPartTimeout)) getCurrentTime
107
-          put $ validMsgParts limit msgParts'
108
-          loop
109
-      where
110
-        validMsgParts limit =
111
-          foldl' (\m (k, v) -> insertWith (++) k [v] m) mempty
112
-          . concat
113
-          . filter ((> limit) . msgPartTime . snd . headEx . sortBy (flip $ comparing (msgPartTime . snd)))
114
-          . groupAllOn (fst &&& msgPartTarget . snd)
115
-          . asList . concatMap (uncurry (map . (,))) . mapToList
116
-
117
-        readLine = do
118
-          eof <- hIsEOF botSocket
119
-          if eof
120
-            then return EOS
121
-            else mask $ \unmask -> do
122
-              line <- map initEx . unmask $ hGetLine botSocket
123
-              infoM . unpack $ "< " ++ line
124
-              now <- getCurrentTime
125
-              return $ Line now line
105
+          loop $ validMsgParts limit msgParts'
106
+
107
+    validMsgParts limit =
108
+      foldl' (\m (k, v) -> insertWith (++) k [v] m) mempty
109
+      . concat
110
+      . filter ((> limit) . msgPartTime . snd . headEx . sortBy (flip $ comparing (msgPartTime . snd)))
111
+      . groupAllOn (fst &&& msgPartTarget . snd)
112
+      . asList
113
+      . concatMap (uncurry (map . (,)))
114
+      . mapToList
115
+
116
+    readLine = do
117
+      eof <- hIsEOF botSocket
118
+      if eof
119
+        then return EOS
120
+        else mask $ \unmask -> do
121
+          line <- map initEx . unmask $ hGetLine botSocket
122
+          infoM . unpack $ "< " ++ line
123
+          now <- getCurrentTime
124
+          return $ Line now line
126 125
 
127 126
 messageProcessLoop :: MessageChannel In -> MessageChannel Message -> IRC ()
128 127
 messageProcessLoop inChan messageChan = loop 0
@@ -139,14 +138,13 @@ messageProcessLoop inChan messageChan = loop 0
139 138
           then infoM "Timeout" >> return Disconnected
140 139
           else do
141 140
             when (status == Kicked) $
142
-              threadDelay (5 * oneSec) >> newMessage JoinCmd >>= sendMessage messageChan
141
+              threadDelay (5 * oneSec) >> (sendMessage messageChan =<< newMessage JoinCmd)
143 142
 
144 143
             mIn <- receiveMessage inChan
145 144
             case mIn of
146 145
               Timeout                  -> do
147
-                idleMsg <- newMessage IdleMsg
148
-                sendMessage messageChan idleMsg
149
-                sendWhoisMessage nick origNick
146
+                sendMessage messageChan =<< newMessage IdleMsg
147
+                sendWhoisMessage nick origNick idleFor
150 148
                 return Idle
151 149
               EOD                      -> infoM "Connection closed" >> return Disconnected
152 150
               Msg (msg@Message { .. }) -> do
@@ -162,25 +160,24 @@ messageProcessLoop inChan messageChan = loop 0
162 160
         NickAvailable    -> return ()
163 161
         _                -> loop 0
164 162
 
165
-      where
166
-        sendWhoisMessage nick origNick =
167
-          when (nick /= origNick && idleFor /= 0 && idleFor `mod` (10 * oneSec) == 0) $
168
-            (newMessage . WhoisCmd . nickToText $ origNick) >>= sendMessage messageChan
169
-
170
-        handleMsg nick origNick message mpass
171
-          | Just (JoinMsg user)     <- fromMessage message, userNick user == nick =
172
-              infoM "Joined" >> return Joined
173
-          | Just (KickMsg { .. })   <- fromMessage message, kickedNick == nick    =
174
-              infoM "Kicked" >> return Kicked
175
-          | Just NickInUseMsg       <- fromMessage message                        =
176
-              infoM "Nick already in use" >> return NickNotAvailable
177
-          | Just (ModeMsg { .. })   <- fromMessage message, modeUser == Self      = do
178
-              whenJust mpass $ \pass -> do
179
-                msg <- newMessage $ PrivMsgReply (User (Nick "NickServ") "") $ "IDENTIFY " ++ pass
180
-                sendMessage messageChan msg
181
-              newMessage JoinCmd >>= sendMessage messageChan
182
-              return Connected
183
-          | Just (WhoisNoSuchNick n) <- fromMessage message, n == origNick        =
184
-              infoM "Original nick available" >> return NickAvailable
185
-          | otherwise                                                             =
186
-              return Connected
163
+    sendWhoisMessage nick origNick idleFor =
164
+      when (nick /= origNick && idleFor /= 0 && idleFor `mod` (10 * oneSec) == 0) $
165
+        sendMessage messageChan =<< (newMessage . WhoisCmd . nickToText $ origNick)
166
+
167
+    handleMsg nick origNick message mpass
168
+      | Just (JoinMsg user)     <- fromMessage message, userNick user == nick =
169
+          infoM "Joined" >> return Joined
170
+      | Just (KickMsg { .. })   <- fromMessage message, kickedNick == nick    =
171
+          infoM "Kicked" >> return Kicked
172
+      | Just NickInUseMsg       <- fromMessage message                        =
173
+          infoM "Nick already in use" >> return NickNotAvailable
174
+      | Just (ModeMsg { .. })   <- fromMessage message, modeUser == Self      = do
175
+          whenJust mpass $ \pass -> do
176
+            msg <- newMessage $ PrivMsgReply (User (Nick "NickServ") "") $ "IDENTIFY " ++ pass
177
+            sendMessage messageChan msg
178
+            sendMessage messageChan =<< newMessage JoinCmd
179
+          return Connected
180
+      | Just (WhoisNoSuchNickMsg n) <- fromMessage message, n == origNick     =
181
+          infoM "Original nick available" >> return NickAvailable
182
+      | otherwise                                                             =
183
+          return Connected

+ 27
- 17
hask-irc-core/Network/IRC/Client.hs View File

@@ -38,7 +38,7 @@ $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
38 38
 
39 39
 data ConnectionResource = ConnectionResource
40 40
   { bot                :: !Bot
41
-  , botStatus          :: !(MVar BotStatus)
41
+  , botStatus          :: !(MVar BotStatus) -- TODO: is this really needed
42 42
   , inChannel          :: !(MessageChannel In)
43 43
   , mainMsgChannel     :: !(MessageChannel Message)
44 44
   , handlerMsgChannels :: !(Map MsgHandlerName (MessageChannel Message))
@@ -59,21 +59,27 @@ connect botConfig@BotConfig { .. } = do
59 59
   mainMsgChannel   <- newMessageChannel messageBus
60 60
 
61 61
   msgHandlersChans <- loadMsgHandlers messageBus
62
-  msgHandlerInfo'  <- foldM (\m (hn, (h, _)) -> getHelp h botConfig >>= \hm -> return $ insertMap hn hm m)
63
-                        mempty (mapToList msgHandlersChans)
62
+  msgHandlerInfo'  <- flip (`foldM` mempty) (mapToList msgHandlersChans)
63
+                      $ \handlerInfo (handlerName, (handler, _)) -> do
64
+                          handlerHelp <- getHelp handler botConfig
65
+                          return $ insertMap handlerName handlerHelp handlerInfo
64 66
 
65 67
   let botConfig'         = botConfig { msgHandlerInfo = msgHandlerInfo'}
66 68
   let msgHandlerChannels = map snd msgHandlersChans
67 69
   let msgHandlers        = map fst msgHandlersChans
68 70
 
69
-  return $ ConnectionResource
70
-            (Bot botConfig' socket msgHandlers) mvBotStatus inChannel mainMsgChannel msgHandlerChannels
71
+  return ConnectionResource { bot                = (Bot botConfig' socket msgHandlers)
72
+                            , botStatus          = mvBotStatus
73
+                            , inChannel          = inChannel
74
+                            , mainMsgChannel     = mainMsgChannel
75
+                            , handlerMsgChannels = msgHandlerChannels
76
+                            }
71 77
   where
72 78
     connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
73
-                           `catch` (\(e :: SomeException) -> do
74
-                                      errorM ("Error while connecting: " ++ show e ++ ". Retrying.")
75
-                                      threadDelay (5 * oneSec)
76
-                                      connectToWithRetry)
79
+                         `catch` (\(e :: SomeException) -> do
80
+                                    errorM ("Error while connecting: " ++ show e ++ ". Retrying.")
81
+                                    threadDelay (5 * oneSec)
82
+                                    connectToWithRetry)
77 83
 
78 84
     mkMsgHandler name messageBus =
79 85
       case lookup name msgHandlerMakers of
@@ -119,7 +125,7 @@ runBotIntenal botConfig' = withSocketsDo $ do
119 125
   where
120 126
     botConfigWithCore = botConfig' {
121 127
       msgHandlerInfo =
122
-        foldl' (\m name -> insertMap name mempty m) mempty
128
+        foldl' (flip (`insertMap` mempty)) mempty
123 129
           (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers)
124 130
     , msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
125 131
     }
@@ -137,15 +143,15 @@ runBotIntenal botConfig' = withSocketsDo $ do
137 143
         Just UserInterrupt -> debugM "User interrupt"          >> return Interrupted
138 144
         _                  -> debugM ("Exception! " ++ show e) >> return Errored
139 145
 
146
+    -- TODO: handle handler errors?
140 147
     runHandler :: BotConfig -> (MsgHandlerName, (MsgHandler, MessageChannel Message)) -> IO ()
141
-    runHandler botConfig (msgHandlerName, (handler, msgChannel)) = receiveMessage msgChannel >>= go
148
+    runHandler botConfig (msgHandlerName, (handler, msgChannel)) = go =<< receiveMessage msgChannel
142 149
       where
143 150
         go msg@Message { .. }
144 151
           | Just QuitCmd <- fromMessage message = do
145 152
               debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName
146 153
               stopMsgHandler handler botConfig
147 154
               closeMessageChannel msgChannel
148
-              return ()
149 155
           | otherwise = do
150 156
               resps <- handleMessage handler botConfig msg
151 157
               forM_ resps $ sendMessage msgChannel
@@ -161,10 +167,12 @@ runBotIntenal botConfig' = withSocketsDo $ do
161 167
           sendMessage mainMsgChannel =<< newMessage UserCmd
162 168
 
163 169
           fork $ sendCommandLoop mainMsgChannel bot
170
+                 `catch` (\(e :: SomeException) -> errorM $ "Error in sendCommandLoop: " ++ show e)
164 171
           fork $ readMessageLoop botStatus inChannel bot oneSec
172
+                 `catch` (\(e :: SomeException) -> errorM $ "Error in readMessageLoop: " ++ show e)
165 173
           forM_ (mapToList . asMap $ mergeMaps msgHandlers handlerMsgChannels) $
166 174
             void . fork . runHandler botConfig
167
-          runIRC bot Connected (messageProcessLoop inChannel mainMsgChannel)
175
+          runIRC bot Connected $ messageProcessLoop inChannel mainMsgChannel
168 176
 
169 177
 -- | Creates and runs an IRC bot for given the config. This IO action runs forever.
170 178
 runBot :: BotConfig -- ^ The bot config used to create the bot.
@@ -172,14 +180,16 @@ runBot :: BotConfig -- ^ The bot config used to create the bot.
172 180
 runBot botConfig = do
173 181
   -- setup signal handling
174 182
   mainThreadId <- myThreadId
175
-  installHandler sigINT  (Catch $ throwTo mainThreadId UserInterrupt) Nothing
176
-  installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
183
+  let interruptMainThread = throwTo mainThreadId UserInterrupt
184
+  installHandler sigINT  (Catch interruptMainThread) Nothing
185
+  installHandler sigTERM (Catch interruptMainThread) Nothing
177 186
 
178 187
   -- setup logging
179 188
   hSetBuffering stdout LineBuffering
180 189
   hSetBuffering stderr LineBuffering
181
-  stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $
182
-                     setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
190
+  stderrHandler <- streamHandler stderr DEBUG >>= \logHandler ->
191
+                     return . setFormatter logHandler $
192
+                       tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
183 193
   updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
184 194
 
185 195
   -- run

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

@@ -14,7 +14,7 @@ module Network.IRC.Configuration
14 14
 import qualified ClassyPrelude as P
15 15
 
16 16
 import ClassyPrelude hiding (lookup)
17
-import Data.Maybe (fromJust)
17
+import Data.Maybe           (fromJust)
18 18
 
19 19
 type Name = Text
20 20
 
@@ -64,7 +64,7 @@ data Value = String Text
64 64
            | List [Value]
65 65
            deriving (Eq, Show)
66 66
 
67
-newtype Configuration = Configuration { configMap :: (Map Name Value) } deriving (Show)
67
+newtype Configuration = Configuration { configMap :: Map Name Value } deriving (Show)
68 68
 
69 69
 fromMap :: Map Name Value -> Configuration
70 70
 fromMap = Configuration

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

@@ -74,7 +74,7 @@ data BotConfig = BotConfig
74 74
   -- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
75 75
   , cmdFormatters    :: ![CommandFormatter]
76 76
   -- | All the bot configuration so that message handlers can lookup their own specific configs.
77
-  , config           :: !(CF.Configuration)
77
+  , config           :: !CF.Configuration
78 78
   }
79 79
 
80 80
 instance Show BotConfig where

+ 9
- 10
hask-irc-core/Network/IRC/Message/Types.hs View File

@@ -129,16 +129,15 @@ data ModeMsg       = ModeMsg { modeUser   :: !User
129 129
 instance MessageC ModeMsg
130 130
 
131 131
 -- | A message received as a response to a 'WhoisCmd'.
132
-data WhoisReplyMsg = WhoisNoSuchNick { whoisNick :: !Nick }
133
-                   | WhoisReplyMsg {
134
-                       whoisNick        :: !Nick
135
-                     , whoisUser        :: !Text
136
-                     , whoisHost        :: !Text
137
-                     , whoisRealName    :: !Text
138
-                     , whoisChannels    :: ![Text]
139
-                     , whoisServer      :: !Text
140
-                     , whoisServerInfo  :: !Text
141
-                     } deriving (Typeable, Show, Eq, Ord)
132
+data WhoisReplyMsg = WhoisNoSuchNickMsg { whoisNick :: !Nick }
133
+                   | WhoisNickInfoMsg { whoisNick        :: !Nick
134
+                                      , whoisUser        :: !Text
135
+                                      , whoisHost        :: !Text
136
+                                      , whoisRealName    :: !Text
137
+                                      , whoisChannels    :: ![Text]
138
+                                      , whoisServer      :: !Text
139
+                                      , whoisServerInfo  :: !Text
140
+                                      } deriving (Typeable, Show, Eq, Ord)
142 141
 instance MessageC WhoisReplyMsg
143 142
 
144 143
 -- | All other messages which are not parsed as any of the above message types.

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

@@ -14,7 +14,8 @@ pingParser :: MessageParser
14 14
 pingParser = MessageParser "ping" go
15 15
   where
16 16
     go _ time line _
17
-      | "PING :" `isPrefixOf` line = ParseDone (Message time line . toMessage . PingMsg . drop 6 $ line) []
17
+      | "PING :" `isPrefixOf` line =
18
+          flip ParseDone [] . Message time line . toMessage . PingMsg . drop 6 $ line
18 19
       | otherwise                  = ParseReject
19 20
 
20 21
 parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
@@ -65,7 +66,7 @@ defaultParser = MessageParser "default" go
65 66
     go _ time line _
66 67
       | "PING :" `isPrefixOf` line = ParseReject
67 68
       | otherwise                  =
68
-          flip ParseDone [] . Message time line $ toMessage $ OtherMsg source command target message
69
+          flip ParseDone [] . Message time line . toMessage . OtherMsg source command target $ message
69 70
       where
70 71
         (_, command, source, target, message) = parseMsgLine line
71 72
 
@@ -105,11 +106,10 @@ whoisParser = MessageParser "whois" go
105 106
 
106 107
     parse :: [MessagePart] -> WhoisReplyMsg
107 108
     parse myMsgParts =
108
-      let partMap = asMap $ foldl' (\m MessagePart { .. } ->
109
-                                      insertMap (words msgPartLine !! 1) msgPartLine m)
110
-                                   mempty myMsgParts
109
+      let partMap = asMap $ flip (`foldl'` mempty) myMsgParts $ \m MessagePart { .. } ->
110
+                              insertMap (words msgPartLine !! 1) msgPartLine m
111 111
       in case lookup "401" partMap of
112
-           Just line -> WhoisNoSuchNick . Nick $ words line !! 3
112
+           Just line -> WhoisNoSuchNickMsg . Nick $ words line !! 3
113 113
            Nothing   -> let
114 114
                splits311   = words . fromJust . lookup "311" $ partMap
115 115
                nick        = Nick (splits311 !! 3)
@@ -124,7 +124,7 @@ whoisParser = MessageParser "whois" go
124 124
                splits312   = words . fromJust . lookup "312" $ partMap
125 125
                server      = splits312 !! 4
126 126
                serverInfo  = drop 1 . unwords . drop 5 $ splits312
127
-             in WhoisReplyMsg nick user host realName channels server serverInfo
127
+             in WhoisNickInfoMsg nick user host realName channels server serverInfo
128 128
 
129 129
 defaultParsers :: [MessageParser]
130 130
 defaultParsers = [pingParser, namesParser, whoisParser, lineParser, defaultParser]

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

@@ -30,7 +30,7 @@ getLogFilePath :: BotConfig -> IO FilePath
30 30
 getLogFilePath BotConfig { .. } = do
31 31
   let logFileDir = CF.require "messagelogger.logdir" config :: Text
32 32
   createDirectoryIfMissing True (unpack logFileDir)
33
-  return $ (unpack logFileDir) </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
33
+  return $ unpack logFileDir </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
34 34
 
35 35
 openLogFile :: FilePath -> IO Handle
36 36
 openLogFile logFilePath = do

Loading…
Cancel
Save