diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Revision history for twitchapi + +## 0.0.1 -- 2022-09-27 + +* Implemented support for Helix (Bits, Channel Points) +* Implemented support for PubSub (partial) + +## 0.0.0 -- 2021-03-22 + +* Pre-release work uploaded to github diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021 Tina Wuest + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tina Wuest nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Web/TwitchAPI/Helix/Bits.hs b/src/Web/TwitchAPI/Helix/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Web/TwitchAPI/Helix/Bits.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Web.TwitchAPI.Helix.Bits where + +import Prelude + +import qualified Data.ByteString.Char8 as BS +import qualified Data.Time as Time +import qualified Data.Time.RFC3339 as Time ( formatTimeRFC3339, parseTimeRFC3339 ) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text ( encodeUtf8 ) +import qualified Network.HTTP.Client as HTTP + +import Data.Maybe ( fromMaybe ) +import Data.Aeson ( FromJSON(..), (.:), withObject + , Object + ) + +import qualified Web.TwitchAPI.Helix.Request as Req + +data Leaderboard = Leaderboard { count :: Maybe Integer + , period :: Maybe Period + , startedAt :: Maybe Time.UTCTime + , userId :: Maybe Integer + } deriving ( Show, Eq ) + +data Period = Day | Week | Month | Year | All deriving ( Eq ) +instance Show Period where + show Day = "day" + show Week = "week" + show Month = "month" + show Year = "year" + show All = "all" + +instance Req.HelixRequest Leaderboard where + toRequest leaderboard = + let count' :: [(BS.ByteString, Maybe BS.ByteString)] = fromMaybe [] $ (\c -> ("count", Just . BS.pack . show $ c):[]) <$> (count leaderboard) + period' :: [(BS.ByteString, Maybe BS.ByteString)] = fromMaybe [] $ (\p -> ("period", Just . BS.pack . show $ p):[]) <$> (period leaderboard) + startedAt' :: [(BS.ByteString, Maybe BS.ByteString)] = fromMaybe [] $ (\s -> ("started_at", Just . Text.encodeUtf8 $ (Time.formatTimeRFC3339 $ Time.utcToZonedTime Time.utc s :: Text.Text)):[]) <$> ((startedAt :: Leaderboard -> Maybe Time.UTCTime) leaderboard) + userId' :: [(BS.ByteString, Maybe BS.ByteString)] = fromMaybe [] $ (\u -> ("user_id", Just . Text.encodeUtf8 . Text.pack . show $ u):[]) <$> ((userId :: Leaderboard -> Maybe Integer) leaderboard) + setQuery = HTTP.setQueryString $ foldl (++) [] [count', period', startedAt', userId'] + in setQuery $ HTTP.parseRequest_ "GET https://api.twitch.tv/helix/bits/leaderboard" + scope Leaderboard{} = Just "bits:read" + +data LeaderboardEntry = LeaderboardEntry { userId :: Integer + , userLogin :: String + , userName :: String + , rank :: Integer + , score :: Integer + } deriving ( Show, Eq ) + +instance FromJSON LeaderboardEntry where + parseJSON = withObject "LeaderboardEntry" $ \o -> do + uid <- o .: "user_id" + userLogin <- o .: "user_login" + userName <- o .: "user_login" + rank <- o .: "rank" + score <- o .: "score" + let userId = read uid :: Integer + return LeaderboardEntry{..} + +data LeaderboardResponse = LeaderboardResponse { endedAt :: Maybe Time.UTCTime + , startedAt :: Maybe Time.UTCTime + , total :: Integer + , entries :: [LeaderboardEntry] + } deriving ( Show, Eq) + +instance FromJSON LeaderboardResponse where + parseJSON = withObject "LeaderboardResponse" $ \o -> do + dates :: Object <- o .: "date_range" + ended :: String <- dates .: "ended_at" + started :: String <- dates .: "started_at" + entries :: [LeaderboardEntry] <- o .: "data" + total <- o .: "total" + let endedAt = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 ended + startedAt = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 started + return LeaderboardResponse{..} + +data Cheermotes = Cheermotes { broadcasterId :: Integer } deriving ( Show, Eq ) + +instance Req.HelixRequest Cheermotes where + toRequest c = + let setQuery = HTTP.setQueryString [("broadcaster_id", Just . BS.pack . show $ (broadcasterId :: Cheermotes -> Integer) c)] + in setQuery $ HTTP.parseRequest_ "GET https://api.twitch.tv/helix/bits/leaderboard" + scope Cheermotes{} = Nothing + +data CheermoteClass = GlobalFirstParty | GlobalThirdParty | ChannelCustom | DisplayOnly | Sponsored | Unknown deriving ( Eq, Show ) + +instance Read CheermoteClass where + readsPrec _ "global_first_party" = [(GlobalFirstParty, "")] + readsPrec _ "global_third_party" = [(GlobalThirdParty, "")] + readsPrec _ "channel_custom" = [(ChannelCustom, "")] + readsPrec _ "display_only" = [(DisplayOnly, "")] + readsPrec _ "sponsored" = [(Sponsored, "")] + readsPrec _ _ = [(Unknown, "")] + +data CheermoteData = CheermoteData { tinyURI :: Maybe String + , smallURI :: Maybe String + , mediumURI :: Maybe String + , largeURI :: Maybe String + , hugeURI :: Maybe String + } deriving ( Eq, Show ) + +instance FromJSON CheermoteData where + parseJSON = withObject "CheermoteData" $ \o -> do + tinyURI <- o .: "1" + smallURI <- o .: "1.5" + mediumURI <- o .: "2" + largeURI <- o .: "3" + hugeURI <- o .: "4" + return CheermoteData{..} + +data CheermoteImages = CheermoteImages { darkAnimated :: CheermoteData + , darkStatic :: CheermoteData + , lightAnimated :: CheermoteData + , lightStatic :: CheermoteData + } deriving ( Eq, Show ) + +instance FromJSON CheermoteImages where + parseJSON = withObject "CheermoteImages" $ \o -> do + dark :: Object <- o .: "dark" + light :: Object <- o .: "light" + darkAnimated <- dark .: "animated" + darkStatic <- dark .: "static" + lightAnimated <- light .: "animated" + lightStatic <- light .: "static" + return CheermoteImages{..} + +data CheermoteTier = CheermoteTier { minBits :: Integer + , cheermoteId :: Integer + , color :: String + , images :: CheermoteImages + , enabled :: Bool + , visible :: Bool + } deriving ( Eq, Show ) + +instance FromJSON CheermoteTier where + parseJSON = withObject "CheermoteTier" $ \o -> do + minBits <- o .: "min_bits" + cheermoteId <- o .: "id" + color <- o .: "color" + images <- o .: "images" + enabled <- o .: "can_cheer" + visible <- o .: "show_in_bits_card" + return CheermoteTier{..} + +data CheermotesResponse = CheermotesResponse { prefix :: String + , tiers :: [CheermoteTier] + , cheermoteType :: String + , order :: Integer + , lastUpdated :: Maybe Time.UTCTime + , charitable :: Bool + } deriving ( Eq, Show ) + +instance FromJSON CheermotesResponse where + parseJSON = withObject "CheermotesResponse" $ \o -> do + updated :: String <- o .: "last_updated" + let lastUpdated = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 updated + prefix <- o .: "prefix" + tiers <- o .: "tiers" + cheermoteType <- o .: "type" + order <- o .: "order" + charitable <- o .: "is_charitable" + return CheermotesResponse{..} diff --git a/src/Web/TwitchAPI/Helix/ChannelPoints.hs b/src/Web/TwitchAPI/Helix/ChannelPoints.hs new file mode 100644 --- /dev/null +++ b/src/Web/TwitchAPI/Helix/ChannelPoints.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Web.TwitchAPI.Helix.ChannelPoints where + +import Prelude + +import qualified Data.ByteString.Char8 as BS +import qualified Data.Time as Time +import qualified Data.Time.RFC3339 as Time ( parseTimeRFC3339 ) +import qualified Data.Text as Text +import qualified Network.HTTP.Client as HTTP + +import Data.Maybe ( fromMaybe ) +import Data.Aeson ( FromJSON(..), (.:), withObject + , ToJSON(..), (.=), object, encode + , Object + ) + +import qualified Web.TwitchAPI.Helix.Request as Req + +data Create = Create { broadcasterId :: Integer + , title :: String + , prompt :: Maybe String + , cost :: Integer + , enabled :: Maybe Bool + , backgroundColor :: Maybe String + , maxPerStream :: Maybe Integer + , maxPerUser :: Maybe Integer + , cooldownSeconds :: Maybe Integer + , autoFulfilled :: Maybe Bool + } deriving ( Show, Eq ) + +instance ToJSON Create where + toJSON Create{..} = + object [ "title" .= (Text.pack title) + , "prompt" .= (Text.pack <$> prompt) + , "cost" .= cost + , "is_enabled" .= (fromMaybe True enabled) + , "background_color" .= (Text.pack <$> backgroundColor) + , "is_user_input_required" .= (fmap (const True) prompt) + , "is_max_per_stream_enabled" .= (fmap (const True) maxPerStream) + , "max_per_stream" .= maxPerStream + , "is_max_per_user_per_stream_enabled" .= (fmap (const True) maxPerUser) + , "max_per_user_per_stream" .= maxPerUser + , "is_global_cooldown_enabled" .= (fmap (const True) cooldownSeconds) + , "global_cooldown_seconds" .= cooldownSeconds + , "should_redemptions_skip_request_queue" .= autoFulfilled + ] + +instance Req.HelixRequest Create where + toRequest create = + let setQuery = HTTP.setQueryString [("broadcaster_id", Just . BS.pack . show $ (broadcasterId :: Create -> Integer) create)] + setBody r = r{ HTTP.requestBody = HTTP.RequestBodyLBS . encode . toJSON $ create } + in setBody . setQuery $ HTTP.parseRequest_ "POST https://api.twitch.tv/helix/channel_points/custom_rewards" + scope Create{} = Just "channel:manage:redemptions" + +data RewardImages = RewardImages { tiny :: Maybe String + , large :: Maybe String + , huge :: Maybe String + } deriving ( Show, Eq ) + +instance FromJSON RewardImages where + parseJSON = withObject "RewardImages" $ \o -> do + tiny <- o .: "url_1x" + large <- o .: "url_2x" + huge <- o .: "url_4x" + return RewardImages{..} + +data CreateResponse = CreateResponse { broadcasterId :: Integer + , broadcasterLogin :: String + , broadcasterName :: String + , rewardId :: String + , rewardTitle :: String + , prompt :: Maybe String + , rewardCost :: Integer + , rewardImage :: Maybe RewardImages + , defaultImage :: RewardImages + , backgroundColor :: String + , maxPerStream :: Maybe Integer + , maxPerUser :: Maybe Integer + , cooldownSeconds :: Maybe Integer + , paused :: Bool + , inStock :: Bool + , autoFulfilled :: Bool + , redemptionCount :: Integer + , cooldownExpires :: Maybe Time.UTCTime + } deriving ( Show, Eq ) + +instance FromJSON CreateResponse where + parseJSON = withObject "CreateResponse" $ \o -> do + bid <- o .: "broadcaster_id" + let broadcasterId = read bid :: Integer + broadcasterLogin <- o .: "broadcaster_login" + broadcasterName <- o .: "broadcaster_name" + rewardId <- o .: "id" + rewardTitle <- o .: "title" + + promptText <- o .: "prompt" + promptEnabled :: Bool <- o .: "is_user_input_required" + let prompt = if promptEnabled then Just promptText else Nothing + + rewardCost <- o .: "cost" + rewardImage <- o .: "image" + defaultImage <- o .: "default_image" + backgroundColor <- o .: "background_color" + + maxObject :: Object <- o .: "max_per_stream_setting" + maxEnabled <- maxObject .: "is_enabled" + streamMax <- maxObject .: "max_per_stream" + let maxPerStream = if maxEnabled then Just streamMax else Nothing + + userMaxObject :: Object <- o .: "max_per_user_per_stream_setting" + userMaxEnabled <- userMaxObject .: "is_enabled" + userMax <- userMaxObject .: "max_per_user_per_stream" + let maxPerUser = if userMaxEnabled then Just userMax else Nothing + + cooldownObject :: Object <- o .: "global_cooldown_setting" + cooldownEnabled <- cooldownObject .: "is_enabled" + cooldown <- cooldownObject .: "global_cooldown_seconds" + let cooldownSeconds = if cooldownEnabled then Just cooldown else Nothing + + paused <- o .: "is_paused" + inStock <- o .: "is_in_stock" + autoFulfilled <- o .: "should_redemptions_skip_request_queue" + redemptionCount <- o .: "redemptions_redeemed_current_stream" + cooldownExpiry :: Maybe String <- o .: "cooldown_expires_at" + let cooldownExpires = Time.zonedTimeToUTC <$> (Time.parseTimeRFC3339 =<< cooldownExpiry) + return CreateResponse{..} diff --git a/src/Web/TwitchAPI/Helix/Request.hs b/src/Web/TwitchAPI/Helix/Request.hs new file mode 100644 --- /dev/null +++ b/src/Web/TwitchAPI/Helix/Request.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Web.TwitchAPI.Helix.Request where + +import Prelude + +import qualified Network.HTTP.Client as HTTP + +class HelixRequest a where + toRequest :: a -> HTTP.Request + scope :: a -> Maybe String diff --git a/src/Web/TwitchAPI/PubSub.hs b/src/Web/TwitchAPI/PubSub.hs new file mode 100644 --- /dev/null +++ b/src/Web/TwitchAPI/PubSub.hs @@ -0,0 +1,668 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Module : TwitchAPI.PubSub +Copyright : (c) Christina Wuest 2021 +License : BSD-style + +Maintainer : tina@wuest.me +Stability : experimental +Portability : non-portable + +Messages sent over Twitch's PubSub interface. +-} + +module Web.TwitchAPI.PubSub where + +import Prelude + +import qualified Data.Time as Time +import qualified Data.Time.RFC3339 as Time ( parseTimeRFC3339 ) +import qualified Data.Time.Clock.POSIX as Time ( posixSecondsToUTCTime ) + +import Data.Aeson ( FromJSON(..), (.:), (.:?), withObject, withText, withEmbeddedJSON + , ToJSON(..), (.=), object + , Object + ) + +import qualified Data.Aeson as JSON + +import Control.Monad ( mzero ) +import GHC.Generics ( Generic ) + +import qualified Data.Aeson.Types as JSON.Types + +data Topic = BitsV1 { channelId :: Integer } + | BitsV2 { channelId :: Integer } + | BitsBadge { channelId :: Integer } + | ChannelPoints { channelId :: Integer } + | ChannelSubscriptions { channelId :: Integer } + | ChatModeratorActions { channelId :: Integer, userId :: Integer } + | Whispers { userId :: Integer } + deriving ( Eq, Show ) + +toRequest :: Topic -> String +toRequest BitsV1{..} = ("channel-bits-events-v1." ++) $ show channelId +toRequest BitsV2{..} = ("channel-bits-events-v2." ++) $ show channelId +toRequest BitsBadge{..} = ("channel-bits-badge-unlocks." ++) $ show channelId +toRequest ChannelPoints{..} = ("channel-points-channel-v1." ++) $ show channelId +toRequest ChannelSubscriptions{..} = ("channel-subscribe-events-v1." ++) $ show channelId +toRequest ChatModeratorActions{..} = "chat_moderator_actions." ++ (show userId) ++ "." ++ (show channelId) +toRequest Whispers{..} = ("whispers." ++) $ show userId + +scope :: Topic -> String +scope BitsV1{} = "bits:read" +scope BitsV2{} = "bits:read" +scope BitsBadge{} = "bits:read" +scope ChannelPoints{} = "channel:read:redemptions" +scope ChannelSubscriptions{} = "channel:read:subscriptions" +scope ChatModeratorActions{} = "channel:moderate" +scope Whispers{} = "whispers:read" + +data RequestType = Listen | Unlisten deriving ( Eq ) + +instance Show RequestType where + show Listen = "LISTEN" + show Unlisten = "UNLISTEN" + +data Request = Request { requestType :: RequestType + , nonce :: Maybe String + , topics :: [Topic] + , authToken :: String + } deriving ( Eq, Show ) + +instance ToJSON Request where + toJSON Request{..} = + object [ "type" .= (show requestType) + , "nonce" .= nonce + , "data" .= object [ "topics" .= (toRequest <$> topics) + , "auth_token" .= authToken + ] + ] + +data RequestError = BadMessage | BadAuth | ServerFail | BadTopic | None deriving ( Eq, Show ) + +instance Read RequestError where + readsPrec _ "ERR_BADMESSAGE" = [(BadMessage, "")] + readsPrec _ "ERR_BADAUTH" = [(BadAuth, "")] + readsPrec _ "ERR_SERVER" = [(ServerFail, "")] + readsPrec _ "ERR_BADTOPIC" = [(BadTopic, "")] + readsPrec _ _ = [(None, "")] + +data Response = Response { nonce :: Maybe String + , errorReported :: RequestError + } deriving ( Show, Eq ) + +instance FromJSON Response where + parseJSON = withObject "Response" $ \o -> + o .: "type" >>= \(reportedType :: String) -> + -- This value is required per Twitch or else any response is invalid + if reportedType == "RESPONSE" then do + nonce <- o .: "nonce" + err <- o .: "error" + let errorReported = read err :: RequestError + return Response{..} + else mzero + +-- Used for Channel Points rewards +data RewardImages = RewardImages { tiny :: Maybe String + , large :: Maybe String + , huge :: Maybe String + } deriving ( Show, Eq, Generic ) + +instance FromJSON RewardImages where + parseJSON = withObject "RewardImages" $ \o -> do + tiny <- o .: "url_1x" + large <- o .: "url_2x" + huge <- o .: "url_4x" + return RewardImages{..} + +data UserInfo = UserInfo { userId :: Integer + , userName :: String + , displayName :: Maybe String + } deriving ( Eq, Show, Generic ) + +instance FromJSON UserInfo where + parseJSON = withObject "UserInfo" $ \o -> do + userId' <- o .: "id" + let userId = read userId' :: Integer + userName <- o .: "login" + displayName <- o .: "display_name" + return UserInfo{..} + +data RewardStatus = Fulfilled | Unfulfilled deriving ( Eq, Show, Generic ) + +instance Read RewardStatus where + readsPrec _ "FULFILLED" = [(Fulfilled, "")] + readsPrec _ _ = [(Unfulfilled, "")] + + +data BadgeUnlock = BadgeUnlock { newVersion :: Integer + , previousVersion :: Integer + } deriving ( Eq, Show, Generic ) + +instance FromJSON BadgeUnlock where + parseJSON = withObject "BadgeUnlock" $ \o -> do + newVersion <- o .: "new_version" + previousVersion <- o .: "previous_version" + return BadgeUnlock{..} + +data SubscriptionTier = Prime | Tier1 | Tier2 | Tier3 deriving ( Eq, Show, Generic ) + +instance FromJSON SubscriptionTier where + parseJSON = withText "SubscriptionTier" $ \o -> + case o of + "1000" -> return Tier1 + "2000" -> return Tier2 + "3000" -> return Tier3 + "Prime" -> return Prime + _ -> mzero + +data EmoteSpec = EmoteSpec { emoteStart :: Integer + , emoteLength :: Integer + , emoteId :: Integer + } deriving ( Eq, Show, Generic ) + +instance FromJSON EmoteSpec where + parseJSON = withObject "EmoteSpec" $ \o -> do + emoteStart <- o .: "start" + emoteEnd :: Integer <- o .: "end" + emoteId' :: Maybe String <- o .:? "id" + let emoteLength = 1 + emoteEnd - emoteStart + case emoteId' of + Just emoteId'' -> + let emoteId = read emoteId'' :: Integer + in return EmoteSpec{..} + Nothing -> do + altEmoteId :: String <- o .: "emote_id" + let emoteId = read altEmoteId :: Integer + return EmoteSpec{..} + +data SubscriptionMessage = SubscriptionMessage { messageBody :: String + , emotes :: [EmoteSpec] + } deriving ( Eq, Show, Generic ) + +instance FromJSON SubscriptionMessage where + parseJSON = withObject "SubscriptionMessage" $ \o -> do + messageBody <- o .: "message" + emotes' <- o .:? "emotes" + let emotes = case emotes' of + Nothing -> [] + Just xs -> xs + return SubscriptionMessage{..} + +data Message = BitsV2Message { badge :: Maybe BadgeUnlock + , bits :: Integer + , channelId :: Integer + , chatMessage :: Maybe String + , context :: String + , messageId :: String + , messageType :: String + , time :: Maybe Time.UTCTime + , userTotal :: Integer + , userId :: Maybe Integer + , userName :: Maybe String + , version :: String + } + | BitsV2AnonymousMessage { bits :: Integer + , channelId :: Integer + , chatMessage :: Maybe String + , context :: String + , messageId :: String + , messageType :: String + , time :: Maybe Time.UTCTime + , version :: String + } + | BitsV1Message { badge :: Maybe BadgeUnlock + , bits :: Integer + , channelId :: Integer + , channelName :: String + , chatMessage :: Maybe String + , context :: String + , messageId :: String + , messageType :: String + , time :: Maybe Time.UTCTime + , userTotal :: Integer + , userId :: Maybe Integer + , userName :: Maybe String + , version :: String + } + | BitsBadgeMessage { userId :: Maybe Integer + , userName :: Maybe String + , channelId :: Integer + , channelName :: String + , bitsTier :: Integer + , chatMessage :: Maybe String + , time :: Maybe Time.UTCTime + } + | ChannelPointsMessage { serverTime :: Maybe Time.UTCTime + , redeemedTime :: Maybe Time.UTCTime + , user :: UserInfo + , rewardId :: String + , channelId :: Integer + , title :: String + , prompt :: Maybe String + , cost :: Integer + , userInput :: Maybe String + , subOnly :: Bool + , image :: Maybe RewardImages + , defaultImage :: RewardImages + , backgroundColor :: String + , enabled :: Bool + , paused :: Bool + , inStock :: Bool + , maxPerStream :: Maybe Integer + , autoFulfilled :: Bool + , status :: RewardStatus + } + | ChannelSubscriptionMessage { user :: UserInfo + , channelName :: String + , channelId :: Integer + , time :: Maybe Time.UTCTime + , subTier :: SubscriptionTier + , subPlanName :: String + , subMessage :: SubscriptionMessage + } + | ChannelResubscriptionMessage { user :: UserInfo + , channelName :: String + , channelId :: Integer + , time :: Maybe Time.UTCTime + , subTier :: SubscriptionTier + , subPlanName :: String + , totalMonths :: Integer + , streakMonths :: Maybe Integer + , subMessage :: SubscriptionMessage + } + | ChannelExtendSubscriptionMessage { user :: UserInfo + , channelName :: String + , channelId :: Integer + , time :: Maybe Time.UTCTime + , subTier :: SubscriptionTier + , subPlanName :: String + , totalMonths :: Integer + , streakMonths :: Maybe Integer + , endMonth :: Integer + , subMessage :: SubscriptionMessage + } + | ChannelSubscriptionGiftMessage { user :: UserInfo + , channelName :: String + , channelId :: Integer + , time :: Maybe Time.UTCTime + , subTier :: SubscriptionTier + , subPlanName :: String + , recipient :: UserInfo + } + | ChannelMultiMonthSubscriptionGiftMessage { user :: UserInfo + , channelName :: String + , channelId :: Integer + , time :: Maybe Time.UTCTime + , subTier :: SubscriptionTier + , subPlanName :: String + , recipient :: UserInfo + , months :: Integer + } + | ChannelAnonymousSubscriptionGiftMessage { channelName :: String + , channelId :: Integer + , time :: Maybe Time.UTCTime + , subTier :: SubscriptionTier + , subPlanName :: String + , recipient :: UserInfo + } + | ChannelAnonymousMultiMonthSubscriptionGiftMessage { channelName :: String + , channelId :: Integer + , time :: Maybe Time.UTCTime + , subTier :: SubscriptionTier + , subPlanName :: String + , recipient :: UserInfo + , months :: Integer + } + | WhisperMessage { messageId :: String + , threadId :: String + , time :: Maybe Time.UTCTime + , messageBody :: String + , emotes :: [EmoteSpec] + , user :: UserInfo + , userColor :: String + , recipient :: UserInfo + } + | SuccessMessage { nonce :: Maybe String } + | ErrorMessage { nonce :: Maybe String + , errorString :: String + } deriving ( Eq, Show, Generic ) + +instance JSON.ToJSON EmoteSpec +instance JSON.ToJSON SubscriptionMessage +instance JSON.ToJSON SubscriptionTier +instance JSON.ToJSON RewardStatus +instance JSON.ToJSON RewardImages +instance JSON.ToJSON UserInfo +instance JSON.ToJSON BadgeUnlock +instance JSON.ToJSON Message + +type MessageParser = Object -> JSON.Types.Parser Message + +parseChannelSubscribeEvent :: MessageParser +parseChannelSubscribeEvent o = do + uid :: String <- o .: "user_id" + userName <- o .: "user_name" + displayName <- o .: "display_name" + let userId = read uid :: Integer + user = UserInfo userId userName displayName + + channelName <- o .: "channel_name" + channel <- o .: "channel_id" + let channelId = read channel :: Integer + + t :: String <- o .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + subTier <- o .: "sub_plan" + subPlanName <- o .: "sub_plan_name" + subMessage <- o .: "sub_message" + + return ChannelSubscriptionMessage{..} + +parseChannelResubscribeEvent :: MessageParser +parseChannelResubscribeEvent o = do + uid :: String <- o .: "user_id" + userName <- o .: "user_name" + displayName <- o .: "display_name" + let userId = read uid :: Integer + user = UserInfo userId userName displayName + + channelName <- o .: "channel_name" + channel <- o .: "channel_id" + let channelId = read channel :: Integer + + t :: String <- o .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + subTier <- o .: "sub_plan" + subPlanName <- o .: "sub_plan_name" + totalMonths <- o .: "cumulative_months" + streakMonths <- o .:? "streak_months" + subMessage <- o .: "sub_message" + + return ChannelResubscriptionMessage{..} + +parseChannelExtendSubEvent :: MessageParser +parseChannelExtendSubEvent o = do + uid :: String <- o .: "user_id" + userName <- o .: "user_name" + displayName <- o .: "display_name" + let userId = read uid :: Integer + user = UserInfo userId userName displayName + + channelName <- o .: "channel_name" + channel <- o .: "channel_id" + let channelId = read channel :: Integer + + t :: String <- o .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + subTier <- o .: "sub_plan" + subPlanName <- o .: "sub_plan_name" + totalMonths <- o .: "cumulative_months" + endMonth <- o .: "benefit_end_month" + streakMonths <- o .:? "streak_months" + subMessage <- o .: "sub_message" + + return ChannelExtendSubscriptionMessage{..} + +parseChannelSubGiftEvent :: MessageParser +parseChannelSubGiftEvent o = do + uid :: String <- o .: "user_id" + userName <- o .: "user_name" + displayName <- o .: "display_name" + let userId = read uid :: Integer + user = UserInfo userId userName displayName + + rid :: String <- o .: "recipient_id" + rUserName <- o .: "recipient_user_name" + rDisplayName <- o .: "recipient_display_name" + let rUserId = read rid :: Integer + recipient = UserInfo rUserId rUserName rDisplayName + + channelName <- o .: "channel_name" + channel <- o .: "channel_id" + let channelId = read channel :: Integer + + t :: String <- o .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + subTier <- o .: "sub_plan" + subPlanName <- o .: "sub_plan_name" + + duration :: Maybe Integer <- o .: "multi_month_duration" + case duration of + Nothing -> return ChannelSubscriptionGiftMessage{..} + Just 1 -> return ChannelSubscriptionGiftMessage{..} + Just months -> return ChannelMultiMonthSubscriptionGiftMessage{..} + +parseChannelAnonSubGiftEvent :: MessageParser +parseChannelAnonSubGiftEvent o = do + rid :: String <- o .: "recipient_id" + rUserName <- o .: "recipient_user_name" + rDisplayName <- o .: "recipient_display_name" + let rUserId = read rid :: Integer + recipient = UserInfo rUserId rUserName rDisplayName + + channelName <- o .: "channel_name" + channel <- o .: "channel_id" + let channelId = read channel :: Integer + + t :: String <- o .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + subTier <- o .: "sub_plan" + subPlanName <- o .: "sub_plan_name" + + duration :: Maybe Integer <- o .: "multi_month_duration" + case duration of + Nothing -> return ChannelAnonymousSubscriptionGiftMessage{..} + Just 1 -> return ChannelAnonymousSubscriptionGiftMessage{..} + Just months -> return ChannelAnonymousMultiMonthSubscriptionGiftMessage{..} + +parseChannelSubscribeMessage :: MessageParser +parseChannelSubscribeMessage o = do + context :: String <- o .: "context" + case context of + "sub" -> parseChannelSubscribeEvent o + "resub" -> parseChannelResubscribeEvent o + "extendsub" -> parseChannelExtendSubEvent o + "subgift" -> parseChannelSubGiftEvent o + "resubgift" -> parseChannelSubGiftEvent o + "anonsubgift" -> parseChannelAnonSubGiftEvent o + "anonresubgift" -> parseChannelAnonSubGiftEvent o + _ -> mzero + +parseBitsV2Message :: MessageParser +parseBitsV2Message o = do + dat <- o .: "data" + anonymous :: Maybe Bool <- o .:? "is_anonymous" + case anonymous of + Nothing -> parseBitsV2 o dat + (Just False) -> parseBitsV2 o dat + (Just True) -> parseBitsV2Anonymous o dat + + +parseBitsV2 :: Object -> MessageParser +parseBitsV2 o dat = do + badge <- dat .: "badge_entitlement" + bits <- dat .: "bits_used" + chatMessage <- dat .: "chat_message" + context <- dat .: "context" + messageId <- o .: "message_id" + messageType <- o .: "message_type" -- Always bits_event? No other examples given in API docs + userTotal <- dat .: "total_bits_used" + userName <- dat .: "user_name" + version <- o .: "version" + + channel :: String <- dat .: "channel_id" + let channelId = read channel :: Integer + + uid :: Maybe String <- dat .: "user_id" + let userId = fmap (read :: String -> Integer) uid + + t :: String <- dat .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + return BitsV2Message{..} + +parseBitsV2Anonymous :: Object -> MessageParser +parseBitsV2Anonymous o dat = do + bits <- dat .: "bits_used" + chatMessage <- dat .: "chat_message" + context <- dat .: "context" + messageId <- o .: "message_id" + messageType <- o .: "message_type" -- Always bits_event? No other examples given in API docs + version <- o .: "version" + + channel :: String <- dat .: "channel_id" + let channelId = read channel :: Integer + + t :: String <- dat .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + return BitsV2AnonymousMessage{..} + +parseBitsV1Message :: MessageParser +parseBitsV1Message o = do + dat <- o .: "data" + badge <- dat .: "badge_entitlement" + bits <- dat .: "bits_used" + channelName <- dat .: "channel_name" + chatMessage <- dat .: "chat_message" + context <- dat .: "context" + messageId <- o .: "message_id" + messageType <- o .: "message_type" -- Always bits_event? No other examples given in API docs + userTotal <- dat .: "total_bits_used" + userName <- dat .: "user_name" + version <- o .: "version" + + uid :: Maybe String <- dat .: "user_id" + let userId = fmap (read :: String -> Integer) uid + + channel :: String <- dat .: "channel_id" + let channelId = read channel :: Integer + + t :: String <- dat .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + + return BitsV1Message{..} + +parseBitsBadgeMessage :: MessageParser +parseBitsBadgeMessage o = do + userId <- o .: "user_id" + userName <- o .: "user_name" + channelName <- o .: "channel_name" + bitsTier <- o .: "badge_tier" + chatMessage <- o .: "chat_message" + + channel :: String <- o .: "channel_id" + t :: String <- o .: "time" + let time = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 t + channelId = read channel :: Integer + return BitsBadgeMessage{..} + +parseRewardMessage :: MessageParser +parseRewardMessage o = do + dat <- o .: "data" + redemption <- dat .: "redemption" + reward <- redemption .: "reward" + user <- redemption .: "user" + rewardId <- reward .: "id" + title <- reward .: "title" + prompt <- reward .: "prompt" + cost <- reward .: "cost" + subOnly <- reward .: "is_sub_only" + image <- reward .: "image" + defaultImage <- reward .: "default_image" + backgroundColor <- reward .: "background_color" + enabled <- reward .: "is_enabled" + paused <- reward .: "is_paused" + inStock <- reward .: "is_in_stock" + autoFulfilled <- reward .: "should_redemptions_skip_request_queue" + + channel :: String <- redemption .: "channel_id" + let channelId = read channel :: Integer + + sTime :: String <- dat .: "timestamp" + rTime :: String <- redemption .: "redeemed_at" + let serverTime = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 sTime + redeemedTime = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 rTime + + promptAnswer <- redemption .:? "user_input" + promptEnabled :: Bool <- reward .: "is_user_input_required" + let userInput = if promptEnabled then promptAnswer else Nothing + + maxObject <- reward .: "max_per_stream" + maxEnabled :: Bool <- maxObject .: "is_enabled" + maxCount <- maxObject .: "max_per_stream" + let maxPerStream = if maxEnabled then Just maxCount else Nothing + + status' <- redemption .: "status" + let status = read status' :: RewardStatus + + return ChannelPointsMessage{..} + +parseWhisperMessage :: MessageParser +parseWhisperMessage o = do + dat <- o .: "data_object" + messageId <- dat .: "message_id" + threadId <- dat .: "thread_id" + messageBody <- dat .: "body" + tags <- dat .: "tags" + emotes <- tags .: "emotes" + userColor <- tags .: "color" + + userId <- dat .: "from_id" + userName <- tags .: "login" + displayName <- tags .: "display_name" + let user = UserInfo userId userName displayName + + recipientData <- dat .: "recipient" + rUserId <- recipientData .: "id" + rUserName <- recipientData .: "username" + rDisplayName <- recipientData .: "display_name" + let recipient = UserInfo rUserId rUserName rDisplayName + + timestamp :: Integer <- dat .: "sent_ts" + let time = Just . Time.posixSecondsToUTCTime $ realToFrac timestamp + + return WhisperMessage{..} + +parseServerResponse :: MessageParser +parseServerResponse o = do + errorString <- o .: "error" + nonce <- o .: "nonce" + if null errorString + then return SuccessMessage{..} + else return ErrorMessage{..} + +instance FromJSON Message where + parseJSON = withObject "Received" $ \o -> do + o .: "type" >>= \(reportedType :: String) -> case reportedType of + "RESPONSE" -> parseServerResponse o + "MESSAGE" -> do + d <- o .: "data" + m <- d .: "message" + m' <- withEmbeddedJSON "Message" parseJSON (JSON.String m) + m' .:? "type" >>= \(message :: Maybe String) -> + case message of + Just "reward-redeemed" -> parseRewardMessage m' + _ -> d .: "topic" >>= \(topic :: String) -> case takeWhile (/= '.') topic of + "channel-bits-badge-unlocks" -> parseBitsBadgeMessage m' + "channel-bits-events-v1" -> parseBitsV1Message m' + "channel-bits-events-v2" -> parseBitsV2Message m' + "channel-subscribe-events-v1" -> parseChannelSubscribeMessage m' + "whispers" -> parseWhisperMessage m' + _ -> mzero + _ -> mzero + +--data ChatModeratorActionsMessage +--data WhispersMessage diff --git a/test/PubSub.hs b/test/PubSub.hs new file mode 100644 --- /dev/null +++ b/test/PubSub.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main ( main ) where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Lazy as BS +import qualified Data.List as List +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Time as Time +import qualified Data.Time.RFC3339 as Time ( parseTimeRFC3339 ) +import qualified Data.Time.Clock.POSIX as Time ( POSIXTime, posixSecondsToUTCTime ) + +import qualified Web.TwitchAPI.PubSub + +import Data.Char ( isDigit, isLetter ) +import Text.Printf ( printf ) + +import Test.QuickCheck +import Test.Hspec + +newtype AlphaString = AlphaString { unwrapAlpha :: String } deriving Show +instance Arbitrary AlphaString where + arbitrary = AlphaString <$> (listOf1 $ elements $ ['a'..'z'] ++ ['A'..'Z']) + +newtype AlphaNumericString = AlphaNumericString { unwrapAlphaNumeric :: String } deriving Show +instance Arbitrary AlphaNumericString where + arbitrary = AlphaNumericString <$> (listOf1 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']) + +newtype NumericString = NumericString { unwrapNumeric :: String } deriving Show +instance Arbitrary NumericString where + arbitrary = NumericString <$> (listOf1 $ elements ['0'..'9']) + +newtype RFC3339 = RFC3339 { unwrapDate :: String } deriving Show +instance Arbitrary RFC3339 where + arbitrary = do + year' :: Integer <- arbitrary + month' :: Integer <- arbitrary + day' :: Integer <- arbitrary + hour' :: Integer <- arbitrary + minute' :: Integer <- arbitrary + second' :: Integer <- arbitrary + fractional' :: Integer <- arbitrary + let year = (year' `mod` 10) + 2010 + month = (month' `mod` 12) + 1 + day = (day' `mod` 28) + 1 + hour = hour' `mod` 24 + minute = minute' `mod` 60 + second = second' `mod` 60 + fractional = fractional' `mod` 1000000000 + dateString :: String = printf "%4d-%02d-%02dT%02d:%02d:%02d%09dZ" year month day hour minute second fractional + return $ RFC3339 dateString + +parseJSON :: JSON.FromJSON a => String -> Either String a +parseJSON x = JSON.eitherDecode $ (BS.fromStrict . T.encodeUtf8 . T.pack) x + +-- Twitch Constants + +anonymousUserID :: Integer +anonymousUserID = 274598607 + +anonymousUserName :: String +anonymousUserName = "ananonymousgifter" + +anonymousUserDisplay :: String +anonymousUserDisplay = "An Anonymous Gifter" + +anonymousUser :: Web.TwitchAPI.PubSub.UserInfo +anonymousUser = Web.TwitchAPI.PubSub.UserInfo anonymousUserID anonymousUserName (Just anonymousUserDisplay) + +-- Server Responses + +successResponseJSON :: String -> String +successResponseJSON n = "{\"type\":\"RESPONSE\",\"error\":\"\",\"nonce\":\"" ++ n ++ "\"}" + +errorResponseJSON :: String -> String -> String +errorResponseJSON n e = "{\"type\":\"RESPONSE\",\"error\":\"" ++ e ++ "\",\"nonce\":\"" ++ n ++ "\"}" + +-- Bits Messages + +bitsV2JSON :: String -> String -> String -> String -> String -> String -> Integer -> Integer -> String -> Maybe (Integer, Integer) -> String +bitsV2JSON u c uid cid time msg bits total mid Nothing = "{\"type\":\"MESSAGE\",\"data\":{\"topic\":\"channel-bits-events-v2.0\",\"message\":\"{\\\"data\\\":{\\\"user_name\\\":\\\"" ++ u ++ "\\\",\\\"channel_name\\\":\\\"" ++ c ++ "\\\",\\\"user_id\\\":\\\"" ++ uid ++ "\\\",\\\"channel_id\\\":\\\"" ++ cid ++ "\\\",\\\"time\\\":\\\"" ++ time ++ "\\\",\\\"chat_message\\\":\\\"" ++ msg ++ "\\\",\\\"bits_used\\\":" ++ (show bits) ++ ",\\\"total_bits_used\\\":" ++ (show total) ++ ",\\\"is_anonymous\\\":false,\\\"context\\\":\\\"cheer\\\",\\\"badge_entitlement\\\":null},\\\"version\\\":\\\"1.0\\\",\\\"message_type\\\":\\\"bits_event\\\",\\\"message_id\\\":\\\"" ++ mid ++ "\\\"}\"}}" +bitsV2JSON u c uid cid time msg bits total mid (Just (nb, pb)) = "{\"type\":\"MESSAGE\",\"data\":{\"topic\":\"channel-bits-events-v2.0\",\"message\":\"{\\\"data\\\":{\\\"user_name\\\":\\\"" ++ u ++ "\\\",\\\"channel_name\\\":\\\"" ++ c ++ "\\\",\\\"user_id\\\":\\\"" ++ uid ++ "\\\",\\\"channel_id\\\":\\\"" ++ cid ++ "\\\",\\\"time\\\":\\\"" ++ time ++ "\\\",\\\"chat_message\\\":\\\"" ++ msg ++ "\\\",\\\"bits_used\\\":" ++ (show bits) ++ ",\\\"total_bits_used\\\":" ++ (show total) ++ ",\\\"is_anonymous\\\":false,\\\"context\\\":\\\"cheer\\\",\\\"badge_entitlement\\\":{\\\"new_version\\\":" ++ (show nb) ++ ", \\\"previous_version\\\":" ++ (show pb) ++ "}},\\\"version\\\":\\\"1.0\\\",\\\"message_type\\\":\\\"bits_event\\\",\\\"message_id\\\":\\\"" ++ mid ++ "\\\"}\"}}" + +-- Subscription Messages +singleMonthAnonymousGiftMessageJSON :: String -> String -> String -> String -> String -> String -> String -> String -> Integer -> String +singleMonthAnonymousGiftMessageJSON channelName cid recipuid recipun recipdisplay time subplan subplanName months = "{\"type\":\"MESSAGE\",\"data\":{\"topic\":\"channel-subscribe-events-v1.0\",\"message\":\"{\\\"benefit_end_month\\\":0,\\\"user_name\\\":\\\"ananonymousgifter\\\",\\\"display_name\\\":\\\"An Anonymous Gifter\\\",\\\"channel_name\\\":\\\"" ++ channelName ++ "\\\",\\\"user_id\\\":\\\"274598607\\\",\\\"channel_id\\\":\\\"" ++ cid ++ "\\\",\\\"recipient_id\\\":\\\"" ++ recipuid ++ "\\\",\\\"recipient_user_name\\\":\\\"" ++ recipun ++ "\\\",\\\"recipient_display_name\\\":\\\"" ++ recipdisplay ++ "\\\",\\\"time\\\":\\\"" ++ time ++ "\\\",\\\"sub_message\\\":{\\\"message\\\":\\\"\\\",\\\"emotes\\\":null},\\\"sub_plan\\\":\\\"" ++ subplan ++ "\\\",\\\"sub_plan_name\\\":\\\"" ++ subplanName ++ "\\\",\\\"months\\\":" ++ (show months) ++ ",\\\"context\\\":\\\"subgift\\\",\\\"is_gift\\\":true,\\\"multi_month_duration\\\":1}\"}}\r\n" + +singleMonthGiftMessageJSON :: String -> String -> String -> String -> String -> String -> String -> String -> String -> String -> String -> Integer -> String +singleMonthGiftMessageJSON channelName cid senderuid senderun senderdisplay recipuid recipun recipdisplay time subplan subplanName months = "{\"type\":\"MESSAGE\",\"data\":{\"topic\":\"channel-subscribe-events-v1.0\",\"message\":\"{\\\"benefit_end_month\\\":0,\\\"user_name\\\":\\\"" ++ senderun ++ "\\\",\\\"display_name\\\":\\\"" ++ senderdisplay ++ "\\\",\\\"channel_name\\\":\\\"" ++ channelName ++ "\\\",\\\"user_id\\\":\\\"" ++ senderuid ++ "\\\",\\\"channel_id\\\":\\\"" ++ cid ++ "\\\",\\\"recipient_id\\\":\\\"" ++ recipuid ++ "\\\",\\\"recipient_user_name\\\":\\\"" ++ recipun ++ "\\\",\\\"recipient_display_name\\\":\\\"" ++ recipdisplay ++ "\\\",\\\"time\\\":\\\"" ++ time ++ "\\\",\\\"sub_message\\\":{\\\"message\\\":\\\"\\\",\\\"emotes\\\":null},\\\"sub_plan\\\":\\\"" ++ subplan ++ "\\\",\\\"sub_plan_name\\\":\\\"" ++ subplanName ++ "\\\",\\\"months\\\":" ++ (show months) ++ ",\\\"context\\\":\\\"subgift\\\",\\\"is_gift\\\":true,\\\"multi_month_duration\\\":1}\"}}\r\n" + +singleMonthResubMessageWithEmotesJSON :: String -> String -> String -> String -> String -> String -> String -> String -> Integer -> String +singleMonthResubMessageWithEmotesJSON subun subdisplay channelName subuid cid time subplan subplanName cumulativeMonths = "{\"type\":\"MESSAGE\",\"data\":{\"topic\":\"channel-subscribe-events-v1.0\",\"message\":\"{\\\"benefit_end_month\\\":0,\\\"user_name\\\":\\\"" ++ subun ++ "\\\",\\\"display_name\\\":\\\"" ++ subdisplay ++ "\\\",\\\"channel_name\\\":\\\"" ++ channelName ++ "\\\",\\\"user_id\\\":\\\"" ++ subuid ++ "\\\",\\\"channel_id\\\":\\\"" ++ cid ++ "\\\",\\\"time\\\":\\\"" ++ time ++ "\\\",\\\"sub_message\\\":{\\\"message\\\":\\\"thaxHi\\\",\\\"emotes\\\":[{\\\"start\\\":0,\\\"end\\\":5,\\\"id\\\":\\\"846333\\\"}]},\\\"sub_plan\\\":\\\"" ++ subplan ++ "\\\",\\\"sub_plan_name\\\":\\\"" ++ subplanName ++ "\\\",\\\"months\\\":0,\\\"cumulative_months\\\":" ++ (show cumulativeMonths) ++ ",\\\"context\\\":\\\"resub\\\",\\\"is_gift\\\":false,\\\"multi_month_duration\\\":0}\"}}\r\n" + +-- Whisper Messages +whisperJSON :: String -> Integer -> String -> Integer -> Integer -> String -> String -> String -> [(Integer, Integer, Integer)] -> Integer -> String -> String -> String -> String +whisperJSON mid serial msg epoch senderuid senderun senderdisplay sendercolor emote3s recipuid recipun recipdisplay nonce = + let emotes = "[" ++ (List.intercalate "," $ fmap (\(start, end, emoteId) -> "{\\\"emote_id\\\":\\\"" ++ (show emoteId) ++ "\\\",\\\"start\\\":" ++ (show start) ++ ",\\\"end\\\":" ++ (show end) ++ "}") emote3s) ++ "]" + emotes' = "[" ++ (List.intercalate "," $ fmap (\(start, end, emoteId) -> "{\\\\\\\"emote_id\\\\\\\":\\\\\\\"" ++ (show emoteId) ++ "\\\\\\\",\\\\\\\"start\\\\\\\":" ++ (show start) ++ ",\\\\\\\"end\\\\\\\":" ++ (show end) ++ "}") emote3s) ++ "]" + in "{\"type\":\"MESSAGE\",\"data\":{\"topic\":\"whispers.0\",\"message\":\"{\\\"type\\\":\\\"whisper_received\\\",\\\"data\\\":\\\"{\\\\\\\"message_id\\\\\\\":\\\\\\\"" ++ mid ++ "\\\\\\\",\\\\\\\"id\\\\\\\":" ++ (show serial) ++ ",\\\\\\\"thread_id\\\\\\\":\\\\\\\"" ++ ((show senderuid) ++ "_" ++ (show recipuid)) ++ "\\\\\\\",\\\\\\\"body\\\\\\\":\\\\\\\"" ++ msg ++ "\\\\\\\",\\\\\\\"sent_ts\\\\\\\":" ++ (show epoch) ++ ",\\\\\\\"from_id\\\\\\\":" ++ (show senderuid) ++ ",\\\\\\\"tags\\\\\\\":{\\\\\\\"login\\\\\\\":\\\\\\\"" ++ senderun ++ "\\\\\\\",\\\\\\\"display_name\\\\\\\":\\\\\\\"" ++ senderdisplay ++ "\\\\\\\",\\\\\\\"color\\\\\\\":\\\\\\\"#" ++ sendercolor ++ "\\\\\\\",\\\\\\\"emotes\\\\\\\":" ++ emotes' ++ ",\\\\\\\"badges\\\\\\\":[{\\\\\\\"id\\\\\\\":\\\\\\\"notimplementedyetimsorry\\\\\\\",\\\\\\\"version\\\\\\\":\\\\\\\"1\\\\\\\"}]},\\\\\\\"recipient\\\\\\\":{\\\\\\\"id\\\\\\\":" ++ (show recipuid) ++ ",\\\\\\\"username\\\\\\\":\\\\\\\"" ++ recipun ++ "\\\\\\\",\\\\\\\"display_name\\\\\\\":\\\\\\\"" ++ recipdisplay ++ "\\\\\\\",\\\\\\\"color\\\\\\\":\\\\\\\"\\\\\\\"},\\\\\\\"nonce\\\\\\\":\\\\\\\"" ++ nonce ++ "\\\\\\\"}\\\",\\\"data_object\\\":{\\\"message_id\\\":\\\"" ++ mid ++ "\\\",\\\"id\\\":" ++ (show serial) ++ ",\\\"thread_id\\\":\\\"" ++ ((show senderuid) ++ "_" ++ (show recipuid)) ++ "\\\",\\\"body\\\":\\\"" ++ msg ++ "\\\",\\\"sent_ts\\\":" ++ (show epoch) ++ ",\\\"from_id\\\":" ++ (show senderuid) ++ ",\\\"tags\\\":{\\\"login\\\":\\\"" ++ senderun ++ "\\\",\\\"display_name\\\":\\\"" ++ senderdisplay ++ "\\\",\\\"color\\\":\\\"#" ++ sendercolor ++ "\\\",\\\"emotes\\\":" ++ emotes ++ ",\\\"badges\\\":[{\\\"id\\\":\\\"notimplementedyetimsorry\\\",\\\"version\\\":\\\"1\\\"}]},\\\"recipient\\\":{\\\"id\\\":" ++ (show recipuid) ++ ",\\\"username\\\":\\\"" ++ recipun ++ "\\\",\\\"display_name\\\":\\\"" ++ recipdisplay ++ "\\\",\\\"color\\\":\\\"\\\"},\\\"nonce\\\":\\\"" ++ nonce ++ "\\\"}}\"}}" + +main :: IO () +main = hspec $ describe "PubSub interactions" $ do + it "Creates SuccessResponses" $ property prop_successResponse + it "Creates ErrorResponses" $ property prop_errorResponse + it "Parses Bits (v2) Messages" $ property prop_errorResponse + it "Parses Gift Single-Month Resubscription Messages with Emotes" $ property prop_singleMonthResubMessageWithEmote + it "Parses Gift Single-Month Subscription Messages" $ property prop_singleMonthGiftMessage + it "Parses Anonymous Gift Single-Month Subscription Messages" $ property prop_singleMonthAnonymousGiftMessage + it "Parses Whisper Messages" $ property prop_whisperMessage + +prop_successResponse :: AlphaNumericString -> Bool +prop_successResponse n = + let nonce = unwrapAlphaNumeric n + json = successResponseJSON nonce + response = Right $ Web.TwitchAPI.PubSub.SuccessMessage (Just nonce) + parsed = parseJSON json :: Either String Web.TwitchAPI.PubSub.Message + in response == parsed + +prop_errorResponse :: AlphaNumericString -> AlphaString -> Bool +prop_errorResponse n e = + let nonce = unwrapAlphaNumeric n + err = unwrapAlpha e + json = errorResponseJSON nonce err + response = Right $ Web.TwitchAPI.PubSub.ErrorMessage (Just nonce) err + parsed = parseJSON json :: Either String Web.TwitchAPI.PubSub.Message + in response == parsed + +prop_bitsV2Message :: AlphaNumericString -> AlphaNumericString -> NumericString -> NumericString -> RFC3339 -> AlphaNumericString -> Integer -> Integer -> AlphaNumericString -> Maybe (Integer, Integer) -> Bool +prop_bitsV2Message un' cn' uid' cid' time' msg' bits total mid' unlock' = + let un = unwrapAlphaNumeric un' + cn = unwrapAlphaNumeric cn' + uid = unwrapNumeric uid' + cid = unwrapNumeric cid' + time = unwrapDate time' + utcTime = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 time + msg = unwrapAlphaNumeric msg' + mid = unwrapAlphaNumeric mid' + context = "cheer" + messageType = "bits_event" + version = "1.0" + unlock = fmap (\(n,p) -> Web.TwitchAPI.PubSub.BadgeUnlock n p) unlock' + json = bitsV2JSON un cn uid cid time msg bits total mid unlock' + response = Right $ Web.TwitchAPI.PubSub.BitsV2Message unlock bits (read cid :: Integer) (Just msg) context mid messageType utcTime total (Just (read uid :: Integer)) (Just un) version + parsed = parseJSON json :: Either String Web.TwitchAPI.PubSub.Message + in response == parsed + +prop_singleMonthGiftMessage :: NumericString -> AlphaNumericString -> AlphaNumericString -> AlphaNumericString -> NumericString -> NumericString -> AlphaNumericString -> AlphaNumericString -> RFC3339 -> Integer -> AlphaNumericString -> Integer -> Bool +prop_singleMonthGiftMessage senderuid' senderun' senderdisplay' channelName' cid' recipuid' recipun' recipdisplay' time' subplan' subplanName' months' = + let channelName = unwrapAlphaNumeric channelName' + cid = unwrapNumeric cid' + senderuid = unwrapNumeric senderuid' + senderun = unwrapAlphaNumeric senderun' + senderdisplay = unwrapAlphaNumeric senderdisplay' + recipuid = unwrapNumeric recipuid' + recipun = unwrapAlphaNumeric recipun' + recipdisplay = unwrapAlphaNumeric recipdisplay' + time = unwrapDate time' + utcTime = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 time + subplan = show $ 1000 * (((abs subplan') `mod` 3) + 1) + subplanName = unwrapAlphaNumeric subplanName' + subTier = case (((abs subplan') `mod` 3) + 1) of + 1 -> Web.TwitchAPI.PubSub.Tier1 + 2 -> Web.TwitchAPI.PubSub.Tier2 + 3 -> Web.TwitchAPI.PubSub.Tier3 + months = ((abs months') + 1) + recipInfo = Web.TwitchAPI.PubSub.UserInfo (read recipuid :: Integer) recipun (Just recipdisplay) + senderInfo = Web.TwitchAPI.PubSub.UserInfo (read senderuid :: Integer) senderun (Just senderdisplay) + json = singleMonthGiftMessageJSON channelName cid senderuid senderun senderdisplay recipuid recipun recipdisplay time subplan subplanName months + response = Right $ Web.TwitchAPI.PubSub.ChannelSubscriptionGiftMessage senderInfo channelName (read cid :: Integer) utcTime subTier subplanName recipInfo + parsed = parseJSON json :: Either String Web.TwitchAPI.PubSub.Message + in response == parsed + +prop_singleMonthAnonymousGiftMessage :: AlphaNumericString -> NumericString -> NumericString -> AlphaNumericString -> AlphaNumericString -> RFC3339 -> Integer -> AlphaNumericString -> Integer -> Bool +prop_singleMonthAnonymousGiftMessage = + prop_singleMonthGiftMessage (NumericString $ show anonymousUserID) (AlphaNumericString anonymousUserName) (AlphaNumericString anonymousUserDisplay) + +prop_singleMonthResubMessageWithEmote :: NumericString -> AlphaNumericString -> AlphaNumericString -> AlphaNumericString -> NumericString -> RFC3339 -> Integer -> AlphaNumericString -> Integer -> Bool +prop_singleMonthResubMessageWithEmote subuid' subun' subdisplay' channelName' cid' time' subplan' subplanName' cumulativeMonths' = + let channelName = unwrapAlphaNumeric channelName' + cid = unwrapNumeric cid' + subuid = unwrapNumeric subuid' + subun = unwrapAlphaNumeric subun' + subdisplay = unwrapAlphaNumeric subdisplay' + time = unwrapDate time' + utcTime = Time.zonedTimeToUTC <$> Time.parseTimeRFC3339 time + subplan = show $ 1000 * (((abs subplan') `mod` 3) + 1) + subplanName = unwrapAlphaNumeric subplanName' + subTier = case (((abs subplan') `mod` 3) + 1) of + 1 -> Web.TwitchAPI.PubSub.Tier1 + 2 -> Web.TwitchAPI.PubSub.Tier2 + 3 -> Web.TwitchAPI.PubSub.Tier3 + cumulativeMonths = ((abs cumulativeMonths') + 1) + streakMonths = Nothing -- hardcoded in JSON + subInfo = Web.TwitchAPI.PubSub.UserInfo (read subuid :: Integer) subun (Just subdisplay) + subMessage = Web.TwitchAPI.PubSub.SubscriptionMessage "thaxHi" [ Web.TwitchAPI.PubSub.EmoteSpec 0 6 846333 ] + json = singleMonthResubMessageWithEmotesJSON subun subdisplay channelName subuid cid time subplan subplanName cumulativeMonths + response = Right $ Web.TwitchAPI.PubSub.ChannelResubscriptionMessage subInfo channelName (read cid :: Integer) utcTime subTier subplanName cumulativeMonths streakMonths subMessage + parsed = parseJSON json :: Either String Web.TwitchAPI.PubSub.Message + in response == parsed + +prop_whisperMessage :: AlphaNumericString -> Integer -> AlphaNumericString -> Integer -> Integer -> AlphaNumericString -> AlphaNumericString -> AlphaNumericString -> [(Integer, Integer, Integer)] -> Integer -> AlphaNumericString -> AlphaNumericString -> NumericString -> Bool +prop_whisperMessage mid' serial msg' epoch' senderuid senderun' senderdisplay' sendercolor' emote3s recipuid recipun' recipdisplay' nonce' = + let mid = unwrapAlphaNumeric mid' + msg = unwrapAlphaNumeric msg' + epoch = abs epoch' + senderun = unwrapAlphaNumeric senderun' + senderdisplay = unwrapAlphaNumeric senderdisplay' + sendercolor = unwrapAlphaNumeric sendercolor' + recipun = unwrapAlphaNumeric recipun' + recipdisplay = unwrapAlphaNumeric recipdisplay' + nonce = unwrapNumeric nonce' + threadId = ((show senderuid) ++ "_" ++ (show recipuid)) + time = Just . Time.posixSecondsToUTCTime $ realToFrac $ epoch + emotes = fmap (\(s, e, i) -> Web.TwitchAPI.PubSub.EmoteSpec s (1 + e - s) i) emote3s + senderInfo = Web.TwitchAPI.PubSub.UserInfo senderuid senderun (Just senderdisplay) + recipInfo = Web.TwitchAPI.PubSub.UserInfo recipuid recipun (Just recipdisplay) + json = whisperJSON mid serial msg epoch senderuid senderun senderdisplay sendercolor emote3s recipuid recipun recipdisplay nonce + response = Right $ Web.TwitchAPI.PubSub.WhisperMessage mid threadId time msg emotes senderInfo ("#" ++ sendercolor) recipInfo + parsed = parseJSON json :: Either String Web.TwitchAPI.PubSub.Message + in response == parsed diff --git a/twitchapi.cabal b/twitchapi.cabal new file mode 100644 --- /dev/null +++ b/twitchapi.cabal @@ -0,0 +1,56 @@ +name: twitchapi +version: 0.0.1 +synopsis: Client access to Twitch.tv API endpoints +description: Twitch.tv API client supporting Helix and PubSub +homepage: https://github.com/wuest/haskell-twitchapi +bug-reports: https://github.com/wuest/haskell-twitchapi/issues +license: BSD3 +license-file: LICENSE +author: Tina Wuest +maintainer: tina@wuest.me +copyright: 2021-2022 Tina Wuest +category: Web +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/wuest/haskell-twitchapi.git + +library + ghc-options: -Wall -fwarn-implicit-prelude -fwarn-monomorphism-restriction -O2 -static + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: Web.TwitchAPI.Helix.Bits + , Web.TwitchAPI.Helix.ChannelPoints + , Web.TwitchAPI.Helix.Request + , Web.TwitchAPI.PubSub + + build-depends: base >= 4.11 && < 4.18 + , aeson >= 2.1 && < 2.2 + , bytestring >= 0.10 && < 0.12 + , hoauth2 >= 1.16 && < 2.6 + , http-client >= 0.5 && < 0.8 + , text >= 1.2 && < 2.1 + , time >= 1.6 && < 1.14 + , timerep >= 2.0 && < 2.2 + , uri-bytestring >= 0.3 && < 0.4 + +test-suite pubsub + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + , src + main-is: PubSub.hs + other-modules: Web.TwitchAPI.PubSub + build-depends: base >= 4.11 && < 4.18 + , QuickCheck >= 2.8 + , hspec >= 2.7 + , aeson >= 2.1 && < 2.2 + , bytestring >= 0.10 && < 0.12 + , text >= 1.2 && < 2.1 + , time >= 1.6 && < 1.14 + , timerep >= 2.0 && < 2.2