diff options
Diffstat (limited to 'fig-monitor-twitch/src/Fig')
7 files changed, 738 insertions, 636 deletions
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 |