2021-10-08 10:45:40 +00:00
module Main where
import Data.List
import Data.Char ( isSpace )
2021-10-09 10:14:11 +00:00
import qualified Data.Text as T
2021-10-08 10:45:40 +00:00
import System.IO
import System.Directory
2021-10-11 17:24:59 +00:00
import System.Process ( readProcess )
2021-10-08 10:45:40 +00:00
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 "
2021-10-08 17:22:55 +00:00
channels = [ " #tildetown " , " #bots " ]
2021-10-08 10:45:40 +00:00
2021-10-09 10:14:11 +00:00
data Socket = Socket { socket :: Handle }
type Net = ReaderT Socket IO
2021-10-08 10:45:40 +00:00
-- Entrypoint
main :: IO ()
main = do
handle <- connectTo hostname port
hSetBuffering stdout NoBuffering
2021-10-09 10:14:11 +00:00
runReaderT run Socket { socket = handle }
2021-10-08 10:45:40 +00:00
run :: Net ()
run = do
sendNick
sendUser
joinChannels
listen
listen :: Net ()
listen = forever $ do
h <- asks socket
line <- liftIO $ hGetLine h
2021-10-08 11:13:29 +00:00
let tokens = words line
2021-10-08 10:45:40 +00:00
-- Debug print
2021-12-17 19:47:42 +00:00
liftIO $ putStrLn $ " < " ++ line
2021-10-08 11:13:29 +00:00
tokenDispatch ( parseUser $ tail line ) ( parseChannel tokens ) tokens
2021-10-09 10:14:11 +00:00
where parseUser str = username
where username = getName str
2021-10-08 10:45:40 +00:00
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
2021-10-08 11:13:29 +00:00
parseChannel ts
| length ts > 3 = Just $ ts !! 2
| otherwise = Nothing
2021-10-08 10:45:40 +00:00
2021-10-08 11:13:29 +00:00
tokenDispatch :: Maybe String -> Maybe String -> [ String ] -> Net ()
tokenDispatch _ _ ( " PING " : _ ) = pong
tokenDispatch _ _ [] = return ()
2021-10-09 10:14:11 +00:00
tokenDispatch ( Just username ) ( Just chn ) ts = if elem " PRIVMSG " ts
2021-10-08 11:13:29 +00:00
then helper
else return ()
2021-10-08 10:45:40 +00:00
where helper
| elem " o/ " tokens = updateRightGreets
| elem " \ \ o " tokens = updateLeftGreets
| otherwise = case head tokens of
2021-10-08 14:23:33 +00:00
-- TODO: make reader monad for this? passing chn is a little tedious
" !greets " -> greets chn
2021-10-08 22:26:38 +00:00
" !qotd " -> qotd chn
2021-10-09 10:14:11 +00:00
" !tz " -> if " !tz " == last tokens
then timezone chn username
else timezone chn $ head $ tail tokens
2021-12-17 19:47:42 +00:00
-- "!eval" -> evalScheme chn $ join $ intersperse " " $ tail tokens
2021-10-08 14:23:33 +00:00
" !rollcall " -> rollcall chn
" !anna " -> anna chn
_ -> return ()
2021-10-08 10:45:40 +00:00
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
2021-10-08 11:13:29 +00:00
tokenDispatch Nothing _ _ = return ()
tokenDispatch _ Nothing _ = return ()
2021-10-08 10:45:40 +00:00
-- 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
2021-10-08 22:26:38 +00:00
qotd :: String -> Net ()
qotd chn = do
handle <- liftIO $ connectTo " 127.0.0.1 " 1717
text <- liftIO $ hGetContents handle
2021-10-08 22:28:50 +00:00
let textLines = lines text
mapM_ ( sendMessage chn ) textLines
2021-10-08 22:26:38 +00:00
return ()
2021-10-08 14:23:33 +00:00
2021-10-08 11:13:29 +00:00
timezone :: String -> String -> Net ()
2021-10-09 10:14:11 +00:00
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
2021-10-08 11:13:29 +00:00
2021-10-11 17:24:59 +00:00
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 ) ) ) "
2021-10-08 22:26:38 +00:00
rollcall :: String -> Net ()
2021-10-11 17:30:41 +00:00
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 "
2021-10-08 22:26:38 +00:00
anna = rollcall
2021-10-08 14:23:33 +00:00
2021-10-08 10:45:40 +00:00
-- Basic commands
write :: String -> String -> Net ()
write cmd args = do
h <- asks socket
2021-12-17 19:47:42 +00:00
liftIO $ hPutStr h $ output
liftIO $ putStr $ " > " ++ output
where output = cmd ++ " " ++ args ++ " \ r \ n "
2021-10-08 10:45:40 +00:00
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 $ " \ x01AC TION " ++ 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
2021-10-08 17:22:55 +00:00
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