/src/XmppBot.hs

  1{-# LANGUAGE UnicodeSyntax, PatternGuards #-}
  2
  3import qualified System.Environment
  4import qualified XMPP
  5import qualified MUC
  6import qualified Sys
  7import qualified Cxx.Show
  8import qualified Request
  9import qualified RequestEval
 10
 11import Data.Char (ord, toLower, toUpper)
 12import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt, usageInfo)
 13import System.IO (putStrLn)
 14import Control.Monad (guard, when, forM_, forever)
 15
 16import Prelude hiding (catch, (.), readFile, putStrLn, putStr, print)
 17import Util
 18
 19type JID = String
 20type Nick = String
 21
 22data RoomConfig = RoomConfig { room_nick :: Nick, allow_nickless_requests :: Bool } deriving Read
 23
 24data BotConfig = BotConfig
 25  { server, user, pass :: String
 26  , max_msg_length :: Int
 27  , no_output_msg :: String
 28  , blacklist :: [JID] -- These may include a resource part, so that room users may be specified.
 29  , rate_limit_messages, rate_limit_window :: Int
 30  , rooms :: [(JID, RoomConfig)]
 31  } deriving Read
 32
 33data Opt = Config String | Help deriving Eq
 34
 35optsDesc :: [OptDescr Opt]
 36optsDesc =
 37  [ Option "c" ["config"] (ReqArg Config "<file>") "Load configuration from <file> instead of \"xmpp-config\"."
 38  , Option "h" ["help"] (NoArg Help) "Display this help and exit."
 39  ]
 40
 41help :: String
 42help = usageInfo "Usage: sudo geordi-xmpp [option]...\nOptions:" optsDesc ++ "\nSee README.xhtml for more information."
 43
 44getArgs :: IO [Opt]
 45getArgs = do
 46  args ← System.Environment.getArgs
 47  case getOpt RequireOrder optsDesc args of
 48    (_, _, err:_) → fail $ init err
 49    (_, w:_, []) → fail $ "superfluous command line argument: " ++ w
 50    (opts, [], []) → return opts
 51
 52nicks_match :: Nick → Nick → Bool
 53nicks_match n (h:t) = n == toLower h : t ∨ n == toUpper h : t
 54nicks_match _ "" = error "empty nick"
 55
 56is_request :: RoomConfig → String → Maybe String
 57is_request (RoomConfig mynick allow_nickless) s
 58  | Just (n, r) ← Request.is_addressed_request s, nicks_match n mynick = Just r
 59  | allow_nickless, Just r ← Request.is_short_request s = Just r
 60  | otherwise = Nothing
 61
 62output_body :: BotConfig → Request.Response → String
 63output_body cfg r = xmlEntities $ take (max_msg_length cfg) $ takeWhile (/= '\n') $
 64  case Request.response_output r of "" → no_output_msg cfg; s → s
 65
 66main :: IO ()
 67main = do
 68  Sys.setlocale_ALL_env
 69  opts ← getArgs
 70  if Help `elem` opts then putStrLn help else do
 71  cfg ← readTypedFile $ findMaybe (\o → case o of Config cf → Just cf; _ → Nothing) opts `orElse` "xmpp-config"
 72  conn ← XMPP.openStream $ server cfg
 73  XMPP.getStreamStart conn
 74  evalRequest ← RequestEval.evaluator Cxx.Show.noHighlighting
 75  limit_rate ← Sys.rate_limiter (rate_limit_messages cfg) (rate_limit_window cfg)
 76  XMPP.runXMPP conn $ do
 77  XMPP.startAuth (user cfg) (server cfg) (pass cfg)
 78  XMPP.sendPresence
 79  XMPP.handleVersion "Geordi C++ bot - http://www.eelis.net/geordi/" "-" "-"
 80  forM_ (rooms cfg) $ \(jid, RoomConfig nick _) → MUC.joinGroupchat nick jid
 81  forever $ do
 82  msg ← XMPP.waitForStanza (XMPP.isMessage .&&. XMPP.hasBody .&&. (not . isDelay))
 83  maybeM (XMPP.getAttr "from" msg) $ \from → do
 84  when (not $ from `elem` blacklist cfg) $ do
 85  maybeM (XMPP.getMessageBody msg) $ \body → do
 86  let
 87    eval r = XMPP.liftIO $ limit_rate >> output_body cfg . evalRequest r (Request.Context [])
 88  case XMPP.getAttr "type" msg of
 89    Just "groupchat"
 90      | (room, '/' : from_nick) ← span (/= '/') from, Just request ← do
 91          room_cfg ← lookup room $ rooms cfg
 92          guard $ room_nick room_cfg /= from_nick
 93          is_request room_cfg body
 94        → eval request >>= MUC.sendGroupchatMessage room
 95    Just "chat" → eval body >>= XMPP.sendMessage from
 96    Nothing → eval body >>= XMPP.sendMessage from
 97    _ → return ()
 98
 99xmlEntities :: String → String
100xmlEntities = concatMap (\c → "&#" ++ show (ord c) ++ ";")
101
102isDelay :: XMPP.StanzaPredicate
103isDelay = maybe False ((== Just "jabber:x:delay") . XMPP.getAttr "xmlns") . XMPP.xmlPath ["x"]