hpaste-0.3: PasteBot.hs

-----------------------------------------------------------------------------
-- |
-- Module      : PasteBot
-- Copyright   : (c) Eric Mertens 2007
-- License     : BSD3-style (see LICENSE)
-- 
-- Maintainer  : emertens@gmail.com
-- Stability   : unstable
-- Portability : portable
--
-----------------------------------------------------------------------------
--
-- HPaste irc announce bot
--

module PasteBot (runBot, PasteAnnounce (..)) where

import Control.Concurrent
import Control.Exception
import Control.Monad.Reader
import Data.Char (isSpace)
import Data.List
import Network
import Prelude hiding (catch)
import System.IO
import System.Exit
import Text.ParserCombinators.ReadP
import Text.Printf

server :: String
server = "irc.se.freenode.net"

port :: PortID
port = PortNumber 6666

chan :: String
chan = "#haskell"

nick :: String
nick = "hpaste"

admin :: String
admin = ":glguy!n=eric@unaffiliated/glguy"

announceurl :: String
announceurl = "Haskell paste bin: http://hpaste.org/"

-- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state.

type Net = ReaderT Bot IO
data Bot = Bot { socket :: Handle, messages :: Chan PasteAnnounce
               , modeVar :: MVar BotMode}

data BotMode = BotMode { isSilenced :: Bool, adminList :: [String] }

data PasteAnnounce = NewPaste String String String
                   | Annotation String String String String

instance Show PasteAnnounce where
  show (NewPaste n t u) = printf " %s pasted \"%s\" at %s" n t u
  show (Annotation n t t' u)
    = printf " %s annotated \"%s\" with \"%s\" at %s" n t t' u

forever :: Monad m => m a -> m b
forever a = a >> forever a

initBotMode :: BotMode
initBotMode = BotMode { isSilenced = False
                      , adminList  = []
                      }

-- Set up actions to run on start and end, and run the main loop

runBot :: Chan PasteAnnounce -> IO ()
runBot ch = bracket (connect ch) disconnect loop
  where
    disconnect = hClose . socket
    loop b = do
      forkIO $ runReaderT chanListener b
      handle (\_ -> return()) $ runReaderT run b

-- Connect to the server and return the initial bot state

connect :: Chan PasteAnnounce -> IO Bot
connect ch = notify $ do
    h <- connectTo server port
    bmodeVar <- newMVar initBotMode
    hSetBuffering h NoBuffering
    return $ Bot h ch bmodeVar
  where
    notify = bracket_
        (printf "Connecting to %s ... " server >> hFlush stdout)
        (putStrLn "done.")

chanListener :: Net b
chanListener = do
  ch <- asks messages
  var <- asks modeVar
  forever $ do
    msg <- io $ readChan ch
    mode <- io $ readMVar var
    unless (isSilenced mode) $
      privmsg $ show msg

-- We're in the Net monad now, so we've connected successfully

-- Join a channel, and start processing commands

run :: Net ()
run = do
    write "NICK" nick
    write "USER" (nick ++ " 0 * :announcer")
    write "JOIN" chan
    listen

-- Process each line from the server

listen :: Net ()
listen = do
  h <- asks socket
  forever $ do
    s <- io $ liftM init $ hGetLine h -- remove newline
    io $ putStrLn s
    if ping s then pong s else isAdmin s >>= eval s
  where
    ping x    = "PING :" `isPrefixOf` x
    pong x    = write "PONG" $ dropWord x
    isAdmin s = do
      var <- asks modeVar
      admins <- io $ liftM adminList $ readMVar var
      return $ admin `isPrefixOf` s || any (`isPrefixOf` s) admins

-- Dispatch a command

urlParser :: ReadS String
urlParser = readP_to_S $ do
    string nick
    optional $ choice [char ':', char ',']
    skipSpaces
    string "url"

eval :: String -> Bool -> Net ()
eval s isAdmin
  | ("!paste" `isPrefixOf` s' || (not $ null $ urlParser s'))
    && (isAdmin || ws !! 2 == chan)
      = privmsg announceurl

  | isAdmin = case () of
                _ | "!quit" `isPrefixOf` s' -> do
                      write "QUIT" ":Exiting"
                      io (exitWith ExitSuccess)

                  | "!say " `isPrefixOf` s' -> privmsg (dropWord s')

                  | "!msg " `isPrefixOf` s' -> privmsgTo (dropWord s')

                  | "!quiet" `isPrefixOf` s' -> setSilenced True

                  | "!verbose" `isPrefixOf` s' -> setSilenced False

                  | "!admin+ " `isPrefixOf` s' -> addAdmin (dropWord s')

                  | "!admin- " `isPrefixOf` s' -> dropAdmin (dropWord s')

		  | otherwise -> return ()

  | otherwise = return ()

  where
    clean = drop 1 . dropWhile (/= ':') . drop 1
    s' = clean s
    ws = words s

    setSilenced b = do
      var <- asks modeVar
      io $ modifyMVar_ var (\m -> return $ m { isSilenced = b })

    addAdmin n = do
      var <- asks modeVar
      io $ modifyMVar_ var (\m -> return $ m { adminList = n : adminList m})

    dropAdmin n = do
      var <- asks modeVar
      io $ modifyMVar_ var
       (\m -> return $ m { adminList = n `delete` adminList m})

-- Send a privmsg to the current chan + server

privmsg :: String -> Net ()
privmsg s = write "PRIVMSG" (chan ++ " :" ++ s)

-- Send a privmsg to the specified user

privmsgTo :: String -> Net ()
privmsgTo s = write "PRIVMSG" s

-- Send a message out to the server we're currently connected to

write :: String -> String -> Net ()
write s t = do
    h <- asks socket
    io $ hPrintf h "%s %s\r\n" s t
    io $ printf    "> %s %s\n" s t

-- Convenience.

io :: IO a -> Net a
io = liftIO

-- Utility function

dropWord :: String -> String
dropWord = dropWhile isSpace . dropWhile (not . isSpace)