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

  1. module Main where
  2. import Data.List
  3. import Data.Char (isSpace)
  4. import qualified Data.Text as T
  5. import System.IO
  6. import System.Directory
  7. import System.Process (readProcess)
  8. import Control.Monad
  9. import Control.Monad.IO.Class
  10. import qualified Network.Socket as N
  11. import Control.Monad.Trans.Reader
  12. -- Configuration
  13. hostname = "127.0.0.1"
  14. port = 6667
  15. name = "anna"
  16. channels = ["#tildetown", "#bots"]
  17. data Socket = Socket { socket :: Handle }
  18. type Net = ReaderT Socket IO
  19. -- Entrypoint
  20. main :: IO ()
  21. main = do
  22. handle <- connectTo hostname port
  23. hSetBuffering stdout NoBuffering
  24. runReaderT run Socket { socket = handle }
  25. run :: Net ()
  26. run = do
  27. sendNick
  28. sendUser
  29. joinChannels
  30. listen
  31. listen :: Net ()
  32. listen = forever $ do
  33. h <- asks socket
  34. line <- liftIO $ hGetLine h
  35. let tokens = words line
  36. -- Debug print
  37. liftIO $ putStrLn $ "< " ++ line
  38. tokenDispatch (parseUser $ tail line) (parseChannel tokens) tokens
  39. where parseUser str = username
  40. where username = getName str
  41. getName :: String -> Maybe String
  42. getName s
  43. | comesBefore ' ' '!' s = Nothing
  44. | otherwise = Just $ takeWhile (\c -> (c /= '!')) s
  45. comesBefore :: Eq a => a -> a -> [a] -> Bool
  46. comesBefore c1 c2 arr
  47. | elemIndex c1 arr == Nothing = False
  48. | elemIndex c2 arr == Nothing = True
  49. | otherwise = elemIndex c1 arr < elemIndex c2 arr
  50. parseChannel ts
  51. | length ts > 3 = Just $ ts !! 2
  52. | otherwise = Nothing
  53. tokenDispatch :: Maybe String -> Maybe String -> [String] -> Net ()
  54. tokenDispatch _ _ ("PING":_) = pong
  55. tokenDispatch _ _ [] = return ()
  56. tokenDispatch (Just username) (Just chn) ts = if elem "PRIVMSG" ts
  57. then helper
  58. else return ()
  59. where helper
  60. | elem "o/" tokens = updateRightGreets
  61. | elem "\\o" tokens = updateLeftGreets
  62. | otherwise = case head tokens of
  63. -- TODO: make reader monad for this? passing chn is a little tedious
  64. "!greets" -> greets chn
  65. "!qotd" -> qotd chn
  66. "!tz" -> if "!tz" == last tokens
  67. then timezone chn username
  68. else timezone chn $ head $ tail tokens
  69. -- "!eval" -> evalScheme chn $ join $ intersperse " " $ tail tokens
  70. "!rollcall" -> rollcall chn
  71. "!anna" -> anna chn
  72. _ -> return ()
  73. tokens = case length msgTokens of
  74. 1 -> [rstrip $ tail $ head msgTokens]
  75. _ -> (tail $ head msgTokens) : ((init $ tail msgTokens) ++ [(rstrip $ last msgTokens)])
  76. msgTokens = drop 3 ts
  77. rstrip = reverse . dropWhile isSpace . reverse
  78. tokenDispatch Nothing _ _ = return ()
  79. tokenDispatch _ Nothing _ = return ()
  80. -- Bot commands
  81. updateRightGreets :: Net ()
  82. updateRightGreets = do
  83. content <- liftIO $ readFile "greets"
  84. let contentLines = lines content
  85. rightGreets = show $ 1 + (read $ head contentLines :: Int)
  86. leftGreets = head $ tail contentLines
  87. liftIO $ removeFile "greets"
  88. liftIO $ writeFile "greets" $ rightGreets ++ "\n" ++ leftGreets ++ "\n"
  89. updateLeftGreets :: Net ()
  90. updateLeftGreets = do
  91. content <- liftIO $ readFile "greets"
  92. let contentLines = lines content
  93. rightGreets = head contentLines
  94. leftGreets = show $ 1 + (read $ head $ tail contentLines :: Int)
  95. liftIO $ removeFile "greets"
  96. liftIO $ writeFile "greets" $ rightGreets ++ "\n" ++ leftGreets ++ "\n"
  97. greets :: String -> Net ()
  98. greets chn = do
  99. content <- liftIO $ readFile "greets"
  100. let contentLines = lines content
  101. displayLine = "o/ - " ++ (head contentLines) ++ " vs \\o - " ++ (head $ tail contentLines)
  102. sendMessage chn displayLine
  103. qotd :: String -> Net ()
  104. qotd chn = do
  105. handle <- liftIO $ connectTo "127.0.0.1" 1717
  106. text <- liftIO $ hGetContents handle
  107. let textLines = lines text
  108. mapM_ (sendMessage chn) textLines
  109. return ()
  110. timezone :: String -> String -> Net ()
  111. timezone chn username = do
  112. let filepath = "/home/" ++ username ++ "/.tz"
  113. existence <- liftIO $ doesFileExist filepath
  114. if existence
  115. then do
  116. contents <- liftIO $ readFile filepath
  117. let cleanContents = sanitize contents
  118. sendMessage chn cleanContents
  119. else sendMessage chn $ username ++ " has not set their timezone. Use `echo '<timezone here>' > ~/.tz' to add your timezone."
  120. where sanitize = T.unpack . T.replace (T.pack "\n") T.empty . T.pack
  121. evalScheme :: String -> String -> Net ()
  122. evalScheme chn form = do
  123. liftIO $ putStrLn form
  124. result <- liftIO $ (\s -> s ++ "\n") <$> readProcess "guile" ["-c", expr] ""
  125. sendMessage chn result
  126. where expr = "(use-modules (ice-9 sandbox) \
  127. \ (rnrs exceptions)) \
  128. \ (display (guard (ex (else 'error)) \
  129. \ (eval-in-sandbox (read (open-input-string \"" ++ form ++ "\")) \
  130. \ #:bindings all-pure-and-impure-bindings)))"
  131. rollcall :: String -> Net ()
  132. 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"
  133. anna = rollcall
  134. -- Basic commands
  135. write :: String -> String -> Net ()
  136. write cmd args = do
  137. h <- asks socket
  138. liftIO $ hPutStr h output
  139. liftIO $ putStr $ "> " ++ output
  140. where output = cmd ++ " " ++ args ++ "\r\n"
  141. sendNick :: Net ()
  142. sendNick = write "NICK" name
  143. sendUser :: Net ()
  144. sendUser = write "USER" $ name ++ " 0.0.0.0 " ++ name ++ " :" ++ name
  145. sendMessage :: String -> String -> Net ()
  146. sendMessage channel message = write "PRIVMSG" $ channel ++ " :" ++ message
  147. sendAction :: String -> String -> Net ()
  148. sendAction channel action = sendMessage channel $ "\x01ACTION " ++ action ++ "\x01"
  149. joinChannels :: Net ()
  150. joinChannels = mapM_ (\chn -> write "JOIN" chn) channels
  151. pong :: Net ()
  152. pong = write "PONG" $ ":" ++ name
  153. -- Connect to a server given its name and port number
  154. connectTo :: N.HostName -> N.PortNumber -> IO Handle
  155. connectTo host port = do
  156. addr : _ <- N.getAddrInfo Nothing (Just host) (Just (show port))
  157. sock <- N.socket (N.addrFamily addr) (N.addrSocketType addr) (N.addrProtocol addr)
  158. N.connect sock (N.addrAddress addr)
  159. N.socketToHandle sock ReadWriteMode