一个用 Haskell 实现的 IRC Bot
An IRC bot written in Haskell
2010-12-12 2012-01-22
所租的房子没网。因不常在家,便用着 15€/GB 的 O2 上网卡。 流量不足以正常看网页,于是上 IRC 吹水成为了查文献外的主要沖浪活动。

写了一个 IRC Bot 供大家娱乐。 代码如下:

  1 import System.IO hiding (hPutStr, putStrLn, hGetLine)
  2 import System.IO.UTF8 hiding (putStrLn)
  3 import qualified System.IO.Error as E
  4 import Data.List
  5 import Control.Concurrent
  6 import Control.Monad.Reader
  7 import Network
  8 import System.Exit
  9 import System.Console.Haskeline
 10 import Data.Maybe
 11 import System.Random
 12 
 13 data Bot = Bot {
 14      server   :: String,
 15      port     :: Int,
 16      channel  :: String,
 17      nick     :: String,
 18      username :: String,
 19      realname :: String
 20 }
 21 
 22 data BotContext = BotContext {
 23      botInfo    :: Bot,
 24      netHandle  :: Handle
 25 }
 26 
 27 
 28 
 29 runBot :: Bot -> IO()
 30 runBot bot = do
 31        h <- connectTo (server bot) (PortNumber (fromIntegral (port bot)))
 32        hSetBuffering h NoBuffering
 33        let botContext = BotContext bot h
 34        forkIO $ runReaderT (loop isLiving) botContext
 35        E.try $ flip runReaderT botContext $ do
 36            loginBot
 37            lift $ forkIO $ runReaderT (loop cmd) botContext
 38            loop event
 39        return ()
 40        where loop x = x >> loop x
 41 
 42 {- active ping to keep live, if the Handle is broken,
 43  - the programm will fail to run, and exits automatically  -}
 44 isLiving :: ReaderT BotContext IO ()
 45 isLiving = do
 46            lift $ threadDelay 180000000 -- 180.000.000 µs = 3 Min
 47            msg $ "PING :test"
 48 
 49 
 50 loginBot :: ReaderT BotContext IO ()
 51 loginBot = do
 52        bot <- ask >>= return.botInfo
 53        msg $ "NICK " ++ (nick bot)
 54        msg $ "USER " ++ (username bot) ++ " 0 * :" ++ (realname bot)
 55        msg $ "JOIN " ++ (channel bot)
 56 
 57 
 58 msg :: String -> ReaderT BotContext IO ()
 59 msg x = do
 60         h <- ask >>= return.netHandle
 61         lift $ hPutStr h $ x ++ "\r\n"
 62         lift $ putStrLn $ ">>" ++ x
 63 
 64 
 65 privmsg :: String -> ReaderT BotContext IO ()
 66 privmsg x = do
 67         bot <- ask >>= return.botInfo
 68         msg $ "PRIVMSG " ++ (channel bot) ++ " :" ++ x
 69 
 70 
 71 ircGetLine :: ReaderT BotContext IO String
 72 ircGetLine = ask >>= return.netHandle >>= lift . hGetLine
 73 
 74 
 75 cmd :: ReaderT BotContext IO ()
 76 cmd = do
 77       -- mbl <- fmap Just $ lift getLine {- for Debug -}
 78       mbl <- lift $ readline "%"
 79       case mbl of
 80         Nothing -> return ()
 81         Just l  -> token l
 82       where
 83         token l | "/quit" `isPrefixOf` l
 84                   = do
 85                     msg $ "QUIT :" ++ (drop 6 l) ++ "\r\n"
 86                     h <- ask >>= return.netHandle
 87                     lift $ hClose h
 88                     lift $ exitSuccess
 89                 | "/join" `isPrefixOf` l = msg $ "JOIN " ++ (drop 6 l) ++ "\r\n"
 90                   {- with ' ' in tail,  prevent it
 91                      to be a prefix of other commands -}
 92                 | "/a " `isPrefixOf` l = privmsg $ '\001':(drop 4 l)
 93                                                    ++ "\001\r\n"
 94                 | "/id " `isPrefixOf` l = msg $ (drop 5 l) ++ "\r\n"
 95                 | spaceStr l = return ()
 96                 | (not $ null l) && head l == '/'  = return ()
 97                 | otherwise = privmsg $ l ++ "\r\n"
 98         spaceStr = null . dropWhile isSpace'
 99 
