Browse Source

Restructed and refactored

Abhinav Sarkar 8 years ago
parent
commit
924e023e27

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

@@ -17,7 +17,7 @@ import qualified System.Log.Logger as HSL
17 17
 
18 18
 import ClassyPrelude
19 19
 import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay)
20
-import Control.Exception.Lifted  (mask_)
20
+import Control.Exception.Lifted  (mask_, mask)
21 21
 import Control.Monad.Reader      (ask)
22 22
 import Control.Monad.State       (get, put)
23 23
 import Data.Time                 (addUTCTime)
@@ -59,11 +59,11 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
59 59
       _       -> sendCommandLoop (commandChan, latch) bot
60 60
 
61 61
 readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
62
-readLineLoop = readLineLoop' []
62
+readLineLoop = go []
63 63
   where
64 64
     msgPartTimeout = 10
65 65
 
66
-    readLineLoop' !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
66
+    go !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
67 67
       botStatus <- readMVar mvBotStatus
68 68
       case botStatus of
69 69
         Disconnected -> latchIt latch
@@ -76,31 +76,30 @@ readLineLoop = readLineLoop' []
76 76
             Right Nothing                 -> writeChan lineChan Timeout >> return msgParts
77 77
             Right (Just (Line time line)) -> do
78 78
               let (mmsg, msgParts') = parseLine botConfig time line msgParts
79
-              case mmsg of
80
-                Nothing  -> return msgParts'
81
-                Just msg -> writeChan lineChan (Msg msg) >> return msgParts'
79
+              whenJust mmsg $ writeChan lineChan . Msg
80
+              return msgParts'
82 81
             Right (Just l)                -> writeChan lineChan l >> return msgParts
83 82
 
84 83
           limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime
85 84
           let msgParts'' = concat
86 85
                            . filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime))
87 86
                            . groupAllOn (msgParserType &&& msgPartTarget) $ msgParts'
88
-          readLineLoop' msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
87
+          go msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay
89 88
       where
90 89
         readLine' = do
91 90
           eof <- hIsEOF socket
92 91
           if eof
93 92
             then return EOF
94
-            else do
95
-              line <- map initEx $ hGetLine socket
93
+            else mask $ \unmask -> do
94
+              line <- map initEx . unmask $ hGetLine socket
96 95
               infoM . unpack $ "< " ++ line
97 96
               now <- getCurrentTime
98 97
               return $ Line now line
99 98
 
100 99
 messageProcessLoop :: Chan Line -> Chan Command -> IRC ()
101
-messageProcessLoop = messageProcessLoop' 0
100
+messageProcessLoop = go 0
102 101
   where
103
-    messageProcessLoop' !idleFor lineChan commandChan = do
102
+    go !idleFor lineChan commandChan = do
104 103
       status         <- get
105 104
       bot@Bot { .. } <- ask
106 105
       let nick       = botNick botConfig
@@ -133,10 +132,10 @@ messageProcessLoop = messageProcessLoop' 0
133 132
 
134 133
       put nStatus
135 134
       case nStatus of
136
-        Idle             -> messageProcessLoop' (idleFor + oneSec) lineChan commandChan
135
+        Idle             -> go (idleFor + oneSec) lineChan commandChan
137 136
         Disconnected     -> return ()
138 137
         NickNotAvailable -> return ()
139
-        _                -> messageProcessLoop' 0 lineChan commandChan
138
+        _                -> go 0 lineChan commandChan
140 139
 
141 140
       where
142 141
         dispatchHandlers Bot { .. } message =

hask-irc-runner/Network/IRC/Client.hs → hask-irc-core/Network/IRC/Client.hs View File

@@ -5,19 +5,27 @@ module Network.IRC.Client (runBot) where
5 5
 import qualified System.Log.Logger as HSL
6 6
 
7 7
 import ClassyPrelude
8
-import Control.Concurrent.Lifted (fork, newChan, threadDelay)
9
-import Control.Exception.Lifted  (AsyncException (UserInterrupt))
8
+import Control.Concurrent.Lifted (fork, newChan, threadDelay, myThreadId, Chan)
9
+import Control.Exception.Lifted  (throwTo, AsyncException (UserInterrupt))
10 10
 import Network                   (PortID (PortNumber), connectTo, withSocketsDo)
11 11
 import System.IO                 (hSetBuffering, BufferMode(..))
12
+import System.Log.Formatter      (tfLogFormatter)
13
+import System.Log.Handler        (setFormatter)
14
+import System.Log.Handler.Simple (streamHandler)
15
+import System.Log.Logger         (Priority (..), updateGlobalLogger, rootLoggerName,
16
+                                  setHandlers, setLevel)
12 17
 import System.Log.Logger.TH      (deriveLoggers)
18
+import System.Posix.Signals      (installHandler, sigINT, sigTERM, Handler (Catch))
13 19
 
14 20
 import Network.IRC.Bot
15
-import Network.IRC.Handlers
16 21
 import Network.IRC.Types
17 22
 import Network.IRC.Util
18 23
 
19 24
 $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
20 25
 
26
+coreMsgHandlerNames :: [MsgHandlerName]
27
+coreMsgHandlerNames = ["pingpong", "help"]
28
+
21 29
 connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent)
22 30
 connect botConfig@BotConfig { .. } = do
23 31
   debugM "Connecting ..."
@@ -43,10 +51,17 @@ connect botConfig@BotConfig { .. } = do
43 51
 
44 52
     newChannel = (,) <$> newChan <*> newEmptyMVar
45 53
 
54
+    mkMsgHandler :: Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
55
+    mkMsgHandler eventChan name =
56
+      flip (`foldM` Nothing) msgHandlerMakers $ \finalHandler handler ->
57
+        case finalHandler of
58
+          Just _  -> return finalHandler
59
+          Nothing -> handler botConfig eventChan name
60
+
46 61
     loadMsgHandlers eventChan =
47 62
       flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
48 63
         debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
49
-        mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName
64
+        mMsgHandler <- mkMsgHandler eventChan msgHandlerName
50 65
         case mMsgHandler of
51 66
           Nothing         -> do
52 67
             debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
