southerntofu
/
cheogram-muc-bridge
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Allow Config to contain more than just the raw config file 

Database connection, version, etc
This commit is contained in:
Stephen Paul Weber 2021-06-25 22:04:58 -05:00
parent b160817afb
commit 27ee019dec
No known key found for this signature in database
GPG Key ID: D11C2911CE519CDE
5 changed files with 94 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
Config.hs
View File

@ -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)
bridgeJid :: XMPP.JID,
db :: DB.Connection,
dbVersion :: Integer,
mucs :: [ConfigFile.Bridge]
}
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
}
-- Not importing Util because Util imports us
s :: (IsString s) => String -> s
s = fromString
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
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
}

50
ConfigFile.hs Normal file
View File

@ -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
}

2
Util.hs
View File

@ -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

3
cheogram-muc-bridge.cabal
View File

@ -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
other-modules: Router, Util, Config, ConfigFile

20
gateway.hs
View File

@ -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,