Rewrite of Anna in Haskell.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

186 lines
6.3 KiB

module Main where
import Data.List
import Data.Char (isSpace)
import qualified Data.Text as T
import System.IO
import System.Directory
import System.Process (readProcess)
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"
8 months ago
channels = ["#tildetown", "#bots"]
data Socket = Socket { socket :: Handle }
type Net = ReaderT Socket IO
-- Entrypoint
main :: IO ()
main = do
handle <- connectTo hostname port
hSetBuffering stdout NoBuffering
runReaderT run Socket { 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
8 months ago
"!qotd" -> qotd chn
"!tz" -> if "!tz" == last tokens
then timezone chn username
else timezone chn $ head $ tail tokens
-- "!eval" -> evalScheme chn $ join $ intersperse " " $ tail tokens
"!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
8 months ago
qotd :: String -> Net ()
qotd chn = do
handle <- liftIO $ connectTo "127.0.0.1" 1717
text <- liftIO $ hGetContents handle
let textLines = lines text
mapM_ (sendMessage chn) textLines
8 months ago
return ()
timezone :: String -> String -> Net ()
timezone chn username = do
let filepath = "/home/" ++ username ++ "/.tz"
existence <- liftIO $ doesFileExist filepath
if existence
then do
contents <- liftIO $ readFile filepath
let cleanContents = sanitize contents
sendMessage chn cleanContents
else sendMessage chn $ username ++ " has not set their timezone. Use `echo '<timezone here>' > ~/.tz' to add your timezone."
where sanitize = T.unpack . T.replace (T.pack "\n") T.empty . T.pack
evalScheme :: String -> String -> Net ()
evalScheme chn form = do
liftIO $ putStrLn form
result <- liftIO $ (\s -> s ++ "\n") <$> readProcess "guile" ["-c", expr] ""
sendMessage chn result
where expr = "(use-modules (ice-9 sandbox) \
\ (rnrs exceptions)) \
\ (display (guard (ex (else 'error)) \
\ (eval-in-sandbox (read (open-input-string \"" ++ form ++ "\")) \
\ #:bindings all-pure-and-impure-bindings)))"
8 months ago
rollcall :: String -> Net ()
rollcall chn = sendMessage chn "Hello! I respond to !anna, !qotd, !greets, and !eval <scheme form>. My source code is available at https://git.tilde.town/opfez/anna2"
8 months ago
anna = rollcall
-- Basic commands
write :: String -> String -> Net ()
write cmd args = do
h <- asks socket
5 months ago
liftIO $ hPutStr h output
liftIO $ putStr $ "> " ++ output
where output = 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 ()
5 months ago
pong = write "PONG" $ ":" ++ name
-- Connect to a server given its name and port number
connectTo :: N.HostName -> N.PortNumber -> IO Handle
connectTo host port = do
8 months ago
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