diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,36 @@ +31000.0.0 +========= + +API changes: + * Added flagged posts API: + * Types: FlaggedPost + * mmGetFlaggedPosts + * mmFlagPost + * mmUnflagPost + * Added preferences API: + * Types: Preference, PreferenceCategory, PreferenceName, + PreferenceValue + * mmDeletePreferences + * mmSavePreferences + * mmGetMyPreferences + * Added PostType for post types (joins, parts, header changes, etc.) + and changed the type of Post.postType to use this new type. + * Added a new field WEData.wepMentions so that websocket events can + include the set of UserIds in a mention set. + * Made most fields of PostPropAttachment optional. + * Added a new PostPropAttachment type as defined by Slack and used by + Mattermost. + * Allow null for the "fields" field of PostPropAttachment. + * Extended PostPropAttachment with additional fields to better match + the upstream spec. + +Other changes: + * Improved the LoginFailureException message format. + * Refrain from logging passwords when logging login requests. + * Logging operations seek to the end of the log in case of a shared log + file. + 30802.1.0 ========= @@ -6,7 +38,7 @@ API changes: * Made the PendingPost `created_at` field optional. It defaults to 0. - This behavior is due to MatterMost's support for admins setting the + This behavior is due to Mattermost's support for admins setting the creation timestamp to values in the past. A value of zero causes the server to use the server's clock to set the creation timestamp. Any other value is only permitted for users with administrative diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,12 @@ [![Build Status](https://travis-ci.org/matterhorn-chat/mattermost-api.svg?branch=master)](https://travis-ci.org/matterhorn-chat/mattermost-api) # mattermost-api -Client side API for communicating with a MatterMost server, in Haskell. +Client side API for communicating with a Mattermost server, in Haskell. # Testing We use the MaterMost docker image for detecting changes in the API. See -`.travis.yml` or the [MatterMost +`.travis.yml` or the [Mattermost docs](https://docs.mattermost.com/install/docker-local-machine.html#one-line-docker-install) for the details. @@ -16,7 +16,7 @@ **Note: The `local_test_mm.sh` script will stop and remove a docker container named `mattermost-preview`.** -**Note: The tests can only be run once against a given MatterMost instance. This +**Note: The tests can only be run once against a given Mattermost instance. This is because the scripts currently assume they can create an initial admin user.** **Note: The scripts assume the instance is reachable on `localhost:8065` over plain @@ -30,7 +30,7 @@ This library uses the same versioning scheme as `matterhorn`, see [Our Versioning Scheme](https://github.com/matterhorn-chat/matterhorn/blob/master/README.md#our-versioning-scheme). -The short version is that in `ABBCC.X.Y`, the `ABBCC` corresponds to MatterMost +The short version is that in `ABBCC.X.Y`, the `ABBCC` corresponds to Mattermost server version `A.BB.CC` and the `X.Y` portion of the version string corresponds to the version of `mattermost-api` package releases. diff --git a/mattermost-api.cabal b/mattermost-api.cabal --- a/mattermost-api.cabal +++ b/mattermost-api.cabal @@ -1,7 +1,7 @@ name: mattermost-api -version: 30802.1.0 -synopsis: Client API for MatterMost chat system -description: Client API for MatterMost chat system +version: 31000.0.0 +synopsis: Client API for Mattermost chat system +description: Client API for Mattermost chat system license: BSD3 license-file: LICENSE author: Jason Dagit @@ -41,10 +41,7 @@ , stm , aeson >= 1.0.0.0 , connection - -- The next two constraints are required to avoid a - -- dependency on 'foundation' , memory <0.14.3 - , cryptonite <0.23 , bytestring , process , HTTP diff --git a/src/Network/Mattermost.hs b/src/Network/Mattermost.hs --- a/src/Network/Mattermost.hs +++ b/src/Network/Mattermost.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.Mattermost ( -- * Types - -- ** Mattermost-Related Types (deprecated: use Network.MatterMost.Types instead) + -- ** Mattermost-Related Types (deprecated: use Network.Mattermost.Types instead) -- n.b. the deprecation notice is in that haddock header because we're -- still waiting for https://ghc.haskell.org/trac/ghc/ticket/4879 ... Login(..) @@ -29,6 +29,7 @@ , MinChannel(..) , UsersCreate(..) , Post(..) +, PostType(..) , PostProps(..) , PendingPost(..) , PostId(..) @@ -40,6 +41,12 @@ , MinCommand(..) , CommandResponse(..) , CommandResponseType(..) +, Preference(..) +, PreferenceCategory(..) +, PreferenceName(..) +, PreferenceValue(..) +, FlaggedPost(..) +, preferenceToFlaggedPost -- ** Log-related types , Logger , LogEvent(..) @@ -92,6 +99,12 @@ , mmUpdatePost , mmExecute , mmGetConfig +, mmSavePreferences +, mmDeletePreferences +, mmFlagPost +, mmUnflagPost +, mmGetFlaggedPosts +, mmGetMyPreferences , mkPendingPost , idString , hoistE @@ -223,10 +236,12 @@ let rawPath = "/api/v3/users/login" path <- mmPath rawPath runLogger cd "mmLogin" $ - HttpRequest GET rawPath (Just (toJSON login)) + HttpRequest GET rawPath (Just (toJSON $ login { password = "" })) rsp <- mmUnauthenticatedHTTPPost cd path login if (rspCode rsp /= (2,0,0)) - then return (Left (LoginFailureException (show (rspCode rsp)))) + then do + let eMsg = "Server returned unexpected " <> showRespCode (rspCode rsp) <> " response" + return $ Left $ LoginFailureException eMsg else do token <- mmGetHeader rsp (HdrCustom "Token") (raw, value) <- mmGetJSONBody "User" rsp @@ -234,6 +249,9 @@ HttpResponse 200 rawPath (Just raw) return (Right (Session cd (Token token), value)) +showRespCode :: (Int, Int, Int) -> String +showRespCode (a, b, c) = concat $ show <$> [a, b, c] + -- | Fire off a login attempt. Note: We get back more than just the auth token. -- We also get all the server-side configuration data for the user. -- @@ -757,6 +775,85 @@ (idString cId) (idString pId) mmDoRequest sess "mmGetReactionsForPost" path + +-- | +-- route: @\/api\/v3\/preferences\/save@ +mmSavePreferences :: Session + -> Seq.Seq Preference + -> IO () +mmSavePreferences sess pref = do + uri <- mmPath "/api/v3/preferences/save" + _ <- mmPOST sess uri pref + return () + +-- | +-- route: @\/api\/v3\/preferences\/save@ +mmDeletePreferences :: Session + -> Seq.Seq Preference + -> IO () +mmDeletePreferences sess pref = do + uri <- mmPath "/api/v3/preferences/delete" + _ <- mmPOST sess uri pref + return () + +-- | +-- route: @\/api\/v3\/preferences\/save@ +-- +-- This is a convenience function for a particular use of +-- 'mmSavePreference' +mmFlagPost :: Session + -> UserId + -> PostId + -> IO () +mmFlagPost sess uId pId = do + let flaggedPost = + FlaggedPost + { flaggedPostUserId = uId + , flaggedPostId = pId + , flaggedPostStatus = True + } + let rawPath = "/api/v3/preferences/save" + runLoggerS sess "mmFlagPost" $ + HttpRequest POST rawPath (Just (toJSON [flaggedPost])) + uri <- mmPath rawPath + _ <- mmPOST sess uri (Seq.singleton flaggedPost) + return () + +-- | +-- route: @\/api\/v3\/preferences\/save@ +-- +-- This is a convenience function for a particular use of +-- 'mmSavePreference' +mmUnflagPost :: Session + -> UserId + -> PostId + -> IO () +mmUnflagPost sess uId pId = do + let flaggedPost = + FlaggedPost + { flaggedPostUserId = uId + , flaggedPostId = pId + , flaggedPostStatus = True + } + let rawPath = "/api/v3/preferences/delete" + runLoggerS sess "mmUnflagPost" $ + HttpRequest POST rawPath (Just (toJSON [flaggedPost])) + uri <- mmPath rawPath + _ <- mmPOST sess uri (Seq.singleton flaggedPost) + return () + +mmGetFlaggedPosts :: Session + -> UserId + -> IO Posts +mmGetFlaggedPosts sess uId = + let path = printf "/api/v4/users/%s/posts/flagged" (idString uId) + in mmDoRequest sess "mmGetFlaggedPosts" path + +mmGetMyPreferences :: Session + -> IO (Seq.Seq Preference) +mmGetMyPreferences sess = + mmDoRequest sess "mmMyPreferences" "/api/v4/users/me/preferences" + -- | This is for making a generic authenticated request. mmRequest :: Session -> URI -> IO Response_String diff --git a/src/Network/Mattermost/Logging.hs b/src/Network/Mattermost/Logging.hs --- a/src/Network/Mattermost/Logging.hs +++ b/src/Network/Mattermost/Logging.hs @@ -15,8 +15,10 @@ , mmLoggerDebugFilterErr ) where +import Control.Monad (when) import Data.Time.Clock (getCurrentTime) -import System.IO (Handle, hFlush, hPutStr, stderr) +import System.IO (Handle, hFlush, hPutStr, stderr + , hIsSeekable, hSeek, SeekMode(..)) import Network.Mattermost.Types.Base @@ -33,6 +35,8 @@ mmLoggerDebug :: Handle -> Logger mmLoggerDebug h LogEvent { logFunction = f, logEventType = e } = do now <- getCurrentTime + canSeek <- hIsSeekable h + when canSeek $ hSeek h SeekFromEnd 0 mapM_ (hPutStr h) [ "[", show now, "] ", f, ": ", show e, "\n" ] hFlush h @@ -62,6 +66,8 @@ mmLoggerInfo :: Handle -> Logger mmLoggerInfo h LogEvent { logFunction = f, logEventType = e } = do now <- getCurrentTime + canSeek <- hIsSeekable h + when canSeek $ hSeek h SeekFromEnd 0 mapM_ (hPutStr h) [ "[", show now, "] ", f, ": ", info e, "\n" ] hFlush h 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 @@ -121,7 +121,6 @@ | Direct | Private | Group - | SystemHeaderChange | Unknown Text deriving (Read, Show, Ord, Eq) @@ -131,14 +130,12 @@ | t == "D" -> Direct | t == "P" -> Private | t == "G" -> Group - | t == "system_header_change" -> SystemHeaderChange | otherwise -> Unknown t instance A.ToJSON Type where toJSON Direct = A.toJSON ("D"::Text) toJSON Ordinary = A.toJSON ("O"::Text) toJSON Private = A.toJSON ("P"::Text) - toJSON SystemHeaderChange = A.toJSON ("system_header_change"::Text) toJSON Group = A.toJSON ("G"::Text) toJSON (Unknown t) = A.toJSON t @@ -492,16 +489,61 @@ 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: +-- https://api.slack.com/docs/message-attachments + +data PostPropAttachmentField = PostPropAttachmentField + { ppafTitle :: Text + , ppafValue :: Text + , ppafShort :: Bool + } deriving (Read, Show, Eq) + +instance A.FromJSON PostPropAttachmentField where + parseJSON = A.withObject "PostPropAttachmentField" $ \v -> do + ppafTitle <- v .: "title" + ppafValue <- v .: "value" + ppafShort <- v .: "short" + return PostPropAttachmentField { .. } + data PostPropAttachment = PostPropAttachment - { ppaColor :: Text - , ppaText :: Text + { ppaId :: Int + , ppaFallback :: Text + , ppaColor :: Text + , ppaPretext :: Text + , ppaAuthorName :: Text + , ppaAuthorLink :: Text + , ppaAuthorIcon :: Text + , ppaTitle :: Text + , ppaTitleLink :: Text + , ppaText :: Text + , ppaFields :: Seq PostPropAttachmentField + , ppaImageURL :: Text + , ppaThumbURL :: Text + , ppaFooter :: Text + , ppaFooterIcon :: Text } deriving (Read, Show, Eq) instance A.FromJSON PostPropAttachment where parseJSON = A.withObject "Attachment" $ \v -> do - ppaColor <- v .: "color" - ppaText <- v .: "text" + let x .:?? f = x .: f <|> return mempty + ppaId <- v .: "id" <|> return 0 + ppaFallback <- v .:?? "fallback" + ppaColor <- v .:?? "color" + ppaPretext <- v .:?? "pretext" + ppaAuthorName <- v .:?? "author_name" + ppaAuthorLink <- v .:?? "author_link" + ppaAuthorIcon <- v .:?? "author_icon" + ppaTitle <- v .:?? "title" + ppaTitleLink <- v .:?? "title_link" + ppaText <- v .:?? "text" + ppaFields <- v .:?? "fields" + ppaImageURL <- v .:?? "image_url" + ppaThumbURL <- v .:?? "thumb_url" + ppaFooter <- v .:?? "footer" + ppaFooterIcon <- v .:?? "footer_icon" return PostPropAttachment { .. } instance A.ToJSON PostPropAttachment where @@ -554,6 +596,45 @@ urlForFile fId = "/api/v3/files/" <> idString fId <> "/get" +data PostType + = PostTypeJoinChannel + | PostTypeLeaveChannel + | PostTypeAddToChannel + | PostTypeRemoveFromChannel + | PostTypeHeaderChange + | PostTypeDisplayNameChange + | PostTypePurposeChange + | PostTypeChannelDeleted + | PostTypeEphemeral + | PostTypeUnknown T.Text + deriving (Read, Show, Eq) + +instance A.FromJSON PostType where + parseJSON = A.withText "Post type" $ \ t -> return $ case t of + "system_join_channel" -> PostTypeJoinChannel + "system_leave_channel" -> PostTypeLeaveChannel + "system_add_to_channel" -> PostTypeAddToChannel + "system_remove_from_channel" -> PostTypeRemoveFromChannel + "system_header_change" -> PostTypeHeaderChange + "system_displayname_change" -> PostTypeDisplayNameChange + "system_purpose_change" -> PostTypePurposeChange + "system_channel_deleted" -> PostTypeChannelDeleted + "system_ephemeral" -> PostTypeEphemeral + _ -> PostTypeUnknown t + +instance A.ToJSON PostType where + toJSON typ = A.String $ case typ of + PostTypeJoinChannel -> "system_join_channel" + PostTypeLeaveChannel -> "system_leave_channel" + PostTypeAddToChannel -> "system_add_to_channel" + PostTypeRemoveFromChannel -> "system_remove_from_channel" + PostTypeHeaderChange -> "system_header_change" + PostTypeDisplayNameChange -> "system_displayname_change" + PostTypePurposeChange -> "system_purpose_change" + PostTypeChannelDeleted -> "system_channel_deleted" + PostTypeEphemeral -> "system_ephemeral" + PostTypeUnknown t -> t + data Post = Post { postPendingPostId :: Maybe PostId @@ -562,7 +643,7 @@ , postRootId :: Text , postFileIds :: Seq FileId , postId :: PostId - , postType :: Type + , postType :: PostType , postMessage :: Text , postDeleteAt :: Maybe UTCTime , postHashtags :: Text @@ -859,3 +940,118 @@ , "emoji_name" .= reactionEmojiName , "create_at" .= utcTimeToMilliseconds reactionCreateAt ] + +-- * Preferences + +data PreferenceCategory + = PreferenceCategoryDirectChannelShow + | PreferenceCategoryTutorialStep + | PreferenceCategoryAdvancedSettings + | PreferenceCategoryFlaggedPost + | PreferenceCategoryDisplaySettings + | PreferenceCategoryTheme + | PreferenceCategoryAuthorizedOAuthApp + | PreferenceCategoryNotifications + | PreferenceCategoryOther Text + deriving (Read, Show, Eq) + +instance A.FromJSON PreferenceCategory where + parseJSON = A.withText "PreferenceCategory" $ \t -> return $ case t of + "direct_channel_show" -> PreferenceCategoryDirectChannelShow + "tutorial_step" -> PreferenceCategoryTutorialStep + "advanced_settings" -> PreferenceCategoryAdvancedSettings + "flagged_post" -> PreferenceCategoryFlaggedPost + "display_settings" -> PreferenceCategoryDisplaySettings + "theme" -> PreferenceCategoryTheme + "oauth_app" -> PreferenceCategoryAuthorizedOAuthApp + "notifications" -> PreferenceCategoryNotifications + _ -> PreferenceCategoryOther t + +instance A.ToJSON PreferenceCategory where + toJSON cat = A.String $ case cat of + PreferenceCategoryDirectChannelShow -> "direct_channel_show" + PreferenceCategoryTutorialStep -> "tutorial_step" + PreferenceCategoryAdvancedSettings -> "advanced_settings" + PreferenceCategoryFlaggedPost -> "flagged_post" + PreferenceCategoryDisplaySettings -> "display_settings" + PreferenceCategoryTheme -> "theme" + PreferenceCategoryAuthorizedOAuthApp -> "oauth_app" + PreferenceCategoryNotifications -> "notifications" + PreferenceCategoryOther t -> t + +data PreferenceName + = PreferenceName { fromRawPreferenceName :: Text } + deriving (Read, Show, Eq) + +instance A.FromJSON PreferenceName where + parseJSON = A.withText "PreferenceValue" (return . PreferenceName) + +instance A.ToJSON PreferenceName where + toJSON = A.toJSON . fromRawPreferenceName + +data PreferenceValue + = PreferenceValue { fromRawPreferenceValue :: Text } + deriving (Read, Show, Eq) + +instance A.FromJSON PreferenceValue where + parseJSON = A.withText "PreferenceValue" (return . PreferenceValue) + +instance A.ToJSON PreferenceValue where + toJSON = A.toJSON . fromRawPreferenceValue + +data Preference + = Preference + { preferenceUserId :: UserId + , preferenceCategory :: PreferenceCategory + , preferenceName :: PreferenceName + , preferenceValue :: PreferenceValue + } deriving (Read, Show, Eq) + +instance A.FromJSON Preference where + parseJSON = A.withObject "Preference" $ \v -> do + preferenceUserId <- v .: "user_id" + preferenceCategory <- v .: "category" + preferenceName <- v .: "name" + preferenceValue <- v .: "value" + return Preference { .. } + +instance A.ToJSON Preference where + toJSON Preference { .. } = A.object + [ "user_id" .= preferenceUserId + , "category" .= preferenceCategory + , "name" .= preferenceName + , "value" .= preferenceValue + ] + +data FlaggedPost = FlaggedPost + { flaggedPostUserId :: UserId + , flaggedPostId :: PostId + , flaggedPostStatus :: Bool + } deriving (Read, Show, Eq) + +-- | Attempt to expose a 'Preference' as a 'FlaggedPost' +preferenceToFlaggedPost :: Preference -> Maybe FlaggedPost +preferenceToFlaggedPost + Preference + { preferenceCategory = PreferenceCategoryFlaggedPost + , preferenceName = PreferenceName name + , preferenceValue = PreferenceValue value + , preferenceUserId = userId + } = Just FlaggedPost + { flaggedPostUserId = userId + , flaggedPostId = PI (Id name) + , flaggedPostStatus = value == "true" + } +preferenceToFlaggedPost _ = Nothing + +instance A.ToJSON FlaggedPost where + toJSON FlaggedPost + { flaggedPostUserId = userId + , flaggedPostId = PI (Id name) + , flaggedPostStatus = status + } = A.toJSON $ Preference + { preferenceCategory = PreferenceCategoryFlaggedPost + , preferenceName = PreferenceName name + , preferenceValue = PreferenceValue (if status then "true" else "false") + , preferenceUserId = userId + } 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 @@ -23,6 +23,8 @@ import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.HashMap.Strict as HM import Data.Int (Int64) +import Data.Sequence (Seq) +import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -50,6 +52,7 @@ | WMUserUpdated | WMUserRemoved | WMPreferenceChanged + | WMPreferenceDeleted | WMEphemeralMessage | WMStatusChange | WMHello @@ -72,7 +75,7 @@ "user_added" -> return WMUserAdded "user_updated" -> return WMUserUpdated "user_removed" -> return WMUserRemoved - "preference_changed" -> return WMPreferenceChanged + "preferences_changed" -> return WMPreferenceChanged "ephemeral_message" -> return WMEphemeralMessage "status_change" -> return WMStatusChange "hello" -> return WMHello @@ -84,6 +87,7 @@ "added_to_team" -> return WMAddedToTeam "webrtc" -> return WMWebRTC "authentication_challenge" -> return WMAuthenticationChallenge + "preferences_deleted" -> return WMPreferenceDeleted _ -> fail ("Unknown websocket message: " ++ show s) instance ToJSON WebsocketEventType where @@ -98,7 +102,8 @@ toJSON WMUserAdded = "user_added" toJSON WMUserUpdated = "user_updated" toJSON WMUserRemoved = "user_removed" - toJSON WMPreferenceChanged = "preference_changed" + toJSON WMPreferenceChanged = "preferences_changed" + toJSON WMPreferenceDeleted = "preferences_deleted" toJSON WMEphemeralMessage = "ephemeral_message" toJSON WMStatusChange = "status_change" toJSON WMHello = "hello" @@ -167,6 +172,8 @@ , wepPost :: Maybe Post , wepStatus :: Maybe Text , wepReaction :: Maybe Reaction + , wepMentions :: Maybe (Set UserId) + , wepPreferences :: Maybe (Seq Preference) } deriving (Read, Show, Eq) instance FromJSON WEData where @@ -186,6 +193,14 @@ 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 return WEData { .. } instance ToJSON WEData where @@ -197,6 +212,8 @@ , "channel_name" .= wepChannelDisplayName , "post" .= toValueString wepPost , "reaction" .= wepReaction + , "mentions" .= toValueString wepMentions + , "preferences" .= toValueString wepPreferences ] --