twitchapi (empty) → 0.0.1
raw patch · 9 files changed
+1296/−0 lines, 9 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, bytestring, hoauth2, hspec, http-client, text, time, timerep, uri-bytestring
Files
- CHANGELOG.md +10/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Web/TwitchAPI/Helix/Bits.hs +167/−0
- src/Web/TwitchAPI/Helix/ChannelPoints.hs +131/−0
- src/Web/TwitchAPI/Helix/Request.hs +11/−0
- src/Web/TwitchAPI/PubSub.hs +668/−0
- test/PubSub.hs +221/−0
- twitchapi.cabal +56/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Web/TwitchAPI/Helix/Bits.hs view
@@ -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{..}
+ src/Web/TwitchAPI/Helix/ChannelPoints.hs view
@@ -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{..}
+ src/Web/TwitchAPI/Helix/Request.hs view
@@ -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
+ src/Web/TwitchAPI/PubSub.hs view
@@ -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
+ test/PubSub.hs view
@@ -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
+ twitchapi.cabal view
@@ -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