PageRenderTime 39ms CodeModel.GetById 18ms app.highlight 15ms RepoModel.GetById 1ms app.codeStats 1ms

/src/XmppBot.hs

http://github.com/Eelis/geordi
Haskell | 103 lines | 86 code | 16 blank | 1 comment | 5 complexity | 548f304836e07a10cd62311416027905 MD5 | raw file
  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"]