diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 "" onStartupCmds strs) "Run a lambdabot command instead of a REPL" + , Option "l" [] (arg "" consoleLogLevel level) "Set the logging level" +-- , Option "t" ["trust"] (arg "" trustedPackages strs) "Trust the specified packages when evaluating code" + , Option "V" ["version"] (NoArg version) "Print the version of lambdabot" +-- , Option "X" [] (arg "" 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] diff --git a/Modules.hs b/Modules.hs new file mode 100644 --- /dev/null +++ b/Modules.hs @@ -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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/XMPP.hs b/XMPP.hs new file mode 100644 --- /dev/null +++ b/XMPP.hs @@ -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 . 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 () diff --git a/lambdabot-xmpp.cabal b/lambdabot-xmpp.cabal new file mode 100644 --- /dev/null +++ b/lambdabot-xmpp.cabal @@ -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