100 {- due to some UTF8 Error @ Data.Char.isSpace -}
101 isSpace' :: Char -> Bool
102 isSpace' ' '  = True
103 isSpace' '\t' = True
104 isSpace' '\r' = True
105 isSpace' '\n' = True
106 isSpace'  _   = False
107 
108 
109 event :: ReaderT BotContext IO ()
110 event = do
111         t <- ircGetLine
112         lift $ putStrLn t
113         if "PING :" `isPrefixOf` t
114           then msg $ "PONG :" ++ drop 6 t
115           else when ("PRIVMSG" `isInfixOf` t) $ do
116                  let t' = safeTail $ dropWhile (/= ':') $ safeTail t
117                      w = replyName t
118                  r <- privateAnswer w t'
119                  d <- lift $ dice 50 {- 1D50 -}
120                  when (isNothing r && d <= 10 ) $ react w t' >> return ()
121         where
122               safeTail [] = []
123               safeTail (_:xs) = xs
124 
125               {- do not want to wrapp StateT any more -}
126               {- dice :: Int -> IO (Int) -- 1Dx -}
127               dice ma = getStdRandom (randomR (1,ma)) :: IO (Int)
128 
129               replyName t = takeWhile (/= '!') $ safeTail t
130 
131               reply w x = do
132                           privmsg $ w ++ (':' : ' ' : x)
133                           return $ Just x
134               -- replyD w x = do {- reply with Delay :: ReaderT IO()-}
135                           -- sec <- lift $ getStdRandom (randomR (5,10))
136                           -- lift $ threadDelay $ sec*1000000
137                           -- privmsg $ w ++ (':' : ' ' : x)
138                           -- return $ Just x
139 
140               privateAnswer w t = do
141                       i <- ask >>= return.nick.botInfo
142                       if (i `isInfixOf` t)
143                          then reactPriv i w t
144                               >>= \r ->
145                                if isNothing r
146                                  then return Nothing -- reply w ":D"
147                                  else return r
148                          else return Nothing
149               {- reactPriv :: My_Nick -> Who -> Text -> Maybe String -}
150               reactPriv i w t
151                     | "你是谁" `isInfixOf` t = reply w $ "我是" ++ i
152                     | "机器人" `isInfixOf` t ||
153                       ("bot" `isInfixOf` t && not ("bot" `isInfixOf` i))
154                                              = reply w "嘘!小样你知道的太多了"
155                     | otherwise = react w t
156               react w t
157                     | "谁" `isInfixOf` t = reply w "我"
158                     | "有没有" `isInfixOf` t = reply w "没有"
159                     | "是不是" `isInfixOf` t = reply w "不是"
160                     | "要不要" `isInfixOf` t = reply w "不要"
161                     | "能不能" `isInfixOf` t = reply w "不能"
162                     | "如何" `isInfixOf` t = reply w "不知道"
163                     | "为什么" `isInfixOf` t = reply w "不为什么"
164                     | "为何" `isInfixOf` t = reply w "不为何"
165                     | "大家好" `isInfixOf` t = reply w "你好"
166                     | "你好" `isInfixOf` t = reply w "你好"
167                     | "吧" `isInfixOf` t = reply w "嗯"
168                     | "在吗" `isInfixOf` t = reply w "不在"
169                     | "为啥" `isInfixOf` t = reply w "不为啥"
170                     | isQuestion t = answer w t
171                     | otherwise = return Nothing
172 
173 
174               isQuestion t = "?" `isInfixOf` t
175                           || "?" `isInfixOf` t
176                           || "吗" `isInfixOf` t
177 
178               {- antwortet nur wenn es sicher eine Frage ist -}
179               answer w t
180                     | "conky" `isInfixOf` t = reply w "不用conky"
181                     | "fvwm" `isInfixOf` t = reply w "不用fvwm"
182                     | "emacs" `isInfixOf` t = reply w "不用emacs"
183                     | "grub2" `isInfixOf` t = reply w "不用grub2"
184                     | "python" `isInfixOf` t = reply w "不用python"
185                     | "有人" `isInfixOf` t = privmsg "<----" >>
186                                              return (Just "<----")
187                     | "知道" `isInfixOf` t = reply w "不知道"
188                     | "需要" `isInfixOf` t = reply w "不需要"
189                     | "明白" `isInfixOf` t = reply w "不明白"
190                     | "听说" `isInfixOf` t = reply w "没听说"
191                     | "了解" `isInfixOf` t = reply w "不了解"
192                     | "熟悉" `isInfixOf` t = reply w "不熟悉"
193                     | "会用" `isInfixOf` t = reply w "不会"
194                     | "可以" `isInfixOf` t = reply w "可以"
195                     | "什么" `isInfixOf` t = reply w "不知道"
196                     | "怎么" `isInfixOf` t = reply w "不知道"
197                     | "怎样" `isInfixOf` t = reply w "不知道"
198                     | "懂" `isInfixOf` t = reply w "不懂"
199                     | "能" `isInfixOf` t = reply w "不能"
200                     | "会" `isInfixOf` t = reply w "不会"
201                     | "是" `isInfixOf` t = reply w "不是"
202                     | "有" `isInfixOf` t = reply w "没有"
203                     | "要" `isInfixOf` t = reply w "不要"
204                     | otherwise = return Nothing
205 
206 
207 main = runBot $ Bot {
208                     server   = "irc.freenode.org",
209                     port     = 6667,
210                     channel  = "#channel",
211                     nick     = "nickname",
212                     username = "username",
213                     realname = "realname"
214                 }
215 
216 
217 readline :: String -> IO (Maybe String)
218 readline = runInputT defaultSettings . getInputLine

有一种写 MUD 的感觉,伴随着曾经的记忆。