@@ -71,15 +86,12 @@ disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (
71 86
       debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName
72 87
       stopMsgHandler msgHandler botConfig
73 88
 
74
-runBot :: BotConfig -> IO ()
75
-runBot botConfig' = withSocketsDo $ do
76
-  hSetBuffering stdout LineBuffering
77
-  debugM "Running with config:"
78
-  print botConfig
79
-  status <- runBot_
89
+runBotIntenal :: BotConfig -> IO ()
90
+runBotIntenal botConfig' = withSocketsDo $ do
91
+  status <- run
80 92
   case status of
81
-    Disconnected     -> debugM "Restarting .." >> runBot botConfig
82
-    Errored          -> debugM "Restarting .." >> runBot botConfig
93
+    Disconnected     -> debugM "Restarting .." >> runBotIntenal botConfig
94
+    Errored          -> debugM "Restarting .." >> runBotIntenal botConfig
83 95
     Interrupted      -> return ()
84 96
     NickNotAvailable -> return ()
85 97
     _                -> error "Unsupported status"
@@ -95,9 +107,11 @@ runBot botConfig' = withSocketsDo $ do
95 107
         Just UserInterrupt -> debugM "User interrupt"          >> return Interrupted
96 108
         _                  -> debugM ("Exception! " ++ show e) >> return Errored
97 109
 
98
-    runBot_ = bracket (connect botConfig) disconnect $
110
+    run = bracket (connect botConfig) disconnect $
99 111
       \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) ->
100 112
         handle handleErrors $ do
113
+          debugM $ "Running with config:\n" ++ show botConfig
114
+
101 115
           sendCommand commandChan NickCmd
102 116
           sendCommand commandChan UserCmd
103 117
 
@@ -105,3 +119,20 @@ runBot botConfig' = withSocketsDo $ do
105 119
           fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
106 120
           fork $ eventProcessLoop eventChannel lineChan commandChan bot
107 121
           runIRC bot Connected (messageProcessLoop lineChan commandChan)
122
+
123
+runBot :: BotConfig -> IO ()
124
+runBot botConfig = do
125
+  -- setup signal handling
126
+  mainThreadId <- myThreadId
127
+  installHandler sigINT  (Catch $ throwTo mainThreadId UserInterrupt) Nothing
128
+  installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
129
+
130
+  -- setup logging
131
+  hSetBuffering stdout LineBuffering
132
+  hSetBuffering stderr LineBuffering
133
+  stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $
134
+                     setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
135
+  updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
136
+
137
+  -- run
138
+  runBotIntenal botConfig

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

@@ -60,18 +60,18 @@ lineParser BotConfig { .. } time line msgParts = flip Done msgParts . Message ti
60 60
               | otherwise         -> ChannelMsg user message
61 61
     _         -> OtherMsg source command target message
62 62
   where
63
-    splits          = words line
64
-    command         = splits !! 1
65
-    source          = drop 1 $ splits !! 0
66
-    target          = splits !! 2
67
-    message         = strip . drop 1 . unwords . drop 3 $ splits
68
-    quitMessage     = strip . drop 1 . unwords . drop 2 $ splits
69
-    user            = uncurry User . (Nick *** drop 1) . break (== '!') $ source
70
-    mode            = splits !! 3
71
-    modeArgs        = drop 4 splits
72
-    kicked          = splits !! 3
73
-    kickReason      = drop 1 . unwords . drop 4 $ splits
74
-    isActionMsg     = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
63
+    splits      = words line
64
+    command     = splits !! 1
65
+    source      = drop 1 $ splits !! 0
66
+    target      = splits !! 2
67
+    message     = strip . drop 1 . unwords . drop 3 $ splits
68
+    quitMessage = strip . drop 1 . unwords . drop 2 $ splits
69
+    user        = uncurry User . (Nick *** drop 1) . break (== '!') $ source
70
+    mode        = splits !! 3
71
+    modeArgs    = drop 4 splits
72
+    kicked      = splits !! 3
73
+    kickReason  = drop 1 . unwords . drop 4 $ splits
74
+    isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
75 75
 
76 76
 partitionMsgParts :: MessageParseType -> Text -> [MessagePart] -> ([MessagePart], [MessagePart])
77 77
 partitionMsgParts parserType target =
@@ -96,11 +96,13 @@ lineFromCommand :: BotConfig -> Command -> Maybe Text
96 96
 lineFromCommand BotConfig { .. } command = case command of
97 97
   PongCmd { .. }                  -> Just $ "PONG :" ++ rmsg
98 98
   PingCmd { .. }                  -> Just $ "PING :" ++ rmsg
99
-  NickCmd                         -> Just $ "NICK " ++ nickToText botNick
100
-  UserCmd                         -> Just $ "USER " ++ nickToText botNick ++ " 0 * :" ++ nickToText botNick
99
+  NickCmd                         -> Just $ "NICK " ++ botNick'
100
+  UserCmd                         -> Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
101 101
   JoinCmd                         -> Just $ "JOIN " ++ channel
102 102
   QuitCmd                         -> Just "QUIT"
103 103
   ChannelMsgReply { .. }          -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
104 104
   PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ rmsg
105 105
   NamesCmd                        -> Just $ "NAMES " ++ channel
106 106
   _                               -> Nothing
107
+  where
108
+    botNick' = nickToText botNick

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

@@ -27,17 +27,19 @@ module Network.IRC.Types
27 27
   , handleMessage
28 28
   , handleEvent
29 29
   , stopMsgHandler
30
-  , getHelp )
30
+  , getHelp
31
+  , MsgHandlerMaker )
31 32
 where
32 33
 
33 34
 import ClassyPrelude
34
-import Control.Monad.Base      (MonadBase)
35
-import Control.Monad.Reader    (ReaderT, MonadReader, runReaderT)
36
-import Control.Monad.State     (StateT, MonadState, execStateT)
37
-import Data.Configurator.Types (Config)
38
-import Data.Data               (Data)
39
-import Data.SafeCopy           (base, deriveSafeCopy)
40
-import Data.Typeable           (cast)
35
+import Control.Concurrent.Lifted (Chan)
36
+import Control.Monad.Base        (MonadBase)
37
+import Control.Monad.Reader      (ReaderT, MonadReader, runReaderT)
38
+import Control.Monad.State       (StateT, MonadState, execStateT)
39
+import Data.Configurator.Types   (Config)
40
+import Data.Data                 (Data)
41
+import Data.SafeCopy             (base, deriveSafeCopy)
42
+import Data.Typeable             (cast)
41 43
 
