parrotbot/src/Main.hs

128 lines
2.8 KiB
Haskell
Raw Permalink Normal View History

2021-03-27 03:17:39 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Main where
import System.IO
import System.Exit (exitSuccess)
2021-03-27 05:06:34 +00:00
import Control.Exception (bracket, bracket_)
import Control.Monad.Reader
import Control.Monad.IO.Class (liftIO)
2021-03-27 03:17:39 +00:00
import Data.List (intercalate, isPrefixOf)
import qualified Network.Socket as N
2021-03-27 05:06:34 +00:00
-- internal imports
import Types
2021-03-27 03:17:39 +00:00
-- configuration options (TODO: Move to yaml and read from there)
server = "irc.freenode.org"
port = 6667
chan = "#parrotbot-testing"
nick = "parrotbot"
2021-03-27 05:06:34 +00:00
-- | Entry point
2021-03-27 03:17:39 +00:00
main :: IO ()
2021-03-27 05:06:34 +00:00
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
2021-03-27 03:17:39 +00:00
connect
2021-03-27 05:06:34 +00:00
:: 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
2021-03-27 03:17:39 +00:00
:: N.HostName -- ^ Domain to connect to
-> N.PortNumber -- ^ Port to connect to
-> IO Handle -- ^ Handle for the connection
2021-03-27 05:06:34 +00:00
connectTo chost cport = do
2021-03-27 03:17:39 +00:00
(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
2021-03-27 05:06:34 +00:00
:: String -- ^ Command to issue
2021-03-27 03:17:39 +00:00
-> String -- ^ Command argument(s)
2021-03-27 05:06:34 +00:00
-> Net ()
write cmd args = do
2021-03-27 03:17:39 +00:00
let msg = intercalate " " [cmd, args, "\r\n"]
2021-03-27 05:06:34 +00:00
handle <- asks botSocket
liftIO $ do
hPutStr handle msg
putStr ("> " <> msg)
2021-03-27 03:17:39 +00:00
-- | Send Messages via PRIVMSG to the connected Channel
privmsg
2021-03-27 05:06:34 +00:00
:: String -- ^ Message Content
-> Net ()
privmsg msg = write "PRIVMSG" (chan <> " :" <> msg)
2021-03-27 03:17:39 +00:00
-- | Listen to and process messages from IRC
listen
2021-03-27 05:06:34 +00:00
:: Net ()
listen = forever $ do
handle <- asks botSocket
line <- liftIO $ hGetLine handle
liftIO $ putStrLn line
2021-03-27 03:17:39 +00:00
let s = init line
if isPing s
then
pong s
else
2021-03-27 05:06:34 +00:00
evaluate (clean s)
2021-03-27 03:17:39 +00:00
where
2021-03-27 05:06:34 +00:00
forever :: Net () -> Net ()
2021-03-27 03:17:39 +00:00
forever a = do
a
forever a
clean :: String -> String
clean = drop 1 . dropWhile (/= ':') . drop 1
isPing :: String -> Bool
isPing s = "PING" `isPrefixOf` s
2021-03-27 05:06:34 +00:00
pong :: String -> Net ()
pong x = write "PONG" (':' : drop 6 x)
2021-03-27 03:17:39 +00:00
-- | Evaluate input from IRC
evaluate
2021-03-27 05:06:34 +00:00
:: 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 _ =
2021-03-27 03:17:39 +00:00
return ()