~singpolyma/cheogram-muc-bridge

27ee019deca4ac0d11da318f6e8204995ed7ac97 — Stephen Paul Weber 2 years ago b160817
Allow Config to contain more than just the raw config file

Database connection, version, etc
5 files changed, 96 insertions(+), 48 deletions(-)

M Config.hs
A ConfigFile.hs
M Util.hs
M cheogram-muc-bridge.cabal
M gateway.hs
M Config.hs => Config.hs +31 -38
@@ 1,51 1,44 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}

module Config where
module Config (setup, Config(..), ConfigFile.ServerConfig(..), ConfigFile.Bridge(..)) where

import Prelude ()
import BasicPrelude

import qualified Network
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Dhall
import qualified Dhall.Core as Dhall
import qualified Network.Protocol.XMPP as XMPP
import qualified Database.SQLite.Simple as DB

import Util

data ServerConfig = ServerConfig {
	host :: Network.HostName,
	port :: Network.PortID
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

data Bridge = Bridge {
	muc1 :: XMPP.JID,
	muc2 :: XMPP.JID
} deriving (Dhall.Generic, Dhall.FromDhall, Show)
import qualified ConfigFile

data Config = Config {
	componentJid :: XMPP.JID,
	server :: ServerConfig,
	server :: ConfigFile.ServerConfig,
	secret :: Text,
	nick :: Text,
	mucs :: [Bridge]
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

instance Dhall.FromDhall XMPP.JID where
	autoWith _ = Dhall.Decoder {
			Dhall.extract = \(Dhall.TextLit (Dhall.Chunks _ txt)) ->
				maybe (Dhall.extractError $ s"Invalid JID") pure $ XMPP.parseJID txt,
			Dhall.expected = pure Dhall.Text
		}

instance Dhall.FromDhall Network.PortID where
	autoWith _ = Dhall.Decoder {
			Dhall.extract = \(Dhall.NaturalLit nat) -> pure $ Network.PortNumber (fromIntegral nat),
			Dhall.expected = pure Dhall.Natural
		}

instance Dhall.FromDhall Network.PortNumber where
	autoWith _ = Dhall.Decoder {
			Dhall.extract = \(Dhall.NaturalLit nat) -> pure $ fromIntegral nat,
			Dhall.expected = pure Dhall.Natural
	bridgeJid :: XMPP.JID,
	db :: DB.Connection,
	dbVersion :: Integer,
	mucs :: [ConfigFile.Bridge]
}

-- Not importing Util because Util imports us
s :: (IsString s) => String -> s
s = fromString

setup :: Text -> IO Config
setup expr = do
	configFile <- Dhall.input Dhall.auto expr
	Just bridgeJid <- return $ XMPP.parseJID $ s"bridge@" ++
		XMPP.formatJID (ConfigFile.componentJid configFile) ++ s"/bridge"
	db <- DB.open (textToString $ ConfigFile.db configFile)
	now <- getPOSIXTime
	return $ Config {
			componentJid = ConfigFile.componentJid configFile,
			server = ConfigFile.server configFile,
			secret = ConfigFile.secret configFile,
			nick = ConfigFile.nick configFile,
			bridgeJid = bridgeJid,
			db = db,
			dbVersion = ceiling now,
			mucs = ConfigFile.mucs configFile
		}

A ConfigFile.hs => ConfigFile.hs +50 -0
@@ 0,0 1,50 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}

module ConfigFile where

import Prelude ()
import BasicPrelude

import qualified Network
import qualified Dhall
import qualified Dhall.Core as Dhall
import qualified Network.Protocol.XMPP as XMPP

data ServerConfig = ServerConfig {
	host :: Network.HostName,
	port :: Network.PortID
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

data Bridge = Bridge {
	muc1 :: XMPP.JID,
	muc2 :: XMPP.JID
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

data Config = Config {
	componentJid :: XMPP.JID,
	server :: ServerConfig,
	secret :: Text,
	nick :: Text,
	db :: Text,
	mucs :: [Bridge]
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

instance Dhall.FromDhall XMPP.JID where
	autoWith _ = Dhall.Decoder {
			Dhall.extract = \(Dhall.TextLit (Dhall.Chunks _ txt)) ->
				maybe (Dhall.extractError $ fromString "Invalid JID") pure $ XMPP.parseJID txt,
			Dhall.expected = pure Dhall.Text
		}

instance Dhall.FromDhall Network.PortID where
	autoWith _ = Dhall.Decoder {
			Dhall.extract = \(Dhall.NaturalLit nat) -> pure $ Network.PortNumber (fromIntegral nat),
			Dhall.expected = pure Dhall.Natural
		}

instance Dhall.FromDhall Network.PortNumber where
	autoWith _ = Dhall.Decoder {
			Dhall.extract = \(Dhall.NaturalLit nat) -> pure $ fromIntegral nat,
			Dhall.expected = pure Dhall.Natural
		}

M Util.hs => Util.hs +2 -0
@@ 13,6 13,8 @@ import qualified Data.Text             as Text
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP

import qualified Config

s :: (IsString s) => String -> s
s = fromString


M cheogram-muc-bridge.cabal => cheogram-muc-bridge.cabal +2 -1
@@ 21,6 21,7 @@ common defs
                       errors                >=2.3 && <2.4,
                       network               >= 2.6.3 && < 2.7,
                       network-protocol-xmpp >=0.4 && <0.5,
                       sqlite-simple         >= 0.4 && <0.5,
                       text                  >=1.2 && <1.3,
                       time                  >=1.5 && <2.0,
                       xml-types             >=0.3 && <0.4


@@ 28,4 29,4 @@ common defs
executable gateway
  import:              defs
  main-is:             gateway.hs
  other-modules:       Router, Util, Config
\ No newline at end of file
  other-modules:       Router, Util, Config, ConfigFile
\ No newline at end of file

M gateway.hs => gateway.hs +11 -9
@@ 5,7 5,6 @@ import BasicPrelude
import System.IO
	(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Error                   (exceptT, justZ)
import qualified Dhall
import qualified Data.Text             as T
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP


@@ 56,7 55,7 @@ handlePresence config presence@XMPP.Presence {
	XMPP.presenceTo = Just to,
	XMPP.presencePayloads = p
}
	| bareTxt to /= s"bridge@" ++ XMPP.formatJID (Config.componentJid config) =
	| bareTxt to /= bareTxt (Config.bridgeJid config) =
		-- This is to one of our ghosts, so just ignore it
		return ()
	| hasMucCode 110 presence = return () -- ignore self presence


@@ 98,7 97,7 @@ handleGroupChat config message@XMPP.Message {
	XMPP.messageFrom = Just from,
	XMPP.messageTo = Just to
}
	| bareTxt to /= s"bridge@" ++ XMPP.formatJID (Config.componentJid config) =
	| bareTxt to /= bareTxt (Config.bridgeJid config) =
		-- This is to one of our ghosts, so just ignore it
		return ()
	| otherwise = forM_ (targets config from) $ \target ->


@@ 150,26 149,29 @@ handleIq config iq@XMPP.IQ {
	target = XMPP.parseJID $ unescapeJid $ XMPP.strNode node
handleIq _ _ = return ()

joinFromBridge :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
joinFromBridge config muc = do
	XMPP.putStanza $ (mucJoin muc (Config.nick config)) {
			XMPP.presenceFrom = Just $ Config.bridgeJid config
		}

main :: IO ()
main = do
	hSetBuffering stdout LineBuffering
	hSetBuffering stderr LineBuffering

	config <- Dhall.input Dhall.auto =<< fmap head getArgs
	config <- Config.setup =<< fmap head getArgs

	let server = XMPP.Server
		(Config.componentJid config)
		(Config.host $ Config.server config)
		(Config.port $ Config.server config)

	let Just bridgeJid = XMPP.parseJID $ s"bridge@" ++
		XMPP.formatJID (Config.componentJid config) ++ s"/bridge"

	exceptT print return $
		runRoutedComponent server (Config.secret config) $ do
			forM_ (Config.mucs config) $ \bridge -> do
				XMPP.putStanza $ (mucJoin (Config.muc1 bridge) (Config.nick config)) { XMPP.presenceFrom = Just bridgeJid }
				XMPP.putStanza $ (mucJoin (Config.muc2 bridge) (Config.nick config)) { XMPP.presenceFrom = Just bridgeJid }
				joinFromBridge config (Config.muc1 bridge)
				joinFromBridge config (Config.muc2 bridge)
			return $ defaultRoutes {
				presenceRoute = handlePresence config,
				presenceErrorRoute = handlePresenceError,