149 lines
4.7 KiB
Haskell
149 lines
4.7 KiB
Haskell
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 = ["#foo", "#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
|
|
let tokens = words line
|
|
-- Debug print
|
|
liftIO $ putStrLn line
|
|
tokenDispatch (parseUser $ tail line) (parseChannel tokens) tokens
|
|
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
|
|
parseChannel ts
|
|
| length ts > 3 = Just $ ts !! 2
|
|
| otherwise = Nothing
|
|
|
|
tokenDispatch :: Maybe String -> Maybe String -> [String] -> Net ()
|
|
tokenDispatch _ _ ("PING":_) = pong
|
|
tokenDispatch _ _ [] = return ()
|
|
tokenDispatch (Just userName) (Just chn) ts = if elem "PRIVMSG" ts
|
|
then helper
|
|
else return ()
|
|
where helper
|
|
| elem "o/" tokens = updateRightGreets
|
|
| elem "\\o" tokens = updateLeftGreets
|
|
| otherwise = case head tokens of
|
|
-- TODO: make reader monad for this? passing chn is a little tedious
|
|
"!greets" -> greets chn
|
|
"!rollcall" -> rollcall chn
|
|
"!anna" -> anna chn
|
|
_ -> 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 ()
|
|
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)
|
|
sendMessage chn displayLine
|
|
|
|
rollcall :: String -> Net ()
|
|
rollcall chn = sendMessage chn "Hello! I respond to !anna and !greets. My source code is available at https://git.tilde.town/opfez/anna"
|
|
anna = rollcall
|
|
|
|
timezone :: String -> String -> Net ()
|
|
timezone chn username = undefined
|
|
|
|
|
|
|
|
-- 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
|