写了一个 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 的感觉，伴随着曾经的记忆。