mattermost-api 50200.3.0 → 50200.4.0
raw patch · 9 files changed
+198/−87 lines, 9 files
Files
- CHANGELOG.md +40/−5
- mattermost-api.cabal +1/−1
- src/Network/Mattermost.hs +1/−1
- src/Network/Mattermost/Endpoints.hs +31/−31
- src/Network/Mattermost/Types.hs +16/−31
- src/Network/Mattermost/Types/Internal.hs +8/−1
- src/Network/Mattermost/Util.hs +15/−7
- src/Network/Mattermost/WebSocket.hs +41/−10
- src/Network/Mattermost/WebSocket/Types.hs +45/−0
CHANGELOG.md view
@@ -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.
mattermost-api.cabal view
@@ -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
src/Network/Mattermost.hs view
@@ -26,6 +26,7 @@ , ChannelData(..) , ChannelId(..) , Channels+, ConnectionType(..) , MinChannel(..) , UsersCreate(..) , Post(..)@@ -59,7 +60,6 @@ , defaultConnectionPoolConfig , mkConnectionData , initConnectionData-, initConnectionDataInsecure , mmCloseSession , mmLogin , mmCreateDirect
src/Network/Mattermost/Endpoints.hs view
@@ -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+ ] -- --
src/Network/Mattermost/Types.hs view
@@ -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
src/Network/Mattermost/Types/Internal.hs view
@@ -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 }
src/Network/Mattermost/Util.hs view
@@ -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
src/Network/Mattermost/WebSocket.hs view
@@ -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
src/Network/Mattermost/WebSocket/Types.hs view
@@ -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