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,