diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ + +50200.5.0 +========= + +API changes: + * Added support for making connections to Mattermost servers that use + non-root URL paths for their API endpoints. This change adds a new + field, `cdUrlPath`, to the `ConnectionData` type. It also added a URL + path argument of type `Text` to `mkConnectionData`. (Thanks Isaiah + Mindich) + * Added `Network.Mattermost.Endpoints.mmGetLimitedClientConfiguration` + (thanks Eric Mertens) + 50200.4.0 ========= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,26 +1,29 @@ [![Hackage](https://img.shields.io/hackage/v/mattermost-api.svg)](https://hackage.haskell.org/package/mattermost-api) [![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, written in +Haskell. + # Testing -We use the MaterMost docker image for detecting changes in the API. See +We use the MatterMost docker image for detecting changes in the API. See `.travis.yml` or the [Mattermost docs](https://docs.mattermost.com/install/docker-local-machine.html#one-line-docker-install) for the details. -If you are testing your changes locally during development, you will want to run -the script `./test/local_test_mm.sh`. +If you are testing your changes locally during development, you will +want to run the script `./test/local_test_mm.sh`. -**Note: The `local_test_mm.sh` script will stop and remove a docker container -named `mattermost-preview`.** +**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 -is because the scripts currently assume they can create an initial admin user.** +**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 -HTTP.** +**Note: The scripts assume the instance is reachable on `localhost:8065` +over plain HTTP.** For use in production we use TLS, but for testing purposes we avoid the certificate setup. @@ -33,4 +36,3 @@ 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. - diff --git a/examples/Config.hs b/examples/Config.hs --- a/examples/Config.hs +++ b/examples/Config.hs @@ -10,4 +10,5 @@ , configTeam :: UserText , configPort :: Int , configPassword :: Text + , configPath :: Text } diff --git a/examples/GetChannels.hs b/examples/GetChannels.hs --- a/examples/GetChannels.hs +++ b/examples/GetChannels.hs @@ -22,7 +22,8 @@ main = do config <- getConfig -- see LocalConfig import cd <- initConnectionData (configHostname config) - (fromIntegral (configPort config)) defaultConnectionPoolConfig + (fromIntegral (configPort config)) (configPath config) + (ConnectHTTPS True) defaultConnectionPoolConfig let login = Login { username = configUsername config , password = configPassword config diff --git a/examples/GetPosts.hs b/examples/GetPosts.hs --- a/examples/GetPosts.hs +++ b/examples/GetPosts.hs @@ -98,8 +98,8 @@ opts <- foldl (>>=) (return defaultOptions) actions config <- getConfig -- see LocalConfig import - cd' <- initConnectionData (configHostname config) (fromIntegral (configPort config)) - defaultConnectionPoolConfig + cd' <- initConnectionData (configHostname config) (fromIntegral (configPort config)) (configPath config) + (ConnectHTTPS True) defaultConnectionPoolConfig let login = Login { username = configUsername config , password = configPassword config } diff --git a/examples/GetTeams.hs b/examples/GetTeams.hs --- a/examples/GetTeams.hs +++ b/examples/GetTeams.hs @@ -18,8 +18,8 @@ main :: IO () main = do config <- getConfig -- see LocalConfig import - cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) - defaultConnectionPoolConfig + cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) (configPath config) + (ConnectHTTPS True) defaultConnectionPoolConfig let login = Login { username = configUsername config , password = configPassword config diff --git a/examples/GetWebsocketConnection.hs b/examples/GetWebsocketConnection.hs --- a/examples/GetWebsocketConnection.hs +++ b/examples/GetWebsocketConnection.hs @@ -53,8 +53,8 @@ opts <- foldl (>>=) (return defaultOptions) actions config <- getConfig -- see LocalConfig import - cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) - defaultConnectionPoolConfig + cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) (configPath config) + (ConnectHTTPS True) defaultConnectionPoolConfig let login = Login { username = configUsername config , password = configPassword config @@ -67,7 +67,7 @@ mmWithWebSocket session printEvent checkForExit -printEvent :: Either String WebsocketEvent -> IO () +printEvent :: Either String (Either WebsocketActionResponse 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 @@ -16,4 +16,5 @@ , configTeam = UserText "TEAMNAME" , configPort = 443 -- currently we only support HTTPS , configPassword = T.pack pass + , configPath = T.empty } diff --git a/examples/MakePost.hs b/examples/MakePost.hs --- a/examples/MakePost.hs +++ b/examples/MakePost.hs @@ -74,8 +74,8 @@ opts <- foldl (>>=) (return defaultOptions) actions config <- getConfig -- see LocalConfig import - cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) - defaultConnectionPoolConfig + cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) (configPath config) + (ConnectHTTPS True) defaultConnectionPoolConfig let login = Login { username = configUsername config , password = configPassword config diff --git a/examples/ShowRawEvents.hs b/examples/ShowRawEvents.hs --- a/examples/ShowRawEvents.hs +++ b/examples/ShowRawEvents.hs @@ -63,8 +63,8 @@ opts <- foldl (>>=) (return defaultOptions) actions config <- getConfig -- see LocalConfig import - cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) - defaultConnectionPoolConfig + cd <- initConnectionData (configHostname config) (fromIntegral (configPort config)) (configPath config) + (ConnectHTTPS True) defaultConnectionPoolConfig let login = Login { username = configUsername config , password = configPassword config @@ -78,7 +78,7 @@ mmWithWebSocket session printEvent checkForExit -printEvent :: Either String WebsocketEvent -> IO () +printEvent :: Either String (Either WebsocketActionResponse 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: 50200.4.0 +version: 50200.5.0 synopsis: Client API for Mattermost chat system description: Client API for Mattermost chat system. Mattermost is a @@ -63,6 +63,7 @@ , HTTP , http-media , network-uri + , modern-uri , text , time , unordered-containers diff --git a/src/Network/Mattermost/Connection.hs b/src/Network/Mattermost/Connection.hs --- a/src/Network/Mattermost/Connection.hs +++ b/src/Network/Mattermost/Connection.hs @@ -102,7 +102,8 @@ -> B.ByteString -> IO HTTP.Response_String submitRequest cd mToken method uri payload = do - path <- mmPath ("/api/v4" ++ uri) + path <- buildPath cd (T.pack uri) + parsedPath <- mmPath $ T.unpack path let contentLength = B.length payload authHeader = case mToken of @@ -110,7 +111,7 @@ Just token -> [HTTP.mkHeader HTTP.HdrAuthorization ("Bearer " ++ getTokenString token)] request = HTTP.Request - { HTTP.rqURI = path + { HTTP.rqURI = parsedPath , HTTP.rqMethod = method , HTTP.rqHeaders = authHeader <> 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 @@ -1003,6 +1003,13 @@ mmGetClientConfiguration format = inGet (printf "/config/client?%s" (mkQueryString [ sequence ("format", fmap T.unpack format) ])) noBody jsonResponse +-- | Limited version of 'mmGetClientConfiguration' that doesn't need a session ID. +mmGetLimitedClientConfiguration :: ConnectionData -> IO LimitedClientConfig +mmGetLimitedClientConfiguration cd = + doUnauthRequest cd HTTP.GET url noBody >>= jsonResponse + where + url = printf "/config/client?%s" (mkQueryString [sequence ("format", Just "old")]) + -- -- | Reload the configuration file to pick up on any changes made to it. -- -- -- -- /Permissions/: Must have @manage_system@ permission. 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 @@ -68,10 +68,11 @@ maybeFail p = (Just <$> p) <|> (return Nothing) -- | 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 +mkConnectionData :: Hostname -> Port -> T.Text -> Pool.Pool MMConn -> ConnectionType -> ConnectionContext -> ConnectionData +mkConnectionData host port path pool connTy ctx = ConnectionData { cdHostname = host , cdPort = port + , cdUrlPath = path , cdConnectionCtx = ctx , cdAutoClose = No , cdConnectionPool = pool @@ -85,11 +86,11 @@ Pool.createPool (mkConnection ctx host port connTy >>= newMMConn) closeMMConn (cpStripesCount cpc) (cpIdleConnTimeout cpc) (cpMaxConnCount cpc) -initConnectionData :: Hostname -> Port -> ConnectionType -> ConnectionPoolConfig -> IO ConnectionData -initConnectionData host port connTy cpc = do +initConnectionData :: Hostname -> Port -> T.Text -> ConnectionType -> ConnectionPoolConfig -> IO ConnectionData +initConnectionData host port path connTy cpc = do ctx <- initConnectionContext pool <- createPool host port ctx cpc connTy - return (mkConnectionData host port pool connTy ctx) + return (mkConnectionData host port path pool connTy ctx) destroyConnectionData :: ConnectionData -> IO () destroyConnectionData = Pool.destroyAllResources . cdConnectionPool diff --git a/src/Network/Mattermost/Types/Config.hs b/src/Network/Mattermost/Types/Config.hs --- a/src/Network/Mattermost/Types/Config.hs +++ b/src/Network/Mattermost/Types/Config.hs @@ -282,6 +282,24 @@ , clientConfigDiagnosticsEnabled :: T.Text } deriving (Read, Show, Eq) +data LimitedClientConfig = LimitedClientConfig + { limitedClientConfigVersion :: T.Text + , limitedClientConfigBuildNumber :: T.Text + , limitedClientConfigBuildDate :: T.Text + , limitedClientConfigBuildHash :: T.Text + , limitedClientConfigBuildHashEnterprise :: T.Text + , limitedClientConfigBuildEnterpriseReady :: T.Text + } deriving (Read, Show, Eq) + +instance A.FromJSON LimitedClientConfig where + parseJSON = A.withObject "LimitedClientConfig" $ \o -> do + limitedClientConfigVersion <- o A..: "Version" + limitedClientConfigBuildNumber <- o A..: "BuildNumber" + limitedClientConfigBuildDate <- o A..: "BuildDate" + limitedClientConfigBuildHash <- o A..: "BuildHash" + limitedClientConfigBuildHashEnterprise <- o A..: "BuildHashEnterprise" + limitedClientConfigBuildEnterpriseReady <- o A..: "BuildEnterpriseReady" + return LimitedClientConfig { .. } instance A.FromJSON ClientConfig where parseJSON = A.withObject "ClientConfig" $ \o -> do 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 @@ -18,6 +18,7 @@ import qualified Network.HTTP.Stream as HTTP import qualified Data.ByteString.Char8 as B import Network.Mattermost.Types.Base +import qualified Data.Text as T data Token = Token String deriving (Read, Show, Eq, Ord) @@ -83,6 +84,7 @@ = ConnectionData { cdHostname :: Hostname , cdPort :: Port + , cdUrlPath :: T.Text , cdAutoClose :: AutoClose , cdConnectionPool :: Pool MMConn , cdConnectionCtx :: C.ConnectionContext 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 @@ -10,12 +10,15 @@ , withConnection , mkConnection , connectionGetExact +, buildPath ) where import Control.Exception (finally, onException) import Data.Char ( toUpper ) import qualified Data.ByteString.Char8 as B import qualified Data.Text as T +import qualified Text.URI as URI +import Data.Monoid ((<>)) import Control.Exception ( Exception , throwIO ) @@ -90,7 +93,7 @@ ConnectHTTP -> Nothing ConnectHTTPS requireTrustedCert -> -- The first argument to TLSSettingsSimple is whether to - -- *disable* cert validation. If requireTrustedCert is True, + -- /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 @@ -115,3 +118,10 @@ | otherwise = do next <- connectionGet con (n - y) loop (B.append bs next) (y + (B.length next)) + +-- | Build a full URI path from the path of an API endpoint +buildPath :: ConnectionData -> T.Text -> IO T.Text +buildPath cd endpoint = do + let rawPath = "/" <> (T.dropWhile (=='/') $ cdUrlPath cd <> "/api/v4/" <> endpoint) + uri <- URI.mkURI rawPath + return $ URI.render uri 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 @@ -162,9 +162,10 @@ ) recv val body (MMWS c health) `catch` propagate [mId, pId] + path <- buildPath cd "/websocket" WS.runClientWithStream stream (T.unpack $ cdHostname cd) - "/api/v4/websocket" + (T.unpack path) WS.defaultConnectionOptions { WS.connectionOnPong = onPong } [ ("Authorization", "Bearer " <> B.pack tk) ] action diff --git a/test/Tests/Util.hs b/test/Tests/Util.hs --- a/test/Tests/Util.hs +++ b/test/Tests/Util.hs @@ -133,7 +133,7 @@ doneMVar <- gets tsDone printFunc <- gets tsPrinter void $ liftIO $ forkIO $ mmWithWebSocket session - (either printFunc (STM.atomically . STM.writeTChan chan)) + (either printFunc (either (\_ -> pure()) (STM.atomically . STM.writeTChan chan))) (const $ takeMVar doneMVar) modify $ \ts -> ts { tsSession = Just session } @@ -330,8 +330,8 @@ connectFromConfig :: TestConfig -> IO ConnectionData connectFromConfig cfg = - initConnectionDataInsecure (configHostname cfg) (fromIntegral (configPort cfg)) - defaultConnectionPoolConfig + initConnectionData (configHostname cfg) (fromIntegral (configPort cfg)) T.empty ConnectHTTP + defaultConnectionPoolConfig getConnection :: TestM ConnectionData getConnection = gets tsConnectionData