42 44
 import Network.IRC.Util
43 45
 
@@ -52,10 +54,10 @@ instance Show Nick where
52 54
 $(deriveSafeCopy 0 'base ''Nick)
53 55
 
54 56
 data User = Self | User { userNick :: !Nick, userServer :: !Text }
55
-            deriving (Show, Eq)
57
+            deriving (Show, Eq, Ord)
56 58
 
57 59
 data Message = Message { msgTime :: !UTCTime, msgLine :: !Text, msgDetails :: MessageDetails}
58
-               deriving (Show, Eq)
60
+               deriving (Show, Eq, Ord)
59 61
 
60 62
 data MessageDetails =
61 63
     IdleMsg
@@ -73,7 +75,7 @@ data MessageDetails =
73 75
   | KickMsg      { user      :: !User, kickedNick :: !Nick, msg       :: !Text }
74 76
   | ModeMsg      { user      :: !User, msgTarget  :: !Text, mode      :: !Text , modeArgs :: ![Text] }
75 77
   | OtherMsg     { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg      :: !Text }
76
-  deriving (Show, Eq)
78
+  deriving (Show, Eq, Ord)
77 79
 
78 80
 data Command =
79 81
     PingCmd         { rmsg  :: !Text }
@@ -85,11 +87,11 @@ data Command =
85 87
   | JoinCmd
86 88
   | QuitCmd
87 89
   | NamesCmd
88
-  deriving (Show, Eq)
90
+  deriving (Show, Eq, Ord)
89 91
 
92
+-- Events
90 93
 
91
-class (Typeable e, Show e) => Event e where
94
+class (Typeable e, Show e, Eq e) => Event e where
92 95
   toEvent :: e -> IO SomeEvent
93 96
   toEvent e = SomeEvent <$> pure e <*> getCurrentTime
94 97
 
@@ -98,30 +100,36 @@ class (Typeable e, Show e) => Event e where
98 100
     ev <- cast e
99 101
     return (ev, time)
100 102
 
101
-data SomeEvent = forall e. Event e => SomeEvent e UTCTime deriving (Typeable)
103
+data SomeEvent = forall e. (Event e, Typeable e) => SomeEvent e UTCTime deriving (Typeable)
102 104
 instance Show SomeEvent where
103 105
   show (SomeEvent e time) = formatTime defaultTimeLocale "[%F %T] " time ++ show e
106
+instance Eq SomeEvent where
107
+  SomeEvent e1 t1 == SomeEvent e2 t2 =
108
+    case cast e2 of
109
+      Just e2' -> e1 == e2' && t1 == t2
110
+      Nothing  -> False
104 111
 
105
-data QuitEvent = QuitEvent deriving (Show, Typeable)
112
+data QuitEvent = QuitEvent deriving (Show, Eq, Ord, Typeable)
106 113
 instance Event QuitEvent
107 114
 
108 115
 data EventResponse =  RespNothing
109 116
                     | RespEvent SomeEvent
110 117
                     | RespMessage Message
111 118
                     | RespCommand Command
112
-                    deriving (Show)
119
+                    deriving (Show, Eq)
113 120
 
114 121
 -- Bot
115 122
 
116 123
 type MsgHandlerName = Text
117 124
 
118
-data BotConfig = BotConfig { server         :: !Text
119
-                           , port           :: !Int
120
-                           , channel        :: !Text
121
-                           , botNick        :: !Nick
122
-                           , botTimeout     :: !Int
123
-                           , msgHandlerInfo :: !(Map MsgHandlerName (Map Text Text))
124
-                           , config         :: !Config }
125
+data BotConfig = BotConfig { server           :: !Text
126
+                           , port             :: !Int
127
+                           , channel          :: !Text
128
+                           , botNick          :: !Nick
129
+                           , botTimeout       :: !Int
130
+                           , msgHandlerInfo   :: !(Map MsgHandlerName (Map Text Text))
131
+                           , msgHandlerMakers :: ![MsgHandlerMaker]
132
+                           , config           :: !Config }
125 133
 
126 134
 instance Show BotConfig where
127 135
   show BotConfig { .. } = "server = "   ++ show server     ++ "\n" ++
@@ -135,15 +143,15 @@ data Bot = Bot { botConfig   :: !BotConfig
135 143
                , socket      :: !Handle
136 144
                , msgHandlers :: !(Map MsgHandlerName MsgHandler) }
137 145
 
138
-data BotStatus = Connected
139
-               | Disconnected
140
-               | Joined
141
-               | Kicked
142
-               | Errored
143
-               | Idle
144
-               | Interrupted
145
-               | NickNotAvailable
146
-               deriving (Show, Eq)
146
+data BotStatus =  Connected
147
+                | Disconnected
148
+                | Joined
149
+                | Kicked
150
+                | Errored
151
+                | Idle
152
+                | Interrupted
153
+                | NickNotAvailable
154
+                deriving (Show, Eq, Ord)
147 155
 
148 156
 newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }
149 157
                 deriving ( Functor
@@ -202,3 +210,5 @@ newMsgHandler = MsgHandler {
202 210
   onEvent   = const $ return RespNothing,
203 211
   onHelp    = return mempty
204 212
 }
213
+
214
+type MsgHandlerMaker = BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)

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

@@ -2,13 +2,13 @@
2 2
 
3 3
 module Network.IRC.Util where
4 4
 
5
-import qualified Data.Text.Lazy          as LzT
6 5
 import qualified Data.Text.Format        as TF
7 6
 
8 7
 import ClassyPrelude
9 8
 import Control.Arrow             (Arrow)
10 9
 import Control.Concurrent.Lifted (Chan)
11 10
 import Control.Monad.Base        (MonadBase)
11
+import Data.Convertible          (convert)
12 12
 import Data.Text                 (strip)
