diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,22 @@ +50200.6.0 +========= + +API changes: + * Version 4 API functions now all have the potential to raise a new + exception type, `RateLimitExceptions`, when HTTP 429 (rate limiting) + responses are received. The new exception type provides rate limit + metadata received from the server so the caller can determine whether + to attempt a request again, and how long to wait before attempting + it. + * The `ChannelNotifyProps` type got a new + `channelNotifyPropsIgnoreChannelMentions` field. + * The `WEData` type got a `wepChannelMember` field. + +Other changes: + * `channel_member_updated` websocket events are now parsed. + * Some haddock syntax errors were fixed (thanks Eric Mertens) + 50200.5.0 ========= diff --git a/examples/MakePost.hs b/examples/MakePost.hs --- a/examples/MakePost.hs +++ b/examples/MakePost.hs @@ -57,7 +57,7 @@ (ReqArg (\arg opt -> return opt { optMessage = T.pack arg }) "MESSAGE") - "message to send" + "message to send (reads stdin if not specified)" , Option "h" ["help"] (NoArg (\_ -> do @@ -102,15 +102,17 @@ when (optVerbose opts) $ do pPrint chan when (channelName chan == optChannel opts) $ do - when (not (T.null (optMessage opts))) $ do - let pendingPost = RawPost + theMsg <- if T.null (optMessage opts) + then T.pack <$> getContents + else return $ optMessage opts + let pendingPost = RawPost { rawPostChannelId = getId chan - , rawPostMessage = optMessage opts + , rawPostMessage = theMsg , rawPostFileIds = mempty , rawPostRootId = Nothing } - -- pendingPost <- mkPendingPost (optMessage opts) - -- (getId mmUser) - -- (getId chan) - post <- mmCreatePost pendingPost session - when (optVerbose opts) (pPrint post) + -- pendingPost <- mkPendingPost (optMessage opts) + -- (getId mmUser) + -- (getId chan) + post <- mmCreatePost pendingPost session + when (optVerbose opts) (pPrint post) diff --git a/mattermost-api.cabal b/mattermost-api.cabal --- a/mattermost-api.cabal +++ b/mattermost-api.cabal @@ -1,5 +1,5 @@ name: mattermost-api -version: 50200.5.0 +version: 50200.6.0 synopsis: Client API for Mattermost chat system description: Client API for Mattermost chat system. Mattermost is a diff --git a/src/Network/Mattermost/Connection.hs b/src/Network/Mattermost/Connection.hs --- a/src/Network/Mattermost/Connection.hs +++ b/src/Network/Mattermost/Connection.hs @@ -5,7 +5,7 @@ import Control.Arrow (left) import Control.Exception (throwIO, IOException, try, throwIO) import Control.Monad (when) -import Data.Maybe (isJust) +import Data.Maybe (isJust, listToMaybe) import Data.Monoid ((<>)) import Data.Pool (destroyAllResources) import qualified Data.Aeson as A @@ -20,6 +20,7 @@ import qualified Network.HTTP.Media as HTTPM import qualified Network.URI as URI import System.IO.Error (isEOFError) +import Text.Read ( readMaybe ) import Network.Mattermost.Exceptions import Network.Mattermost.Types @@ -95,6 +96,18 @@ -> IO HTTP.Response_String doUnauthRequest cd = submitRequest cd Nothing +-- | Submit an HTTP request. +-- +-- If the request fails due to a 429 (rate-limited) response, this +-- raises 'RateLimitException' with the fields populated from the +-- response headers where possible. +-- +-- If the response status is 2XX, the response is returned. +-- +-- If the response status is anything else, its body is assumed to be +-- a JSON encoding of a Mattermost server error. If it can be decoded +-- as such, a 'MattermostError' exception is raised. Otherwise an +-- 'HTTPResponseException' is raised. submitRequest :: ConnectionData -> Maybe Token -> HTTP.RequestMethod @@ -151,6 +164,14 @@ rsp <- hoistE (left ConnectionException rawResponse) case HTTP.rspCode rsp of + (4, 2, 9) -> do + -- Extract rate limit information if possible + let headers = HTTP.getHeaders rsp + mLimit = readMaybe =<< findHeader rateLimitLimitHeader headers + mRemaining = readMaybe =<< findHeader rateLimitRemainingHeader headers + mReset = readMaybe =<< findHeader rateLimitResetHeader headers + + throwIO $ RateLimitException mLimit mRemaining mReset (2, _, _) -> return rsp code -> do case A.eitherDecode (BL.pack (HTTP.rspBody rsp)) of @@ -158,6 +179,27 @@ throwIO (err :: MattermostError) Left _ -> throwIO (HTTPResponseException ("Server returned unexpected " ++ show code ++ " response")) + +-- NOTE: At least as of HTTP-4000.3.14, custom header names are matched +-- case-sensitively when looking them up in responses. This is a bug +-- (reported at https://github.com/haskell/HTTP/issues/128) and in +-- the mean time we use our own header-matching implementation. +findHeader :: HTTP.HeaderName -> [HTTP.Header] -> Maybe String +findHeader n hs = HTTP.hdrValue <$> listToMaybe (filter (matchHeader n) hs) + +matchHeader :: HTTP.HeaderName -> HTTP.Header -> Bool +matchHeader (HTTP.HdrCustom a) (HTTP.Header (HTTP.HdrCustom b) _) = + (toLower <$> a) == (toLower <$> b) +matchHeader a (HTTP.Header b _) = a == b + +rateLimitLimitHeader :: HTTP.HeaderName +rateLimitLimitHeader = HTTP.HdrCustom "X-RateLimit-Limit" + +rateLimitRemainingHeader :: HTTP.HeaderName +rateLimitRemainingHeader = HTTP.HdrCustom "X-RateLimit-Remaining" + +rateLimitResetHeader :: HTTP.HeaderName +rateLimitResetHeader = HTTP.HdrCustom "X-RateLimit-Reset" isConnectionError :: IOException -> Bool isConnectionError e = diff --git a/src/Network/Mattermost/Exceptions.hs b/src/Network/Mattermost/Exceptions.hs --- a/src/Network/Mattermost/Exceptions.hs +++ b/src/Network/Mattermost/Exceptions.hs @@ -12,6 +12,7 @@ , MattermostError(..) , ConnectionException(..) , MattermostServerError(..) +, RateLimitException(..) ) where import qualified Data.Aeson as A @@ -84,6 +85,23 @@ deriving (Show, Typeable) instance Exception MattermostServerError + +-- | An exception raised when a request could not be completed due to a +-- request rate limit violation. +data RateLimitException = + RateLimitException { rateLimitExceptionLimit :: Maybe Int + -- ^ The total number of requests allowed in the + -- current rate limit window. + , rateLimitExceptionRemaining :: Maybe Int + -- ^ The number of requests remaining in the + -- current rate limit window. + , rateLimitExceptionReset :: Maybe Int + -- ^ The number of seconds until the rate limit + -- window resets. + } + deriving (Show, Typeable) + +instance Exception RateLimitException -- diff --git a/src/Network/Mattermost/Types.hs b/src/Network/Mattermost/Types.hs --- a/src/Network/Mattermost/Types.hs +++ b/src/Network/Mattermost/Types.hs @@ -315,10 +315,11 @@ } deriving (Eq, Show, Read, Ord) data ChannelNotifyProps = ChannelNotifyProps - { channelNotifyPropsEmail :: WithDefault Bool - , channelNotifyPropsDesktop :: WithDefault NotifyOption - , channelNotifyPropsPush :: WithDefault NotifyOption - , channelNotifyPropsMarkUnread :: WithDefault NotifyOption + { channelNotifyPropsEmail :: WithDefault Bool + , channelNotifyPropsDesktop :: WithDefault NotifyOption + , channelNotifyPropsPush :: WithDefault NotifyOption + , channelNotifyPropsMarkUnread :: WithDefault NotifyOption + , channelNotifyPropsIgnoreChannelMentions :: WithDefault Bool } deriving (Eq, Show, Read, Ord) emptyUserNotifyProps :: UserNotifyProps @@ -334,10 +335,11 @@ emptyChannelNotifyProps :: ChannelNotifyProps emptyChannelNotifyProps = ChannelNotifyProps - { channelNotifyPropsEmail = Default - , channelNotifyPropsPush = Default - , channelNotifyPropsDesktop = Default - , channelNotifyPropsMarkUnread = Default + { channelNotifyPropsEmail = Default + , channelNotifyPropsPush = Default + , channelNotifyPropsDesktop = Default + , channelNotifyPropsMarkUnread = Default + , channelNotifyPropsIgnoreChannelMentions = Default } newtype BoolString = BoolString { fromBoolString :: Bool } @@ -353,6 +355,19 @@ toJSON (BoolString True) = A.String "true" toJSON (BoolString False) = A.String "false" +newtype OnOffString = OnOffString{ fromOnOffString :: Bool } + +instance A.FromJSON OnOffString where + parseJSON = A.withText "on/off setting" $ \v -> + case v of + "on" -> return (OnOffString True) + "off" -> return (OnOffString False) + _ -> fail "Expected \"on\" or \"off\"" + +instance A.ToJSON OnOffString where + toJSON (OnOffString True) = A.String "on" + toJSON (OnOffString False) = A.String "off" + instance A.FromJSON UserNotifyProps where parseJSON = A.withObject "UserNotifyProps" $ \v -> do userNotifyPropsMentionKeys <- (fmap UserText) <$> T.split (==',') <$> @@ -383,14 +398,17 @@ channelNotifyPropsPush <- v .:? "push" .!= IsValue NotifyOptionMention channelNotifyPropsDesktop <- v .:? "desktop" .!= IsValue NotifyOptionAll channelNotifyPropsMarkUnread <- v .:? "mark_unread" .!= IsValue NotifyOptionAll + channelNotifyPropsIgnoreChannelMentions <- fmap fromOnOffString <$> + (v .:? "ignore_channel_mentions" .!= Default) return ChannelNotifyProps { .. } instance A.ToJSON ChannelNotifyProps where toJSON ChannelNotifyProps { .. } = A.object - [ "email" .= fmap BoolString channelNotifyPropsEmail - , "push" .= channelNotifyPropsPush - , "desktop" .= channelNotifyPropsDesktop - , "mark_unread" .= channelNotifyPropsMarkUnread + [ "email" .= fmap BoolString channelNotifyPropsEmail + , "push" .= channelNotifyPropsPush + , "desktop" .= channelNotifyPropsDesktop + , "mark_unread" .= channelNotifyPropsMarkUnread + , "ignore_channel_mentions" .= channelNotifyPropsIgnoreChannelMentions ] -- diff --git a/src/Network/Mattermost/WebSocket/Types.hs b/src/Network/Mattermost/WebSocket/Types.hs --- a/src/Network/Mattermost/WebSocket/Types.hs +++ b/src/Network/Mattermost/WebSocket/Types.hs @@ -70,6 +70,7 @@ | WMReactionRemoved | WMChannelViewed | WMChannelUpdated + | WMChannelMemberUpdated | WMEmojiAdded | WMUserRoleUpdated | WMPluginStatusesChanged @@ -106,6 +107,7 @@ "preferences_deleted" -> return WMPreferenceDeleted "channel_viewed" -> return WMChannelViewed "channel_updated" -> return WMChannelUpdated + "channel_member_updated" -> return WMChannelMemberUpdated "emoji_added" -> return WMEmojiAdded "user_role_updated" -> return WMUserRoleUpdated "plugin_statuses_changed" -> return WMPluginStatusesChanged @@ -141,6 +143,7 @@ toJSON WMAuthenticationChallenge = "authentication_challenge" toJSON WMChannelViewed = "channel_viewed" toJSON WMChannelUpdated = "channel_updated" + toJSON WMChannelMemberUpdated = "channel_member_updated" toJSON WMEmojiAdded = "emoji_added" toJSON WMUserRoleUpdated = "user_role_updated" toJSON WMPluginStatusesChanged = "plugin_statuses_changed" @@ -205,6 +208,7 @@ , wepReaction :: Maybe Reaction , wepMentions :: Maybe (Set UserId) , wepPreferences :: Maybe (Seq Preference) + , wepChannelMember :: Maybe ChannelMember } deriving (Read, Show, Eq) instance FromJSON WEData where @@ -215,23 +219,12 @@ wepUserId <- o .:? "user_id" wepUser <- o .:? "user" wepChannelDisplayName <- o .:? "channel_name" - wepPostRaw <- o .:? "post" - wepPost <- case wepPostRaw of - Just str -> fromValueString str - Nothing -> return Nothing - wepStatus <- o .:? "status" - wepReactionRaw <- o .:? "reaction" - wepReaction <- case wepReactionRaw of - Just str -> fromValueString str - Nothing -> return Nothing - wepMentionsRaw <- o .:? "mentions" - wepMentions <- case wepMentionsRaw of - Just str -> fromValueString str - Nothing -> return Nothing - wepPreferencesRaw <- o .:? "preferences" - wepPreferences <- case wepPreferencesRaw of - Just str -> fromValueString str - Nothing -> return Nothing + wepPost <- mapM fromValueString =<< o .:? "post" + wepStatus <- o .:? "status" + wepReaction <- mapM fromValueString =<< o .:? "reaction" + wepMentions <- mapM fromValueString =<< o .:? "mentions" + wepPreferences <- mapM fromValueString =<< o .:? "preferences" + wepChannelMember <- mapM fromValueString =<< o .:? "channelMember" return WEData { .. } instance ToJSON WEData where @@ -245,6 +238,7 @@ , "reaction" .= wepReaction , "mentions" .= toValueString wepMentions , "preferences" .= toValueString wepPreferences + , "channelMember" .= toValueString wepChannelMember ] --