diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ========= diff --git a/examples/GetWebsocketConnection.hs b/examples/GetWebsocketConnection.hs --- a/examples/GetWebsocketConnection.hs +++ b/examples/GetWebsocketConnection.hs @@ -68,7 +68,7 @@ mmWithWebSocket session printEvent checkForExit -printEvent :: WebsocketEvent -> IO () +printEvent :: Either String WebsocketEvent -> IO () printEvent we = pPrint we checkForExit :: MMWebSocket -> IO () diff --git a/examples/LocalConfig.hs b/examples/LocalConfig.hs --- a/examples/LocalConfig.hs +++ b/examples/LocalConfig.hs @@ -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 } diff --git a/examples/ShowRawEvents.hs b/examples/ShowRawEvents.hs --- a/examples/ShowRawEvents.hs +++ b/examples/ShowRawEvents.hs @@ -79,7 +79,7 @@ mmWithWebSocket session printEvent checkForExit -printEvent :: WebsocketEvent -> IO () +printEvent :: Either String WebsocketEvent -> IO () printEvent e = pPrint e checkForExit :: MMWebSocket -> IO () 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: 40000.1.0 +version: 40400.0.0 synopsis: Client API for Mattermost chat system description: Client API for Mattermost chat system license: BSD3 diff --git a/src/Network/Mattermost.hs b/src/Network/Mattermost.hs --- a/src/Network/Mattermost.hs +++ b/src/Network/Mattermost.hs @@ -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 diff --git a/src/Network/Mattermost/Lenses.hs b/src/Network/Mattermost/Lenses.hs --- a/src/Network/Mattermost/Lenses.hs +++ b/src/Network/Mattermost/Lenses.hs @@ -24,8 +24,11 @@ -- * 'TeamMember' lenses suffixLenses ''TeamMember --- * 'NotifyProps' lenses -suffixLenses ''NotifyProps +-- * 'UserNotifyProps' lenses +suffixLenses ''UserNotifyProps + +-- * 'ChannelNotifyProps' lenses +suffixLenses ''ChannelNotifyProps -- * 'Channel' lenses suffixLenses ''Channel 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 @@ -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 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 @@ -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) 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 @@ -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) 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 @@ -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" -- diff --git a/test/Tests/Util.hs b/test/Tests/Util.hs --- a/test/Tests/Util.hs +++ b/test/Tests/Util.hs @@ -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 }