diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,44 @@ +50200.4.0 +========= + * The post pinning API is now supported. + * Adds a new postPinned field to the Post type to allow parsing + "is_pinned" values in post editing websocket events. Typically + "is_pinned" is not present in post structures, in which case this + will take the value Nothing. + * Exposes the new StatusOK type that is returned by new API functions. + * Adds new API functions: + * mmPinPostToChannel + * mmUnpinPostToChannel + * mmGetChannelPinnedPosts + + * The library now supports connecting to HTTPS endpoints without valid + certificates. + + This change gets rid of the initConnectionDataInsecure function + and instead makes initConnectionData take a new argument of type + 'ConnectionType' that describes how the connection should be made. + + The ConnectionType type indicates that a connection should be HTTP, + HTTPS with cert validation, or HTTPS without cert validation. + + This change also modified ConnectionData to carry the connecion type + rather than just a Bool indicating HTTP/HTTPS. + + * Websocket action responses are now parsed properly. + + Websocket actions, such as "user typing" notifications, generate + server responses that we previously could not parse. We weren't + parsing them because the parser for websocket events wasn't aware + of an alternative response message structure. This patch adds a new + type for action responses. It adds a new type rather than adding a + new constructor to the event type because I think that's a less ugly + API (the API in this patch is not ideal). This patch also adds logic + to the websocket response parser to first attempt to parse incoming + messages as websocket events (the most common case) and then fall + back to attempting a parse as a websocket action response. If both + fail, the message and the parse exceptions are all logged. + 50200.3.0 ========= @@ -403,8 +443,3 @@ ========= Initial release for server version 3.6.0. - -0.1.0.0 -======= - -First version. 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.3.0 +version: 50200.4.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 @@ -26,6 +26,7 @@ , ChannelData(..) , ChannelId(..) , Channels +, ConnectionType(..) , MinChannel(..) , UsersCreate(..) , Post(..) @@ -59,7 +60,6 @@ , defaultConnectionPoolConfig , mkConnectionData , initConnectionData -, initConnectionDataInsecure , mmCloseSession , mmLogin , mmCreateDirect diff --git a/src/Network/Mattermost/Endpoints.hs b/src/Network/Mattermost/Endpoints.hs --- a/src/Network/Mattermost/Endpoints.hs +++ b/src/Network/Mattermost/Endpoints.hs @@ -154,10 +154,10 @@ mmCreateDirectMessageChannel body = inPost "/channels/direct" (jsonBody body) jsonResponse --- -- | Get a list of pinned posts for channel. --- mmGetChannelsPinnedPosts :: ChannelId -> Session -> IO PostList --- mmGetChannelsPinnedPosts channelId = --- inGet (printf "/channels/%s/pinned" channelId) noBody jsonResponse +-- | Get a list of pinned posts for channel. +mmGetChannelPinnedPosts :: ChannelId -> Session -> IO Posts +mmGetChannelPinnedPosts channelId = + inGet (printf "/channels/%s/pinned" channelId) noBody jsonResponse -- | Get statistics for a channel. -- @@ -666,14 +666,14 @@ mmSearchForTeamPosts teamId body = inPost (printf "/teams/%s/posts/search" teamId) (jsonBody body) jsonResponse --- -- | Pin a post to a channel it is in based from the provided post id --- -- string. --- -- --- -- /Permissions/: Must be authenticated and have the @read_channel@ --- -- permission to the channel the post is in. --- mmPinPostToChannel :: PostId -> Session -> IO () --- mmPinPostToChannel postId = --- inPost (printf "/posts/%s/pin" postId) noBody jsonResponse +-- | Pin a post to a channel it is in based from the provided post id +-- string. +-- +-- /Permissions/: Must be authenticated and have the @read_channel@ +-- permission to the channel the post is in. +mmPinPostToChannel :: PostId -> Session -> IO StatusOK +mmPinPostToChannel postId = + inPost (printf "/posts/%s/pin" postId) noBody jsonResponse -- | Get a post and the rest of the posts in the same thread. -- @@ -741,14 +741,14 @@ , sequence ("per_page", fmap show flaggedPostsQueryPerPage) ] --- -- | Unpin a post to a channel it is in based from the provided post id --- -- string. --- -- --- -- /Permissions/: Must be authenticated and have the @read_channel@ --- -- permission to the channel the post is in. --- mmUnpinPostToChannel :: PostId -> Session -> IO () --- mmUnpinPostToChannel postId = --- inPost (printf "/posts/%s/unpin" postId) noBody jsonResponse +-- | Unpin a post to a channel it is in based from the provided post id +-- string. +-- +-- /Permissions/: Must be authenticated and have the @read_channel@ +-- permission to the channel the post is in. +mmUnpinPostToChannel :: PostId -> Session -> IO StatusOK +mmUnpinPostToChannel postId = + inPost (printf "/posts/%s/unpin" postId) noBody jsonResponse -- | Partially update a post by providing only the fields you want to -- update. Omitted fields will not be updated. The fields that can be @@ -2957,19 +2957,19 @@ -- -- --- newtype StatusOK = StatusOK --- { statusOKStatus :: Text --- } deriving (Read, Show, Eq) +newtype StatusOK = StatusOK + { statusOKStatus :: Text + } deriving (Read, Show, Eq) --- instance A.FromJSON StatusOK where --- parseJSON = A.withObject "statusOK" $ \v -> do --- statusOKStatus <- v A..: "status" --- return StatusOK { .. } +instance A.FromJSON StatusOK where + parseJSON = A.withObject "statusOK" $ \v -> do + statusOKStatus <- v A..: "status" + return StatusOK { .. } --- instance A.ToJSON StatusOK where --- toJSON StatusOK { .. } = A.object --- [ "status" A..= statusOKStatus --- ] +instance A.ToJSON StatusOK where + toJSON StatusOK { .. } = A.object + [ "status" A..= statusOKStatus + ] -- -- 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 @@ -8,6 +8,7 @@ module Network.Mattermost.Types ( module Network.Mattermost.Types , module Network.Mattermost.Types.Base + , ConnectionType(..) ) where @@ -41,7 +42,7 @@ ) import Network.Mattermost.Types.Base import Network.Mattermost.Types.Internal -import Network.Mattermost.Util (mkConnection) +import Network.Mattermost.Util (mkConnection, ConnectionType(..)) newtype UserText = UserText Text deriving (Eq, Show, Ord, Read) @@ -66,22 +67,9 @@ maybeFail :: Parser a -> Parser (Maybe a) maybeFail p = (Just <$> p) <|> (return Nothing) --- | Creates a structure representing a TLS connection to the server. -mkConnectionData :: Hostname -> Port -> Pool.Pool MMConn -> ConnectionContext -> ConnectionData -mkConnectionData host port pool ctx = ConnectionData - { cdHostname = host - , cdPort = port - , cdConnectionCtx = ctx - , cdAutoClose = No - , cdConnectionPool = pool - , cdToken = Nothing - , cdLogger = Nothing - , cdUseTLS = True - } - --- | Plaintext HTTP instead of a TLS connection. -mkConnectionDataInsecure :: Hostname -> Port -> ConnectionContext -> Pool.Pool MMConn -> ConnectionData -mkConnectionDataInsecure host port ctx pool = ConnectionData +-- | Creates a structure representing a connection to the server. +mkConnectionData :: Hostname -> Port -> Pool.Pool MMConn -> ConnectionType -> ConnectionContext -> ConnectionData +mkConnectionData host port pool connTy ctx = ConnectionData { cdHostname = host , cdPort = port , cdConnectionCtx = ctx @@ -89,25 +77,19 @@ , cdConnectionPool = pool , cdToken = Nothing , cdLogger = Nothing - , cdUseTLS = False + , cdConnectionType = connTy } -createPool :: Hostname -> Port -> ConnectionContext -> ConnectionPoolConfig -> Bool -> IO (Pool.Pool MMConn) -createPool host port ctx cpc secure = - Pool.createPool (mkConnection ctx host port secure >>= newMMConn) closeMMConn +createPool :: Hostname -> Port -> ConnectionContext -> ConnectionPoolConfig -> ConnectionType -> IO (Pool.Pool MMConn) +createPool host port ctx cpc connTy = + Pool.createPool (mkConnection ctx host port connTy >>= newMMConn) closeMMConn (cpStripesCount cpc) (cpIdleConnTimeout cpc) (cpMaxConnCount cpc) -initConnectionData :: Hostname -> Port -> ConnectionPoolConfig -> IO ConnectionData -initConnectionData host port cpc = do - ctx <- initConnectionContext - pool <- createPool host port ctx cpc True - return (mkConnectionData host port pool ctx) - -initConnectionDataInsecure :: Hostname -> Port -> ConnectionPoolConfig -> IO ConnectionData -initConnectionDataInsecure host port cpc = do +initConnectionData :: Hostname -> Port -> ConnectionType -> ConnectionPoolConfig -> IO ConnectionData +initConnectionData host port connTy cpc = do ctx <- initConnectionContext - pool <- createPool host port ctx cpc False - return (mkConnectionDataInsecure host port ctx pool) + pool <- createPool host port ctx cpc connTy + return (mkConnectionData host port pool connTy ctx) destroyConnectionData :: ConnectionData -> IO () destroyConnectionData = Pool.destroyAllResources . cdConnectionPool @@ -801,6 +783,7 @@ , postCreateAt :: ServerTime , postChannelId :: ChannelId , postHasReactions :: Bool + , postPinned :: Maybe Bool } deriving (Read, Show, Eq) instance HasId Post PostId where @@ -824,6 +807,7 @@ postCreateAt <- timeFromServer <$> v .: "create_at" postChannelId <- v .: "channel_id" postHasReactions <- v .:? "has_reactions" .!= False + postPinned <- v .:? "is_pinned" return Post { .. } instance A.ToJSON Post where @@ -843,6 +827,7 @@ , "create_at" .= timeToServer postCreateAt , "channel_id" .= postChannelId , "has_reactions" .= postHasReactions + , "is_pinned" .= postPinned ] data PendingPost diff --git a/src/Network/Mattermost/Types/Internal.hs b/src/Network/Mattermost/Types/Internal.hs --- a/src/Network/Mattermost/Types/Internal.hs +++ b/src/Network/Mattermost/Types/Internal.hs @@ -72,6 +72,13 @@ close con = C.connectionClose (fromMMConn con) closeOnEnd _ _ = return () +data ConnectionType = + ConnectHTTPS Bool + -- ^ Boolean is whether to require trusted certificate + | ConnectHTTP + -- ^ Make an insecure connection over HTTP + deriving (Eq, Show, Read) + data ConnectionData = ConnectionData { cdHostname :: Hostname @@ -81,5 +88,5 @@ , cdConnectionCtx :: C.ConnectionContext , cdToken :: Maybe Token , cdLogger :: Maybe Logger - , cdUseTLS :: Bool + , cdConnectionType :: ConnectionType } diff --git a/src/Network/Mattermost/Util.hs b/src/Network/Mattermost/Util.hs --- a/src/Network/Mattermost/Util.hs +++ b/src/Network/Mattermost/Util.hs @@ -2,7 +2,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.Mattermost.Util -( assertE +( ConnectionType(..) +, assertE , noteE , hoistE , (~=) @@ -74,17 +75,24 @@ -- * Only SOCKS version 4 and 5 proxies are supported using socks4:// -- and socks5:// URIs, and -- * No proxy authentication is supported. -mkConnection :: ConnectionContext -> Hostname -> Port -> Bool -> IO Connection -mkConnection ctx host port secure = do - proxy' <- if secure then proxyForScheme HTTPS else return Nothing +mkConnection :: ConnectionContext -> Hostname -> Port -> ConnectionType -> IO Connection +mkConnection ctx host port connTy = do + proxy' <- case connTy of + ConnectHTTPS _ -> proxyForScheme HTTPS + ConnectHTTP -> return Nothing + canUseProxy <- proxyHostPermitted (T.unpack host) let proxy = if canUseProxy then proxy' else Nothing connectTo ctx $ ConnectionParams { connectionHostname = T.unpack host , connectionPort = fromIntegral port - , connectionUseSecure = if secure - then Just (TLSSettingsSimple False False False) - else Nothing + , connectionUseSecure = case connTy of + ConnectHTTP -> Nothing + ConnectHTTPS requireTrustedCert -> + -- The first argument to TLSSettingsSimple is whether to + -- *disable* cert validation. If requireTrustedCert is True, + -- we want that argument to be False to force validation. + Just (TLSSettingsSimple (not requireTrustedCert) False False) , connectionUseSocks = do (ty, cHost, cPort) <- proxy case ty of 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 @@ -14,7 +14,7 @@ import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay) import qualified Control.Concurrent.STM.TQueue as Queue -import Control.Exception (Exception, SomeException, catch, throwIO, throwTo, try) +import Control.Exception (Exception, SomeException, catch, throwIO, throwTo, try, evaluate) import Control.Monad (forever) import Control.Monad.STM (atomically) import Data.Aeson (toJSON) @@ -106,11 +106,11 @@ loop (n+1) mmWithWebSocket :: Session - -> (Either String WebsocketEvent -> IO ()) + -> (Either String (Either WebsocketActionResponse WebsocketEvent) -> IO ()) -> (MMWebSocket -> IO ()) -> IO () mmWithWebSocket (Session cd (Token tk)) recv body = do - con <- mkConnection (cdConnectionCtx cd) (cdHostname cd) (cdPort cd) (cdUseTLS cd) + con <- mkConnection (cdConnectionCtx cd) (cdHostname cd) (cdPort cd) (cdConnectionType cd) stream <- connectionToStream con health <- newIORef 0 myId <- myThreadId @@ -119,16 +119,47 @@ let action c = do pId <- forkIO (pingThread onPing c `catch` cleanup) mId <- forkIO $ flip catch cleanup $ forever $ do - result <- try $ do - v <- WS.receiveData c - v `seq` return v + result :: Either SomeException WS.DataMessage + <- try $ do + msg <- WS.receiveDataMessage c + msg `seq` return msg + val <- case result of - Left (WS.ParseException e) -> return $ Left e - Left e -> throwIO e - Right ws -> return $ Right ws + Left e -> do + doLog $ WebSocketResponse $ Right $ toJSON $ + "Got exception on receiveDataMessage: " <> show e + throwIO e + Right dataMsg -> do + -- The message could be either a websocket event or + -- an action response. Those have different Haskell + -- types, so we need to attempt to parse each. + evResult <- try $ evaluate $ WS.fromDataMessage dataMsg + case evResult of + Right wev -> return $ Right $ Right wev + Left (e1::SomeException) -> do + respResult <- try $ evaluate $ WS.fromDataMessage dataMsg + case respResult of + Right actionResp -> return $ Right $ Left actionResp + Left (e2::SomeException) -> do + doLog $ WebSocketResponse $ Left $ + "Failed to parse (exceptions following): " <> show dataMsg + doLog $ WebSocketResponse $ Left $ + "Failed to parse as a websocket event: " <> show e1 + doLog $ WebSocketResponse $ Left $ + "Failed to parse as a websocket action response: " <> show e2 + -- Log both exceptions, but throw + -- the second. This isn't great + -- because we don't know which + -- exception is the *right* one. The + -- best we can do is throw one of + -- them and log both. + throwIO e2 + doLog (WebSocketResponse $ case val of Left s -> Left s - Right v -> Right $ toJSON v) + Right (Left v) -> Right $ toJSON v + Right (Right v) -> Right $ toJSON v + ) recv val body (MMWS c health) `catch` propagate [mId, pId] WS.runClientWithStream stream 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} @@ -8,6 +9,8 @@ , WEData(..) , WEBroadcast(..) , WebsocketAction(..) +, WebsocketActionResponse(..) +, WebsocketActionStatus(..) ) where import Control.Applicative @@ -20,6 +23,9 @@ ) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ( (<>) ) +#endif import Data.ByteString.Lazy (fromStrict, toStrict) import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.HashMap.Strict as HM @@ -293,4 +299,43 @@ instance WebSocketsData WebsocketAction where fromDataMessage _ = error "Not implemented" fromLazyByteString _ = error "Not implemented" + toLazyByteString = A.encode + +data WebsocketActionStatus = + WebsocketActionStatusOK + deriving (Read, Show, Eq, Ord) + +instance FromJSON WebsocketActionStatus where + parseJSON = A.withText "WebsocketActionStatus" $ \t -> + case t of + "OK" -> return WebsocketActionStatusOK + _ -> fail $ "Invalid WebsocketActionStatus: " <> show t + +instance ToJSON WebsocketActionStatus where + toJSON WebsocketActionStatusOK = "OK" + +data WebsocketActionResponse = + WebsocketActionResponse { warStatus :: WebsocketActionStatus + , warSeqReply :: Int64 + } + deriving (Read, Show, Eq, Ord) + +instance FromJSON WebsocketActionResponse where + parseJSON = + A.withObject "WebsocketActionResponse" $ \o -> + WebsocketActionResponse <$> o A..: "status" + <*> o A..: "seq_reply" + +instance ToJSON WebsocketActionResponse where + toJSON (WebsocketActionResponse status s) = + A.object [ "status" A..= A.toJSON status + , "seq" A..= A.toJSON s + ] + +instance WebSocketsData WebsocketActionResponse where + fromDataMessage (WS.Text bs _) = fromLazyByteString bs + fromDataMessage (WS.Binary bs) = fromLazyByteString bs + fromLazyByteString s = case A.eitherDecode s of + Left err -> throw (JSONDecodeException err (BC.unpack s)) + Right v -> v toLazyByteString = A.encode