Nie możesz wybrać więcej, niż 25 tematów
Tematy muszą się zaczynać od litery lub cyfry, mogą zawierać myślniki ('-') i mogą mieć do 35 znaków.
185 wiersze
6.3 KiB
185 wiersze
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
|
|
|