From 432ff585d9fa0aafcf898a2e8e8be2d5b4524874 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Fri, 19 Apr 2024 02:08:00 -0400 Subject: Multi-bridge functionality --- .gitignore | 1 + .../fig-bridge-irc-discord.cabal | 3 +- fig-bridge-irc-discord/main/Main.hs | 6 +- .../src/Fig/Bridge/IRCDiscord.hs | 51 +++- .../src/Fig/Bridge/IRCDiscord/Utils.hs | 29 +++ fig-frontend/fig-frontend.cabal | 2 +- fig-frontend/src/Fig/Frontend.hs | 162 +++++++------ fig-frontend/src/Fig/Frontend/Auth.hs | 43 ++-- fig-monitor-discord/src/Fig/Monitor/Discord.hs | 15 +- .../src/Fig/Monitor/Discord/Utils.hs | 2 - fig-monitor-irc/src/Fig/Monitor/IRC.hs | 23 +- fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs | 2 - fig-utils/src/Fig/Prelude.hs | 4 +- flake.lock | 268 +-------------------- flake.nix | 86 ++++--- 15 files changed, 261 insertions(+), 436 deletions(-) create mode 100644 fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord/Utils.hs diff --git a/.gitignore b/.gitignore index d82ba86..91b3204 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ dist-newstyle node_modules fig-monitor-*.toml +fig-bridge-*.toml fig-frontend.toml fig-frontend-assets fig-frontend-client/output/* \ No newline at end of file diff --git a/fig-bridge-irc-discord/fig-bridge-irc-discord.cabal b/fig-bridge-irc-discord/fig-bridge-irc-discord.cabal index 6a59f11..4d10b4e 100644 --- a/fig-bridge-irc-discord/fig-bridge-irc-discord.cabal +++ b/fig-bridge-irc-discord/fig-bridge-irc-discord.cabal @@ -37,6 +37,7 @@ library hs-source-dirs: src exposed-modules: Fig.Bridge.IRCDiscord + Fig.Bridge.IRCDiscord.Utils executable fig-bridge-irc-discord import: defaults @@ -44,4 +45,4 @@ executable fig-bridge-irc-discord build-depends: fig-bridge-irc-discord, optparse-applicative hs-source-dirs: main - main-is: Main.hs \ No newline at end of file + main-is: Main.hs diff --git a/fig-bridge-irc-discord/main/Main.hs b/fig-bridge-irc-discord/main/Main.hs index 8cd1fcb..2c6d2ba 100644 --- a/fig-bridge-irc-discord/main/Main.hs +++ b/fig-bridge-irc-discord/main/Main.hs @@ -5,16 +5,19 @@ import Fig.Prelude import Options.Applicative import Fig.Bridge.IRCDiscord +import Fig.Bridge.IRCDiscord.Utils data Opts = Opts { busHost :: Text , busPort :: Text + , config :: FilePath } parseOpts :: Parser Opts parseOpts = Opts <$> strOption (long "bus-host" <> metavar "HOST" <> help "Address of message bus" <> value "localhost") <*> strOption (long "bus-port" <> metavar "PORT" <> help "Message bus port" <> showDefault <> value "32050") + <*> strOption (long "config" <> metavar "PATH" <> help "Path to config file" <> showDefault <> value "fig-bridge-irc-discord.toml") main :: IO () main = do @@ -22,4 +25,5 @@ main = do ( fullDesc <> header "fig-bridge-irc-discord - bridge between IRC and Discord" ) - bridge (opts.busHost, opts.busPort) + cfg <- loadConfig opts.config + bridge cfg (opts.busHost, opts.busPort) diff --git a/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord.hs b/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord.hs index b1e6c43..c3232cb 100644 --- a/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord.hs +++ b/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord.hs @@ -4,11 +4,14 @@ module Fig.Bridge.IRCDiscord where import Fig.Prelude +import qualified Data.List as List + +import Fig.Bridge.IRCDiscord.Utils import Fig.Utils.SExpr import Fig.Bus.Client -bridge :: (Text, Text) -> IO () -bridge busAddr = do +bridge :: Config -> (Text, Text) -> IO () +bridge cfg busAddr = do busClient busAddr (\cmds -> do cmds.subscribe [sexp|(monitor irc chat incoming)|] @@ -16,17 +19,39 @@ bridge busAddr = do ) (\cmds d -> do case d of - SExprList [ev, user, _, msg] - | ev == [sexp|(monitor irc chat incoming)|] -> - cmds.publish [sexp|(monitor discord chat outgoing)|] - [ user - , msg - ] - | ev == [sexp|(monitor discord chat incoming)|] -> - cmds.publish [sexp|(monitor irc chat outgoing)|] - [ user - , msg - ] + SExprList [ev, tchan, user, _, msg] + | ev == [sexp|(monitor irc chat incoming)|] + , SExprString chan <- tchan -> + case List.find ((== chan) . snd) cfg.mapping of + Nothing -> log $ mconcat + [ "Message on unmapped IRC channel: " <> tshow chan + ] + Just (dchan, _) -> do + log $ mconcat + [ "Incoming message on IRC channel " <> tshow chan + , ", bridging to Discord channel " <> tshow dchan + ] + cmds.publish [sexp|(monitor discord chat outgoing)|] + [ SExprInteger $ fromIntegral dchan + , user + , msg + ] + | ev == [sexp|(monitor discord chat incoming)|] + , SExprInteger chan <- tchan -> + case List.find ((== fromInteger chan) . fst) cfg.mapping of + Nothing -> log $ mconcat + [ "Message on unmapped Discord channel: " <> tshow chan + ] + Just (_, ichan) -> do + log $ mconcat + [ "Incoming message on Discord channel " <> tshow chan + , ", bridging to IRC channel " <> ichan + ] + cmds.publish [sexp|(monitor irc chat outgoing)|] + [ SExprString ichan + , user + , msg + ] _ -> log $ "Invalid message: " <> tshow d ) (pure ()) diff --git a/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord/Utils.hs b/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord/Utils.hs new file mode 100644 index 0000000..00d227d --- /dev/null +++ b/fig-bridge-irc-discord/src/Fig/Bridge/IRCDiscord/Utils.hs @@ -0,0 +1,29 @@ +{-# Language ApplicativeDo #-} + +module Fig.Bridge.IRCDiscord.Utils + ( FigBridgeIRCDiscordException(..) + , Config(..) + , loadConfig + ) where + +import Fig.Prelude + +import qualified Toml + +newtype FigBridgeIRCDiscordException = FigBridgeIRCDiscordException Text + deriving (Show, Eq, Ord) +instance Exception FigBridgeIRCDiscordException + +newtype Config = Config + { mapping :: [(Int, Text)] + } deriving (Show, Eq, Ord) + +configCodec :: Toml.TomlCodec Config +configCodec = do + mapping <- Toml.list (Toml.pair (Toml.int "discord") (Toml.text "irc")) "mapping" Toml..= (\a -> a.mapping) + pure $ Config{..} + +loadConfig :: FilePath -> IO Config +loadConfig path = Toml.decodeFileEither configCodec path >>= \case + Left err -> throwM . FigBridgeIRCDiscordException $ tshow err + Right config -> pure config diff --git a/fig-frontend/fig-frontend.cabal b/fig-frontend/fig-frontend.cabal index 855683b..f3c4f2e 100644 --- a/fig-frontend/fig-frontend.cabal +++ b/fig-frontend/fig-frontend.cabal @@ -32,11 +32,11 @@ common deps , random , req , safe-exceptions + , scotty , text , time , tomland , transformers - , twain , unordered-containers , vector , wai diff --git a/fig-frontend/src/Fig/Frontend.hs b/fig-frontend/src/Fig/Frontend.hs index 92a9d04..51938dc 100644 --- a/fig-frontend/src/Fig/Frontend.hs +++ b/fig-frontend/src/Fig/Frontend.hs @@ -9,12 +9,14 @@ import System.Random (randomRIO) import Control.Lens (use, (^?), Ixed (..)) import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.L import qualified Data.ByteString.Base64 as BS.Base64 +import qualified Network.Wai as Wai import qualified Network.Wai.Middleware.Static as Wai.Static import qualified Network.Wai.Handler.Warp as Warp -import qualified Web.Twain as Tw +import qualified Web.Scotty as Sc import Fig.Utils.SExpr import Fig.Bus.Client @@ -37,83 +39,93 @@ server cfg busAddr = do sexprStr :: Text -> SExpr sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8 -app :: Config -> Commands IO -> IO Tw.Application +app :: Config -> Commands IO -> IO Wai.Application app cfg cmds = do log "Connecting to database..." db <- DB.connect cfg log "Connected! Server active." st <- stateRef - pure $ foldr' @[] ($) - (Tw.notFound . Tw.send $ Tw.text "not found") - [ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath - , Tw.get "/api/check" $ authed cfg \auth -> do - Tw.send $ Tw.json @[Text] [auth.id, auth.name] - , Tw.put "/api/buffer" do - buf <- withState st $ use buffer - Tw.send $ Tw.text buf - , Tw.get "/api/motd" do - DB.get db "motd" >>= \case - Nothing -> Tw.send $ Tw.text "" - Just val -> Tw.send . Tw.text $ decodeUtf8 val - , Tw.get "/api/catchphrase" do - let catchphrases = - [ "vtuber (male)" - , "man of letters" - , "cool guy, online" - , "internet clown man" - , "professional emacs fan" - , "web freak" - , "guy who really likes programming" - , "i use nixos btw" - , "(are these funny or cringe or both?)" - , "haha yay" - , "Joel" - ] :: [Text] - i <- randomRIO (0, length catchphrases - 1) - case catchphrases ^? ix i of - Nothing -> Tw.send $ Tw.text "man of letters" - Just val -> Tw.send $ Tw.text val - , Tw.get "/api/user/:name" do - name <- Text.toLower <$> Tw.param "name" - DB.get db ("user:" <> encodeUtf8 name) >>= \case - Nothing -> Tw.send . Tw.status Tw.status404 $ Tw.text "user not found" - Just val -> Tw.send . Tw.text $ decodeUtf8 val - , Tw.post "/api/redeem" do - me <- Text.toLower <$> Tw.param "ayem" - name <- Tw.param "name" - input <- Tw.paramMaybe "input" - liftIO $ cmds.publish [sexp|(frontend redeem incoming)|] - $ mconcat - [ [ sexprStr me - , sexprStr name - ] - , maybe [] ((:[]) . sexprStr) input + Sc.scottyApp do + Sc.middleware $ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath + Sc.get "/api/check" $ authed cfg \auth -> do + Sc.json @[Text] [auth.id, auth.name] + Sc.put "/api/buffer" do + buf <- withState st $ use buffer + Sc.text $ Text.L.fromStrict buf + Sc.get "/api/motd" do + DB.get db "motd" >>= \case + Nothing -> Sc.text "" + Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val + Sc.get "/api/motd" do + DB.get db "motd" >>= \case + Nothing -> Sc.text "" + Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val + Sc.get "/api/catchphrase" do + let catchphrases = + [ "vtuber (male)" + , "man of letters" + , "cool guy, online" + , "internet clown man" + , "professional emacs fan" + , "web freak" + , "guy who really likes programming" + , "i use nixos btw" + , "(are these funny or cringe or both?)" + , "haha yay" + , "Joel" + ] :: [Text] + i <- randomRIO (0, length catchphrases - 1) + case catchphrases ^? ix i of + Nothing -> Sc.text "man of letters" + Just val -> Sc.text $ Text.L.fromStrict val + Sc.get "/api/user/:name" do + name <- Text.toLower <$> Sc.pathParam "name" + DB.get db ("user:" <> encodeUtf8 name) >>= \case + Nothing -> do + Sc.status status404 + Sc.text "user not found" + Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val + Sc.post "/api/redeem" do + me <- Text.toLower <$> Sc.formParam "ayem" + name <- Sc.formParam "name" + input <- Sc.formParamMaybe "input" + liftIO $ cmds.publish [sexp|(frontend redeem incoming)|] + $ mconcat + [ [ sexprStr me + , sexprStr name ] - Tw.send $ Tw.text "it worked" - , Tw.get "/api/songs" do - DB.hvals db "songnames" >>= \case - Nothing -> Tw.send . Tw.status Tw.status404 $ Tw.text "no sounds found :(" - Just songs -> Tw.send . Tw.text . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs - , Tw.get "/api/song/:hash" do - hash <- Tw.param "hash" - DB.hget db "songnotes" hash >>= \case - Nothing -> Tw.send . Tw.status Tw.status404 $ Tw.text "song not found" - Just val -> Tw.send . Tw.text $ decodeUtf8 val - , Tw.get "/api/poke/:name" do - target <- encodeUtf8 . Text.toLower <$> Tw.param "name" - inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target) - Tw.send . Tw.text . pretty . SExprList @Void $ sexprStr . decodeUtf8 <$> inbox - , Tw.post "/api/poke/:name" do - me <- encodeUtf8 . Text.toLower <$> Tw.param "ayem" - target <- encodeUtf8 . Text.toLower <$> Tw.param "name" - DB.sismember db ("pokeinbox:" <> me) target >>= \case - True -> do - log . tshow $ "handshake between " <> me <> " and " <> target <> " complete!" - DB.srem db ("pokeinbox:" <> target) [me] - DB.srem db ("pokeinbox:" <> me) [target] - Tw.send $ Tw.text "complete" - False -> do - log . tshow $ "partial handshake from " <> me <> " to " <> target - DB.sadd db ("pokeinbox:" <> target) [me] - Tw.send $ Tw.text "partial" - ] + , maybe [] ((:[]) . sexprStr) input + ] + Sc.text "it worked" + Sc.get "/api/songs" do + DB.hvals db "songnames" >>= \case + Nothing -> do + Sc.status status404 + Sc.text "no sounds found :(" + Just songs -> Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> songs + Sc.get "/api/song/:hash" do + hash <- Sc.pathParam "hash" + DB.hget db "songnotes" hash >>= \case + Nothing -> do + Sc.status status404 + Sc.text "song not found" + Just val -> Sc.text . Text.L.fromStrict $ decodeUtf8 val + Sc.get "/api/poke/:name" do + target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name" + inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target) + Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ sexprStr . decodeUtf8 <$> inbox + Sc.post "/api/poke/:name" do + me <- encodeUtf8 . Text.toLower <$> Sc.formParam "ayem" + target <- encodeUtf8 . Text.toLower <$> Sc.pathParam "name" + DB.sismember db ("pokeinbox:" <> me) target >>= \case + True -> do + log . tshow $ "handshake between " <> me <> " and " <> target <> " complete!" + DB.srem db ("pokeinbox:" <> target) [me] + DB.srem db ("pokeinbox:" <> me) [target] + Sc.text "complete" + False -> do + log . tshow $ "partial handshake from " <> me <> " to " <> target + DB.sadd db ("pokeinbox:" <> target) [me] + Sc.text "partial" + Sc.notFound do + Sc.text "not found" diff --git a/fig-frontend/src/Fig/Frontend/Auth.hs b/fig-frontend/src/Fig/Frontend/Auth.hs index 72eac0d..e9fe233 100644 --- a/fig-frontend/src/Fig/Frontend/Auth.hs +++ b/fig-frontend/src/Fig/Frontend/Auth.hs @@ -2,29 +2,28 @@ module Fig.Frontend.Auth where import Fig.Prelude -import GHC.Generics (Generic) - import qualified Network.HTTP.Req as R import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import qualified Web.Twain as Tw - import qualified Jose.Jwk as Jwk import qualified Jose.Jwt as Jwt +import qualified Web.Scotty as Sc +import qualified Web.Scotty.Cookie as Sc.C + import Fig.Frontend.Utils data TokenContents = TokenContents - { aud :: Text - , exp :: Int - , iat :: Int - , iss :: Text - , sub :: Text - , azp :: Text - , nonce :: Text - , preferred_username :: Text + { aud :: !Text + , exp :: !Int + , iat :: !Int + , iss :: !Text + , sub :: !Text + , azp :: !Text + , nonce :: !Text + , preferred_username :: !Text } deriving (Show, Eq, Generic) instance Aeson.FromJSON TokenContents @@ -52,14 +51,14 @@ validateToken encodedToken = fetchJwk >>= \case log $ tshow contents pure $ Aeson.decodeStrict contents -data Auth = Auth { id :: Text, name :: Text } deriving Show -checkAuth :: Config -> Tw.ResponderM (Maybe Auth) +data Auth = Auth { id :: !Text, name :: !Text } deriving Show +checkAuth :: Config -> Sc.ActionM (Maybe Auth) checkAuth cfg = (,) - <$> Tw.cookieParamMaybe "id_token" - <*> Tw.cookieParamMaybe "authnonce" + <$> Sc.C.getCookie "id_token" + <*> Sc.C.getCookie "authnonce" >>= \case (Just token, Just nonce) -> do - validateToken token >>= \case + validateToken (encodeUtf8 token) >>= \case Just tc | tc.aud == cfg.clientId , tc.nonce == nonce @@ -69,10 +68,12 @@ checkAuth cfg = (,) { name = tc.preferred_username , id = tc.sub } - _ -> pure Nothing - _ -> pure Nothing + _else -> pure Nothing + _else -> pure Nothing -authed :: Config -> (Auth -> Tw.ResponderM a) -> Tw.ResponderM a +authed :: Config -> (Auth -> Sc.ActionM ()) -> Sc.ActionM () authed cfg f = checkAuth cfg >>= \case - Nothing -> Tw.send . Tw.status Tw.status401 $ Tw.text "unauthorized" + Nothing -> do + Sc.status status401 + Sc.text "unauthorized" Just auth -> f auth diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord.hs b/fig-monitor-discord/src/Fig/Monitor/Discord.hs index d5b09f3..714d10b 100644 --- a/fig-monitor-discord/src/Fig/Monitor/Discord.hs +++ b/fig-monitor-discord/src/Fig/Monitor/Discord.hs @@ -4,8 +4,6 @@ module Fig.Monitor.Discord where import Fig.Prelude -import GHC.Real (fromIntegral) - import Control.Monad (unless) import Control.Monad.Reader (runReaderT) import qualified Control.Concurrent.Async as Async @@ -27,7 +25,8 @@ import Fig.Bus.Client import Fig.Monitor.Discord.Utils data OutgoingMessage = OutgoingMessage - { user :: Text + { chan :: Integer + , user :: Text , msg :: Text } @@ -44,7 +43,6 @@ stickerUrl sid ty = base <> sid <> "." <> ext discordBot :: Config -> (Text, Text) -> IO () discordBot cfg busAddr = do outgoing <- Chan.newChan @OutgoingMessage - let cid = Dis.DiscordId $ Dis.Snowflake $ fromIntegral cfg.channel busClient busAddr (\cmds -> do cmds.subscribe [sexp|(monitor discord chat outgoing)|] @@ -62,6 +60,7 @@ discordBot cfg busAddr = do dst <- ask liftIO . void . Async.async . forever $ flip runReaderT dst do o <- liftIO $ Chan.readChan outgoing + let cid = Dis.DiscordId $ Dis.Snowflake $ fromIntegral o.chan void . Dis.restCall . Dis.CreateMessage cid $ mconcat [ "`<", o.user, ">` " , o.msg @@ -79,6 +78,7 @@ discordBot cfg busAddr = do void . Dis.restCall . Dis.CreateInteractionResponse (Dis.interactionId cmd) (Dis.interactionToken cmd) $ Dis.interactionResponseBasic "pong" Dis.MessageCreate m -> let + chan = Dis.messageChannelId m auth = Dis.messageAuthor m mmemb = Dis.messageMember m msticker = Dis.messageStickerItems m >>= headMay @@ -122,7 +122,8 @@ discordBot cfg busAddr = do in unless (Dis.userIsBot auth) do log $ "Received: " <> processedMsg <> " (from " <> name <> ")" liftIO $ cmds.publish [sexp|(monitor discord chat incoming)|] - [ SExprString . BS.Base64.encodeBase64 $ encodeUtf8 name + [ SExprInteger . fromIntegral . Dis.unSnowflake $ Dis.unId chan + , SExprString . BS.Base64.encodeBase64 $ encodeUtf8 name , SExprList [] , SExprString . BS.Base64.encodeBase64 . encodeUtf8 . Text.intercalate " " $ maybe [] ((:[]) . (<>":")) replyStr <> @@ -136,7 +137,7 @@ discordBot cfg busAddr = do ) (\_cmds d -> do case d of - SExprList [ev, SExprString euser, SExprString emsg] + SExprList [ev, SExprInteger chan, SExprString euser, SExprString emsg] | ev == [sexp|(monitor discord chat outgoing)|] , Right user <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 euser) , Right msg <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 emsg) -> do @@ -147,7 +148,7 @@ discordBot cfg busAddr = do , (":mrred:", "<:mrred:1154524307649724449>") ] let newMsg = foldr' (\(n, r) h -> Text.replace n r h) msg replacements - Chan.writeChan outgoing OutgoingMessage { user = user, msg = newMsg } + Chan.writeChan outgoing OutgoingMessage { chan, user, msg = newMsg } _ -> log $ "Invalid outgoing message: " <> tshow d ) (pure ()) diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs b/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs index b2a316d..21e3a72 100644 --- a/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs +++ b/fig-monitor-discord/src/Fig/Monitor/Discord/Utils.hs @@ -16,13 +16,11 @@ instance Exception FigMonitorDiscordException data Config = Config { authToken :: Text - , channel :: Int } deriving (Show, Eq, Ord) configCodec :: Toml.TomlCodec Config configCodec = do authToken <- Toml.text "auth_token" Toml..= (\a -> a.authToken) - channel <- Toml.int "channel" Toml..= (\a -> a.channel) pure $ Config{..} loadConfig :: FilePath -> IO Config diff --git a/fig-monitor-irc/src/Fig/Monitor/IRC.hs b/fig-monitor-irc/src/Fig/Monitor/IRC.hs index 08ddf24..c84b2f4 100644 --- a/fig-monitor-irc/src/Fig/Monitor/IRC.hs +++ b/fig-monitor-irc/src/Fig/Monitor/IRC.hs @@ -20,15 +20,11 @@ import Fig.Bus.Client import Fig.Monitor.IRC.Utils data OutgoingMessage = OutgoingMessage - { user :: Text + { chan :: Text + , user :: Text , msg :: Text } -srcUser :: IRC.Source a -> Maybe a -srcUser (IRC.Channel _ user) = Just user -srcUser (IRC.User user) = Just user -srcUser _ = Nothing - ircBot :: Config -> (Text, Text) -> IO () ircBot cfg busAddr = do outgoing <- Chan.newChan @OutgoingMessage @@ -37,7 +33,7 @@ ircBot cfg busAddr = do ( Conc.readMVar mircst >>= \ircst -> forever $ do o <- liftIO $ Chan.readChan outgoing log $ "Sending: " <> o.msg <> " (from " <> o.user <> ")" - let msg = IRC.Privmsg cfg.sendchannel . Right . Text.take 400 $ mconcat + let msg = IRC.Privmsg o.chan . Right . Text.take 400 $ mconcat [ "<", o.user, "> " , Text.replace "\n" " " o.msg ] @@ -53,15 +49,16 @@ ircBot cfg busAddr = do | IRC.Privmsg _ (Right msg) <- ev ^. IRC.message -> Just msg | otherwise -> Nothing ) - ( \src msg -> case srcUser src of - Just user -> do + ( \src msg -> case src of + IRC.Channel chan user -> do log $ "Received: " <> msg <> " (from " <> user <> ")" liftIO $ cmds.publish [sexp|(monitor irc chat incoming)|] - [ SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ user + [ SExprString chan + , SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ user , SExprList [] , SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ msg ] - Nothing -> pure () + _ -> pure () ) ircst <- IRC.newIRCState ( IRC.tlsConnection (IRC.WithDefaultConfig (encodeUtf8 cfg.host) cfg.port) @@ -78,11 +75,11 @@ ircBot cfg busAddr = do ) (\_cmds d -> do case d of - SExprList [ev, SExprString euser, SExprString emsg] + SExprList [ev, SExprString chan, SExprString euser, SExprString emsg] | ev == [sexp|(monitor irc chat outgoing)|] , Right user <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 euser) , Right msg <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 emsg) -> do - Chan.writeChan outgoing OutgoingMessage { user = user, msg = msg } + Chan.writeChan outgoing OutgoingMessage { chan, user, msg = msg } _ -> log $ "Invalid outgoing message: " <> tshow d ) (pure ()) diff --git a/fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs b/fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs index 2cf46b1..b117662 100644 --- a/fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs +++ b/fig-monitor-irc/src/Fig/Monitor/IRC/Utils.hs @@ -18,7 +18,6 @@ data Config = Config { host :: Text , port :: Int , nick :: Text - , sendchannel :: Text , channels :: [Text] } deriving (Show, Eq, Ord) @@ -27,7 +26,6 @@ configCodec = do host <- Toml.text "host" Toml..= (\a -> a.host) port <- Toml.int "port" Toml..= (\a -> a.port) nick <- Toml.text "nick" Toml..= (\a -> a.nick) - sendchannel <- Toml.text "sendchannel" Toml..= (\a -> a.sendchannel) channels <- Toml.arrayOf Toml._Text "channels" Toml..= (\a -> a.channels) pure $ Config{..} diff --git a/fig-utils/src/Fig/Prelude.hs b/fig-utils/src/Fig/Prelude.hs index 060f197..607d26e 100644 --- a/fig-utils/src/Fig/Prelude.hs +++ b/fig-utils/src/Fig/Prelude.hs @@ -1,7 +1,7 @@ {-# Language UndecidableInstances #-} module Fig.Prelude - ( quot, mod, rem, quotRem + ( quot, mod, rem, quotRem, fromIntegral , module GHC.Generics , module GHC.Num , module GHC.Float @@ -52,7 +52,7 @@ module Fig.Prelude , Fix(..), unFix ) where -import Prelude (quot, mod, rem, quotRem) +import Prelude (quot, mod, rem, quotRem, fromIntegral) import GHC.Generics (Generic) import GHC.Num (Num(..), Integer) diff --git a/flake.lock b/flake.lock index 66db5b4..2e7f74f 100644 --- a/flake.lock +++ b/flake.lock @@ -1,135 +1,5 @@ { "nodes": { - "docs-search": { - "flake": false, - "locked": { - "lastModified": 1675992564, - "narHash": "sha256-Tk9VSogFHXtXe9O9vuCEfM/PV/S7plMIO0I++fCZn7U=", - "owner": "purs-nix", - "repo": "purescript-docs-search", - "rev": "35822b1d6ce65b1a07f80dd9e2caf15c3ee83e2c", - "type": "github" - }, - "original": { - "owner": "purs-nix", - "repo": "purescript-docs-search", - "type": "github" - } - }, - "flake-utils": { - "locked": { - "lastModified": 1644229661, - "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_2": { - "locked": { - "lastModified": 1618217525, - "narHash": "sha256-WGrhVczjXTiswQaoxQ+0PTfbLNeOQM6M36zvLn78AYg=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c6169a2772643c4a93a0b5ac1c61e296cba68544", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_3": { - "locked": { - "lastModified": 1618217525, - "narHash": "sha256-WGrhVczjXTiswQaoxQ+0PTfbLNeOQM6M36zvLn78AYg=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c6169a2772643c4a93a0b5ac1c61e296cba68544", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "get-flake": { - "locked": { - "lastModified": 1644686428, - "narHash": "sha256-zkhYsURWFrvEZLkIoBeqFBzSu+cA2u5mo6M8vq9LN7M=", - "owner": "ursi", - "repo": "get-flake", - "rev": "703f15558daa56dfae19d1858bb3046afe68831a", - "type": "github" - }, - "original": { - "owner": "ursi", - "repo": "get-flake", - "type": "github" - } - }, - "lint-utils": { - "inputs": { - "flake-utils": "flake-utils", - "nixpkgs": [ - "purs-nix", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1707777931, - "narHash": "sha256-PsPb5xMBZ9dPDP04o9vqKEUIEG80Z84/74fPuOMs0ZI=", - "owner": "homotopic", - "repo": "lint-utils", - "rev": "5f11e3e51d8f1aa4ed62a89e90f05953931e105a", - "type": "github" - }, - "original": { - "owner": "homotopic", - "repo": "lint-utils", - "type": "github" - } - }, - "make-shell": { - "locked": { - "lastModified": 1634940815, - "narHash": "sha256-P69OmveboXzS+es1vQGS4bt+ckwbeIExqxfGLjGuJqA=", - "owner": "ursi", - "repo": "nix-make-shell", - "rev": "8add91681170924e4d0591b22f294aee3f5516f9", - "type": "github" - }, - "original": { - "owner": "ursi", - "ref": "1", - "repo": "nix-make-shell", - "type": "github" - } - }, - "make-shell_2": { - "locked": { - "lastModified": 1634940815, - "narHash": "sha256-P69OmveboXzS+es1vQGS4bt+ckwbeIExqxfGLjGuJqA=", - "owner": "ursi", - "repo": "nix-make-shell", - "rev": "8add91681170924e4d0591b22f294aee3f5516f9", - "type": "github" - }, - "original": { - "owner": "ursi", - "ref": "1", - "repo": "nix-make-shell", - "type": "github" - } - }, "nixpkgs": { "locked": { "lastModified": 1708815994, @@ -146,145 +16,9 @@ "type": "github" } }, - "nixpkgs_2": { - "locked": { - "lastModified": 1704161960, - "narHash": "sha256-QGua89Pmq+FBAro8NriTuoO/wNaUtugt29/qqA8zeeM=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "63143ac2c9186be6d9da6035fa22620018c85932", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_3": { - "locked": { - "lastModified": 1656549732, - "narHash": "sha256-eILutFZGjfk2bEzfim8S/qyYc//0S1KsCeO+OWbtoR0=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "d3248619647234b5dc74a6921bcdf6dd8323eb22", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "parsec": { - "locked": { - "lastModified": 1635533376, - "narHash": "sha256-/HrG0UPGnI5VdkhrNrpDiM2+nhdL6lD/bqyGtYv0QDE=", - "owner": "nprindle", - "repo": "nix-parsec", - "rev": "1bf25dd9c5de1257a1c67de3c81c96d05e8beb5e", - "type": "github" - }, - "original": { - "owner": "nprindle", - "repo": "nix-parsec", - "type": "github" - } - }, - "ps-tools": { - "inputs": { - "make-shell": "make-shell_2", - "nixpkgs": "nixpkgs_3", - "utils": "utils" - }, - "locked": { - "lastModified": 1704567308, - "narHash": "sha256-WbFPIkKLtyQOPBUjintckKIYnfs7MvIbmfVsLRSAPlc=", - "owner": "purs-nix", - "repo": "purescript-tools", - "rev": "ac626313141cbee78f06eb3c5e90359f695aef9b", - "type": "github" - }, - "original": { - "owner": "purs-nix", - "repo": "purescript-tools", - "type": "github" - } - }, - "purs-nix": { - "inputs": { - "docs-search": "docs-search", - "get-flake": "get-flake", - "lint-utils": "lint-utils", - "make-shell": "make-shell", - "nixpkgs": "nixpkgs_2", - "parsec": "parsec", - "ps-tools": "ps-tools", - "utils": "utils_2" - }, - "locked": { - "lastModified": 1707933489, - "narHash": "sha256-LP05KSBQ02mgBDiVdW53h9ViFBtFQIo4dT3FCebucI0=", - "owner": "purs-nix", - "repo": "purs-nix", - "rev": "72c9a8b7df0e53ff8b24fef00d9ea74d3a5b6522", - "type": "github" - }, - "original": { - "owner": "purs-nix", - "ref": "ps-0.15", - "repo": "purs-nix", - "type": "github" - } - }, "root": { "inputs": { - "nixpkgs": "nixpkgs", - "ps-tools": [ - "purs-nix", - "ps-tools" - ], - "purs-nix": "purs-nix" - } - }, - "utils": { - "inputs": { - "flake-utils": "flake-utils_2" - }, - "locked": { - "lastModified": 1656044990, - "narHash": "sha256-f01BB7CaOyntOab9XnpH9HD63rGcnu2iyL4M2ubs5F8=", - "owner": "ursi", - "repo": "flake-utils", - "rev": "f53b674a2c90f6202a2f4cd491aba121775490b5", - "type": "github" - }, - "original": { - "owner": "ursi", - "ref": "8", - "repo": "flake-utils", - "type": "github" - } - }, - "utils_2": { - "inputs": { - "flake-utils": "flake-utils_3" - }, - "locked": { - "lastModified": 1656044990, - "narHash": "sha256-f01BB7CaOyntOab9XnpH9HD63rGcnu2iyL4M2ubs5F8=", - "owner": "ursi", - "repo": "flake-utils", - "rev": "f53b674a2c90f6202a2f4cd491aba121775490b5", - "type": "github" - }, - "original": { - "owner": "ursi", - "ref": "8", - "repo": "flake-utils", - "type": "github" + "nixpkgs": "nixpkgs" } } }, diff --git a/flake.nix b/flake.nix index 9575cc1..8422b18 100644 --- a/flake.nix +++ b/flake.nix @@ -3,23 +3,30 @@ inputs = { nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable"; - ps-tools.follows = "purs-nix/ps-tools"; - purs-nix.url = "github:purs-nix/purs-nix/ps-0.15"; + # commented pending https://github.com/purs-nix/purs-nix/issues/55 + # ps-tools.follows = "purs-nix/ps-tools"; + # purs-nix.url = "github:purs-nix/purs-nix/ps-0.15"; }; outputs = { self, nixpkgs, ... }@inputs: let system = "x86_64-linux"; pkgs = nixpkgs.legacyPackages.${system}; - ps-tools = inputs.ps-tools.legacyPackages.${system}; - purs-nix = inputs.purs-nix { inherit system; }; + # ps-tools = inputs.ps-tools.legacyPackages.${system}; + # purs-nix = inputs.purs-nix { inherit system; }; haskellOverrides = self: super: { + scotty = self.callHackageDirect { + pkg = "scotty"; + ver = "0.21"; + sha256 = "sha256-coeQZJT7COSmoyA1eiykoMFv3+xNnxkF5tX4mlFcd84="; + } {}; discord-haskell = self.callCabal2nix "discord-haskell" ./deps/discord-haskell {}; irc-conduit = self.callCabal2nix "irc-conduit" ./deps/irc-conduit {}; irc-client = self.callCabal2nix "irc-client" ./deps/irc-client {}; fig-utils = self.callCabal2nix "fig-utils" ./fig-utils {}; fig-bus = self.callCabal2nix "fig-bus" ./fig-bus {}; + fig-monitor-twitch = self.callCabal2nix "fig-monitor-twitch" ./fig-monitor-twitch {}; fig-monitor-discord = self.callCabal2nix "fig-monitor-discord" ./fig-monitor-discord {}; fig-monitor-irc = self.callCabal2nix "fig-monitor-irc" ./fig-monitor-irc {}; fig-monitor-bullfrog = self.callCabal2nix "fig-monitor-bullfrog" ./fig-monitor-bullfrog {}; @@ -32,25 +39,25 @@ overrides = haskellOverrides; }; - purescript = purs-nix.purs { - dependencies = [ - "console" - "effect" - "prelude" - "random" - "refs" - "web-html" - "web-dom" - "web-uievents" - "canvas" - "argonaut" - "fetch" - "fetch-argonaut" - ]; - dir = ./fig-frontend-client; - srcs = [ "src" ]; - }; - fig-frontend-client = purescript.bundle {}; + # purescript = purs-nix.purs { + # dependencies = [ + # "console" + # "effect" + # "prelude" + # "random" + # "refs" + # "web-html" + # "web-dom" + # "web-uievents" + # "canvas" + # "argonaut" + # "fetch" + # "fetch-argonaut" + # ]; + # dir = ./fig-frontend-client; + # srcs = [ "src" ]; + # }; + # fig-frontend-client = purescript.bundle {}; figBusModule = { config, lib, ... }: let @@ -108,7 +115,6 @@ description = "Path to config file"; default = pkgs.writeText "fig-monitor-discord.toml" '' auth_token = "" - channel = 1064660360533135551 ''; }; }; @@ -153,8 +159,7 @@ host = "colonq.computer" port = 26697 nick = "discord" - sendchannel = "#cyberspace" - channels = ["#cyberspace"] + channels = ["#cyberspace", "#geiserzone", "#jakerealm"] ''; }; }; @@ -192,6 +197,23 @@ default = 32050; description = "Address of message bus"; }; + configFile = lib.mkOption { + type = lib.types.path; + description = "Path to config file"; + default = pkgs.writeText "fig-bridge-irc-discord.toml" '' + [[mapping]] + irc = "#cyberspace" + discord = 1064660360533135551 # the-computer in clonkcord + + [[mapping]] + irc = "#geiserzone" + discord = 1117224697914990662 # bot-test in clonkcord + + [[mapping]] + irc = "#jakerealm" + discord = 1135088202114412628 # general in jakecord + ''; + }; }; config = lib.mkIf cfg.enable { systemd.services."colonq.fig-bridge-irc-discord" = { @@ -199,7 +221,7 @@ after = ["colonq.fig-bus.service"]; serviceConfig = { Restart = "on-failure"; - ExecStart = "${haskellPackages.fig-bridge-irc-discord}/bin/fig-bridge-irc-discord --bus-host ${cfg.busHost} --bus-port ${toString cfg.busPort}"; + ExecStart = "${haskellPackages.fig-bridge-irc-discord}/bin/fig-bridge-irc-discord --bus-host ${cfg.busHost} --bus-port ${toString cfg.busPort} --config ${cfg.configFile}"; DynamicUser = "yes"; RuntimeDirectory = "colonq.fig-bridge-irc-discord"; RuntimeDirectoryMode = "0755"; @@ -261,6 +283,7 @@ packages = hspkgs: with hspkgs; [ fig-utils fig-bus + fig-monitor-twitch fig-monitor-discord fig-monitor-irc fig-monitor-bullfrog @@ -273,10 +296,10 @@ buildInputs = [ haskellPackages.haskell-language-server pkgs.nodejs - (purescript.command {}) - ps-tools.for-0_15.purescript-language-server - purs-nix.esbuild - purs-nix.purescript + # (purescript.command {}) + # ps-tools.for-0_15.purescript-language-server + # purs-nix.esbuild + # purs-nix.purescript pkgs.m4 pkgs.dhall pkgs.dhall-json @@ -285,6 +308,7 @@ packages.x86_64-linux = { default = haskellPackages.fig-bus; figBus = haskellPackages.fig-bus; + figMonitorTwitch = haskellPackages.fig-monitor-twitch; figMonitorDiscord = haskellPackages.fig-monitor-discord; figMonitorIRC = haskellPackages.fig-monitor-irc; figMonitorBullfrog = haskellPackages.fig-monitor-bullfrog; -- cgit v1.2.3