initial, greets support is in babyyyy

master
opfez 2021-10-08 12:45:40 +02:00
commit c0a8b7b64d
1 changed files with 132 additions and 0 deletions

132
Anna.hs 100644
View File

@ -0,0 +1,132 @@
module Main where
import Data.List
import Data.Char (isSpace)
import System.IO
import System.Directory
import Control.Monad
import Control.Monad.IO.Class
import qualified Network.Socket as N
import Control.Monad.Trans.Reader
-- Configuration
hostname = "127.0.0.1"
port = 6667
name = "anna"
channels = ["#bots"]
data Bot = Bot { socket :: Handle }
type Net = ReaderT Bot IO
-- Entrypoint
main :: IO ()
main = do
handle <- connectTo hostname port
hSetBuffering stdout NoBuffering
runReaderT run Bot { socket = handle }
run :: Net ()
run = do
sendNick
sendUser
joinChannels
listen
listen :: Net ()
listen = forever $ do
h <- asks socket
line <- liftIO $ hGetLine h
-- Debug print
liftIO $ putStrLn line
tokenDispatch (parseUser $ tail line) (words line)
where parseUser str = userName
where userName = getName str
getName :: String -> Maybe String
getName s
| comesBefore ' ' '!' s = Nothing
| otherwise = Just $ takeWhile (\c -> (c /= '!')) s
comesBefore :: Eq a => a -> a -> [a] -> Bool
comesBefore c1 c2 arr
| elemIndex c1 arr == Nothing = False
| elemIndex c2 arr == Nothing = True
| otherwise = elemIndex c1 arr < elemIndex c2 arr
tokenDispatch :: Maybe String -> [String] -> Net ()
tokenDispatch _ ("PING":_) = pong
tokenDispatch _ [] = return ()
tokenDispatch (Just userName) ts = if elem "PRIVMSG" ts
then helper
else return ()
where helper
| elem "o/" tokens = updateRightGreets
| elem "\\o" tokens = updateLeftGreets
| otherwise = case head tokens of
"!greets" -> greets $ head channels
_ -> return ()
tokens = case length msgTokens of
1 -> [rstrip $ tail $ head msgTokens]
_ -> (tail $ head msgTokens) : ((init $ tail msgTokens) ++ [(rstrip $ last msgTokens)])
msgTokens = drop 3 ts
rstrip = reverse . dropWhile isSpace . reverse
tokenDispatch Nothing _ = return ()
-- Bot commands
updateRightGreets :: Net ()
updateRightGreets = do
content <- liftIO $ readFile "greets"
let contentLines = lines content
rightGreets = show $ 1 + (read $ head contentLines :: Int)
leftGreets = head $ tail contentLines
liftIO $ removeFile "greets"
liftIO $ writeFile "greets" $ rightGreets ++ "\n" ++ leftGreets ++ "\n"
updateLeftGreets :: Net ()
updateLeftGreets = do
content <- liftIO $ readFile "greets"
let contentLines = lines content
rightGreets = head contentLines
leftGreets = show $ 1 + (read $ head $ tail contentLines :: Int)
liftIO $ removeFile "greets"
liftIO $ writeFile "greets" $ rightGreets ++ "\n" ++ leftGreets ++ "\n"
greets :: String -> Net ()
greets chn = do
content <- liftIO $ readFile "greets"
let contentLines = lines content
displayLine = "o/ - " ++ (head contentLines) ++ " vs \\o - " ++ (head $ tail contentLines)
liftIO $ putStrLn displayLine
sendMessage chn displayLine
-- Basic commands
write :: String -> String -> Net ()
write cmd args = do
h <- asks socket
liftIO $ hPutStr h $ cmd ++ " " ++ args ++ "\r\n"
sendNick :: Net ()
sendNick = write "NICK" name
sendUser :: Net ()
sendUser = write "USER" $ name ++ " 0.0.0.0 " ++ name ++ " :" ++ name
sendMessage :: String -> String -> Net ()
sendMessage channel message = write "PRIVMSG" $ channel ++ " :" ++ message
sendAction :: String -> String -> Net ()
sendAction channel action = sendMessage channel $ "\x01ACTION " ++ action ++ "\x01"
joinChannels :: Net ()
joinChannels = mapM_ (\chn -> write "JOIN" chn) channels
pong :: Net ()
pong = write "PONG" $ ":" ++ name ++ "\r\n"
-- Connect to a server given its name and port number
connectTo :: N.HostName -> N.PortNumber -> IO Handle
connectTo host port = do
addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
N.connect sock (N.addrAddress addr)
N.socketToHandle sock ReadWriteMode