131 lines
3.1 KiB
Haskell
131 lines
3.1 KiB
Haskell
--
|
|
-- A simple, clean IRC bot in Haskell
|
|
--
|
|
-- http://www.haskell.org/haskellwiki/Roll_your_own_IRC_bot
|
|
|
|
import Data.List
|
|
import Network
|
|
import Network.HTTP
|
|
import System.IO
|
|
import System.Time
|
|
import System.Exit
|
|
import Control.Monad.Reader
|
|
--import Control.Exception -- for base-3, with base-4 use Control.OldException
|
|
import Control.OldException
|
|
import Text.Printf
|
|
import Prelude hiding (catch)
|
|
|
|
import HTMLParsing
|
|
|
|
server = "irc.freenode.net"
|
|
port = 6667
|
|
chan = "#cheeseburger"
|
|
nick = "cheesebot"
|
|
|
|
--
|
|
-- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state.
|
|
-- A socket and the bot's start time.
|
|
--
|
|
type Net = ReaderT Bot IO
|
|
data Bot = Bot { socket :: Handle, starttime :: ClockTime }
|
|
|
|
--
|
|
-- Set up actions to run on start and end, and run the main loop
|
|
--
|
|
main :: IO ()
|
|
main = bracket connect disconnect loop
|
|
where
|
|
disconnect = hClose . socket
|
|
loop st = catch (runReaderT run st) (const $ return ())
|
|
|
|
--
|
|
-- Connect to the server and return the initial bot state
|
|
--
|
|
connect :: IO Bot
|
|
connect = notify $ do
|
|
t <- getClockTime
|
|
h <- connectTo server (PortNumber (fromIntegral Main.port))
|
|
hSetBuffering h NoBuffering
|
|
return (Bot h t)
|
|
where
|
|
notify a = bracket_
|
|
(printf "Connecting to %s ... " server >> hFlush stdout)
|
|
(putStrLn "done.")
|
|
a
|
|
|
|
--
|
|
-- 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 * :tutorial bot")
|
|
write "JOIN" chan
|
|
asks socket >>= listen
|
|
|
|
--
|
|
-- Process each line from the server
|
|
--
|
|
listen :: Handle -> Net ()
|
|
listen h = forever $ do
|
|
s <- init `fmap` io (hGetLine h)
|
|
io (putStrLn s)
|
|
if ping s then pong s else eval (clean s)
|
|
where
|
|
forever a = a >> forever a
|
|
clean = drop 1 . dropWhile (/= ':') . dropWhile (/= ' ')
|
|
ping x = "PING :" `isPrefixOf` x
|
|
pong x = write "PONG" (':' : drop 6 x)
|
|
|
|
--
|
|
-- Dispatch a command
|
|
--
|
|
eval :: String -> Net ()
|
|
eval x | "cheesebot" `isPrefixOf` x = privmsg (answerRequest (drop 9 x))
|
|
eval x | isYouTubeURL x = do
|
|
youtubeTitle <- io $ getHTTPTitle x
|
|
privmsg youtubeTitle
|
|
eval _ = return () -- ignore everything else
|
|
|
|
--
|
|
-- Send a privmsg to the current chan + server
|
|
--
|
|
privmsg :: String -> Net ()
|
|
privmsg s = write "PRIVMSG" (chan ++ " :" ++ 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
|
|
|
|
--
|
|
-- Answer simple request
|
|
--
|
|
answerRequest :: String -> String
|
|
answerRequest x
|
|
| "/quit" `isInfixOf` x = "Nice try"
|
|
| ":" `isPrefixOf` x = drop 1 x
|
|
| "," `isPrefixOf` x = drop 1 x
|
|
| otherwise = x
|
|
|
|
--
|
|
-- Youtube
|
|
--
|
|
isYouTubeURL :: String -> Bool
|
|
isYouTubeURL s =
|
|
"http://www.youtube.com/" `isPrefixOf` s
|
|
|| "https://www.youtube.com/" `isPrefixOf` s
|
|
|| "http://youtu.be/" `isPrefixOf` s
|
|
|| "https://youtu.be/" `isPrefixOf` s
|
|
|
|
--
|
|
-- Convenience.
|
|
--
|
|
io :: IO a -> Net a
|
|
io = liftIO
|