128 lines
2.8 KiB
Haskell
128 lines
2.8 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Main where
|
|
|
|
import System.IO
|
|
import System.Exit (exitSuccess)
|
|
|
|
import Control.Exception (bracket, bracket_)
|
|
|
|
import Control.Monad.Reader
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
import Data.List (intercalate, isPrefixOf)
|
|
|
|
import qualified Network.Socket as N
|
|
|
|
-- internal imports
|
|
import Types
|
|
|
|
-- configuration options (TODO: Move to yaml and read from there)
|
|
server = "irc.freenode.org"
|
|
port = 6667
|
|
chan = "#parrotbot-testing"
|
|
nick = "parrotbot"
|
|
|
|
-- | Entry point
|
|
main :: IO ()
|
|
main =
|
|
bracket connect disconnect loop
|
|
where
|
|
disconnect = hClose . botSocket
|
|
loop st = runReaderT run st
|
|
|
|
-- | Process bot comands inside of its monad
|
|
run
|
|
:: Net ()
|
|
run = do
|
|
write "NICK" nick
|
|
write "USER" (nick <> " 0 * :parrot bot")
|
|
write "JOIN" chan
|
|
listen
|
|
|
|
-- | Connect to the server und return the initial bot state
|
|
connect
|
|
:: IO Bot
|
|
connect = notify $ do
|
|
handle <- connectTo server port
|
|
return (Bot handle)
|
|
where
|
|
notify a = bracket_
|
|
(do
|
|
putStrLn ("Connecting to " <> server <> "…")
|
|
hFlush stdout
|
|
)
|
|
(putStrLn "done.")
|
|
a
|
|
|
|
-- | Connect to an IRC server given domain name and port (Helper for 'connect'
|
|
connectTo
|
|
:: N.HostName -- ^ Domain to connect to
|
|
-> N.PortNumber -- ^ Port to connect to
|
|
-> IO Handle -- ^ Handle for the connection
|
|
connectTo chost cport = do
|
|
(addr:_) <- N.getAddrInfo Nothing (Just chost) (Just (show cport))
|
|
sock <- N.socket
|
|
(N.addrFamily addr)
|
|
(N.addrSocketType addr)
|
|
(N.addrProtocol addr)
|
|
N.connect sock (N.addrAddress addr)
|
|
N.socketToHandle sock ReadWriteMode
|
|
|
|
-- | Send messages to IRC
|
|
write
|
|
:: String -- ^ Command to issue
|
|
-> String -- ^ Command argument(s)
|
|
-> Net ()
|
|
write cmd args = do
|
|
let msg = intercalate " " [cmd, args, "\r\n"]
|
|
handle <- asks botSocket
|
|
liftIO $ do
|
|
hPutStr handle msg
|
|
putStr ("> " <> msg)
|
|
|
|
-- | Send Messages via PRIVMSG to the connected Channel
|
|
privmsg
|
|
:: String -- ^ Message Content
|
|
-> Net ()
|
|
privmsg msg = write "PRIVMSG" (chan <> " :" <> msg)
|
|
|
|
-- | Listen to and process messages from IRC
|
|
listen
|
|
:: Net ()
|
|
listen = forever $ do
|
|
handle <- asks botSocket
|
|
line <- liftIO $ hGetLine handle
|
|
liftIO $ putStrLn line
|
|
let s = init line
|
|
if isPing s
|
|
then
|
|
pong s
|
|
else
|
|
evaluate (clean s)
|
|
where
|
|
forever :: Net () -> Net ()
|
|
forever a = do
|
|
a
|
|
forever a
|
|
|
|
clean :: String -> String
|
|
clean = drop 1 . dropWhile (/= ':') . drop 1
|
|
|
|
isPing :: String -> Bool
|
|
isPing s = "PING" `isPrefixOf` s
|
|
|
|
pong :: String -> Net ()
|
|
pong x = write "PONG" (':' : drop 6 x)
|
|
|
|
-- | Evaluate input from IRC
|
|
evaluate
|
|
:: String -- ^ Input to be processed
|
|
-> Net ()
|
|
evaluate "!quit" = do
|
|
write "QUIT" ":I have been orderd to go"
|
|
liftIO exitSuccess
|
|
evaluate text | "!say " `isPrefixOf` text =
|
|
privmsg (drop 5 text)
|
|
evaluate _ =
|
|
return ()
|