gistfile1.hs

import System.IO hiding (hPutStr, putStrLn, hGetLine)
import System.IO.UTF8 hiding (putStrLn)
import qualified System.IO.Error as E
import Data.List
import Control.Concurrent
import Control.Monad.Reader
import Network
import System.Exit
import System.Console.Haskeline
import Data.Maybe
import System.Random

data Bot = Bot {
     server   :: String,
     port     :: Int,
     channel  :: String,
     nick     :: String,
     username :: String,
     realname :: String
}

data BotContext = BotContext {
     botInfo    :: Bot,
     netHandle  :: Handle
}



runBot :: Bot -> IO()
runBot bot = do
       h <- connectTo (server bot) (PortNumber (fromIntegral (port bot)))
       hSetBuffering h NoBuffering
       let botContext = BotContext bot h
       forkIO $ runReaderT (loop isLiving) botContext
       E.try $ flip runReaderT botContext $ do
           loginBot
           lift $ forkIO $ runReaderT (loop cmd) botContext
           loop event
       return ()
       where loop x = x >> loop x

{- active ping to keep live, if the Handle is broken,
 - the programm will fail to run, and exit automatic  -}
isLiving :: ReaderT BotContext IO ()
isLiving = do
           lift $ threadDelay 180000000 -- 180.000.000 µs = 3 Min
           msg $ "PING :test"


loginBot :: ReaderT BotContext IO ()
loginBot = do
       bot <- ask >>= return.botInfo
       msg $ "NICK " ++ (nick bot)
       msg $ "USER " ++ (username bot) ++ " 0 * :" ++ (realname bot)
       msg $ "JOIN " ++ (channel bot)


msg :: String -> ReaderT BotContext IO ()
msg x = do
        h <- ask >>= return.netHandle
        lift $ hPutStr h $ x ++ "\r\n"
        lift $ putStrLn $ ">>" ++ x


privmsg :: String -> ReaderT BotContext IO ()
privmsg x = do
        bot <- ask >>= return.botInfo
        msg $ "PRIVMSG " ++ (channel bot) ++ " :" ++ x


ircGetLine :: ReaderT BotContext IO String
ircGetLine = ask >>= return.netHandle >>= lift . hGetLine


cmd :: ReaderT BotContext IO ()
cmd = do
      -- mbl <- fmap Just $ lift getLine {- for Debug -}
      mbl <- lift $ readline "%"
      case mbl of
        Nothing -> return ()
        Just l  -> token l
      where
        token l | "/quit" `isPrefixOf` l
                  = do
                    msg $ "QUIT :" ++ (drop 6 l) ++ "\r\n"
                    h <- ask >>= return.netHandle
                    lift $ hClose h
                    lift $ exitSuccess
                | "/join" `isPrefixOf` l = msg $ "JOIN " ++ (drop 6 l) ++ "\r\n"
                  {- with ' ' in tail,  prevent it
                     to be a prefix of other commands -}
                | "/a " `isPrefixOf` l = privmsg $ '\001':(drop 4 l)
                                                   ++ "\001\r\n"
                | "/id " `isPrefixOf` l = msg $ (drop 5 l) ++ "\r\n"
                | spaceStr l = return ()
                | (not $ null l) && head l == '/'  = return ()
                | otherwise = privmsg $ l ++ "\r\n"
        spaceStr = null . dropWhile isSpace'

{- due to some UTF8 Error @ Data.Char.isSpace -}
isSpace' :: Char -> Bool
isSpace' ' '  = True
isSpace' '\t' = True
isSpace' '\r' = True
isSpace' '\n' = True
isSpace'  _   = False


