Awful Bot for HIMA

himabot.hs

module Main where

import Prelude()
import Prelude.Plus
import Data.Char
import Data.Maybe
import Network.Socket
import qualified Network.IRC as I
import Control.Concurrent
import Data.Time

sayMessageTo :: Handle -> I.Message -> IO ()
sayMessageTo h msg = print msg >> hPutStr h (I.encode msg ++ "\r\n")

getInfo :: String -> Int -> IO AddrInfo
getInfo host port = head <$>
                    getAddrInfo (Just (defaultHints { addrSocketType = Stream }))
                                (Just host)
                                (Just $ show port)

connectTo :: String -> Int -> IO Handle
connectTo host port = do
  info <- getInfo host port
  sock <- socket (addrFamily info)
                 (addrSocketType info)
                 (addrProtocol info)
  connect sock (addrAddress info)
  hdl <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl LineBuffering
  return hdl

auth :: Handle -> String -> IO ()
auth h nick = do
  sayMessageTo h (I.nick nick)
  sayMessageTo h (I.user nick "8" "*" nick)

joinChan :: Handle -> String -> IO ()
joinChan h ch = sayMessageTo h (I.joinChan ch)

notice :: String -> String -> I.Message
notice ch msg = I.Message Nothing "NOTICE" [ch,msg]

pongIfPing :: Handle -> I.Message -> IO ()
pongIfPing h msg = when (I.msg_command msg == "PING")
                        (sayMessageTo h msg { I.msg_prefix=Nothing, I.msg_command="PONG" })

getMsg :: Handle -> IO I.Message
getMsg h = fromJust . I.decode <$> hGetLine h

getMsgResponding :: Handle -> IO I.Message
getMsgResponding h = do
  m <- getMsg h
  pongIfPing h m
  return m

waitUntil :: (I.Command -> Bool) -> Handle -> IO ()
waitUntil pred h = do
  m <- getMsgResponding h
  when (not . pred . I.msg_command $ m) (waitUntil pred h)

performBot :: Handle -> (I.Message -> IO [I.Message]) -> IO ()
performBot h f = do
  msg <- getMsgResponding h
  msgs <- f msg
  mapM_ (sayMessageTo h) msgs

data Time = IsHour (Int -> Bool) | IsMinute (Int -> Bool) | And Time Time

type TimeTable = [(Time,String)]

withTimes :: TimeTable -> Handle -> String -> IO ()
withTimes table h ch = forkIO action >> return ()
    where action = forever $ do
            (hour,min) <- getHourAndMin
            let msgs = map snd . filter (interpretWith (hour,min) . fst) $ table
            forM_ msgs (sayMessageTo h . notice ch)
            threadDelay (60*1000*1000)

timeTable :: TimeTable
-- timeTable = [ (IsMinute (const True), "minute!")
--             , (IsMinute ((==0) . (`mod` 10)), "tenth!") ]
timeTable = [ (IsHour (==20) `And` IsMinute (==00), "HIMA はじまりますよー")
            , (IsHour (==20) `And` IsMinute (==20), "nonowarn いそげ")
            , (IsHour (==20) `And` IsMinute (==30), "かずさんおねがいしまーす")
            , (IsHour (==21) `And` IsMinute (==00), "一応この時間から雑談です")
            , (IsHour (==23) `And` IsMinute (==00),
               "一応終わりの時間です おつかれさまでした")
            ]

interpretWith :: (Int,Int) -> Time -> Bool
interpretWith (hour,min) time =
    case time of
      IsHour p -> p hour
      IsMinute p -> p min
      And p p' -> interpretWith (hour,min) p && interpretWith (hour,min) p'

getHourAndMin :: IO (Int,Int)
getHourAndMin = (todHour &&& todMin) . localTimeOfDay . zonedTimeToLocalTime <$> getZonedTime

main = do
  [host,nick,ch] <- getArgs
  h <- connectTo host 6667
  auth h nick
  waitUntil (== "001") h
  joinChan h ch
--   forever (performBot h $ \m -> if I.msg_command m == "PRIVMSG"
--                                 then return [notice ch "you're noisy"] else return [])
  withTimes timeTable h ch
  forever $ performBot h $ \m -> return $
                                 if "ひま" `isInfixOf` concat (I.msg_params m)
                                 then [notice ch "ひまだなー"]
                                 else []