13 13
 import Data.Time                 (diffUTCTime)
14 14
 
@@ -49,7 +49,7 @@ atomicModIORef ref f = void . atomicModifyIORef' ref $ \v -> (f v, v)
49 49
 -- | Display a time span as one time relative to another.
50 50
 relativeTime :: UTCTime -> UTCTime -> Text
51 51
 relativeTime t1 t2 =
52
-  maybe "unknown" (LzT.toStrict . format) $ find (\(s,_,_) -> abs period >= s) ranges
52
+  maybe "unknown" (convert . format) $ find (\(s,_,_) -> abs period >= s) ranges
53 53
   where
54 54
     minute = 60; hour = minute * 60; day = hour * 24;
55 55
     week = day * 7; month = day * 30; year = month * 12

+ 13
- 9
hask-irc-core/hask-irc-core.cabal View File

@@ -54,22 +54,26 @@ library
54 54
                        DeriveDataTypeable
55 55
 
56 56
   build-depends:       base                 >=4.5     && <4.8,
57
-                       text                 >=0.11    && <0.12,
58
-                       mtl                  >=2.1     && <2.2,
59
-                       configurator         >=0.2     && <0.3,
60
-                       safecopy             >=0.8     && <0.9,
61
-                       time                 >=1.4     && <1.5,
62 57
                        classy-prelude       >=0.9     && <1.0,
63
-                       text-format          >=0.3     && <0.4,
64
-                       lifted-base          >=0.2     && <0.3,
58
+                       configurator         >=0.2     && <0.3,
59
+                       convertible          >=1.1     && <1.2,
65 60
                        hslogger             >=1.2     && <1.3,
66 61
                        hslogger-template    >=2.0     && <2.1,
67
-                       transformers-base    >=0.4     && <0.5
62
+                       lifted-base          >=0.2     && <0.3,
63
+                       mtl                  >=2.1     && <2.2,
64
+                       network              >=2.3     && <2.5,
65
+                       safecopy             >=0.8     && <0.9,
66
+                       text                 >=0.11    && <0.12,
67
+                       text-format          >=0.3     && <0.4,
68
+                       time                 >=1.4     && <1.5,
69
+                       transformers-base    >=0.4     && <0.5,
70
+                       unix                 >=2.7     && <2.8
68 71
 
69 72
   exposed-modules:     Network.IRC.Types,
70 73
                        Network.IRC.Protocol,
71 74
                        Network.IRC.Util,
72
-                       Network.IRC.Bot
75
+                       Network.IRC.Bot,
76
+                       Network.IRC.Client
73 77
 
74 78
   default-language:    Haskell2010
75 79
 

+ 11
- 26
hask-irc-handlers/Network/IRC/Handlers.hs View File

@@ -1,6 +1,4 @@
1
-{-# LANGUAGE FlexibleContexts #-}
2
-
3
-module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where
1
+module Network.IRC.Handlers (allMsgHandlerMakers) where
4 2
 
5 3
 import qualified Network.IRC.Handlers.Auth          as Auth
6 4
 import qualified Network.IRC.Handlers.Core          as Core
@@ -10,28 +8,15 @@ import qualified Network.IRC.Handlers.NickTracker   as NickTracker
10 8
 import qualified Network.IRC.Handlers.SongSearch    as SongSearch
11 9
 import qualified Network.IRC.Handlers.Tell          as Tell
12 10
 
13
-import ClassyPrelude
14
-import Control.Concurrent.Lifted  (Chan)
15
-
16 11
 import Network.IRC.Types
17 12
 
18
-coreMsgHandlerNames :: [Text]
19
-coreMsgHandlerNames = ["pingpong", "help"]
20
-
21
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
22
-mkMsgHandler botConfig eventChan name =
23
-  flip (`foldM` Nothing) handlerMakers $ \finalHandler handler ->
24
-    case finalHandler of
25
-      Just _  -> return finalHandler
26
-      Nothing -> handler botConfig eventChan name
27
-
28
-  where
29
-    handlerMakers = [
30
-        Auth.mkMsgHandler
31
-      , Core.mkMsgHandler
32
-      , Greet.mkMsgHandler
33
-      , Logger.mkMsgHandler
34
-      , NickTracker.mkMsgHandler
35
-      , SongSearch.mkMsgHandler
36
-      , Tell.mkMsgHandler
37
-      ]
13
+allMsgHandlerMakers :: [MsgHandlerMaker]
14
+allMsgHandlerMakers = [
15
+    Auth.mkMsgHandler
16
+  , Core.mkMsgHandler
17
+  , Greet.mkMsgHandler
18
+  , Logger.mkMsgHandler
19
+  , NickTracker.mkMsgHandler
20
+  , SongSearch.mkMsgHandler
21
+  , Tell.mkMsgHandler
22
+  ]

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

@@ -7,12 +7,11 @@ import qualified Data.UUID    as U
7 7
 import qualified Data.UUID.V4 as U
8 8
 
9 9
 import ClassyPrelude
10
-import Control.Concurrent.Lifted (Chan)
11
-import Control.Monad.Reader      (asks)
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)
10
+import Control.Monad.Reader (asks)
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)
16 15
 
17 16
 import Network.IRC.Handlers.Auth.Types
18 17
 import Network.IRC.Types
@@ -66,7 +65,7 @@ authEvent state event = case fromEvent event of
66 65
     return RespNothing
67 66
   _                                    -> return RespNothing
68 67
 
69
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
68
+mkMsgHandler :: MsgHandlerMaker
70 69
 mkMsgHandler BotConfig { .. } _ "auth" = do
71 70
   state <- io $ openLocalState emptyAuth >>= newIORef