event :: ReaderT BotContext IO ()
event = do
        t <- ircGetLine
        lift $ putStrLn t
        if "PING :" `isPrefixOf` t
          then msg $ "PONG :" ++ drop 6 t
          else when ("PRIVMSG" `isInfixOf` t) $ do
                 let t' = safeTail $ dropWhile (/= ':') $ safeTail t
                     w = replyName t
                 r <- privateAnswer w t'
                 d <- lift $ dice 100 {- 1D100 -}
                 when (isNothing r && d <= 10 ) $ react w t' >> return ()
        where
              safeTail [] = []
              safeTail (_:xs) = xs

              {- do not want to wrapp StateT any more -}
              {- dice :: Int -> IO (Int) -- 1Dx -}
              dice ma = getStdRandom (randomR (1,ma)) :: IO (Int)

              replyName t = takeWhile (/= '!') $ safeTail t

              reply w x = do
                          privmsg $ w ++ (':' : ' ' : x)
                          return $ Just x
              -- replyD w x = do {- reply with Delay :: ReaderT IO()-}
                          -- sec <- lift $ getStdRandom (randomR (5,10))
                          -- lift $ threadDelay $ sec*1000000
                          -- privmsg $ w ++ (':' : ' ' : x)
                          -- return $ Just x

              privateAnswer w t = do
                      i <- ask >>= return.nick.botInfo
                      if (i `isInfixOf` t)
                         then reactPriv i w t
                              >>= \r ->
                               if isNothing r
                                 then return Nothing -- reply w ":D"
                                 else return r
                         else return Nothing
              {- reactPriv :: My_Nick -> Who -> Text -> Maybe String -}
              reactPriv i w t
                    | "你是谁" `isInfixOf` t = reply w $ "我是" ++ i
                    | "机器人" `isInfixOf` t ||
                      ("bot" `isInfixOf` t && not ("bot" `isInfixOf` i))
                                             = reply w "嘘！小样你知道的太多了"
                    | otherwise = react w t
              react w t
                    | "谁" `isInfixOf` t = reply w "我"
                    | "有没有" `isInfixOf` t = reply w "没有"
                    | "是不是" `isInfixOf` t = reply w "不是"
                    | "要不要" `isInfixOf` t = reply w "不要"
                    | "能不能" `isInfixOf` t = reply w "不能"
                    | "如何" `isInfixOf` t = reply w "不知道"
                    | "为什么" `isInfixOf` t = reply w "不为什么"
                    | "为何" `isInfixOf` t = reply w "不为何"
                    | "大家好" `isInfixOf` t = reply w "你好"
                    | "你好" `isInfixOf` t = reply w "你好"
                    | "吧" `isInfixOf` t = reply w "嗯"
                    | "在吗" `isInfixOf` t = reply w "不在"
                    | "为啥" `isInfixOf` t = reply w "不为啥"
                    | isQuestion t = answer w t
                    | otherwise = return Nothing


              isQuestion t = "?" `isInfixOf` t
                          || "？" `isInfixOf` t
                          || "吗" `isInfixOf` t

              {- antwortet nur wenn es sicher eine Frage ist -}
              answer w t
                    | "conky" `isInfixOf` t = reply w "不用conky"
                    | "fvwm" `isInfixOf` t = reply w "不用fvwm"
                    | "emacs" `isInfixOf` t = reply w "不用emacs"
                    | "grub2" `isInfixOf` t = reply w "不用grub2"
                    | "python" `isInfixOf` t = reply w "不用python"
                    | "有人" `isInfixOf` t = privmsg "<----" >>
                                             return (Just "<----")
                    | "知道" `isInfixOf` t = reply w "不知道"
                    | "需要" `isInfixOf` t = reply w "不需要"
                    | "明白" `isInfixOf` t = reply w "不明白"
                    | "听说" `isInfixOf` t = reply w "没听说"
                    | "了解" `isInfixOf` t = reply w "不了解"
                    | "熟悉" `isInfixOf` t = reply w "不熟悉"
                    | "会用" `isInfixOf` t = reply w "不会"
                    | "可以" `isInfixOf` t = reply w "可以"
                    | "什么" `isInfixOf` t = reply w "不知道"
                    | "怎么" `isInfixOf` t = reply w "不知道"
                    | "怎样" `isInfixOf` t = reply w "不知道"
                    | "懂" `isInfixOf` t = reply w "不懂"
                    | "能" `isInfixOf` t = reply w "不能"
                    | "会" `isInfixOf` t = reply w "不会"
                    | "是" `isInfixOf` t = reply w "不是"
                    | "有" `isInfixOf` t = reply w "没有"
                    | "要" `isInfixOf` t = reply w "不要"
                    | otherwise = return Nothing


main = runBot $ Bot {
                    server   = "irc.freenode.org",
                    port     = 6667,
                    channel  = "#ubuntu-cn",
                    nick     = "snugglebat",
                    username = "purple",
                    realname = "purple"
                }


readline :: String -> IO (Maybe String)
readline = runInputT defaultSettings . getInputLine