diff options
| -rw-r--r-- | fig-frontend/src/Fig/Frontend.hs | 17 | ||||
| -rw-r--r-- | fig-frontend/src/Fig/Frontend/DB.hs | 20 | ||||
| -rw-r--r-- | fig-monitor-discord/src/Fig/Monitor/Discord.hs | 1 | ||||
| -rw-r--r-- | fig-monitor-twitch/src/Fig/Monitor/Twitch.hs | 30 | ||||
| -rw-r--r-- | fig-utils/src/Fig/Prelude.hs | 4 |
5 files changed, 71 insertions, 1 deletions
diff --git a/fig-frontend/src/Fig/Frontend.hs b/fig-frontend/src/Fig/Frontend.hs index 3cab953..b1c6aed 100644 --- a/fig-frontend/src/Fig/Frontend.hs +++ b/fig-frontend/src/Fig/Frontend.hs @@ -65,4 +65,21 @@ app cfg = do DB.hget db "songnotes" hash >>= \case Nothing -> Tw.send . Tw.status Tw.status404 $ Tw.text "song not found" Just val -> Tw.send . Tw.text $ decodeUtf8 val + , Tw.get "/api/poke/:name" do + target <- encodeUtf8 . toLower <$> Tw.param "name" + inbox <- fromMaybe [] <$> DB.smembers db ("pokeinbox:" <> target) + Tw.send . Tw.text . pretty . SExprList @Void $ SExprString . decodeUtf8 <$> inbox + , Tw.post "/api/poke/:name" do + me <- encodeUtf8 . toLower <$> Tw.param "ayem" + target <- encodeUtf8 . toLower <$> Tw.param "name" + DB.sismember db ("pokeinbox:" <> me) target >>= \case + True -> do + log . tshow $ "handshake between " <> me <> " and " <> target <> " complete!" + DB.srem db ("pokeinbox:" <> target) [me] + DB.srem db ("pokeinbox:" <> me) [target] + Tw.send $ Tw.text "complete" + False -> do + log . tshow $ "partial handshake from " <> me <> " to " <> target + DB.sadd db ("pokeinbox:" <> target) [me] + Tw.send $ Tw.text "partial" ] diff --git a/fig-frontend/src/Fig/Frontend/DB.hs b/fig-frontend/src/Fig/Frontend/DB.hs index d0641de..5ca8772 100644 --- a/fig-frontend/src/Fig/Frontend/DB.hs +++ b/fig-frontend/src/Fig/Frontend/DB.hs @@ -24,3 +24,23 @@ hget c key hkey = liftIO $ Redis.runRedis c do hvals :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe [ByteString]) hvals c key = liftIO $ Redis.runRedis c do hush <$> Redis.hvals key + +sadd :: MonadIO m => Redis.Connection -> ByteString -> [ByteString] -> m () +sadd c key skeys = liftIO $ Redis.runRedis c do + _ <- Redis.sadd key skeys + pure () + +srem :: MonadIO m => Redis.Connection -> ByteString -> [ByteString] -> m () +srem c key skeys = liftIO $ Redis.runRedis c do + _ <- Redis.srem key skeys + pure () + +smembers :: MonadIO m => Redis.Connection -> ByteString -> m (Maybe [ByteString]) +smembers c key = liftIO $ Redis.runRedis c do + hush <$> Redis.smembers key + +sismember :: MonadIO m => Redis.Connection -> ByteString -> ByteString -> m Bool +sismember c key skey = liftIO $ Redis.runRedis c do + Redis.sismember key skey >>= hush >>> \case + Just x -> pure x + Nothing -> pure False diff --git a/fig-monitor-discord/src/Fig/Monitor/Discord.hs b/fig-monitor-discord/src/Fig/Monitor/Discord.hs index a0c1b16..d5b09f3 100644 --- a/fig-monitor-discord/src/Fig/Monitor/Discord.hs +++ b/fig-monitor-discord/src/Fig/Monitor/Discord.hs @@ -6,7 +6,6 @@ import Fig.Prelude import GHC.Real (fromIntegral) -import Control.Arrow ((>>>)) import Control.Monad (unless) import Control.Monad.Reader (runReaderT) import qualified Control.Concurrent.Async as Async diff --git a/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs b/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs index 360e9c8..1889545 100644 --- a/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs +++ b/fig-monitor-twitch/src/Fig/Monitor/Twitch.hs @@ -210,6 +210,29 @@ removeVIP vipuser user = do 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) + twitchEventClient :: Config -> (Text, Text) -> IO () twitchEventClient cfg busAddr = do WS.runSecureClient "eventsub.wss.twitch.tv" 443 "/ws" \conn -> do @@ -241,6 +264,7 @@ twitchEventClient cfg busAddr = do cmds.subscribe [sexp|(monitor twitch prediction finish)|] cmds.subscribe [sexp|(monitor twitch vip add)|] cmds.subscribe [sexp|(monitor twitch vip remove)|] + cmds.subscribe [sexp|(monitor twitch shoutout)|] forever do resp <- WS.receiveData conn case Aeson.eitherDecodeStrict resp of @@ -404,6 +428,12 @@ twitchEventClient cfg busAddr = do loginToMaybeUserId u >>= \case Nothing -> pure () Just vipuser -> removeVIP vipuser user + | ev == [sexp|(monitor twitch shoutout)|] -> do + runAuthed cfg do + user <- loginToUserId cfg.userLogin + loginToMaybeUserId u >>= \case + Nothing -> pure () + Just souser -> shoutout souser user _ -> log $ "Invalid incoming message: " <> tshow d ) (pure ()) diff --git a/fig-utils/src/Fig/Prelude.hs b/fig-utils/src/Fig/Prelude.hs index 80e5829..060f197 100644 --- a/fig-utils/src/Fig/Prelude.hs +++ b/fig-utils/src/Fig/Prelude.hs @@ -46,6 +46,7 @@ module Fig.Prelude , headMay, atMay , throwLeft , log + , (>>>) , Pretty(..) , Fix(..), unFix @@ -113,6 +114,9 @@ throwLeft :: (Exception e, MonadThrow m) => (b -> e) -> Either b a -> m a throwLeft f (Left x) = throwM $ f x throwLeft _ (Right x) = pure x +(>>>) :: (a -> b) -> (b -> c) -> a -> c +(>>>) = flip (.) + log :: MonadIO m => Text -> m () log msg = do t <- liftIO Time.getCurrentTime |