diff options
29 files changed, 779 insertions, 677 deletions
diff --git a/fig-monitor-twitch/fig-monitor-twitch.cabal b/fig-monitor-twitch/fig-monitor-twitch.cabal index 2174b43..54b82f7 100644 --- a/fig-monitor-twitch/fig-monitor-twitch.cabal +++ b/fig-monitor-twitch/fig-monitor-twitch.cabal @@ -45,9 +45,11 @@ library exposed-modules: Fig.Monitor.Twitch Fig.Monitor.Twitch.Utils - -- Fig.Monitor.Twitch.Chat - -- Fig.Monitor.Twitch.EventSub - -- Fig.Monitor.Twitch.UserTokenRedirectServer + Fig.Monitor.Twitch.Auth.UserToken + Fig.Monitor.Twitch.Auth.AppToken + Fig.Monitor.Twitch.LiveChecker + Fig.Monitor.Twitch.Chatbot + Fig.Monitor.Twitch.EventMonitor executable fig-monitor-twitch import: defaults diff --git a/fig-monitor-twitch/main/Main.hs b/fig-monitor-twitch/main/Main.hs index 682d35b..a370b0b 100644 --- a/fig-monitor-twitch/main/Main.hs +++ b/fig-monitor-twitch/main/Main.hs @@ -12,7 +12,6 @@ data Command | Chatbot | LiveChecker | RedirectServer !Bool - | Validate parseCommand :: Parser Command parseCommand = subparser $ mconcat @@ -21,7 +20,6 @@ parseCommand = subparser $ mconcat , command "live-checker" $ info (pure LiveChecker) (progDesc "Launch the Twitch live status checker") , command "user-token-server" $ info (pure $ RedirectServer True) (progDesc "Launch a web server to handle authentication redirects") , command "user-token-server-read-only" $ info (pure $ RedirectServer False) (progDesc "Launch a web server to handle authentication redirects") - , command "validate-endpoint" $ info (pure Validate) (progDesc "Test Twitch authentication") ] data Opts = Opts { busHost :: !Text @@ -45,8 +43,7 @@ main = do ) cfg <- loadConfig opts.config case opts.command of - Monitor -> twitchEventClient cfg (opts.busHost, opts.busPort) - Chatbot -> twitchChatClient cfg (opts.busHost, opts.busPort) - LiveChecker -> twitchChannelLiveMonitor cfg (opts.busHost, opts.busPort) + Monitor -> twitchEventMonitor cfg (opts.busHost, opts.busPort) + Chatbot -> twitchChatbot cfg (opts.busHost, opts.busPort) + LiveChecker -> twitchChannelLiveChecker cfg (opts.busHost, opts.busPort) RedirectServer rw -> userTokenRedirectServer cfg rw - Validate -> twitchEndpointTest cfg diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs index e1c7cc9..497e123 100644 --- a/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs @@ -1,584 +1,25 @@ -{-# Language RecordWildCards #-} {-# Language ApplicativeDo #-} module Fig.Monitor.Twitch - ( twitchEventClient - , twitchChatClient - , twitchChannelLiveMonitor - , twitchEndpointTest + ( twitchChatbot + , twitchEventMonitor + , twitchChannelLiveChecker , userTokenRedirectServer ) where import Fig.Prelude -import Control.Concurrent (threadDelay) - -import qualified Data.Maybe as Maybe -import qualified Data.Text as Text import qualified Data.Text.Lazy as Text.Lazy -import qualified Data.Vector as V -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set import Data.Default.Class (def) -import Data.Aeson ((.:), (.:?), (.=)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Types as Aeson - -import qualified Wuss as WS -import qualified Network.WebSockets.Connection as WS - import Network.Wai.Handler.Warp (setPort) import qualified Web.Scotty as Scotty -import Network.HTTP.Client as HTTP -import Network.HTTP.Types.Status as HTTP - -import Fig.Bus.Binary.Client import Fig.Monitor.Twitch.Utils - -loginToMaybeUserId :: Text -> Authed (Maybe Text) -loginToMaybeUserId login = do - res <- authedRequestJSON @() "GET" ("https://api.twitch.tv/helix/users?login=" <> login) Nothing - let mid = flip Aeson.parseMaybe res \obj -> do - obj .: "data" >>= \case - Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" - _else -> mempty - pure mid - -loginToUserId :: Text -> Authed Text -loginToUserId login = do - res <- authedRequestJSON @() "GET" ("https://api.twitch.tv/helix/users?login=" <> login) Nothing - let mid = flip Aeson.parseMaybe res \obj -> do - obj .: "data" >>= \case - Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" - _else -> mempty - maybe (throwM $ FigMonitorTwitchException "Failed to extract user ID") pure mid - -usersAreLive :: [Text] -> Authed (Set.Set Text) -usersAreLive users = do - log $ "Checking liveness for: " <> Text.intercalate " " users - res <- authedRequestJSON @() - "GET" - ( mconcat - [ "https://api.twitch.tv/helix/streams?type=live" - , mconcat $ ("&user_login="<>) <$> users - ] - ) - Nothing - let mos = flip Aeson.parseEither res \obj -> do - obj .: "data" >>= \case - Aeson.Array os -> catMaybes . toList <$> forM os \case - Aeson.Object o -> Just <$> o .: "user_login" - _else -> pure Nothing - _else -> mempty - case mos of - Left err -> throwM $ FigMonitorTwitchException $ "Failed to check liveness: " <> pack err <> "\nResponse was: " <> tshow res - Right os -> pure . Set.fromList $ filter (`elem` os) users - -subscribe :: Text -> Text -> Text -> Authed () -subscribe sessionId event user = do - log $ "Subscribing to " <> event <> " events for user ID: " <> user - res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" . Just $ Aeson.object - [ "type" .= event - , "version" .= ("1" :: Text) - , "condition" .= Aeson.object - [ "broadcaster_user_id" .= user - ] - , "transport" .= Aeson.object - [ "method" .= ("websocket" :: Text) - , "session_id" .= sessionId - ] - ] - case Aeson.parseMaybe (.: "total_cost") res of - Just (_ :: Int) -> pure () - _else -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" - -subscribeFollows :: Text -> Text -> Authed () -subscribeFollows sessionId user = do - log $ "Subscribing to channel.follow events for user ID: " <> user - res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" . Just $ Aeson.object - [ "type" .= ("channel.follow" :: Text) - , "version" .= ("2" :: Text) - , "condition" .= Aeson.object - [ "broadcaster_user_id" .= user - , "moderator_user_id" .= user - ] - , "transport" .= Aeson.object - [ "method" .= ("websocket" :: Text) - , "session_id" .= sessionId - ] - ] - case Aeson.parseMaybe (.: "total_cost") res of - Just (_ :: Int) -> pure () - _else -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" - -subscribeRaids :: Text -> Text -> Authed () -subscribeRaids sessionId user = do - log $ "Subscribing to channel.raid events for user ID: " <> user - res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" . Just $ Aeson.object - [ "type" .= ("channel.raid" :: Text) - , "version" .= ("1" :: Text) - , "condition" .= Aeson.object - [ "to_broadcaster_user_id" .= user - ] - , "transport" .= Aeson.object - [ "method" .= ("websocket" :: Text) - , "session_id" .= sessionId - ] - ] - case Aeson.parseMaybe (.: "total_cost") res of - Just (_ :: Int) -> pure () - _else -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" - -poll :: Text -> [Text] -> Text -> Authed () -poll title choices user = do - log $ "Starting a new poll: \"" <> title <> "\"" - res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/polls" . Just $ Aeson.object - [ "broadcaster_id" .= user - , "title" .= title - , "choices" .= ((\c -> Aeson.object ["title" .= c]) <$> choices) - , "channel_points_voting_enabled" .= True - , "channel_points_per_vote" .= (1000 :: Integer) - , "duration" .= (60 :: Integer) - ] - let mid = flip Aeson.parseMaybe res \obj -> do - obj .: "data" >>= \case - Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" - _else -> mempty - case mid of - Just (_ :: Text) -> pure () - Nothing -> do - log "Failed to start poll" - log $ tshow res - -createPrediction :: Text -> [Text] -> Text -> Authed () -createPrediction title choices user = do - log $ "Starting a new prediction: \"" <> title <> "\"" - res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/predictions" . Just $ Aeson.object - [ "broadcaster_id" .= user - , "title" .= title - , "outcomes" .= ((\c -> Aeson.object ["title" .= c]) <$> choices) - , "prediction_window" .= (120 :: Integer) - ] - let mid = flip Aeson.parseMaybe res \obj -> do - obj .: "data" >>= \case - Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" - _else -> mempty - case mid of - Just (_ :: Text) -> pure () - Nothing -> log "Failed to start prediction" - -finishPrediction :: Text -> Text -> Text -> Authed () -finishPrediction pid oid user = do - log $ "Ending prediction: \"" <> pid <> "\"" - res <- authedRequestJSON "PATCH" "https://api.twitch.tv/helix/predictions" . Just $ Aeson.object - [ "broadcaster_id" .= user - , "id" .= pid - , "status" .= ("RESOLVED" :: Text) - , "winning_outcome_id" .= oid - ] - let mid = flip Aeson.parseMaybe res \obj -> do - obj .: "data" >>= \case - Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" - _else -> mempty - case mid of - Just (_ :: Text) -> pure () - Nothing -> log "Failed to end prediction" - -addVIP :: Text -> Text -> Authed () -addVIP vipuser user = do - log $ "Adding VIP user: \"" <> vipuser <> "\"" - let body = Aeson.encode $ Aeson.object - [ "broadcaster_id" .= user - , "user_id" .= vipuser - ] - rc <- ask - initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/channels/vips" - let request = initialRequest - { method = encodeUtf8 "POST" - , requestBody = RequestBodyLBS body - , requestHeaders = - [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) - , ("Client-Id", encodeUtf8 rc.config.clientId) - , ("Content-Type", "application/json") - ] - } - response <- liftIO $ HTTP.httpLbs request rc.manager - unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do - log $ "Failed to add VIP: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) - -removeVIP :: Text -> Text -> Authed () -removeVIP vipuser user = do - log $ "Removing VIP user: \"" <> vipuser <> "\"" - let body = Aeson.encode $ Aeson.object - [ "broadcaster_id" .= user - , "user_id" .= vipuser - ] - rc <- ask - initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/channels/vips" - let request = initialRequest - { method = encodeUtf8 "DELETE" - , requestBody = RequestBodyLBS body - , requestHeaders = - [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) - , ("Client-Id", encodeUtf8 rc.config.clientId) - , ("Content-Type", "application/json") - ] - } - response <- liftIO $ HTTP.httpLbs request rc.manager - unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do - log $ "Failed to remove VIP: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) - -shoutout :: Text -> Text -> Authed () -shoutout souser user = do - log $ "Shoutout to: \"" <> souser <> "\"" - let body = Aeson.encode $ Aeson.object - [ "from_broadcaster_id" .= user - , "moderator_id" .= user - , "to_broadcaster_id" .= souser - ] - rc <- ask - initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/chat/shoutouts" - let request = initialRequest - { method = encodeUtf8 "POST" - , requestBody = RequestBodyLBS body - , requestHeaders = - [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) - , ("Client-Id", encodeUtf8 rc.config.clientId) - , ("Content-Type", "application/json") - ] - } - response <- liftIO $ HTTP.httpLbs request rc.manager - unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do - log $ "Failed to shoutout: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) - -twitchEndpointTest :: Config -> IO () -twitchEndpointTest cfg = runAuthed cfg do - user <- loginToUserId "lcolonq" - log user - -twitchEventClient :: Config -> (Text, Text) -> IO () -twitchEventClient cfg busAddr = do - WS.runSecureClient "eventsub.wss.twitch.tv" 443 "/ws" \conn -> do - welcomeStr <- WS.receiveData conn - (sessionId :: Text) <- case Aeson.eitherDecodeStrict welcomeStr of - Left err -> throwM . FigMonitorTwitchException $ tshow err - Right res -> do - let mid = flip Aeson.parseMaybe res \obj -> do - payload <- obj .: "payload" - session <- payload .: "session" - session .: "id" - maybe (throwM $ FigMonitorTwitchException "Failed to extract session ID") pure mid - log $ "Connected to Twitch API, session ID is: " <> sessionId - runAuthed cfg do - user <- loginToUserId cfg.userLogin - subscribe sessionId "channel.channel_points_custom_reward_redemption.add" user - subscribe sessionId "channel.prediction.begin" user - subscribe sessionId "channel.prediction.end" user - subscribe sessionId "channel.poll.begin" user - subscribe sessionId "channel.poll.end" user - subscribe sessionId "channel.subscribe" user - subscribe sessionId "channel.subscription.gift" user - subscribeFollows sessionId user - subscribeRaids sessionId user - busClient busAddr - (\cmds -> do - cmds.subscribe "fig monitor twitch poll create" - cmds.subscribe "fig monitor twitch prediction create" - cmds.subscribe "fig monitor twitch prediction finish" - cmds.subscribe "fig monitor twitch vip add" - cmds.subscribe "fig monitor twitch vip remove" - cmds.subscribe "fig monitor twitch shoutout" - forever do - resp <- WS.receiveData conn - case Aeson.eitherDecodeStrict resp of - Left err -> throwM . FigMonitorTwitchException $ tshow err - Right res -> case Aeson.parseMaybe ((.: "metadata") >=> (.: "message_type")) res of - Just ("notification" :: Text) -> case Aeson.parseMaybe ((.: "metadata") >=> (.: "subscription_type")) res of - Just ("channel.channel_points_custom_reward_redemption.add" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - nm <- event .: "user_login" - reward <- event .: "reward" - title <- reward .: "title" - minput <- event .:? "user_input" - pure (nm, title, minput) - case Aeson.parseMaybe parseEvent res of - Just (nm, title, minput) -> do - log $ "Channel point reward \"" <> title <> "\" redeemed by: " <> nm - cmds.publish "fig monitor twitch redeem incoming" - . encodeUtf8 . Text.intercalate "\t" $ - [nm, title] <> Maybe.maybeToList minput - _else -> log "Failed to extract payload from channel point redeem event" - Just ("channel.prediction.begin" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - pid <- event .: "id" - oids <- event .: "outcomes" >>= \case - Aeson.Array os -> forM os $ \case - Aeson.Object out -> (,) <$> (out .: "title") <*> (out .: "id") - _else -> mempty - _else -> mempty - pure (pid, oids) - case Aeson.parseMaybe parseEvent res of - Just (pid, oids) -> do - log $ "Prediction begin: " <> pid - cmds.publish "fig monitor twitch prediction begin" - . encodeUtf8 . Text.unwords $ - [ pid ] <> ((\(title, oid) -> title <> "," <> oid) <$> toList oids) - _else -> log "Failed to extract ID from payload for prediction begin event" - Just ("channel.prediction.end" :: Text) -> do - log "Prediction end" - cmds.publish "fig monitor twitch prediction end" "" - Just ("channel.raid" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - event .: "from_broadcaster_user_login" - case Aeson.parseMaybe parseEvent res of - Just nm -> do - log $ "Incoming raid from: " <> nm - cmds.publish "fig monitor twitch raid" $ encodeUtf8 nm - _else -> log "Failed to extract user from raid event" - Just ("channel.follow" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - event .: "user_login" - case Aeson.parseMaybe parseEvent res of - Just nm -> do - log $ "New follower: " <> nm - cmds.publish "fig monitor twitch follow" $ encodeUtf8 nm - _else -> log "Failed to extract user from follow event" - Just ("channel.subscribe" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - login <- event .: "user_login" - gift <- event .: "is_gift" - pure (login, gift) - case Aeson.parseMaybe parseEvent res of - Just (nm, False) -> do - log $ "New subscriber: " <> nm - cmds.publish "fig monitor twitch subscribe" $ encodeUtf8 nm - Just _ -> log "Skipping gifted subscription" - _else -> log "Failed to extract user from subscribe event" - Just ("channel.cheer" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - nm <- event .: "user_login" - bits <- event .: "bits" - pure (nm, bits) - case Aeson.parseMaybe parseEvent res of - Just (nm, bits) -> do - log $ "New cheer: " <> nm <> " " <> tshow bits - cmds.publish "fig monitor twitch cheer" - . encodeUtf8 . Text.unwords $ - [nm, bits] - _else -> log "Failed to extract user from cheer event" - Just ("channel.subscription.gift" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - nm <- event .: "user_login" - num <- event .: "total" - pure (nm, num) - case Aeson.parseMaybe parseEvent res of - Just (nm, num) -> do - log $ "User " <> nm <> " gifted subs: " <> tshow num - cmds.publish "fig monitor twitch gift" - . encodeUtf8 . Text.unwords $ - [nm, num] - _else -> log "Failed to extract user from gift sub event" - Just ("channel.poll.begin" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - event .: "id" - case Aeson.parseMaybe parseEvent res of - Just pollid -> do - log $ "Poll begin: " <> pollid - cmds.publish "fig monitor twitch poll begin" $ encodeUtf8 pollid - _else -> log "Failed to extract ID from payload for poll begin event" - Just ("channel.poll.end" :: Text) -> do - let parseEvent o = do - payload <- o .: "payload" - event <- payload .: "event" - status <- event .: "status" - pollid <- event .: "id" - event .: "choices" >>= \case - Aeson.Array cs -> do - choices <- forM cs \case - Aeson.Object c -> do - t <- c .: "title" - v <- c .: "votes" - pure (t, v) - _else -> mempty - pure (status, pollid, toList choices) - _else -> mempty - case Aeson.parseEither parseEvent res of - Right (status :: Text, pollid, choices :: [(Text, Integer)]) -> do - when (status /= "archived") do - let schoices = (\(t, v) -> t <> "\t" <> tshow v) <$> choices - log $ "Poll end: " <> pollid - cmds.publish "fig monitor twitch poll end" . encodeUtf8 . Text.intercalate "\n" - $ [pollid] <> schoices - Left err -> log $ "Failed to extract ID from payload for poll end event: " <> pack err - _else -> log $ "Received unknown notification event: " <> tshow resp - Just "session_keepalive" -> pure () - _else -> log $ "Received unknown response: " <> tshow resp - ) - (\_cmds ev d -> do - let args = Text.splitOn "\t" $ decodeUtf8 d - case (ev, args) of - ("fig monitor twitch poll create", [title, schoices]) -> do - let choices = Text.splitOn "\n" schoices - runAuthed cfg do - user <- loginToUserId cfg.userLogin - poll title choices user - ("fig monitor twitch prediction create", [title, schoices]) -> do - let choices = Text.splitOn "\n" schoices - runAuthed cfg do - user <- loginToUserId cfg.userLogin - createPrediction title choices user - ("fig monitor twitch prediction finish", [pid, oid]) -> do - runAuthed cfg do - user <- loginToUserId cfg.userLogin - finishPrediction pid oid user - ("fig monitor twitch vip add", [u]) -> do - runAuthed cfg do - user <- loginToUserId cfg.userLogin - loginToMaybeUserId u >>= \case - Nothing -> pure () - Just vipuser -> addVIP vipuser user - ("fig monitor twitch vip remove", [u]) -> do - runAuthed cfg do - user <- loginToUserId cfg.userLogin - loginToMaybeUserId u >>= \case - Nothing -> pure () - Just vipuser -> removeVIP vipuser user - ("fig monitor twitch vip shoutout", [u]) -> do - runAuthed cfg do - user <- loginToUserId cfg.userLogin - loginToMaybeUserId u >>= \case - Nothing -> pure () - Just souser -> shoutout souser user - _else -> log $ "Invalid incoming message: " <> tshow (ev, args) - ) - (pure ()) - -twitchChannelLiveMonitor :: Config -> (Text, Text) -> IO () -twitchChannelLiveMonitor cfg busAddr = do - busClient busAddr - (\cmds -> do - let - loop :: IO () - loop = do - log "Updating liveness..." - live <- runAuthed cfg $ usersAreLive cfg.monitor - if null live - then log "Update complete! No users live" - else log $ "Update complete! Live users: " <> Text.unwords (Set.toList live) - cmds.publish "fig monitor twitch stream online" . encodeUtf8 . Text.unwords $ Set.toList live - threadDelay $ 5 * 60 * 1000000 -- wait 5 minutes - loop - loop - ) - (\_cmds _ev _d -> pure ()) - (pure ()) - -data IRCMessage = IRCMessage - { tags :: !(Map.Map Text Text) - , prefix :: !(Maybe Text) - , command :: !Text - , params :: ![Text] - } deriving (Show, Eq, Ord) - -parseIRCMessage :: Text -> IRCMessage -parseIRCMessage (Text.strip -> fullrest) = - let - (tags, tagsrest) = - if Text.head fullrest == '@' - then - let (tstr, rest) = Text.breakOn " " fullrest - in ( Map.fromList $ second (Text.drop 1) . Text.breakOn "=" <$> Text.splitOn ";" (Text.drop 1 tstr) - , Text.strip rest - ) - else (Map.empty, fullrest) - (prefix, prefixrest) = - if Text.head tagsrest == ':' - then - let (pstr, rest) = Text.breakOn " " tagsrest - in ( Just $ Text.drop 1 pstr - , Text.strip rest - ) - else (Nothing, tagsrest) - (command, cmdrest) = Text.breakOn " " prefixrest - params = case Text.breakOn ":" $ Text.strip cmdrest of - (Text.strip -> "", rest) -> [rest] - (ps, rest) -> Text.splitOn " " (Text.strip ps) <> [Text.drop 1 rest] - in IRCMessage{..} - -twitchChatClient :: Config -> (Text, Text) -> IO () -twitchChatClient cfg busAddr = do - log "Starting chatbot" - case headMay cfg.monitor of - Nothing -> pure () - Just chan -> WS.runSecureClient "irc-ws.chat.twitch.tv" 443 "/" \conn -> do - WS.sendTextData conn $ "PASS oauth:" <> cfg.userToken - WS.sendTextData conn ("NICK lcolonq" :: Text) - WS.sendTextData conn ("CAP REQ :twitch.tv/commands twitch.tv/tags" :: Text) - WS.sendTextData conn $ "JOIN #" <> chan - -- WS.sendTextData conn ("PRIVMSG #lcolonq :test the other direction" :: Text) - busClient busAddr - (\cmds -> do - cmds.subscribe "fig monitor twitch chat outgoing" - forever do - resp <- WS.receiveData conn - forM (Text.lines resp) $ \line -> do - let msg = parseIRCMessage line - case msg.command of - "PING" -> do - log "Received PING, sending PONG" - WS.sendTextData conn $ "PONG :" <> mconcat msg.params - "CLEARCHAT" -> do - log "Received CLEARCHAT" - cmds.publish "fig monitor twitch chat clear-chat" . encodeUtf8 $ Text.unwords msg.params - "NOTICE" -> do - log "Received NOTICE" - cmds.publish "fig monitor twitch chat notice" . encodeUtf8 $ Text.unwords msg.params - "USERNOTICE" -> do - log "Received USERNOTICE" - cmds.publish "fig monitor twitch chat user-notice" . encodeUtf8 $ Text.unwords msg.params - "PRIVMSG" - | Just displaynm <- Map.lookup "display-name" msg.tags - , Nothing <- Map.lookup "custom-reward-id" msg.tags -> do - log $ "Received chat message from: " <> displaynm - cmds.publish "fig monitor twitch chat incoming" . encodeUtf8 . Text.unwords $ - [ displaynm - , Text.intercalate "\n" $ (\(key, v) -> key <> "\t" <> v) <$> Map.toList msg.tags - ] <> drop 1 msg.params - _ -> pure () - ) - (\_cmds ev d -> do - case ev of - "fig monitor twitch chat outgoing" -> do - let msg = decodeUtf8 d - log $ "Sending chat message: " <> msg - WS.sendTextData conn $ mconcat - [ "PRIVMSG #" - , chan - , " :" - , msg - ] - _else -> log $ "Invalid incoming event: " <> tshow ev - ) - (pure ()) +import Fig.Monitor.Twitch.LiveChecker +import Fig.Monitor.Twitch.EventMonitor +import Fig.Monitor.Twitch.Chatbot userTokenRedirectServer :: Config -> Bool -> IO () userTokenRedirectServer cfg rw = do diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch/Auth/AppToken.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Auth/AppToken.hs new file mode 100644 index 0000000..2796f7e --- /dev/null +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Auth/AppToken.hs @@ -0,0 +1,82 @@ +module Fig.Monitor.Twitch.Auth.AppToken + ( Authed + , RequestConfig(..) + , authedRequest, authedRequestJSON + , runAuthed + ) where + +import Fig.Prelude + +import qualified Data.ByteString.Lazy as BS.Lazy + +import Control.Monad.Reader (ReaderT, runReaderT) + +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import Network.HTTP.Client as HTTP +import Network.HTTP.Client.TLS as HTTP +import Network.HTTP.Client.MultipartFormData as HTTP + +import Fig.Monitor.Twitch.Utils + +data RequestConfig = RequestConfig + { config :: Config + , manager :: HTTP.Manager + , appToken :: Text + } + +newtype Authed a = Authed { unAuthed :: ReaderT RequestConfig IO a } + deriving (Functor, Applicative, Monad, MonadReader RequestConfig, MonadIO, MonadThrow) + +authedRequest :: Text -> Text -> BS.Lazy.ByteString -> Authed BS.Lazy.ByteString +authedRequest method url body = do + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack url + let request = initialRequest + { method = encodeUtf8 method + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.appToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + pure $ HTTP.responseBody response + +authedRequestJSON :: (Aeson.ToJSON a, Aeson.FromJSON b) => Text -> Text -> Maybe a -> Authed b +authedRequestJSON method url val = do + resp <- authedRequest method url $ maybe "" Aeson.encode val + case Aeson.eitherDecode resp of + Left err -> do + throwM . FigMonitorTwitchException $ tshow err + Right res -> pure res + +getAppToken :: HTTP.Manager -> Config -> IO Text +getAppToken manager config = do + initialRequest <- HTTP.parseRequest "https://id.twitch.tv/oauth2/token" + let preRequest = initialRequest + { method = "POST" + , requestHeaders = [("Content-Type", "application/json")] + } + request <- HTTP.formDataBody + [ partBS "client_id" $ encodeUtf8 config.clientId + , partBS "client_secret" $ encodeUtf8 config.clientSecret + , partBS "grant_type" "client_credentials" + ] + preRequest + response <- liftIO $ HTTP.httpLbs request manager + case Aeson.eitherDecode $ HTTP.responseBody response of + Left err -> throwM . FigMonitorTwitchException $ tshow err + Right v -> case Aeson.parseMaybe (.: "access_token") v of + Nothing -> throwM $ FigMonitorTwitchException "failed to obtain access token" + Just t -> pure t + +runAuthed :: Config -> Authed a -> IO a +runAuthed config body = do + manager <- HTTP.newManager HTTP.tlsManagerSettings + appToken <- getAppToken manager config + log $ "got app token! " <> appToken + runReaderT body.unAuthed RequestConfig{..} diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch/Auth/UserToken.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Auth/UserToken.hs new file mode 100644 index 0000000..c8cb3ac --- /dev/null +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Auth/UserToken.hs @@ -0,0 +1,56 @@ +module Fig.Monitor.Twitch.Auth.UserToken + ( Authed + , RequestConfig(..) + , authedRequest, authedRequestJSON + , runAuthed + ) where + +import Fig.Prelude + +import qualified Data.ByteString.Lazy as BS.Lazy + +import Control.Monad.Reader (ReaderT, runReaderT) + +import qualified Data.Aeson as Aeson + +import Network.HTTP.Client as HTTP +import Network.HTTP.Client.TLS as HTTP + +import Fig.Monitor.Twitch.Utils + +data RequestConfig = RequestConfig + { config :: Config + , manager :: HTTP.Manager + } + +newtype Authed a = Authed { unAuthed :: ReaderT RequestConfig IO a } + deriving (Functor, Applicative, Monad, MonadReader RequestConfig, MonadIO, MonadThrow) + +authedRequest :: Text -> Text -> BS.Lazy.ByteString -> Authed BS.Lazy.ByteString +authedRequest method url body = do + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack url + let request = initialRequest + { method = encodeUtf8 method + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + pure $ HTTP.responseBody response + +authedRequestJSON :: (Aeson.ToJSON a, Aeson.FromJSON b) => Text -> Text -> Maybe a -> Authed b +authedRequestJSON method url val = do + resp <- authedRequest method url $ maybe "" Aeson.encode val + case Aeson.eitherDecode resp of + Left err -> do + throwM . FigMonitorTwitchException $ tshow err + Right res -> pure res + +runAuthed :: Config -> Authed a -> IO a +runAuthed config body = do + manager <- HTTP.newManager HTTP.tlsManagerSettings + runReaderT body.unAuthed RequestConfig{..} diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch/Chatbot.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Chatbot.hs new file mode 100644 index 0000000..92f6830 --- /dev/null +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Chatbot.hs @@ -0,0 +1,102 @@ +module Fig.Monitor.Twitch.Chatbot + ( twitchChatbot + ) where + +import Fig.Prelude + +import qualified Data.Text as Text +import qualified Data.Map.Strict as Map + +import qualified Wuss as WS +import qualified Network.WebSockets.Connection as WS + +import Fig.Bus.Binary.Client +import Fig.Monitor.Twitch.Utils + +twitchChatbot :: Config -> (Text, Text) -> IO () +twitchChatbot cfg busAddr = do + log "Starting chatbot" + case headMay cfg.monitor of + Nothing -> pure () + Just chan -> WS.runSecureClient "irc-ws.chat.twitch.tv" 443 "/" \conn -> do + WS.sendTextData conn $ "PASS oauth:" <> cfg.userToken + WS.sendTextData conn ("NICK lcolonq" :: Text) + WS.sendTextData conn ("CAP REQ :twitch.tv/commands twitch.tv/tags" :: Text) + WS.sendTextData conn $ "JOIN #" <> chan + -- WS.sendTextData conn ("PRIVMSG #lcolonq :test the other direction" :: Text) + busClient busAddr + (\cmds -> do + cmds.subscribe "fig monitor twitch chat outgoing" + forever do + resp <- WS.receiveData conn + forM (Text.lines resp) $ \line -> do + let msg = parseIRCMessage line + case msg.command of + "PING" -> do + log "Received PING, sending PONG" + WS.sendTextData conn $ "PONG :" <> mconcat msg.params + "CLEARCHAT" -> do + log "Received CLEARCHAT" + cmds.publish "fig monitor twitch chat clear-chat" . encodeUtf8 $ Text.unwords msg.params + "NOTICE" -> do + log "Received NOTICE" + cmds.publish "fig monitor twitch chat notice" . encodeUtf8 $ Text.unwords msg.params + "USERNOTICE" -> do + log "Received USERNOTICE" + cmds.publish "fig monitor twitch chat user-notice" . encodeUtf8 $ Text.unwords msg.params + "PRIVMSG" + | Just displaynm <- Map.lookup "display-name" msg.tags + , Nothing <- Map.lookup "custom-reward-id" msg.tags -> do + log $ "Received chat message from: " <> displaynm + cmds.publish "fig monitor twitch chat incoming" . encodeUtf8 . Text.unwords $ + [ displaynm + , Text.intercalate "\n" $ (\(key, v) -> key <> "\t" <> v) <$> Map.toList msg.tags + ] <> drop 1 msg.params + _ -> pure () + ) + (\_cmds ev d -> do + case ev of + "fig monitor twitch chat outgoing" -> do + let msg = decodeUtf8 d + log $ "Sending chat message: " <> msg + WS.sendTextData conn $ mconcat + [ "PRIVMSG #" + , chan + , " :" + , msg + ] + _else -> log $ "Invalid incoming event: " <> tshow ev + ) + (pure ()) + +data IRCMessage = IRCMessage + { tags :: !(Map.Map Text Text) + , prefix :: !(Maybe Text) + , command :: !Text + , params :: ![Text] + } deriving (Show, Eq, Ord) + +parseIRCMessage :: Text -> IRCMessage +parseIRCMessage (Text.strip -> fullrest) = + let + (tags, tagsrest) = + if Text.head fullrest == '@' + then + let (tstr, rest) = Text.breakOn " " fullrest + in ( Map.fromList $ second (Text.drop 1) . Text.breakOn "=" <$> Text.splitOn ";" (Text.drop 1 tstr) + , Text.strip rest + ) + else (Map.empty, fullrest) + (prefix, prefixrest) = + if Text.head tagsrest == ':' + then + let (pstr, rest) = Text.breakOn " " tagsrest + in ( Just $ Text.drop 1 pstr + , Text.strip rest + ) + else (Nothing, tagsrest) + (command, cmdrest) = Text.breakOn " " prefixrest + params = case Text.breakOn ":" $ Text.strip cmdrest of + (Text.strip -> "", rest) -> [rest] + (ps, rest) -> Text.splitOn " " (Text.strip ps) <> [Text.drop 1 rest] + in IRCMessage{..} diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch/EventMonitor.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch/EventMonitor.hs new file mode 100644 index 0000000..1cb2aa2 --- /dev/null +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch/EventMonitor.hs @@ -0,0 +1,431 @@ +module Fig.Monitor.Twitch.EventMonitor + ( twitchEventMonitor + ) where + +import Fig.Prelude + +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import qualified Data.Vector as V + +import Data.Aeson ((.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Wuss as WS +import qualified Network.WebSockets.Connection as WS + +import Network.HTTP.Client as HTTP +import Network.HTTP.Types.Status as HTTP + +import Fig.Bus.Binary.Client +import Fig.Monitor.Twitch.Utils +import Fig.Monitor.Twitch.Auth.UserToken + +twitchEventMonitor :: Config -> (Text, Text) -> IO () +twitchEventMonitor cfg busAddr = do + WS.runSecureClient "eventsub.wss.twitch.tv" 443 "/ws" \conn -> do + welcomeStr <- WS.receiveData conn + (sessionId :: Text) <- case Aeson.eitherDecodeStrict welcomeStr of + Left err -> throwM . FigMonitorTwitchException $ tshow err + Right res -> do + let mid = flip Aeson.parseMaybe res \obj -> do + payload <- obj .: "payload" + session <- payload .: "session" + session .: "id" + maybe (throwM $ FigMonitorTwitchException "Failed to extract session ID") pure mid + log $ "Connected to Twitch API, session ID is: " <> sessionId + runAuthed cfg do + user <- loginToUserId cfg.userLogin + subscribe sessionId "channel.channel_points_custom_reward_redemption.add" user + subscribe sessionId "channel.prediction.begin" user + subscribe sessionId "channel.prediction.end" user + subscribe sessionId "channel.poll.begin" user + subscribe sessionId "channel.poll.end" user + subscribe sessionId "channel.subscribe" user + subscribe sessionId "channel.subscription.gift" user + subscribeFollows sessionId user + subscribeRaids sessionId user + busClient busAddr + (\cmds -> do + cmds.subscribe "fig monitor twitch poll create" + cmds.subscribe "fig monitor twitch prediction create" + cmds.subscribe "fig monitor twitch prediction finish" + cmds.subscribe "fig monitor twitch vip add" + cmds.subscribe "fig monitor twitch vip remove" + cmds.subscribe "fig monitor twitch shoutout" + forever do + resp <- WS.receiveData conn + case Aeson.eitherDecodeStrict resp of + Left err -> throwM . FigMonitorTwitchException $ tshow err + Right res -> case Aeson.parseMaybe ((.: "metadata") >=> (.: "message_type")) res of + Just ("notification" :: Text) -> case Aeson.parseMaybe ((.: "metadata") >=> (.: "subscription_type")) res of + Just ("channel.channel_points_custom_reward_redemption.add" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + nm <- event .: "user_login" + reward <- event .: "reward" + title <- reward .: "title" + minput <- event .:? "user_input" + pure (nm, title, minput) + case Aeson.parseMaybe parseEvent res of + Just (nm, title, minput) -> do + log $ "Channel point reward \"" <> title <> "\" redeemed by: " <> nm + cmds.publish "fig monitor twitch redeem incoming" + . encodeUtf8 . Text.intercalate "\t" $ + [nm, title] <> Maybe.maybeToList minput + _else -> log "Failed to extract payload from channel point redeem event" + Just ("channel.prediction.begin" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + pid <- event .: "id" + oids <- event .: "outcomes" >>= \case + Aeson.Array os -> forM os $ \case + Aeson.Object out -> (,) <$> (out .: "title") <*> (out .: "id") + _else -> mempty + _else -> mempty + pure (pid, oids) + case Aeson.parseMaybe parseEvent res of + Just (pid, oids) -> do + log $ "Prediction begin: " <> pid + cmds.publish "fig monitor twitch prediction begin" + . encodeUtf8 . Text.unwords $ + [ pid ] <> ((\(title, oid) -> title <> "," <> oid) <$> toList oids) + _else -> log "Failed to extract ID from payload for prediction begin event" + Just ("channel.prediction.end" :: Text) -> do + log "Prediction end" + cmds.publish "fig monitor twitch prediction end" "" + Just ("channel.raid" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + event .: "from_broadcaster_user_login" + case Aeson.parseMaybe parseEvent res of + Just nm -> do + log $ "Incoming raid from: " <> nm + cmds.publish "fig monitor twitch raid" $ encodeUtf8 nm + _else -> log "Failed to extract user from raid event" + Just ("channel.follow" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + event .: "user_login" + case Aeson.parseMaybe parseEvent res of + Just nm -> do + log $ "New follower: " <> nm + cmds.publish "fig monitor twitch follow" $ encodeUtf8 nm + _else -> log "Failed to extract user from follow event" + Just ("channel.subscribe" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + login <- event .: "user_login" + gift <- event .: "is_gift" + pure (login, gift) + case Aeson.parseMaybe parseEvent res of + Just (nm, False) -> do + log $ "New subscriber: " <> nm + cmds.publish "fig monitor twitch subscribe" $ encodeUtf8 nm + Just _ -> log "Skipping gifted subscription" + _else -> log "Failed to extract user from subscribe event" + Just ("channel.cheer" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + nm <- event .: "user_login" + bits <- event .: "bits" + pure (nm, bits) + case Aeson.parseMaybe parseEvent res of + Just (nm, bits) -> do + log $ "New cheer: " <> nm <> " " <> tshow bits + cmds.publish "fig monitor twitch cheer" + . encodeUtf8 . Text.unwords $ + [nm, bits] + _else -> log "Failed to extract user from cheer event" + Just ("channel.subscription.gift" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + nm <- event .: "user_login" + num <- event .: "total" + pure (nm, num) + case Aeson.parseMaybe parseEvent res of + Just (nm, num) -> do + log $ "User " <> nm <> " gifted subs: " <> tshow num + cmds.publish "fig monitor twitch gift" + . encodeUtf8 . Text.unwords $ + [nm, num] + _else -> log "Failed to extract user from gift sub event" + Just ("channel.poll.begin" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + event .: "id" + case Aeson.parseMaybe parseEvent res of + Just pollid -> do + log $ "Poll begin: " <> pollid + cmds.publish "fig monitor twitch poll begin" $ encodeUtf8 pollid + _else -> log "Failed to extract ID from payload for poll begin event" + Just ("channel.poll.end" :: Text) -> do + let parseEvent o = do + payload <- o .: "payload" + event <- payload .: "event" + status <- event .: "status" + pollid <- event .: "id" + event .: "choices" >>= \case + Aeson.Array cs -> do + choices <- forM cs \case + Aeson.Object c -> do + t <- c .: "title" + v <- c .: "votes" + pure (t, v) + _else -> mempty + pure (status, pollid, toList choices) + _else -> mempty + case Aeson.parseEither parseEvent res of + Right (status :: Text, pollid, choices :: [(Text, Integer)]) -> do + when (status /= "archived") do + let schoices = (\(t, v) -> t <> "\t" <> tshow v) <$> choices + log $ "Poll end: " <> pollid + cmds.publish "fig monitor twitch poll end" . encodeUtf8 . Text.intercalate "\n" + $ [pollid] <> schoices + Left err -> log $ "Failed to extract ID from payload for poll end event: " <> pack err + _else -> log $ "Received unknown notification event: " <> tshow resp + Just "session_keepalive" -> pure () + _else -> log $ "Received unknown response: " <> tshow resp + ) + (\_cmds ev d -> do + let args = Text.splitOn "\t" $ decodeUtf8 d + case (ev, args) of + ("fig monitor twitch poll create", [title, schoices]) -> do + let choices = Text.splitOn "\n" schoices + runAuthed cfg do + user <- loginToUserId cfg.userLogin + poll title choices user + ("fig monitor twitch prediction create", [title, schoices]) -> do + let choices = Text.splitOn "\n" schoices + runAuthed cfg do + user <- loginToUserId cfg.userLogin + createPrediction title choices user + ("fig monitor twitch prediction finish", [pid, oid]) -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + finishPrediction pid oid user + ("fig monitor twitch vip add", [u]) -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + loginToMaybeUserId u >>= \case + Nothing -> pure () + Just vipuser -> addVIP vipuser user + ("fig monitor twitch vip remove", [u]) -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + loginToMaybeUserId u >>= \case + Nothing -> pure () + Just vipuser -> removeVIP vipuser user + ("fig monitor twitch vip shoutout", [u]) -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + loginToMaybeUserId u >>= \case + Nothing -> pure () + Just souser -> shoutout souser user + _else -> log $ "Invalid incoming message: " <> tshow (ev, args) + ) + (pure ()) + +loginToMaybeUserId :: Text -> Authed (Maybe Text) +loginToMaybeUserId login = do + res <- authedRequestJSON @() "GET" ("https://api.twitch.tv/helix/users?login=" <> login) Nothing + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _else -> mempty + pure mid + +loginToUserId :: Text -> Authed Text +loginToUserId login = do + res <- authedRequestJSON @() "GET" ("https://api.twitch.tv/helix/users?login=" <> login) Nothing + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _else -> mempty + maybe (throwM $ FigMonitorTwitchException "Failed to extract user ID") pure mid + +subscribe :: Text -> Text -> Text -> Authed () +subscribe sessionId event user = do + log $ "Subscribing to " <> event <> " events for user ID: " <> user + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" . Just $ Aeson.object + [ "type" .= event + , "version" .= ("1" :: Text) + , "condition" .= Aeson.object + [ "broadcaster_user_id" .= user + ] + , "transport" .= Aeson.object + [ "method" .= ("websocket" :: Text) + , "session_id" .= sessionId + ] + ] + case Aeson.parseMaybe (.: "total_cost") res of + Just (_ :: Int) -> pure () + _else -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" + +subscribeFollows :: Text -> Text -> Authed () +subscribeFollows sessionId user = do + log $ "Subscribing to channel.follow events for user ID: " <> user + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" . Just $ Aeson.object + [ "type" .= ("channel.follow" :: Text) + , "version" .= ("2" :: Text) + , "condition" .= Aeson.object + [ "broadcaster_user_id" .= user + , "moderator_user_id" .= user + ] + , "transport" .= Aeson.object + [ "method" .= ("websocket" :: Text) + , "session_id" .= sessionId + ] + ] + case Aeson.parseMaybe (.: "total_cost") res of + Just (_ :: Int) -> pure () + _else -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" + +subscribeRaids :: Text -> Text -> Authed () +subscribeRaids sessionId user = do + log $ "Subscribing to channel.raid events for user ID: " <> user + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/eventsub/subscriptions" . Just $ Aeson.object + [ "type" .= ("channel.raid" :: Text) + , "version" .= ("1" :: Text) + , "condition" .= Aeson.object + [ "to_broadcaster_user_id" .= user + ] + , "transport" .= Aeson.object + [ "method" .= ("websocket" :: Text) + , "session_id" .= sessionId + ] + ] + case Aeson.parseMaybe (.: "total_cost") res of + Just (_ :: Int) -> pure () + _else -> throwM $ FigMonitorTwitchException "Failed to subscribe to event" + +poll :: Text -> [Text] -> Text -> Authed () +poll title choices user = do + log $ "Starting a new poll: \"" <> title <> "\"" + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/polls" . Just $ Aeson.object + [ "broadcaster_id" .= user + , "title" .= title + , "choices" .= ((\c -> Aeson.object ["title" .= c]) <$> choices) + , "channel_points_voting_enabled" .= True + , "channel_points_per_vote" .= (1000 :: Integer) + , "duration" .= (60 :: Integer) + ] + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _else -> mempty + case mid of + Just (_ :: Text) -> pure () + Nothing -> do + log "Failed to start poll" + log $ tshow res + +createPrediction :: Text -> [Text] -> Text -> Authed () +createPrediction title choices user = do + log $ "Starting a new prediction: \"" <> title <> "\"" + res <- authedRequestJSON "POST" "https://api.twitch.tv/helix/predictions" . Just $ Aeson.object + [ "broadcaster_id" .= user + , "title" .= title + , "outcomes" .= ((\c -> Aeson.object ["title" .= c]) <$> choices) + , "prediction_window" .= (120 :: Integer) + ] + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _else -> mempty + case mid of + Just (_ :: Text) -> pure () + Nothing -> log "Failed to start prediction" + +finishPrediction :: Text -> Text -> Text -> Authed () +finishPrediction pid oid user = do + log $ "Ending prediction: \"" <> pid <> "\"" + res <- authedRequestJSON "PATCH" "https://api.twitch.tv/helix/predictions" . Just $ Aeson.object + [ "broadcaster_id" .= user + , "id" .= pid + , "status" .= ("RESOLVED" :: Text) + , "winning_outcome_id" .= oid + ] + let mid = flip Aeson.parseMaybe res \obj -> do + obj .: "data" >>= \case + Aeson.Array ((V.!? 0) -> Just (Aeson.Object d)) -> d .: "id" + _else -> mempty + case mid of + Just (_ :: Text) -> pure () + Nothing -> log "Failed to end prediction" + +addVIP :: Text -> Text -> Authed () +addVIP vipuser user = do + log $ "Adding VIP user: \"" <> vipuser <> "\"" + let body = Aeson.encode $ Aeson.object + [ "broadcaster_id" .= user + , "user_id" .= vipuser + ] + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/channels/vips" + let request = initialRequest + { method = encodeUtf8 "POST" + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do + log $ "Failed to add VIP: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) + +removeVIP :: Text -> Text -> Authed () +removeVIP vipuser user = do + log $ "Removing VIP user: \"" <> vipuser <> "\"" + let body = Aeson.encode $ Aeson.object + [ "broadcaster_id" .= user + , "user_id" .= vipuser + ] + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/channels/vips" + let request = initialRequest + { method = encodeUtf8 "DELETE" + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do + log $ "Failed to remove VIP: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) + +shoutout :: Text -> Text -> Authed () +shoutout souser user = do + log $ "Shoutout to: \"" <> souser <> "\"" + let body = Aeson.encode $ Aeson.object + [ "from_broadcaster_id" .= user + , "moderator_id" .= user + , "to_broadcaster_id" .= souser + ] + rc <- ask + initialRequest <- liftIO . HTTP.parseRequest $ unpack "https://api.twitch.tv/helix/chat/shoutouts" + let request = initialRequest + { method = encodeUtf8 "POST" + , requestBody = RequestBodyLBS body + , requestHeaders = + [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) + , ("Client-Id", encodeUtf8 rc.config.clientId) + , ("Content-Type", "application/json") + ] + } + response <- liftIO $ HTTP.httpLbs request rc.manager + unless (HTTP.statusIsSuccessful $ HTTP.responseStatus response) $ do + log $ "Failed to shoutout: error " <> tshow (HTTP.statusCode $ HTTP.responseStatus response) diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch/LiveChecker.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch/LiveChecker.hs new file mode 100644 index 0000000..cf0389a --- /dev/null +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch/LiveChecker.hs @@ -0,0 +1,59 @@ +module Fig.Monitor.Twitch.LiveChecker + ( twitchChannelLiveChecker + ) where + +import Fig.Prelude + +import Control.Concurrent (threadDelay) + +import qualified Data.Text as Text +import qualified Data.Set as Set + +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import Fig.Bus.Binary.Client +import Fig.Monitor.Twitch.Auth.AppToken +import Fig.Monitor.Twitch.Utils + +twitchChannelLiveChecker :: Config -> (Text, Text) -> IO () +twitchChannelLiveChecker cfg busAddr = do + busClient busAddr + (\cmds -> do + let + loop :: IO () + loop = do + log "Updating liveness..." + live <- runAuthed cfg $ usersAreLive cfg.monitor + if null live + then log "Update complete! No users live" + else log $ "Update complete! Live users: " <> Text.unwords (Set.toList live) + cmds.publish "fig monitor twitch stream online" . encodeUtf8 . Text.unwords $ Set.toList live + threadDelay $ 5 * 60 * 1000000 -- wait 5 minutes + loop + loop + ) + (\_cmds _ev _d -> pure ()) + (pure ()) + +usersAreLive :: [Text] -> Authed (Set.Set Text) +usersAreLive users = do + log $ "Checking liveness for: " <> Text.intercalate " " users + res <- authedRequestJSON @() + "GET" + ( mconcat + [ "https://api.twitch.tv/helix/streams?type=live" + , mconcat $ ("&user_login="<>) <$> users + ] + ) + Nothing + let mos = flip Aeson.parseEither res \obj -> do + obj .: "data" >>= \case + Aeson.Array os -> catMaybes . toList <$> forM os \case + Aeson.Object o -> Just <$> o .: "user_login" + _else -> pure Nothing + _else -> mempty + case mos of + Left err -> throwM $ FigMonitorTwitchException $ "Failed to check liveness: " <> pack err <> "\nResponse was: " <> tshow res + Right os -> pure . Set.fromList $ filter (`elem` os) users diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch/Utils.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Utils.hs index 94d7b6a..7a33b05 100644 --- a/fig-monitor-twitch/src/Fig/Monitor/Twitch/Utils.hs +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch/Utils.hs @@ -4,35 +4,20 @@ module Fig.Monitor.Twitch.Utils ( FigMonitorTwitchException(..) , loadConfig - , RequestConfig(..) , Config(..) - , authedRequest - , authedRequestJSON - , Authed - , runAuthed - , userIsLiveScrape ) where import Fig.Prelude -import Control.Monad.Reader (ReaderT, runReaderT) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS.Lazy - import qualified Toml -import qualified Data.Aeson as Aeson - -import Network.HTTP.Client as HTTP -import Network.HTTP.Client.TLS as HTTP - newtype FigMonitorTwitchException = FigMonitorTwitchException Text deriving (Show, Eq, Ord) instance Exception FigMonitorTwitchException data Config = Config { clientId :: Text + , clientSecret :: Text , userToken :: Text , userLogin :: Text , monitor :: [Text] @@ -41,8 +26,8 @@ data Config = Config configCodec :: Toml.TomlCodec Config configCodec = do clientId <- Toml.text "client_id" Toml..= (\a -> a.clientId) + clientSecret <- Toml.text "client_secret" Toml..= (\a -> a.clientSecret) userToken <- Toml.text "user_token" Toml..= (\a -> a.userToken) - -- userIds <- Toml.arrayOf Toml._Text "user_ids" Toml..= (\a -> a.userIds) userLogin <- Toml.text "user_login" Toml..= (\a -> a.userLogin) monitor <- Toml.arrayOf Toml._Text "monitor" Toml..= (\a -> a.monitor) pure $ Config{..} @@ -51,57 +36,3 @@ loadConfig :: FilePath -> IO Config loadConfig path = Toml.decodeFileEither configCodec path >>= \case Left err -> throwM . FigMonitorTwitchException $ tshow err Right config -> pure config - -data RequestConfig = RequestConfig - { config :: Config - , manager :: HTTP.Manager - } - -newtype Authed a = Authed { unAuthed :: ReaderT RequestConfig IO a } - deriving (Functor, Applicative, Monad, MonadReader RequestConfig, MonadIO, MonadThrow) - -authedRequest :: Text -> Text -> BS.Lazy.ByteString -> Authed BS.Lazy.ByteString -authedRequest method url body = do - rc <- ask - initialRequest <- liftIO . HTTP.parseRequest $ unpack url - let request = initialRequest - { method = encodeUtf8 method - , requestBody = RequestBodyLBS body - , requestHeaders = - [ ("Authorization", encodeUtf8 $ "Bearer " <> rc.config.userToken) - , ("Client-Id", encodeUtf8 rc.config.clientId) - , ("Content-Type", "application/json") - ] - } - response <- liftIO $ HTTP.httpLbs request rc.manager - pure $ HTTP.responseBody response - -authedRequestJSON :: (Aeson.ToJSON a, Aeson.FromJSON b) => Text -> Text -> Maybe a -> Authed b -authedRequestJSON method url val = do - resp <- authedRequest method url $ maybe "" Aeson.encode val - case Aeson.eitherDecode resp of - Left err -> do - throwM . FigMonitorTwitchException $ tshow err - Right res -> pure res - -runAuthed :: Config -> Authed a -> IO a -runAuthed config body = do - manager <- HTTP.newManager HTTP.tlsManagerSettings - runReaderT body.unAuthed RequestConfig{..} - -userIsLiveScrape :: Text -> Authed Bool -userIsLiveScrape user = do - rc <- ask - request <- liftIO . HTTP.parseRequest $ mconcat - [ "https://twitch.tv/" - , unpack user - ] - response <- liftIO $ HTTP.httpLbs request rc.manager - let res = BS.isInfixOf "\"isLiveBroadcast\":true" . BS.Lazy.toStrict $ HTTP.responseBody response - log $ mconcat - [ user - , " is " - , if res then "" else "not " - , "live" - ] - pure res diff --git a/fig-utils/fig-utils.cabal b/fig-utils/fig-utils.cabal index e2fc86c..a302cc4 100644 --- a/fig-utils/fig-utils.cabal +++ b/fig-utils/fig-utils.cabal @@ -15,6 +15,7 @@ library exposed-modules: Fig.Prelude Fig.Utils + Fig.Utils.DB Fig.Utils.Net Fig.Utils.SExpr Fig.Utils.FFI @@ -28,6 +29,7 @@ library , containers , directory , filepath + , hedis , megaparsec , mtl , network diff --git a/fig-utils/src/Fig/Prelude.hs b/fig-utils/src/Fig/Prelude.hs index fbbd31c..63ae360 100644 --- a/fig-utils/src/Fig/Prelude.hs +++ b/fig-utils/src/Fig/Prelude.hs @@ -44,6 +44,7 @@ module Fig.Prelude , tshow , headMay, atMay + , hush , throwLeft , eitherToMaybe , log @@ -111,6 +112,10 @@ atMay [] _ = Nothing atMay (x:_) 0 = Just x atMay (_:xs) n = atMay xs $ n - 1 +hush :: Either a b -> Maybe b +hush (Left _) = Nothing +hush (Right x) = Just x + throwLeft :: (Exception e, MonadThrow m) => (b -> e) -> Either b a -> m a throwLeft f (Left x) = throwM $ f x throwLeft _ (Right x) = pure x diff --git a/fig-web/src/Fig/Web/DB.hs b/fig-utils/src/Fig/Utils/DB.hs index fb5a98c..88a2f37 100644 --- a/fig-web/src/Fig/Web/DB.hs +++ b/fig-utils/src/Fig/Utils/DB.hs @@ -1,6 +1,4 @@ -module Fig.Web.DB where - -import Control.Error.Util (hush) +module Fig.Utils.DB where import Data.Maybe (mapMaybe) import Data.Map.Strict (Map) @@ -9,12 +7,12 @@ import qualified Data.Map.Strict as Map import qualified Database.Redis as Redis import Fig.Prelude -import Fig.Web.Types -import Fig.Web.Utils -connect :: MonadIO m => Config -> m DB -connect cfg = liftIO $ DB <$> Redis.checkedConnect Redis.defaultConnectInfo - { Redis.connectHost = unpack cfg.dbHost +newtype DB = DB { conn :: Redis.Connection } + +connect :: MonadIO m => Text -> m DB +connect host = liftIO $ DB <$> Redis.checkedConnect Redis.defaultConnectInfo + { Redis.connectHost = unpack host } run :: MonadIO m => DB -> Redis.Redis a -> m a diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal index 7a1f54c..c9bec26 100644 --- a/fig-web/fig-web.cabal +++ b/fig-web/fig-web.cabal @@ -17,7 +17,6 @@ common deps , containers , data-default-class , directory - , errors , filepath , hedis , http-types @@ -60,7 +59,6 @@ library Fig.Web.Utils Fig.Web.Types Fig.Web.Auth - Fig.Web.DB Fig.Web.Public Fig.Web.Secure Fig.Web.Module.Misc diff --git a/fig-web/src/Fig/Web/Module/Advent.hs b/fig-web/src/Fig/Web/Module/Advent.hs index d1bfe1c..dff11e3 100644 --- a/fig-web/src/Fig/Web/Module/Advent.hs +++ b/fig-web/src/Fig/Web/Module/Advent.hs @@ -8,7 +8,7 @@ import Text.HTML.SanitizeXSS (sanitize) import Fig.Web.Utils import Fig.Web.Types import Fig.Web.Auth -import Fig.Web.DB as DB +import Fig.Utils.DB as DB import qualified Fig.Utils.FFI as FFI keybase :: Integer -> Text -> Text -> ByteString diff --git a/fig-web/src/Fig/Web/Module/Bells.hs b/fig-web/src/Fig/Web/Module/Bells.hs index f4f8112..ba2d9cf 100644 --- a/fig-web/src/Fig/Web/Module/Bells.hs +++ b/fig-web/src/Fig/Web/Module/Bells.hs @@ -7,7 +7,7 @@ import Fig.Prelude import Fig.Utils.SExpr import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/Debt.hs b/fig-web/src/Fig/Web/Module/Debt.hs index 643f99f..60f1ab7 100644 --- a/fig-web/src/Fig/Web/Module/Debt.hs +++ b/fig-web/src/Fig/Web/Module/Debt.hs @@ -9,7 +9,7 @@ import qualified Data.Map.Strict as Map import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/Exchange.hs b/fig-web/src/Fig/Web/Module/Exchange.hs index 11af071..aacf207 100644 --- a/fig-web/src/Fig/Web/Module/Exchange.hs +++ b/fig-web/src/Fig/Web/Module/Exchange.hs @@ -5,8 +5,6 @@ module Fig.Web.Module.Exchange import Fig.Prelude -import Control.Error.Util (hush) - import qualified Database.Redis as Redis import Data.Maybe (mapMaybe) @@ -20,6 +18,8 @@ import Fig.Web.Utils import Fig.Web.Types import Fig.Web.Auth +import qualified Fig.Utils.DB as DB + public :: PublicModule public a = do onGet "/api/exchange" do diff --git a/fig-web/src/Fig/Web/Module/Gizmo.hs b/fig-web/src/Fig/Web/Module/Gizmo.hs index 70078fb..b7f0248 100644 --- a/fig-web/src/Fig/Web/Module/Gizmo.hs +++ b/fig-web/src/Fig/Web/Module/Gizmo.hs @@ -14,7 +14,7 @@ import qualified Network.WebSockets as WS import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/HLS.hs b/fig-web/src/Fig/Web/Module/HLS.hs index 66242e5..fb3a717 100644 --- a/fig-web/src/Fig/Web/Module/HLS.hs +++ b/fig-web/src/Fig/Web/Module/HLS.hs @@ -8,7 +8,7 @@ import Data.Functor ((<&>)) import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/Misc.hs b/fig-web/src/Fig/Web/Module/Misc.hs index c7ca250..3163b3f 100644 --- a/fig-web/src/Fig/Web/Module/Misc.hs +++ b/fig-web/src/Fig/Web/Module/Misc.hs @@ -10,7 +10,7 @@ import Control.Lens ((^?), Ixed (..)) import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/Puzzle.hs b/fig-web/src/Fig/Web/Module/Puzzle.hs index b8e469b..5278721 100644 --- a/fig-web/src/Fig/Web/Module/Puzzle.hs +++ b/fig-web/src/Fig/Web/Module/Puzzle.hs @@ -17,7 +17,7 @@ import Fig.Utils.FFI (checkAnswer) import Fig.Web.Utils import Fig.Web.Types import Fig.Web.Auth -import Fig.Web.DB +import Fig.Utils.DB data Puzzle = Puzzle { pid :: Text diff --git a/fig-web/src/Fig/Web/Module/Sentiment.hs b/fig-web/src/Fig/Web/Module/Sentiment.hs index 41f90f3..2bf1edb 100644 --- a/fig-web/src/Fig/Web/Module/Sentiment.hs +++ b/fig-web/src/Fig/Web/Module/Sentiment.hs @@ -6,7 +6,7 @@ import Fig.Prelude import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/Shader.hs b/fig-web/src/Fig/Web/Module/Shader.hs index e5dfc95..a0773a7 100644 --- a/fig-web/src/Fig/Web/Module/Shader.hs +++ b/fig-web/src/Fig/Web/Module/Shader.hs @@ -6,7 +6,7 @@ import Fig.Prelude import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/TCG.hs b/fig-web/src/Fig/Web/Module/TCG.hs index e57cb28..4f7c094 100644 --- a/fig-web/src/Fig/Web/Module/TCG.hs +++ b/fig-web/src/Fig/Web/Module/TCG.hs @@ -11,7 +11,7 @@ import qualified Data.ByteString as BS import Fig.Web.Utils import Fig.Web.Types -import qualified Fig.Web.DB as DB +import qualified Fig.Utils.DB as DB public :: PublicModule public a = do diff --git a/fig-web/src/Fig/Web/Module/User.hs b/fig-web/src/Fig/Web/Module/User.hs index 1e82e0b..550130c 100644 --- a/fig-web/src/Fig/Web/Module/User.hs +++ b/fig-web/src/Fig/Web/Module/User.hs @@ -16,7 +16,8 @@ import qualified Database.Redis as Redis import Fig.Web.Utils import Fig.Web.Types import Fig.Web.Auth -import qualified Fig.Web.DB as DB +import Fig.Utils.DB (DB) +import qualified Fig.Utils.DB as DB getText :: MonadIO m => DB -> ByteString -> m (Maybe Text) getText db key = do diff --git a/fig-web/src/Fig/Web/Public.hs b/fig-web/src/Fig/Web/Public.hs index 69678bb..816f724 100644 --- a/fig-web/src/Fig/Web/Public.hs +++ b/fig-web/src/Fig/Web/Public.hs @@ -10,10 +10,10 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Web.Scotty as Sc +import qualified Fig.Utils.DB as DB import Fig.Bus.Binary.Client import Fig.Web.Types import Fig.Web.Utils -import qualified Fig.Web.DB as DB import qualified Fig.Web.Module.Misc as Misc import qualified Fig.Web.Module.TwitchAuth as TwitchAuth import qualified Fig.Web.Module.Exchange as Exchange @@ -39,7 +39,7 @@ server :: PublicOptions -> Config -> (Text, Text) -> IO () server options cfg busAddr = do log $ "Web server running on port " <> tshow cfg.port log "Connecting to database..." - db <- DB.connect cfg + db <- DB.connect cfg.dbHost channels <- newChannels globals <- newGlobals busClient busAddr diff --git a/fig-web/src/Fig/Web/Secure.hs b/fig-web/src/Fig/Web/Secure.hs index 5aebff8..b1f04f5 100644 --- a/fig-web/src/Fig/Web/Secure.hs +++ b/fig-web/src/Fig/Web/Secure.hs @@ -10,11 +10,11 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Web.Scotty as Sc +import qualified Fig.Utils.DB as DB import Fig.Bus.Binary.Client import Fig.Web.Types import Fig.Web.Utils import Fig.Web.Auth -import qualified Fig.Web.DB as DB import qualified Fig.Web.Module.Exchange as Exchange import qualified Fig.Web.Module.Redeem as Redeem import qualified Fig.Web.Module.Advent as Advent @@ -29,7 +29,7 @@ server :: SecureOptions -> Config -> (Text, Text) -> IO () server options cfg busAddr = do log $ "Web server running on port " <> tshow cfg.port log "Connecting to database..." - db <- DB.connect cfg + db <- DB.connect cfg.dbHost channels <- newChannels globals <- newGlobals busClient busAddr diff --git a/fig-web/src/Fig/Web/Types.hs b/fig-web/src/Fig/Web/Types.hs index 3390d88..176f2ac 100644 --- a/fig-web/src/Fig/Web/Types.hs +++ b/fig-web/src/Fig/Web/Types.hs @@ -5,7 +5,6 @@ module Fig.Web.Types , newChannels , Globals(..) , newGlobals - , DB(..) , ModuleArgs(..) , PublicOptions(..), SecureOptions(..) , PublicModuleArgs, SecureModuleArgs @@ -26,10 +25,9 @@ import qualified Network.WebSockets as WS import qualified Web.Scotty as Sc -import qualified Database.Redis as Redis - import qualified Data.Aeson as Aeson +import Fig.Utils.DB import Fig.Bus.Binary.Client import Fig.Web.Utils @@ -69,8 +67,6 @@ newGlobals = do currentlyLive <- MVar.newMVar Set.empty pure Globals {..} -newtype DB = DB { conn :: Redis.Connection } - data ModuleArgs o = ModuleArgs { cfg :: Config , cmds :: Commands IO @@ -140,6 +140,7 @@ description = "Path to config file"; default = pkgs.writeText "fig-monitor-twitch.toml" '' client_id = "" + client_secret = "" user_token = "" user_login = "" monitor = [] |