Rewrite of Anna in Haskell.
Vous ne pouvez pas sélectionner plus de 25 sujets Les noms de sujets doivent commencer par une lettre ou un nombre, peuvent contenir des tirets ('-') et peuvent comporter jusqu'à 35 caractères.

185 lignes
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"
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
"!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
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
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)))"
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"
anna = rollcall
-- Basic commands
write :: String -> String -> Net ()
write cmd args = do
h <- asks socket
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 ()
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
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