diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,23 @@ +50200.11.0 +========== + +API changes: (Thanks Ajay Eeralla) + * Added a new constructor `PreferenceCategoryFavoriteChannel` to the + `PreferenceCategory` type and updated its JSON parser to recognize + this category. + * Added a `FavoriteChannelPreference` type and + `preferenceToFavoriteChannelPreference` smart constructor. + +Other changes: + * Logging now uses `show`, not `toJSON`, for values to be logged. + This changes the logging functionality to use simple Show instances + instead of first converting internal data types back to AESON + structures. That wasn't really providing any additional value, and + the extra conversion was producing at least one inconsistency due + to an unfinished ToJSON implementation. (Thanks to Karl Smeltzer + (@karljs)) + 50200.10.0 ========== 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.10.0 +version: 50200.11.0 synopsis: Client API for Mattermost chat system description: Client API for Mattermost chat system. Mattermost is a diff --git a/src/Network/Mattermost.hs b/src/Network/Mattermost.hs --- a/src/Network/Mattermost.hs +++ b/src/Network/Mattermost.hs @@ -219,7 +219,7 @@ let rawPath = "/api/v3/users/login" path <- mmPath rawPath runLogger cd "mmLogin" $ - HttpRequest GET rawPath (Just (toJSON $ login { password = "" })) + HttpRequest GET rawPath (Just (show $ login { password = "" })) rsp <- mmUnauthenticatedHTTPPost cd path login if (rspCode rsp /= (2,0,0)) then do @@ -229,7 +229,7 @@ token <- mmGetHeader rsp (HdrCustom "Token") (raw, value) <- mmGetJSONBody "User" rsp runLogger cd "mmLogin" $ - HttpResponse 200 rawPath (Just raw) + HttpResponse 200 rawPath (Just $ show raw) return (Right (Session cd (Token token), value)) showRespCode :: (Int, Int, Int) -> String @@ -257,11 +257,11 @@ let path = "/api/v3/teams/create" uri <- mmPath path runLoggerS sess "mmCreateTeam" $ - HttpRequest POST path (Just (toJSON payload)) + HttpRequest POST path (Just $ show payload) rsp <- mmPOST sess uri payload (val, r) <- mmGetJSONBody "Team" rsp runLoggerS sess "mmCreateTeam" $ - HttpResponse 200 path (Just val) + HttpResponse 200 path (Just $ show val) return r -- | Requires an authenticated user. Returns the full list of channels @@ -346,7 +346,7 @@ payload = HM.fromList $ [("channel_id" :: T.Text, chanid)] ++ prev uri <- mmPath path runLoggerS sess "mmViewChannel" $ - HttpRequest POST path (Just (toJSON payload)) + HttpRequest POST path (Just $ show payload) _ <- mmPOST sess uri payload runLoggerS sess "mmViewChannel" $ HttpResponse 200 path Nothing @@ -368,7 +368,7 @@ rsp <- mmPOST sess uri (""::T.Text) (val, (_::Channel)) <- mmGetJSONBody "Channel" rsp runLoggerS sess "mmJoinChannel" $ - HttpResponse 200 path (Just val) + HttpResponse 200 path (Just $ show val) return () -- | @@ -384,11 +384,11 @@ payload = HM.fromList [("id" :: T.Text, chanid)] uri <- mmPath path runLoggerS sess "mmLeaveChannel" $ - HttpRequest POST path (Just (toJSON payload)) + HttpRequest POST path (Just $ show payload) rsp <- mmPOST sess uri payload (val, (_::HM.HashMap T.Text ChannelId)) <- mmGetJSONBody "Channel name/ID map" rsp runLoggerS sess "mmCreateDirect" $ - HttpResponse 200 path (Just val) + HttpResponse 200 path (Just $ show val) return () -- | @@ -437,7 +437,7 @@ rsp <- mmRequest sess uri (raw, json) <- mmGetJSONBody "Posts" rsp runLoggerS sess "mmGetPost" $ - HttpResponse 200 path (Just raw) + HttpResponse 200 path (Just $ show raw) return json -- | @@ -488,11 +488,11 @@ uri <- mmPath path let req = SearchPosts terms isOrSearch runLoggerS sess "mmSearchPosts" $ - HttpRequest POST path (Just (toJSON req)) + HttpRequest POST path (Just $ show req) rsp <- mmPOST sess uri req (raw, value) <- mmGetJSONBody "SearchPostsResult" rsp runLoggerS sess "mmSearchPosts" $ - HttpResponse 200 path (Just raw) + HttpResponse 200 path (Just $ show raw) return value -- | @@ -591,11 +591,11 @@ payload = HM.fromList [("user_id" :: T.Text, userid)] uri <- mmPath path runLoggerS sess "mmCreateDirect" $ - HttpRequest POST path (Just (toJSON payload)) + HttpRequest POST path (Just $ show payload) rsp <- mmPOST sess uri payload (val, r) <- mmGetJSONBody "Channel" rsp runLoggerS sess "mmCreateDirect" $ - HttpResponse 200 path (Just val) + HttpResponse 200 path (Just $ show val) return r -- { name, display_name, purpose, header } @@ -606,11 +606,11 @@ let path = printf "/api/v3/teams/%s/channels/create" (idString teamid) uri <- mmPath path runLoggerS sess "mmCreateChannel" $ - HttpRequest POST path (Just (toJSON payload)) + HttpRequest POST path (Just $ show payload) rsp <- mmPOST sess uri payload (val, r) <- mmGetJSONBody "Channel" rsp runLoggerS sess "mmCreateChannel" $ - HttpResponse 200 path (Just val) + HttpResponse 200 path (Just $ show val) return r -- | @@ -661,11 +661,11 @@ (idString chanid) uri <- mmPath path runLoggerS sess "mmUpdatePost" $ - HttpRequest POST path (Just (toJSON post)) + HttpRequest POST path (Just (show post)) rsp <- mmPOST sess uri post (val, r) <- mmGetJSONBody "Post" rsp runLoggerS sess "mmUpdatePost" $ - HttpResponse 200 path (Just (val)) + HttpResponse 200 path (Just $ show val) return r -- | @@ -681,11 +681,11 @@ (idString chanid) uri <- mmPath path runLoggerS sess "mmPost" $ - HttpRequest POST path (Just (toJSON post)) + HttpRequest POST path (Just $ show post) rsp <- mmPOST sess uri post (val, r) <- mmGetJSONBody "Post" rsp runLoggerS sess "mmPost" $ - HttpResponse 200 path (Just (val)) + HttpResponse 200 path (Just $ show val) return r -- | Get the system configuration. Requires administrative permission. @@ -713,7 +713,7 @@ let path = "/api/v3/admin/save_config" uri <- mmPath path runLoggerS sess "mmSaveConfig" $ - HttpRequest POST path (Just config) + HttpRequest POST path (Just $ show config) _ <- mmPOST sess uri config runLoggerS sess "mmSaveConfig" $ HttpResponse 200 path Nothing @@ -733,11 +733,11 @@ req = object ["user_id" .= uId] uri <- mmPath path runLoggerS sess "mmChannelAddUser" $ - HttpRequest POST path (Just req) + HttpRequest POST path (Just $ show req) rsp <- mmPOST sess uri req (val, r) <- mmGetJSONBody "ChannelData" rsp runLoggerS sess "mmChannelAddUser" $ - HttpResponse 200 path (Just val) + HttpResponse 200 path (Just $ show val) return r -- | @@ -752,7 +752,7 @@ req = object ["user_id" .= uId] uri <- mmPath path runLoggerS sess "mmTeamAddUser" $ - HttpRequest POST path (Just req) + HttpRequest POST path (Just $ show req) _ <- mmPOST sess uri req runLoggerS sess "mmTeamAddUSer" $ HttpResponse 200 path Nothing @@ -769,11 +769,11 @@ (idString teamid) uri <- mmPath path runLoggerS sess "mmExecute" $ - HttpRequest POST path (Just (toJSON command)) + HttpRequest POST path (Just $ show command) rsp <- mmPOST sess uri command (val, r) <- mmGetJSONBody "Value" rsp runLoggerS sess "mmExecute" $ - HttpResponse 200 path (Just (val)) + HttpResponse 200 path (Just $ show val) return r -- | @@ -785,11 +785,11 @@ let path = "/api/v3/users/create" uri <- mmPath path runLogger cd "mmUsersCreate" $ - HttpRequest POST path (Just (toJSON usersCreate)) + HttpRequest POST path (Just $ show usersCreate) rsp <- mmUnauthenticatedHTTPPost cd uri usersCreate (val, r) <- mmGetJSONBody "User" rsp runLogger cd "mmUsersCreate" $ - HttpResponse 200 path (Just (val)) + HttpResponse 200 path (Just $ show val) return r -- | @@ -801,11 +801,11 @@ let path = "/api/v3/users/create" uri <- mmPath path runLoggerS sess "mmUsersCreateWithToken" $ - HttpRequest POST path (Just (toJSON usersCreate)) + HttpRequest POST path (Just $ show usersCreate) rsp <- mmPOST sess uri usersCreate (val, r) <- mmGetJSONBody "User" rsp runLoggerS sess "mmUsersCreateWithToken" $ - HttpResponse 200 path (Just (val)) + HttpResponse 200 path (Just $ show val) return r -- | @@ -869,7 +869,7 @@ } let rawPath = "/api/v3/preferences/save" runLoggerS sess "mmFlagPost" $ - HttpRequest POST rawPath (Just (toJSON [flaggedPost])) + HttpRequest POST rawPath (Just (show [flaggedPost])) uri <- mmPath rawPath _ <- mmPOST sess uri (Seq.singleton flaggedPost) return () @@ -892,7 +892,7 @@ } let rawPath = "/api/v3/preferences/delete" runLoggerS sess "mmUnflagPost" $ - HttpRequest POST rawPath (Just (toJSON [flaggedPost])) + HttpRequest POST rawPath (Just (show [flaggedPost])) uri <- mmPath rawPath _ <- mmPOST sess uri (Seq.singleton flaggedPost) return () @@ -928,11 +928,11 @@ fnname = "mmCreateGroupChannel" uri <- mmPath path runLoggerS sess fnname $ - HttpRequest POST path (Just (toJSON uIds)) + HttpRequest POST path (Just $ show uIds) rsp <- mmPOST sess uri uIds (raw, json) <- mmGetJSONBody fnname rsp runLogger cd fnname $ - HttpResponse 200 path (Just raw) + HttpResponse 200 path (Just $ show raw) return json mmDeleteRequest :: Session -> URI -> IO () @@ -991,7 +991,7 @@ rsp <- mmRequest sess uri (raw,json) <- mmGetJSONBody fnname rsp runLogger cd fnname $ - HttpResponse 200 path (Just raw) + HttpResponse 200 path (Just $ show raw) action json mmPOST :: ToJSON t => Session -> URI -> t -> IO Response_String @@ -1011,7 +1011,7 @@ uri <- mmPath path let req = SetChannelHeader chanid header runLoggerS sess "mmSetChannelHeader" $ - HttpRequest POST path (Just (toJSON req)) + HttpRequest POST path (Just (show req)) rsp <- mmPOST sess uri req (_, r) <- mmGetJSONBody "Channel" rsp return r 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 @@ -44,7 +44,7 @@ ) import Network.Mattermost.Types.Base import Network.Mattermost.Types.Internal -import Network.Mattermost.Util (mkConnection, ConnectionType(..)) +import Network.Mattermost.Util ( mkConnection ) newtype UserText = UserText Text deriving (Eq, Show, Ord, Read) @@ -121,7 +121,7 @@ = Login { username :: Text , password :: Text - } + } deriving (Show) instance A.ToJSON Login where toJSON l = A.object ["login_id" A..= username l @@ -132,7 +132,7 @@ data SetChannelHeader = SetChannelHeader { setChannelHeaderChanId :: ChannelId , setChannelHeaderString :: Text - } + } deriving (Show) instance A.ToJSON SetChannelHeader where toJSON (SetChannelHeader cId p) = @@ -143,7 +143,7 @@ data SearchPosts = SearchPosts { searchPostsTerms :: Text , searchPostsIsOrSearch :: Bool - } + } deriving (Show) instance A.ToJSON SearchPosts where toJSON (SearchPosts t os) = @@ -617,6 +617,7 @@ userLocale <- o .: "locale" return User { .. } + -- The PostPropAttachment and PostPropAttachmentField types are -- actually defined by Slack, and simply used by Mattermost; the -- description of these fields can be found in this document: @@ -1133,6 +1134,7 @@ data PreferenceCategory = PreferenceCategoryDirectChannelShow | PreferenceCategoryGroupChannelShow + | PreferenceCategoryFavoriteChannel | PreferenceCategoryTutorialStep | PreferenceCategoryAdvancedSettings | PreferenceCategoryFlaggedPost @@ -1147,33 +1149,35 @@ instance A.FromJSON PreferenceCategory where parseJSON = A.withText "PreferenceCategory" $ \t -> return $ case t of - "direct_channel_show" -> PreferenceCategoryDirectChannelShow - "group_channel_show" -> PreferenceCategoryGroupChannelShow - "tutorial_step" -> PreferenceCategoryTutorialStep - "advanced_settings" -> PreferenceCategoryAdvancedSettings - "flagged_post" -> PreferenceCategoryFlaggedPost - "display_settings" -> PreferenceCategoryDisplaySettings - "theme" -> PreferenceCategoryTheme - "oauth_app" -> PreferenceCategoryAuthorizedOAuthApp - "notifications" -> PreferenceCategoryNotifications - "last" -> PreferenceCategoryLast - "teams_order" -> PreferenceCategoryTeamsOrder - _ -> PreferenceCategoryOther t + "direct_channel_show" -> PreferenceCategoryDirectChannelShow + "group_channel_show" -> PreferenceCategoryGroupChannelShow + "favorite_channel" -> PreferenceCategoryFavoriteChannel + "tutorial_step" -> PreferenceCategoryTutorialStep + "advanced_settings" -> PreferenceCategoryAdvancedSettings + "flagged_post" -> PreferenceCategoryFlaggedPost + "display_settings" -> PreferenceCategoryDisplaySettings + "theme" -> PreferenceCategoryTheme + "oauth_app" -> PreferenceCategoryAuthorizedOAuthApp + "notifications" -> PreferenceCategoryNotifications + "last" -> PreferenceCategoryLast + "teams_order" -> PreferenceCategoryTeamsOrder + _ -> PreferenceCategoryOther t instance A.ToJSON PreferenceCategory where toJSON cat = A.String $ case cat of - PreferenceCategoryDirectChannelShow -> "direct_channel_show" - PreferenceCategoryGroupChannelShow -> "group_channel_show" - PreferenceCategoryTutorialStep -> "tutorial_step" - PreferenceCategoryAdvancedSettings -> "advanced_settings" - PreferenceCategoryFlaggedPost -> "flagged_post" - PreferenceCategoryDisplaySettings -> "display_settings" - PreferenceCategoryTheme -> "theme" - PreferenceCategoryAuthorizedOAuthApp -> "oauth_app" - PreferenceCategoryNotifications -> "notifications" - PreferenceCategoryLast -> "last" - PreferenceCategoryTeamsOrder -> "teams_order" - PreferenceCategoryOther t -> t + PreferenceCategoryDirectChannelShow -> "direct_channel_show" + PreferenceCategoryGroupChannelShow -> "group_channel_show" + PreferenceCategoryFavoriteChannel -> "favorite_channel" + PreferenceCategoryTutorialStep -> "tutorial_step" + PreferenceCategoryAdvancedSettings -> "advanced_settings" + PreferenceCategoryFlaggedPost -> "flagged_post" + PreferenceCategoryDisplaySettings -> "display_settings" + PreferenceCategoryTheme -> "theme" + PreferenceCategoryAuthorizedOAuthApp -> "oauth_app" + PreferenceCategoryNotifications -> "notifications" + PreferenceCategoryLast -> "last" + PreferenceCategoryTeamsOrder -> "teams_order" + PreferenceCategoryOther t -> t data PreferenceName = PreferenceName { fromRawPreferenceName :: Text } @@ -1219,12 +1223,30 @@ , "value" .= preferenceValue ] +data FavoriteChannelPreference = + FavoriteChannelPreference { favoriteChannelId :: ChannelId + , favoriteChannelShow :: Bool + } deriving (Read, Show, Eq) + +-- | Attempt to expose a 'Preference' as a 'FavoriteChannelPreference' +preferenceToFavoriteChannelPreference :: Preference -> Maybe FavoriteChannelPreference +preferenceToFavoriteChannelPreference + Preference + { preferenceCategory = PreferenceCategoryFavoriteChannel + , preferenceName = PreferenceName name + , preferenceValue = PreferenceValue value + } = Just FavoriteChannelPreference + { favoriteChannelId = CI (Id name) + , favoriteChannelShow = value == "true" + } +preferenceToFavoriteChannelPreference _ = Nothing + data GroupChannelPreference = GroupChannelPreference { groupChannelId :: ChannelId , groupChannelShow :: Bool } deriving (Read, Show, Eq) --- | Attempt to expose a 'Preference' as a 'FlaggedPost' +-- | Attempt to expose a 'Preference' as a 'GroupChannelPreference' preferenceToGroupChannelPreference :: Preference -> Maybe GroupChannelPreference preferenceToGroupChannelPreference Preference @@ -1418,7 +1440,6 @@ instance A.ToJSON User where toJSON = error "to user" instance A.ToJSON Team where toJSON = error "to team" - -- -- diff --git a/src/Network/Mattermost/Types/Base.hs b/src/Network/Mattermost/Types/Base.hs --- a/src/Network/Mattermost/Types/Base.hs +++ b/src/Network/Mattermost/Types/Base.hs @@ -25,10 +25,10 @@ -- | A 'LogEventType' describes the particular event that happened data LogEventType - = HttpRequest RequestMethod String (Maybe A.Value) - | HttpResponse Int String (Maybe A.Value) + = HttpRequest RequestMethod String (Maybe String) + | HttpResponse Int String (Maybe String) | WebSocketRequest A.Value - | WebSocketResponse (Either String A.Value) + | WebSocketResponse (Either String String) -- ^ Left means we got an exception trying to parse the response; -- Right means we succeeded and here it is. | WebSocketPing diff --git a/src/Network/Mattermost/WebSocket.hs b/src/Network/Mattermost/WebSocket.hs --- a/src/Network/Mattermost/WebSocket.hs +++ b/src/Network/Mattermost/WebSocket.hs @@ -126,7 +126,7 @@ val <- case result of Left e -> do - doLog $ WebSocketResponse $ Right $ toJSON $ + doLog $ WebSocketResponse $ Right $ "Got exception on receiveDataMessage: " <> show e throwIO e Right dataMsg -> do @@ -157,8 +157,8 @@ doLog (WebSocketResponse $ case val of Left s -> Left s - Right (Left v) -> Right $ toJSON v - Right (Right v) -> Right $ toJSON v + Right (Left v) -> Right $ show v + Right (Right v) -> Right $ show v ) recv val body (MMWS c health) `catch` propagate [mId, pId]