72 71
   return . Just $ newMsgHandler { onMessage = authMessage state

+ 1
- 2
hask-irc-handlers/Network/IRC/Handlers/Auth/Types.hs View File

@@ -1,5 +1,4 @@
1 1
 {-# LANGUAGE DeriveDataTypeable #-}
2
-{-# LANGUAGE NoImplicitPrelude #-}
3 2
 {-# LANGUAGE TemplateHaskell #-}
4 3
 
5 4
 module Network.IRC.Handlers.Auth.Types where
@@ -18,7 +17,7 @@ emptyAuth = Auth mempty
18 17
 
19 18
 $(deriveSafeCopy 0 'base ''Auth)
20 19
 
21
-data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Typeable)
20
+data AuthEvent = AuthEvent Nick Token (MVar Bool) deriving (Eq, Typeable)
22 21
 
23 22
 instance Event AuthEvent
24 23
 

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

@@ -1,7 +1,6 @@
1 1
 module Network.IRC.Handlers.Core (mkMsgHandler) where
2 2
 
3 3
 import ClassyPrelude
4
-import Control.Concurrent.Lifted  (Chan)
5 4
 import Control.Monad.Reader       (ask)
6 5
 import Data.Convertible           (convert)
7 6
 import Data.Time                  (addUTCTime)
@@ -9,7 +8,7 @@ import Data.Time                  (addUTCTime)
9 8
 import Network.IRC.Types
10 9
 import Network.IRC.Util
11 10
 
12
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
11
+mkMsgHandler :: MsgHandlerMaker
13 12
 mkMsgHandler _ _ "pingpong" = do
14 13
   state <- getCurrentTime >>= newIORef
15 14
   return . Just $ newMsgHandler { onMessage = pingPong state }
@@ -44,11 +43,13 @@ help Message { msgDetails = ChannelMsg { .. }, .. }
44 43
   | "!help" == clean msg = do
45 44
       BotConfig { .. } <- ask
46 45
       let commands = concatMap mapKeys . mapValues $ msgHandlerInfo
47
-      return [ChannelMsgReply $ "I know these commands: " ++ unwords commands]
46
+      return [ ChannelMsgReply $ "I know these commands: " ++ unwords commands
47
+             , ChannelMsgReply "Type !help <command> to know more about any command"]
48 48
   | "!help" `isPrefixOf` msg = do
49 49
       BotConfig { .. } <- ask
50
-      let command = cons '!'. dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
51
-      let mHelp   = find ((== command) . fst) . concatMap mapToList . mapValues $ msgHandlerInfo
50
+      let command = dropWhile (== '!') . clean . unwords . drop 1 . words $ msg
51
+      let mHelp   = find ((\c -> c == command || c == cons '!' command) . fst)
52
+                    . concatMap mapToList . mapValues $ msgHandlerInfo
52 53
       return [ChannelMsgReply $ maybe ("No such command found: " ++ command) snd mHelp]
53 54
 
54 55
 help _ = return []

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

@@ -1,13 +1,12 @@
1 1
 module Network.IRC.Handlers.Greet (mkMsgHandler) where
2 2
 
3 3
 import ClassyPrelude
4
-import Control.Concurrent.Lifted  (Chan)
5
-import Control.Monad.Reader       (ask)
4
+import Control.Monad.Reader (ask)
6 5
 
7 6
 import Network.IRC.Types
8 7
 import Network.IRC.Util
9 8
 
10
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
9
+mkMsgHandler :: MsgHandlerMaker
11 10
 mkMsgHandler _ _ "greeter"  = return . Just $ newMsgHandler { onMessage = greeter }
12 11
 mkMsgHandler _ _ "welcomer" = return . Just $ newMsgHandler { onMessage = welcomer }
13 12
 mkMsgHandler _ _ _          = return Nothing

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

@@ -2,25 +2,24 @@
2 2
 
3 3
 module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where
4 4
 
5
-import qualified Data.Configurator       as C
5
+import qualified Data.Configurator       as CF
6 6
 import qualified Data.Text.Format        as TF
7 7
 import qualified Data.Text.Format.Params as TF
8 8
 
9
-import ClassyPrelude hiding      ((</>), (<.>), FilePath, log)
10
-import Control.Concurrent.Lifted (Chan)
11
-import Control.Exception.Lifted  (mask_)
12
-import Control.Monad.Reader      (ask)
13
-import Data.Time                 (diffDays)
14
-import System.Directory          (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
15
-import System.FilePath           (FilePath, (</>), (<.>))
16
-import System.IO                 (openFile, IOMode(..), hSetBuffering, BufferMode(..))
9
+import ClassyPrelude hiding     ((</>), (<.>), FilePath, log)
10
+import Control.Exception.Lifted (mask_)
11
+import Control.Monad.Reader     (ask)
12
+import Data.Time                (diffDays)
13
+import System.Directory         (createDirectoryIfMissing, getModificationTime, copyFile, removeFile)
14
+import System.FilePath          (FilePath, (</>), (<.>))
15
+import System.IO                (openFile, IOMode(..), hSetBuffering, BufferMode(..))
17 16
 
18 17
 import Network.IRC.Types
19 18
 import Network.IRC.Util
20 19
 
21 20
 type LoggerState = Maybe (Handle, Day)
22 21
 
23
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
22
+mkMsgHandler :: MsgHandlerMaker
24 23
 mkMsgHandler botConfig _ "messagelogger" = do
25 24
   state <- io $ newIORef Nothing
26 25
   initMessageLogger botConfig state
@@ -30,7 +29,7 @@ mkMsgHandler _ _ _                       = return Nothing
30 29
 
31 30
 getLogFilePath :: BotConfig -> IO FilePath
32 31
 getLogFilePath BotConfig { .. } = do
33
-  logFileDir <- C.require config "messagelogger.logdir"
32
+  logFileDir <- CF.require config "messagelogger.logdir"
34 33
   createDirectoryIfMissing True logFileDir
35 34
   return $ logFileDir </> unpack (channel ++ "-" ++ nickToText botNick) <.> "log"
36 35
 

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

@@ -8,16 +8,15 @@ import qualified Data.IxSet        as IS
8 8
 import qualified Data.UUID         as U
9 9
 import qualified Data.UUID.V4      as U
10 10
 
11
-import ClassyPrelude hiding      (swap)
12
-import Control.Concurrent.Lifted (Chan)
13
-import Control.Monad.Reader      (ask)
14
-import Control.Monad.State       (get, put)
15
-import Data.Acid                 (AcidState, Query, Update, makeAcidic, query, update,
16
-                                  openLocalState, createArchive)
17
-import Data.Acid.Local           (createCheckpointAndClose)
18
-import Data.Convertible          (convert)
19
-import Data.IxSet                (getOne, (@=))
20
-import Data.Time                 (addUTCTime, NominalDiffTime)
11
+import ClassyPrelude hiding (swap)
12
+import Control.Monad.Reader (ask)
13
+import Control.Monad.State  (get, put)
14
+import Data.Acid            (AcidState, Query, Update, makeAcidic, query, update,
15
+                             openLocalState, createArchive)
16
+import Data.Acid.Local      (createCheckpointAndClose)
17
+import Data.Convertible     (convert)
18
+import Data.IxSet           (getOne, (@=))
19
+import Data.Time            (addUTCTime, NominalDiffTime)
21 20
 
22 21
 import Network.IRC.Handlers.NickTracker.Types
23 22
 import Network.IRC.Types
@@ -187,7 +186,7 @@ stopNickTracker state = io $ do
187 186
   createArchive acid
188 187
   createCheckpointAndClose acid
189 188
 
190
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
189
+mkMsgHandler :: MsgHandlerMaker
191 190
 mkMsgHandler BotConfig { .. } _ "nicktracker" = do
192 191
   state <- io $ do
193 192
     now             <- getCurrentTime

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

@@ -10,7 +10,8 @@ import Data.SafeCopy             (base, deriveSafeCopy)
10 10
 
11 11
 import Network.IRC.Types
12 12
 
13
-newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeable)
13
+newtype CanonicalNick = CanonicalNick { canonicalNickToText :: Text }
14
+                        deriving (Eq, Ord, Show, Data, Typeable)
14 15
 newtype LastSeenOn    = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
15 16
 
16 17
 data NickTrack = NickTrack {
@@ -37,7 +38,7 @@ $(deriveSafeCopy 0 'base ''NickTracking)
37 38
 emptyNickTracking :: NickTracking
38 39
 emptyNickTracking = NickTracking empty
39 40
 
40
-data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Typeable)
41
+data NickTrackRequest = NickTrackRequest Nick (MVar (Maybe NickTrack)) deriving (Eq, Typeable)
41 42
 
42 43
 instance Event NickTrackRequest
43 44
 
@@ -46,7 +47,7 @@ instance Show NickTrackRequest where
46 47
 
47 48
 getCanonicalNick :: Chan SomeEvent -> Nick -> IO (Maybe CanonicalNick)
48 49
 getCanonicalNick eventChan nick = do
49
-  reply <- newEmptyMVar
50
+  reply   <- newEmptyMVar
50 51
   request <- toEvent $ NickTrackRequest nick reply
51 52
   writeChan eventChan request
52 53
   map (map canonicalNick) $ takeMVar reply

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

@@ -7,21 +7,20 @@ import qualified Data.Configurator as CF
7 7
 import qualified System.Log.Logger as HSL
8 8
 
9 9
 import ClassyPrelude
10
-import Control.Concurrent.Lifted (Chan)
11
-import Control.Exception.Lifted  (evaluate)
12
-import Control.Monad.Reader      (ask)
13
-import Data.Aeson                (FromJSON, parseJSON, Value (..), (.:))
14
-import Data.Aeson.Types          (emptyArray)
15
-import Data.Text                 (strip)
16
-import Network.Curl.Aeson        (curlAesonGet, CurlAesonException)
17
-import Network.HTTP.Base         (urlEncode)
18
-import System.Log.Logger.TH      (deriveLoggers)
10
+import Control.Exception.Lifted (evaluate)
11
+import Control.Monad.Reader     (ask)
12
+import Data.Aeson               (FromJSON, parseJSON, Value (..), (.:))
13
+import Data.Aeson.Types         (emptyArray)
14
+import Data.Text                (strip)
15
+import Network.Curl.Aeson       (curlAesonGet, CurlAesonException)
16
+import Network.HTTP.Base        (urlEncode)
17
+import System.Log.Logger.TH     (deriveLoggers)
19 18
 
20 19
 import Network.IRC.Types
21 20
 
22 21
 $(deriveLoggers "HSL" [HSL.ERROR])
23 22
 
24
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
23
+mkMsgHandler :: MsgHandlerMaker
25 24
 mkMsgHandler _ _ "songsearch" =
26 25
   return . Just $ newMsgHandler { onMessage = songSearch,
27 26
                                   onHelp    = return $ singletonMap "!m" helpMsg }

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

@@ -21,6 +21,8 @@ import Network.IRC.Handlers.Tell.Types
21 21
 import Network.IRC.Types
22 22
 import Network.IRC.Util
23 23
 
24
+-- database
25
+
24 26
 getUndeliveredTellsQ :: CanonicalNick -> Query Tells [Tell]
25 27
 getUndeliveredTellsQ nick = do
26 28
   Tells { .. } <- ask
@@ -41,6 +43,8 @@ getUndeliveredTells acid = query acid . GetUndeliveredTellsQ
41 43
 saveTell :: AcidState Tells -> Tell -> IO ()
42 44
 saveTell acid = update acid . SaveTellQ
43 45
 
46
+-- handler
47
+
44 48
 newtype TellState = TellState { acid :: AcidState Tells }
45 49
 
46 50
 tellMsg :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> Message ->  m [Command]
@@ -50,10 +54,9 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
50 54
   , length args >= 2             = io $ do
51 55
       TellState { .. } <- readIORef state
52 56
       reps <- if "<" `isPrefixOf` headEx args
53
-        then do
57
+        then do -- multi tell
54 58
           let (nicks, message) =
55 59
                 (parseNicks *** (strip . drop 1)) . break (== '>') . drop 1 . unwords $ args
56
-
57 60
           if null message
58 61
             then return []
59 62
             else do
@@ -63,7 +66,7 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
63 66
                            (if null passes then [] else
64 67
                               ["Message noted and will be passed on to " ++ intercalate ", " passes])
65 68
               return reps
66
-        else do
69
+        else do -- single tell
67 70
           let nick = Nick . headEx $ args
68 71
           let message = strip . unwords . drop 1 $ args
69 72
           if null message
@@ -91,7 +94,7 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
91 94
 
92 95
     getTellsToDeliver = io $ do
93 96
       TellState { .. } <- readIORef state
94
-      mcn <- getCanonicalNick eventChan $ userNick user
97
+      mcn              <- getCanonicalNick eventChan $ userNick user
95 98
       case mcn of
96 99
         Nothing            -> return []
97 100
         Just canonicalNick -> do
@@ -109,21 +112,29 @@ tellMsg eventChan state Message { msgDetails = ChannelMsg { .. }, .. }
109 112
 
110 113
 tellMsg _ _ _ = return []
111 114
 
115
+tellEvent :: MonadMsgHandler m => Chan SomeEvent -> IORef TellState -> SomeEvent -> m EventResponse
116
+tellEvent eventChan state event = case fromEvent event of
117
+  Just (TellRequest user message, evTime) -> do
118
+    tellMsg eventChan state . Message evTime "" $ ChannelMsg user message
119
+    return RespNothing
120
+  _                                       -> return RespNothing
121
+
112 122
 stopTell :: MonadMsgHandler m => IORef TellState -> m ()
113 123
 stopTell state = io $ do
114 124
   TellState { .. } <- readIORef state
115 125
   createArchive acid
116 126
   createCheckpointAndClose acid
117 127
 
118
-mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
128
+mkMsgHandler :: MsgHandlerMaker
119 129
 mkMsgHandler BotConfig { .. } eventChan "tells" = do
120
-  acid <- openLocalState emptyTells
130
+  acid  <- openLocalState emptyTells
121 131
   state <- newIORef (TellState acid)
122 132
   return . Just $ newMsgHandler { onMessage = tellMsg eventChan state
133
+                                , onEvent   = tellEvent eventChan state
123 134
                                 , onStop    = stopTell state
124 135
                                 , onHelp    = return helpMsgs }
125 136
   where
126 137
     helpMsgs = mapFromList [
127 138
       ("!tell", "Publically passes a message to a user or a bunch of users. " ++
128
-                "!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>") ]
139
+                "!tell <nick> <message> or !tell <<nick1> <nick2> ...> <message>.") ]
129 140
 mkMsgHandler _ _ _                            = return Nothing

+ 15
- 4
hask-irc-handlers/Network/IRC/Handlers/Tell/Types.hs View File

@@ -1,13 +1,13 @@
1 1
 {-# LANGUAGE DeriveDataTypeable #-}
2
-{-# LANGUAGE NoImplicitPrelude #-}
3 2
 {-# LANGUAGE TemplateHaskell #-}
4 3
 
5 4
 module Network.IRC.Handlers.Tell.Types where
6 5
 
7 6
 import ClassyPrelude
8
-import Data.Data      (Data)
9
-import Data.IxSet     (IxSet, Indexable (..), ixSet, ixFun)
10
-import Data.SafeCopy  (base, deriveSafeCopy)
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)
11 11
 
12 12
 import Network.IRC.Handlers.NickTracker.Types
13 13
 import Network.IRC.Types
@@ -41,3 +41,14 @@ $(deriveSafeCopy 0 'base ''Tells)
41 41
 
42 42
 emptyTells :: Tells
43 43
 emptyTells = Tells (TellId 1) empty
44
+
45
+data TellRequest = TellRequest User Text deriving (Eq, Typeable)
46
+
47
+instance Event TellRequest
48
+
49
+instance Show TellRequest where
50
+  show (TellRequest user tell) =
51
+    "TellRequest[" ++ unpack (nickToText (userNick user) ++ ": " ++ tell) ++ "]"
52
+
53
+sendTell :: Chan SomeEvent -> User -> Text -> IO ()
54
+sendTell eventChan user tell = toEvent (TellRequest user tell) >>= writeChan eventChan

+ 11
- 11
hask-irc-handlers/hask-irc-handlers.cabal View File

@@ -55,24 +55,24 @@ library
55 55
 
56 56
   build-depends:       base                 >=4.5     && <4.8,
57 57
                        hask-irc-core        ==0.1.0,
58
-                       text                 >=0.11    && <0.12,
59
-                       mtl                  >=2.1     && <2.2,
60
-                       configurator         >=0.2     && <0.3,
61
-                       time                 >=1.4     && <1.5,
62
-                       curl-aeson           >=0.0.3   && <0.1,
58
+                       acid-state           >=0.12    && <0.13,
63 59
                        aeson                >=0.6.0.0 && <0.7,
64
-                       HTTP                 >=4000    && <5000,
65 60
                        classy-prelude       >=0.9     && <1.0,
66
-                       text-format          >=0.3     && <0.4,
67
-                       filepath             >=1.3     && <1.4,
68
-                       directory            >=1.2     && <1.3,
69
-                       lifted-base          >=0.2     && <0.3,
61
+                       configurator         >=0.2     && <0.3,
70 62
                        convertible          >=1.1     && <1.2,
63
+                       curl-aeson           >=0.0.3   && <0.1,
64
+                       directory            >=1.2     && <1.3,
65
+                       filepath             >=1.3     && <1.4,
71 66
                        hslogger             >=1.2     && <1.3,
72 67
                        hslogger-template    >=2.0     && <2.1,
68
+                       HTTP                 >=4000    && <5000,
73 69
                        ixset                >=1.0     && <1.1,
74
-                       acid-state           >=0.12    && <0.13,
70
+                       lifted-base          >=0.2     && <0.3,
71
+                       mtl                  >=2.1     && <2.2,
75 72
                        safecopy             >=0.8     && <0.9,
73
+                       text                 >=0.11    && <0.12,
74
+                       text-format          >=0.3     && <0.4,
75
+                       time                 >=1.4     && <1.5,
76 76
                        uuid                 >=1.3     && <1.4
77 77
 
78 78
   exposed-modules:     Network.IRC.Handlers,

+ 50
- 3
hask-irc-runner/Main.hs View File

@@ -1,8 +1,55 @@
1
+{-# LANGUAGE OverlappingInstances #-}
2
+
1 3
 module Main where
2 4
 
3
-import qualified Network.IRC.Runner as Runner
5
+import qualified Data.Configurator as CF
6
+
7
+import ClassyPrelude hiding    (getArgs)
8
+import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
9
+import System.Environment      (getArgs, getProgName)
10
+import System.Exit             (exitFailure)
4 11
 
5
-import Prelude
12
+import Network.IRC.Client
13
+import Network.IRC.Handlers
14
+import Network.IRC.Types
15
+
16
+instance Configured a => Configured [a] where
17
+  convert (List xs) = Just . mapMaybe convert $ xs
18
+  convert _ = Nothing
6 19
 
7 20
 main :: IO ()
8
-main = Runner.run
21
+main = do
22
+  -- get args
23
+  args <- getArgs
24
+  prog <- getProgName
25
+
26
+  when (length args < 1) $ do
27
+    putStrLn $ "Usage: " ++ pack prog ++ " <config file path>"
28
+    exitFailure
29
+
30
+  -- load config and start the bot
31
+  let configFile = headEx args
32
+  loadBotConfig configFile >>= runBot
33
+
34
+loadBotConfig :: String -> IO BotConfig
35
+loadBotConfig configFile = do
36
+  eCfg <- try $ CF.load [CF.Required configFile]
37
+  case eCfg of
38
+    Left (ParseError _ _) -> error "Error while loading config"
39
+    Right cfg             -> do
40
+      eBotConfig <- try $ do
41
+        handlers :: [Text] <- CF.require cfg "msghandlers"
42
+        let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
43
+        BotConfig                          <$>
44
+          CF.require cfg "server"          <*>
45
+          CF.require cfg "port"            <*>
46
+          CF.require cfg "channel"         <*>
47
+          (Nick <$> CF.require cfg "nick") <*>
48
+          CF.require cfg "timeout"         <*>
49
+          pure handlerInfo                 <*>
50
+          pure allMsgHandlerMakers         <*>
51
+          pure cfg
52
+
53
+      case eBotConfig of
54
+        Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
55
+        Right botConf     -> return botConf

+ 0
- 71
hask-irc-runner/Network/IRC/Runner.hs View File

@@ -1,71 +0,0 @@
1
-{-# LANGUAGE OverlappingInstances #-}
2
-
3
-module Network.IRC.Runner (run) where
4
-
5
-import qualified Data.Configurator as CF
6
-
7
-import ClassyPrelude hiding      (getArgs)
8
-import Control.Concurrent.Lifted (myThreadId)
9
-import Control.Exception.Lifted  (throwTo, AsyncException (UserInterrupt))
10
-import Data.Configurator.Types   (Configured (..), Value (List), ConfigError (..), KeyError (..))
11
-import System.Environment        (getArgs, getProgName)
12
-import System.Exit               (exitFailure)
13
-import System.Log.Formatter      (tfLogFormatter)
14
-import System.Log.Handler        (setFormatter)
15
-import System.Log.Handler.Simple (streamHandler)
16
-import System.Log.Logger         (Priority (..), updateGlobalLogger, rootLoggerName,
17
-                                  setHandlers, setLevel)
18
-import System.Posix.Signals      (installHandler, sigINT, sigTERM, Handler (Catch))
19
-
20
-import Network.IRC.Types
21
-import Network.IRC.Client
22
-
23
-instance Configured a => Configured [a] where
24
-  convert (List xs) = Just . mapMaybe convert $ xs
25
-  convert _ = Nothing
26
-
27
-run :: IO ()
28
-run = do
29
-  -- get args
30
-  args <- getArgs
31
-  prog <- getProgName
32
-
33
-  when (length args < 1) $ do
34
-    putStrLn $ "Usage: " ++ pack prog ++ " <config file path>"
35
-    exitFailure
36
-
37
-  -- setup signal handling
38
-  mainThreadId <- myThreadId
39
-  installHandler sigINT  (Catch $ throwTo mainThreadId UserInterrupt) Nothing
40
-  installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
41
-
42
-  -- setup logging
43
-  stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $
44
-                     setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
45
-  updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
46
-
47
-  -- load config and start the bot
48
-  let configFile = headEx args
49
-  loadBotConfig configFile >>= runBot
50
-
51
-loadBotConfig :: String -> IO BotConfig
52
-loadBotConfig configFile = do
53
-  eCfg <- try $ CF.load [CF.Required configFile]
54
-  case eCfg of
55
-    Left (ParseError _ _) -> error "Error while loading config"
56
-    Right cfg             -> do
57
-      eBotConfig <- try $ do
58
-        handlers :: [Text] <- CF.require cfg "msghandlers"
59
-        let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
60
-        BotConfig                          <$>
61
-          CF.require cfg "server"          <*>
62
-          CF.require cfg "port"            <*>
63
-          CF.require cfg "channel"         <*>
64
-          (Nick <$> CF.require cfg "nick") <*>
65
-          CF.require cfg "timeout"         <*>
66
-          pure handlerInfo                 <*>
67
-          pure cfg
68
-
69
-      case eBotConfig of
70
-        Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
71
-        Right botConf     -> return botConf

+ 2
- 7
hask-irc-runner/hask-irc-runner.cabal View File

@@ -63,13 +63,8 @@ executable hask-irc
63 63
   build-depends:       base                 >=4.5     && <4.8,
64 64
                        hask-irc-core        ==0.1.0,
65 65
                        hask-irc-handlers    ==0.1.0,
66
-                       configurator         >=0.2     && <0.3,
67 66
                        classy-prelude       >=0.9     && <1.0,
68
-                       network              >=2.3     && <2.5,
69
-                       lifted-base          >=0.2     && <0.3,
70
-                       unix                 >=2.7     && <2.8,
71
-                       hslogger             >=1.2     && <1.3,
72
-                       hslogger-template    >=2.0     && <2.1
67
+                       configurator         >=0.2     && <0.3
73 68
 
74 69
   -- Directories containing source files.
75 70
   -- hs-source-dirs:
@@ -77,5 +72,5 @@ executable hask-irc
77 72
   -- Base language which the package is written in.
78 73
   default-language:    Haskell2010
79 74
 
80
-  ghc-options:         -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans
75
+  ghc-options:         -O2 -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans
81 76
 

Loading…
Cancel
Save