Refactor, use app tokens

1 files changed, 431 insertions, 0 deletions

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)