mattermost-api 30802.1.0 → 31000.0.0

raw patch · 7 files changed

+370/−25 lines, 7 filesdep −cryptonitePVP ok

version bump matches the API change (PVP)

Dependencies removed: cryptonite

API changes (from Hackage documentation)

Files

• CHANGELOG.md +33/−1
• README.md +4/−4
• mattermost-api.cabal +3/−6
• src/Network/Mattermost.hs +100/−3
• src/Network/Mattermost/Logging.hs +7/−1
• src/Network/Mattermost/Types.hs +204/−8
• src/Network/Mattermost/WebSocket/Types.hs +19/−2

@@ -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

@@ -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. 

@@ -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

@@ -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 = "<elided>" }))   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

@@ -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

@@ -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+          }

@@ -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     ]  --