anna2/Anna.hs

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