lambdabot-xmpp (empty) → 0.1.0.0
raw patch · 6 files changed
+341/−0 lines, 6 filesdep +basedep +data-defaultdep +lambdabot-coresetup-changed
Dependencies added: base, data-default, lambdabot-core, lambdabot-haskell-plugins, lambdabot-irc-plugins, lambdabot-misc-plugins, lambdabot-novelty-plugins, lambdabot-reference-plugins, lambdabot-social-plugins, lifted-base, mtl, network, pontarius-xmpp, split, text, tls, x509-validation, xml-types
Files
- LICENSE +14/−0
- Main.hs +86/−0
- Modules.hs +25/−0
- Setup.hs +2/−0
- XMPP.hs +168/−0
- lambdabot-xmpp.cabal +46/−0
+ LICENSE view
@@ -0,0 +1,14 @@+ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+ Version 2, December 2004++ Copyright (C) 2004 Sam Hocevar+ 22 rue de Plaisance, 75014 Paris, France+ Everyone is permitted to copy and distribute verbatim or modified+ copies of this license document, and changing it is allowed as long+ as the name is changed.++ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. You just DO WHAT THE FUCK YOU WANT TO.+
+ Main.hs view
@@ -0,0 +1,86 @@+--+-- | Let's go lambdabot!+--+module Main where++import Lambdabot.Main+import Modules (modulesInfo)+import qualified Paths_lambdabot_xmpp as P++import Control.Applicative+import Control.Monad+import Control.Monad.Identity+import Data.Char+import Data.Version+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++import XMPP++flags :: [OptDescr (IO (DSum Config Identity))]+flags = + [ Option "h?" ["help"] (NoArg (usage [])) "Print this help message"+ , Option "e" [] (arg "<command>" onStartupCmds strs) "Run a lambdabot command instead of a REPL"+ , Option "l" [] (arg "<level>" consoleLogLevel level) "Set the logging level"+-- , Option "t" ["trust"] (arg "<package>" trustedPackages strs) "Trust the specified packages when evaluating code"+ , Option "V" ["version"] (NoArg version) "Print the version of lambdabot"+-- , Option "X" [] (arg "<extension>" languageExts strs) "Set a GHC language extension for @run"+ , Option "n" ["nice"] (NoArg noinsult) "Be nice (disable insulting error messages)"+ ] where + arg :: String -> Config t -> (String -> IO t) -> ArgDescr (IO (DSum Config Identity))+ arg descr key fn = ReqArg (fmap (key ==>) . fn) descr+ + strs = return . (:[])+ + level str = case reads (map toUpper str) of+ (lv, []):_ -> return lv+ _ -> usage+ [ "Unknown log level."+ , "Valid levels are: " ++ show [DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY]+ ]+ + noinsult = return (enableInsults ==> False)+++versionString :: String+versionString = ("lambdabot version " ++ showVersion P.version)++version :: IO a+version = do+ putStrLn versionString+ exitWith ExitSuccess++usage :: [String] -> IO a+usage errors = do+ cmd <- getProgName+ + let isErr = not (null errors)+ out = if isErr then stderr else stdout+ + mapM_ (hPutStrLn out) errors+ when isErr (hPutStrLn out "")+ + hPutStrLn out versionString+ hPutStr out (usageInfo (cmd ++ " [options]") flags)+ + exitWith (if isErr then ExitFailure 1 else ExitSuccess)++-- do argument handling+main :: IO ()+main = do+ (config, nonOpts, errors) <- getOpt Permute flags <$> getArgs+ when (not (null errors && null nonOpts)) (usage errors)+ config' <- sequence config+ dir <- P.getDataDir+ exitWith <=< lambdabotMain modulesInfo $+ [dataDir ==> dir, lbVersion ==> P.version] ++ config'+++-- special online target for ghci use+online :: [String] -> IO ()+online strs = do+ dir <- P.getDataDir+ void $ lambdabotMain modulesInfo+ [dataDir ==> dir, lbVersion ==> P.version, onStartupCmds ==> strs]
+ Modules.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}++module Modules (modulesInfo) where++import Lambdabot.Main++-- to add a new plugin, one must first add a qualified import here, and also+-- add a string in the list below+import Lambdabot.Plugin.Haskell+import Lambdabot.Plugin.IRC+import Lambdabot.Plugin.Misc+import Lambdabot.Plugin.Novelty+import Lambdabot.Plugin.Reference+import Lambdabot.Plugin.Social++import XMPP++modulesInfo :: Modules+modulesInfo = $(modules $ corePlugins+ ++ haskellPlugins+ ++ xmppPlugins+ ++ ["dummy", "fresh", "todo"] -- miscPlugins+ ++ ["bf", "dice", "elite", "filter", "quote", "slap", "unlambda", "vixen"] -- noveltyPlugins+ ++ referencePlugins+ ++ socialPlugins)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ XMPP.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedStrings #-}++module XMPP (+ xmppPlugins,+ xmppPlugin+) where++-- base+import Data.Char (isControl)+import Control.Monad+import Data.List.Split+import Data.List++-- Hackage+import Control.Concurrent.Lifted (fork)+import Control.Exception.Lifted as E (SomeException(..), throwIO, catch)+import Control.Monad.Trans (lift)+import Network (PortID(..))+import qualified Data.Text as T+import Network.TLS (+ ClientParams(..), ClientHooks(..), defaultParamsClient, Supported(..)+ )+import qualified Network.TLS.Extra as CI+import Data.Default (def)+import Network.Xmpp (+ SessionConfiguration(sessionStreamConfiguration)+ , StreamConfiguration(tlsParams)+ , parseJid, getJid, resourcepart, Session, session, plain+ , Presence(presenceFrom, presenceTo, presencePayload)+ , sendPresence, getMessage, messageFrom, messageTo, messagePayload+ , sendMessage, Message(..), MessageType(..)+ )+import Data.XML.Types (+ nameLocalName, elementName, elementText+ , Element(Element), Name(Name), Content(ContentText), Node(..)+ )+import System.Timeout.Lifted (timeout)+import qualified Data.X509.Validation as XV++-- Lambdabot+import Lambdabot.IRC+import Lambdabot.Logging+import Lambdabot.Monad+import Lambdabot.Plugin+import Lambdabot.Util++------+type XMPP = ModuleT () LB++data XMPPConfig = XMPPConfig {+ xmppHost :: String,+ xmppPort :: PortID,+ xmppUser :: String,+ xmppNick :: String,+ xmppPass :: String,+ xmppRoom :: String+ }++----++xmppPlugins :: [String]+xmppPlugins = ["xmpp"]++xmppPlugin :: Module ()+xmppPlugin = newModule+ { moduleCmds = return+ [ (command "xmpp-connect")+ { aliases = []+ , help = say "xmpp-connect <tag> <host> <portnum> <xmpp_user> <xmpp_nick> <xmpp_pass> <xmpp_room>. connect to an xmpp server"+ , process = \rest ->+ case splitOn " " rest of+ tag:hostn:portn:usern:nick:passw:room -> do+ pn <- (PortNumber . fromInteger) `fmap` readM portn+ let xmppconf = XMPPConfig hostn pn usern nick passw (intercalate " " room)+ lift (online tag xmppconf)+ _ -> say "XMPP: Not enough parameters!"+ }+ ]+ }+ +sendMessage' :: Session -> XMPPConfig -> IrcMessage -> XMPP ()+sendMessage' sess xmppconf ircmsg = do+ let msg = Data.List.last (ircMsgParams ircmsg)+ let msg' = filtermsg $ T.filter (not . isControl) (T.drop 1 (T.pack msg))+ let name = Name "body" (Just "jabber:client") Nothing+ node = NodeContent (ContentText msg')+ let payload = Element name [] [node]++ let m = Message{ messageFrom = Nothing+ , messageID = Nothing+ , messageTo = Just (parseJid (xmppRoom xmppconf))+ , messageType = GroupChat+ , messagePayload = [payload]+ , messageLangTag = Nothing+ , messageAttributes = []+ }+ io $ sendMessage m sess >> return ()++ where+ filtermsg :: T.Text -> T.Text+ filtermsg m = case (T.isPrefixOf "ACTION " m) of+ True -> T.replace "ACTION" "/me" m+ False -> T.stripStart m+ ++online :: String -> XMPPConfig -> XMPP ()+online tag xmppconf = do+ sess <- io $ xmppListen xmppconf+ E.catch+ (registerServer tag (sendMessage' sess xmppconf))+ (\err@SomeException{} -> E.throwIO err)+ + void . fork $ E.catch+ (lb (readerLoop tag sess xmppconf))+ (\e@SomeException{} -> do+ errorM (show e)+ unregisterServer tag)++readerLoop :: String -> Session -> XMPPConfig -> LB ()+readerLoop tag sess xmppconf = forever $ do+ mes <- io $ getMessage sess++ let from = maybe "(anybody)" T.unpack (resourcepart =<< messageFrom mes)+ let to = maybe "(anybody)" T.unpack (resourcepart =<< messageTo mes)+ let bodyElems = elems "body" mes+ let delayElems = elems "delay" mes++ when ((/=) from (xmppNick xmppconf) &&+ null delayElems &&+ (not . null) bodyElems) $ do+ + let body = head $ elementText (head bodyElems)+ + void . fork . void . timeout 15000000 . received $ IrcMessage {+ ircMsgServer = tag+ , ircMsgLBName = xmppNick xmppconf+ , ircMsgPrefix = from+ , ircMsgCommand = "PRIVMSG"+ , ircMsgParams = [to, ':' : T.unpack body]+ }+ return ()+ (readerLoop tag sess xmppconf)++ where+ elems tagname mes = filter ((== tagname) . nameLocalName . elementName) $+ (messagePayload mes)++xmppListen :: XMPPConfig -> IO Session+xmppListen xmppconf = do+ result <- session+ (xmppHost xmppconf)+ (Just (\_ -> [plain (T.pack . xmppUser $ xmppconf) Nothing (T.pack . xmppPass $ xmppconf)], Nothing))+ def+ sess <- case result of+ Right s -> return s+ Left e -> error $ "XmppFailure: " ++ (show e)+ sendMUCPresence xmppconf sess+ return sess++sendMUCPresence :: XMPPConfig -> Session -> IO ()+sendMUCPresence xmppconf sess = do+ jid <- getJid $ sess+ _ <- sendPresence (def {+ presenceFrom = jid+ , presenceTo = Just . parseJid $ (xmppRoom xmppconf) ++ '/' : (xmppNick xmppconf)+ , presencePayload = [Element "x" [(Name "xmlns" Nothing Nothing, [ContentText "http://jabber.org/protocol/muc"])] []]+ }) sess+ return ()
+ lambdabot-xmpp.cabal view
@@ -0,0 +1,46 @@+name: lambdabot-xmpp+version: 0.1.0.0+synopsis: Lambdabot plugin for XMPP (Jabber) protocol+description: Usage: cabal build && .\/dist\/build\/lambdabot\/lambdabot -e 'xmpp-connect asdfasdf example.com 5222 username nick password haskell@conference.example.com'+license: OtherLicense+license-file: LICENSE+author: Adam Flott, Sergey Alirzaev+maintainer: zl29ah@gmail.com+category: Development+build-type: Simple+cabal-version: >=1.10+Tested-With: GHC == 8.4.4++Source-repository head+ type: git+ location: https://github.com/l29ah/lambdabot-xmpp++Source-repository this+ type: git+ location: https://github.com/l29ah/lambdabot-xmpp+ tag: 0.1.0.0++executable lambdabot+ main-is: Main.hs+ other-modules: Modules,+ Paths_lambdabot_xmpp,+ XMPP+ build-depends: base >=4.11 && <4.12,+ pontarius-xmpp >= 0.4.5 && < 0.6,+ lambdabot-core >= 5.1 && < 5.2,+ lambdabot-haskell-plugins >= 5.1 && < 5.2,+ lambdabot-irc-plugins >= 5.1 && < 5.2,+ lambdabot-misc-plugins >= 5.1 && < 5.2,+ lambdabot-novelty-plugins >= 5.1 && < 5.2,+ lambdabot-reference-plugins >= 5.1 && < 5.2,+ lambdabot-social-plugins >= 5.1 && < 5.2,+ data-default >= 0.7.1.1 && < 0.8,+ split >= 0.2.3.3 && < 0.3,+ lifted-base >= 0.2.3.12 && < 0.3,+ mtl >= 2.2.2 && < 2.3,+ network >= 2.6.3.2 && < 2.7,+ text >= 1.2.3.1 && < 1.3,+ tls >= 1.4.1 && < 1.5,+ x509-validation >= 1.6.10 && < 1.7,+ xml-types >= 0.3.6 && < 0.4+ default-language: Haskell2010