mattermost-api 40000.1.0 → 40400.0.0
raw patch · 12 files changed
+237/−54 lines, 12 filesnew-uploader
Files
- CHANGELOG.md +18/−0
- examples/GetWebsocketConnection.hs +1/−1
- examples/LocalConfig.hs +3/−3
- examples/ShowRawEvents.hs +1/−1
- mattermost-api.cabal +1/−1
- src/Network/Mattermost.hs +100/−1
- src/Network/Mattermost/Lenses.hs +5/−2
- src/Network/Mattermost/Types.hs +87/−38
- src/Network/Mattermost/Types/Base.hs +3/−1
- src/Network/Mattermost/WebSocket.hs +13/−5
- src/Network/Mattermost/WebSocket/Types.hs +3/−0
- test/Tests/Util.hs +2/−1
CHANGELOG.md view
@@ -1,3 +1,21 @@+40400.0.0+=========++API changes:+ * Added endpoints for some preference endpoints, group channels, and+ post search:+ * `mmChannelRemoveUser`+ * `mmCreateGroupChannel`+ * `mmSearchPosts`+ * `mmSetPreferences`+ * Added `GroupChannelPreferences` type for showing/hiding group+ channels+ * Separated the previous `NotifyProps` type into `UserNotifyProps`+ and `ChannelNotifyProps`.+ * Websocket parse failures are now captured and appear to the library+ user as an `Either String WebsocketEvent`, where the `String`+ represent a parse failure.+ * Add support for `user_role_updated` websocket event type. 40000.1.0 =========
examples/GetWebsocketConnection.hs view
@@ -68,7 +68,7 @@ mmWithWebSocket session printEvent checkForExit -printEvent :: WebsocketEvent -> IO ()+printEvent :: Either String WebsocketEvent -> IO () printEvent we = pPrint we checkForExit :: MMWebSocket -> IO ()
examples/LocalConfig.hs view
@@ -9,9 +9,9 @@ let cmd = words "pass ldap" pass <- takeWhile (/='\n') <$> readProcess (head cmd) (tail cmd) "" return $ Config- { configUsername = T.pack "USERNAME"- , configHostname = T.pack "mattermost.example.com"- , configTeam = T.pack "TEAMNAME"+ { configUsername = T.pack "gdritter"+ , configHostname = T.pack "matterhorn-dev.galois.com"+ , configTeam = T.pack "galwegians" , configPort = 443 -- currently we only support HTTPS , configPassword = T.pack pass }
examples/ShowRawEvents.hs view
@@ -79,7 +79,7 @@ mmWithWebSocket session printEvent checkForExit -printEvent :: WebsocketEvent -> IO ()+printEvent :: Either String WebsocketEvent -> IO () printEvent e = pPrint e checkForExit :: MMWebSocket -> IO ()
mattermost-api.cabal view
@@ -1,5 +1,5 @@ name: mattermost-api-version: 40000.1.0+version: 40400.0.0 synopsis: Client API for Mattermost chat system description: Client API for Mattermost chat system license: BSD3
src/Network/Mattermost.hs view
@@ -62,6 +62,7 @@ , mmLogin , mmCreateDirect , mmCreateChannel+, mmCreateGroupChannel , mmCreateTeam , mmDeleteChannel , mmLeaveChannel@@ -80,6 +81,7 @@ , mmGetPostsSince , mmGetPostsBefore , mmGetPostsAfter+, mmSearchPosts , mmGetReactionsForPost , mmGetFileInfo , mmGetFile@@ -95,6 +97,7 @@ , mmSaveConfig , mmSetChannelHeader , mmChannelAddUser+, mmChannelRemoveUser , mmTeamAddUser , mmUsersCreate , mmUsersCreateWithSession@@ -102,6 +105,7 @@ , mmUpdatePost , mmExecute , mmGetConfig+, mmSetPreferences , mmSavePreferences , mmDeletePreferences , mmFlagPost@@ -498,6 +502,25 @@ limit -- |+-- route: @\/api\/v4\/teams\/{team_id}\/posts\/search@+mmSearchPosts :: Session+ -> TeamId+ -> T.Text+ -> Bool+ -> IO Posts+mmSearchPosts sess teamid terms isOrSearch = do+ let path = printf "/api/v4/teams/%s/posts/search" $ idString teamid+ uri <- mmPath path+ let req = SearchPosts terms isOrSearch+ runLoggerS sess "mmSearchPosts" $+ HttpRequest POST path (Just (toJSON req))+ rsp <- mmPOST sess uri req+ (raw, value) <- mmGetJSONBody "SearchPostsResult" rsp+ runLoggerS sess "mmSearchPosts" $+ HttpResponse 200 path (Just raw)+ return value++-- | -- route: @\/api\/v3\/files\/{file_id}\/get_info@ mmGetFileInfo :: Session -> FileId@@ -814,6 +837,15 @@ (idString pId) mmDoRequest sess "mmGetReactionsForPost" path +mmSetPreferences :: Session+ -> UserId+ -> Seq.Seq Preference+ -> IO ()+mmSetPreferences sess uId prefs = do+ uri <- mmPath $ printf "/api/v4/users/%s/preferences" (idString uId)+ _ <- mmPUT sess uri prefs+ return ()+ -- | -- route: @\/api\/v3\/preferences\/save@ mmSavePreferences :: Session@@ -892,7 +924,48 @@ mmGetMyPreferences sess = mmDoRequest sess "mmMyPreferences" "/api/v4/users/me/preferences" +-- | Remove the specified user from the specified channel.+mmChannelRemoveUser :: Session+ -> ChannelId+ -> UserId+ -> IO ()+mmChannelRemoveUser sess cId uId =+ let path = printf "/api/v4/channels/%s/members/%s" (idString cId) (idString uId)+ in mmDeleteRequest sess =<< mmPath path +-- | Create a group channel containing the specified users in addition+-- to the user making the request.+mmCreateGroupChannel :: Session+ -> [UserId]+ -> IO Channel+mmCreateGroupChannel sess@(Session cd _) uIds = do+ let path = "/api/v4/channels/group"+ fnname = "mmCreateGroupChannel"+ uri <- mmPath path+ runLoggerS sess fnname $+ HttpRequest POST path (Just (toJSON uIds))+ rsp <- mmPOST sess uri uIds+ (raw, json) <- mmGetJSONBody fnname rsp+ runLogger cd fnname $+ HttpResponse 200 path (Just raw)+ return json++mmDeleteRequest :: Session -> URI -> IO ()+mmDeleteRequest (Session cd token) path = do+ rawRsp <- withConnection cd $ \con -> do+ let request = Request+ { rqURI = path+ , rqMethod = DELETE+ , rqHeaders = [ mkHeader HdrAuthorization ("Bearer " ++ getTokenString token)+ , mkHeader HdrHost (T.unpack $ cdHostname cd)+ , mkHeader HdrUserAgent defaultUserAgent+ ] ++ autoCloseToHeader (cdAutoClose cd)+ , rqBody = ""+ }+ simpleHTTP_ con request+ rsp <- hoistE $ left ConnectionException rawRsp+ assert200Response path rsp+ -- | This is for making a generic authenticated request. mmRequest :: Session -> URI -> IO Response_String mmRequest (Session cd token) path = do@@ -940,6 +1013,10 @@ mmPOST sess path json = mmRawPOST sess path (BL.toStrict (encode json)) +mmPUT :: ToJSON t => Session -> URI -> t -> IO Response_String+mmPUT sess path json =+ mmRawPUT sess path (BL.toStrict (encode json))+ -- | -- route: @\/api\/v3\/teams\/{team_id}\/channels\/update_header@ mmSetChannelHeader :: Session -> TeamId -> ChannelId -> T.Text -> IO Channel@@ -974,9 +1051,31 @@ assert200Response path rsp return rsp +mmRawPUT :: Session -> URI -> B.ByteString -> IO Response_String+mmRawPUT (Session cd token) path content = do+ rawRsp <- withConnection cd $ \con -> do+ let contentLength = B.length content+ request = Request+ { rqURI = path+ , rqMethod = PUT+ , rqHeaders = [ mkHeader HdrAuthorization ("Bearer " ++ getTokenString token)+ , mkHeader HdrHost (T.unpack $ cdHostname cd)+ , mkHeader HdrUserAgent defaultUserAgent+ , mkHeader HdrContentType "application/json"+ , mkHeader HdrContentLength (show contentLength)+ ] ++ autoCloseToHeader (cdAutoClose cd)+ , rqBody = B.unpack content+ }+ simpleHTTP_ con request+ rsp <- hoistE $ left ConnectionException rawRsp+ assert200Response path rsp+ return rsp+ assert200Response :: URI -> Response_String -> IO () assert200Response path rsp =- when (rspCode rsp /= (2,0,0)) $+ let is20x (2, 0, _) = True+ is20x _ = False+ in when (not $ is20x $ rspCode rsp) $ let httpExc = HTTPResponseException $ "mmRequest: expected 200 response, got " <> (show $ rspCode rsp) in case eitherDecode $ BL.pack $ rspBody rsp of
src/Network/Mattermost/Lenses.hs view
@@ -24,8 +24,11 @@ -- * 'TeamMember' lenses suffixLenses ''TeamMember --- * 'NotifyProps' lenses-suffixLenses ''NotifyProps+-- * 'UserNotifyProps' lenses+suffixLenses ''UserNotifyProps++-- * 'ChannelNotifyProps' lenses+suffixLenses ''ChannelNotifyProps -- * 'Channel' lenses suffixLenses ''Channel
src/Network/Mattermost/Types.hs view
@@ -117,6 +117,17 @@ ,"channel_header" A..= p ] +data SearchPosts = SearchPosts+ { searchPostsTerms :: Text+ , searchPostsIsOrSearch :: Bool+ }++instance A.ToJSON SearchPosts where+ toJSON (SearchPosts t os) =+ A.object ["terms" A..= t+ ,"is_or_search" A..= os+ ]+ data Type = Ordinary | Direct | Private@@ -254,29 +265,42 @@ parseJSON (A.String "none") = return NotifyOptionNone parseJSON xs = fail ("Unknown NotifyOption value: " ++ show xs) -data NotifyProps = NotifyProps- { notifyPropsMentionKeys :: [Text]- , notifyPropsEmail :: WithDefault Bool- , notifyPropsPush :: WithDefault NotifyOption- , notifyPropsDesktop :: WithDefault NotifyOption- , notifyPropsDesktopSound :: WithDefault Bool- , notifyPropsChannel :: WithDefault Bool- , notifyPropsFirstName :: WithDefault Bool- , notifyPropsMarkUnread :: WithDefault NotifyOption+data UserNotifyProps = UserNotifyProps+ { userNotifyPropsMentionKeys :: [Text]+ , userNotifyPropsEmail :: Bool+ , userNotifyPropsPush :: NotifyOption+ , userNotifyPropsDesktop :: NotifyOption+ , userNotifyPropsDesktopSound :: Bool+ , userNotifyPropsChannel :: Bool+ , userNotifyPropsFirstName :: Bool } deriving (Eq, Show, Read, Ord) -emptyNotifyProps :: NotifyProps-emptyNotifyProps = NotifyProps- { notifyPropsMentionKeys = []- , notifyPropsEmail = IsValue False- , notifyPropsPush = IsValue NotifyOptionNone- , notifyPropsDesktop = IsValue NotifyOptionNone- , notifyPropsDesktopSound = IsValue False- , notifyPropsChannel = IsValue False- , notifyPropsFirstName = IsValue False- , notifyPropsMarkUnread = IsValue NotifyOptionNone+data ChannelNotifyProps = ChannelNotifyProps+ { channelNotifyPropsEmail :: WithDefault Bool+ , channelNotifyPropsDesktop :: WithDefault NotifyOption+ , channelNotifyPropsPush :: WithDefault NotifyOption+ , channelNotifyPropsMarkUnread :: WithDefault NotifyOption+ } deriving (Eq, Show, Read, Ord)++emptyUserNotifyProps :: UserNotifyProps+emptyUserNotifyProps = UserNotifyProps+ { userNotifyPropsMentionKeys = []+ , userNotifyPropsEmail = False+ , userNotifyPropsPush = NotifyOptionNone+ , userNotifyPropsDesktop = NotifyOptionNone+ , userNotifyPropsDesktopSound = False+ , userNotifyPropsChannel = False+ , userNotifyPropsFirstName = False } +emptyChannelNotifyProps :: ChannelNotifyProps+emptyChannelNotifyProps = ChannelNotifyProps+ { channelNotifyPropsEmail = Default+ , channelNotifyPropsPush = Default+ , channelNotifyPropsDesktop = Default+ , channelNotifyPropsMarkUnread = Default+ }+ newtype BoolString = BoolString { fromBoolString :: Bool } instance A.FromJSON BoolString where@@ -286,23 +310,27 @@ "false" -> return (BoolString False) _ -> fail "Expected \"true\" or \"false\"" -instance A.FromJSON NotifyProps where- parseJSON = A.withObject "NotifyProps" $ \v -> do- notifyPropsMentionKeys <- T.split (==',') <$>- (v .:? "mention_keys" .!= "")- notifyPropsEmail <- fmap fromBoolString <$>- (v .:? "email" .!= IsValue (BoolString True))- notifyPropsPush <- v .:? "push" .!= IsValue NotifyOptionMention- notifyPropsDesktop <- v .:? "desktop" .!= IsValue NotifyOptionAll- notifyPropsDesktopSound <- fmap fromBoolString <$>- (v .:? "desktop_sound" .!= IsValue (BoolString True))- notifyPropsChannel <- fmap fromBoolString <$>- (v .:? "channel" .!= IsValue (BoolString True))- notifyPropsFirstName <- fmap fromBoolString <$>- (v .:? "first_name" .!= IsValue (BoolString False))- notifyPropsMarkUnread <- v .:? "mark_unread" .!= IsValue NotifyOptionAll- return NotifyProps { .. }+instance A.FromJSON UserNotifyProps where+ parseJSON = A.withObject "UserNotifyProps" $ \v -> do+ userNotifyPropsMentionKeys <- T.split (==',') <$>+ (v .:? "mention_keys" .!= "")+ userNotifyPropsPush <- v .:? "push" .!= NotifyOptionMention+ userNotifyPropsDesktop <- v .:? "desktop" .!= NotifyOptionAll+ userNotifyPropsEmail <- fromBoolString <$> (v .:? "email" .!= BoolString True)+ userNotifyPropsDesktopSound <- fromBoolString <$> (v .:? "desktop_sound" .!= BoolString True)+ userNotifyPropsChannel <- fromBoolString <$> (v .:? "channel" .!= BoolString True)+ userNotifyPropsFirstName <- fromBoolString <$> (v .:? "first_name" .!= BoolString False)+ return UserNotifyProps { .. } +instance A.FromJSON ChannelNotifyProps where+ parseJSON = A.withObject "ChannelNotifyProps" $ \v -> do+ channelNotifyPropsEmail <- fmap fromBoolString <$>+ (v .:? "email" .!= IsValue (BoolString True))+ channelNotifyPropsPush <- v .:? "push" .!= IsValue NotifyOptionMention+ channelNotifyPropsDesktop <- v .:? "desktop" .!= IsValue NotifyOptionAll+ channelNotifyPropsMarkUnread <- v .:? "mark_unread" .!= IsValue NotifyOptionAll+ return ChannelNotifyProps { .. }+ -- newtype ChannelId = CI { unCI :: Id }@@ -373,7 +401,7 @@ , channelDataLastViewedAt :: UTCTime , channelDataMsgCount :: Int , channelDataMentionCount :: Int- , channelDataNotifyProps :: NotifyProps+ , channelDataNotifyProps :: ChannelNotifyProps , channelDataLastUpdateAt :: UTCTime } deriving (Read, Show, Eq) @@ -461,7 +489,7 @@ , userFirstName :: Text , userLastName :: Text , userRoles :: Text- , userNotifyProps :: NotifyProps+ , userNotifyProps :: UserNotifyProps , userLastPasswordUpdate :: Maybe UTCTime , userLastPictureUpdate :: Maybe UTCTime , userLocale :: Text@@ -482,7 +510,7 @@ userFirstName <- o .: "first_name" userLastName <- o .: "last_name" userRoles <- o .: "roles"- userNotifyProps <- o .:? "notify_props" .!= emptyNotifyProps+ userNotifyProps <- o .:? "notify_props" .!= emptyUserNotifyProps userLastPasswordUpdate <- (millisecondsToUTCTime <$>) <$> (o .:? "last_password_update") userLastPictureUpdate <- (millisecondsToUTCTime <$>) <$> (o .:? "last_picture_update")@@ -949,6 +977,7 @@ data PreferenceCategory = PreferenceCategoryDirectChannelShow+ | PreferenceCategoryGroupChannelShow | PreferenceCategoryTutorialStep | PreferenceCategoryAdvancedSettings | PreferenceCategoryFlaggedPost@@ -963,6 +992,7 @@ 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@@ -976,6 +1006,7 @@ 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"@@ -1029,6 +1060,24 @@ , "name" .= preferenceName , "value" .= preferenceValue ]++data GroupChannelPreference =+ GroupChannelPreference { groupChannelId :: ChannelId+ , groupChannelShow :: Bool+ } deriving (Read, Show, Eq)++-- | Attempt to expose a 'Preference' as a 'FlaggedPost'+preferenceToGroupChannelPreference :: Preference -> Maybe GroupChannelPreference+preferenceToGroupChannelPreference+ Preference+ { preferenceCategory = PreferenceCategoryGroupChannelShow+ , preferenceName = PreferenceName name+ , preferenceValue = PreferenceValue value+ } = Just GroupChannelPreference+ { groupChannelId = CI (Id name)+ , groupChannelShow = value == "true"+ }+preferenceToGroupChannelPreference _ = Nothing data FlaggedPost = FlaggedPost { flaggedPostUserId :: UserId
src/Network/Mattermost/Types/Base.hs view
@@ -27,7 +27,9 @@ = HttpRequest RequestMethod String (Maybe A.Value) | HttpResponse Int String (Maybe A.Value) | WebSocketRequest A.Value- | WebSocketResponse A.Value+ | WebSocketResponse (Either String A.Value)+ -- ^ Left means we got an exception trying to parse the response;+ -- Right means we succeeded and here it is. | WebSocketPing | WebSocketPong deriving (Eq, Show)
src/Network/Mattermost/WebSocket.hs view
@@ -13,7 +13,7 @@ import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay) import qualified Control.Concurrent.STM.TQueue as Queue-import Control.Exception (Exception, SomeException, catch, throwIO, throwTo)+import Control.Exception (Exception, SomeException, catch, throwIO, throwTo, try) import Control.Monad (forever) import Control.Monad.STM (atomically) import Data.Aeson (toJSON)@@ -105,7 +105,7 @@ loop (n+1) mmWithWebSocket :: Session- -> (WebsocketEvent -> IO ())+ -> (Either String WebsocketEvent -> IO ()) -> (MMWebSocket -> IO ()) -> IO () mmWithWebSocket (Session cd (Token tk)) recv body = do@@ -118,9 +118,17 @@ let action c = do pId <- forkIO (pingThread onPing c `catch` cleanup) mId <- forkIO $ flip catch cleanup $ forever $ do- p <- WS.receiveData c- doLog (WebSocketResponse (toJSON p))- recv p+ result <- try $ do+ v <- WS.receiveData c+ v `seq` return v+ val <- case result of+ Left (WS.ParseException e) -> return $ Left e+ Left e -> throwIO e+ Right ws -> return $ Right ws+ doLog (WebSocketResponse $ case val of+ Left s -> Left s+ Right v -> Right $ toJSON v)+ recv val body (MMWS c health) `catch` propagate [mId, pId] WS.runClientWithStream stream (T.unpack $ cdHostname cd)
src/Network/Mattermost/WebSocket/Types.hs view
@@ -63,6 +63,7 @@ | WMChannelViewed | WMChannelUpdated | WMEmojiAdded+ | WMUserRoleUpdated deriving (Read, Show, Eq, Ord) instance FromJSON WebsocketEventType where@@ -94,6 +95,7 @@ "channel_viewed" -> return WMChannelViewed "channel_updated" -> return WMChannelUpdated "emoji_added" -> return WMEmojiAdded+ "user_role_updated" -> return WMUserRoleUpdated _ -> fail ("Unknown websocket message: " ++ show s) instance ToJSON WebsocketEventType where@@ -124,6 +126,7 @@ toJSON WMChannelViewed = "channel_viewed" toJSON WMChannelUpdated = "channel_updated" toJSON WMEmojiAdded = "emoji_added"+ toJSON WMUserRoleUpdated = "user_role_updated" --
test/Tests/Util.hs view
@@ -124,8 +124,9 @@ print_ $ "Authenticated as " ++ T.unpack (username login) chan <- gets tsWebsocketChan doneMVar <- gets tsDone+ printFunc <- gets tsPrinter void $ liftIO $ forkIO $ mmWithWebSocket session- (STM.atomically . STM.writeTChan chan)+ (either printFunc (STM.atomically . STM.writeTChan chan)) (const $ takeMVar doneMVar) modify $ \ts -> ts { tsSession = Just session }