diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Changelog -## 0.1.0.0 (next) +## 0.1.1.0 + +- Ensure aeson encoding test is reproducible using aeson-pretty +- Increase retry delay up to 2 minutes +- Add leaveRoomById client function +- Add joinRoom client function +- Handle 400s error message returned by the API +- Handle rate limit response in the retry helper + +## 0.1.0.0 - Initial release diff --git a/matrix-client.cabal b/matrix-client.cabal --- a/matrix-client.cabal +++ b/matrix-client.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: matrix-client -version: 0.1.0.0 +version: 0.1.1.0 synopsis: A matrix client library description: Matrix client is a library to interface with https://matrix.org. @@ -51,6 +51,7 @@ , hashable , http-client >= 0.5.0 && < 0.8 , http-client-tls >= 0.2.0 && < 0.4 + , http-types >= 0.10.0 && < 0.13 , retry ^>= 0.8 , text >= 0.11.1.0 && < 1.3 , time @@ -71,8 +72,10 @@ hs-source-dirs: test, src main-is: Spec.hs build-depends: base - , matrix-client + , aeson-pretty , hspec >= 2 + , matrix-client + , text test-suite doctest type: exitcode-stdio-1.0 diff --git a/src/Network/Matrix/Client.hs b/src/Network/Matrix/Client.hs --- a/src/Network/Matrix/Client.hs +++ b/src/Network/Matrix/Client.hs @@ -28,7 +28,9 @@ -- * Room membership RoomID (..), getJoinedRooms, + joinRoom, joinRoomById, + leaveRoomById, ) where @@ -36,7 +38,9 @@ import Data.Aeson (FromJSON (..), Value (Object), encode, (.:)) import Data.Hashable (Hashable) import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Types.URI (urlEncode) import Network.Matrix.Events import Network.Matrix.Internal @@ -110,7 +114,25 @@ response <- doRequest session request pure $ unRooms <$> response +-- | Note that this API takes either a room ID or alias, unlike 'joinRoomById' +joinRoom :: ClientSession -> Text -> MatrixIO RoomID +joinRoom session roomName = do + request <- mkRequest session True $ "/_matrix/client/r0/join/" <> roomNameUrl + doRequest session (request {HTTP.method = "POST"}) + where + roomNameUrl = decodeUtf8 . urlEncode True . encodeUtf8 $ roomName + joinRoomById :: ClientSession -> RoomID -> MatrixIO RoomID joinRoomById session (RoomID roomId) = do request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/join" doRequest session (request {HTTP.method = "POST"}) + +leaveRoomById :: ClientSession -> RoomID -> MatrixIO () +leaveRoomById session (RoomID roomId) = do + request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/leave" + fmap ensureEmptyObject <$> doRequest session (request {HTTP.method = "POST"}) + where + ensureEmptyObject :: Value -> () + ensureEmptyObject value = case value of + Object xs | xs == mempty -> () + _anyOther -> error $ "Unknown leave response: " <> show value diff --git a/src/Network/Matrix/Internal.hs b/src/Network/Matrix/Internal.hs --- a/src/Network/Matrix/Internal.hs +++ b/src/Network/Matrix/Internal.hs @@ -1,22 +1,26 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} -- | This module contains low-level HTTP utility module Network.Matrix.Internal where -import Control.Monad (mzero) -import Control.Monad.Catch (Handler (Handler), MonadMask) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, throw, throwIO) +import Control.Monad (mzero, unless, void) +import Control.Monad.Catch (Handler (Handler)) import Control.Retry (RetryStatus (..)) import qualified Control.Retry as Retry import Data.Aeson (FromJSON (..), Value (Object), eitherDecode, (.:), (.:?)) -import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy (ByteString, toStrict) +import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.IO (hPutStrLn) import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types (Status (..)) import System.Environment (getEnv) import System.IO (stderr) @@ -31,13 +35,28 @@ mkManager :: IO HTTP.Manager mkManager = HTTP.newManager tlsManagerSettings +checkMatrixResponse :: HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO () +checkMatrixResponse req res = + unless (200 <= code && code < 500) $ do + chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024 + throwResponseError req res chunk + where + Status code _ = HTTP.responseStatus res + +throwResponseError :: HTTP.Request -> HTTP.Response body -> ByteString -> IO a +throwResponseError req res chunk = + throwIO $ HTTP.HttpExceptionRequest req ex + where + ex = HTTP.StatusCodeException (void res) (toStrict chunk) + mkRequest' :: Text -> MatrixToken -> Bool -> Text -> IO HTTP.Request mkRequest' baseUrl (MatrixToken token) auth path = do initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) pure $ initRequest { HTTP.requestHeaders = - [("Content-Type", "application/json")] <> authHeaders + [("Content-Type", "application/json")] <> authHeaders, + HTTP.checkResponse = checkMatrixResponse } where authHeaders = @@ -46,14 +65,16 @@ doRequest' :: FromJSON a => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a) doRequest' manager request = do response <- HTTP.httpLbs request manager - pure $ decodeResp (HTTP.responseBody response) + case decodeResp (HTTP.responseBody response) of + Nothing -> throwResponseError request response (HTTP.responseBody response) + Just a -> pure a -decodeResp :: FromJSON a => ByteString -> Either MatrixError a +decodeResp :: FromJSON a => ByteString -> Maybe (Either MatrixError a) decodeResp resp = case eitherDecode resp of - Right a -> pure a - Left err -> case eitherDecode resp of - Right me -> Left me - Left _ -> error $ "Could not decode: " <> err + Right a -> Just $ pure a + Left _ -> case eitherDecode resp of + Right me -> Just $ Left me + Left _ -> Nothing newtype UserID = UserID Text deriving (Show, Eq) @@ -68,6 +89,10 @@ } deriving (Show, Eq) +data MatrixException = MatrixRateLimit deriving (Show) + +instance Exception MatrixException + instance FromJSON MatrixError where parseJSON (Object v) = MatrixError @@ -80,27 +105,41 @@ type MatrixIO a = IO (Either MatrixError a) -- | Retry 5 times network action, doubling backoff each time -retry :: (MonadMask m, MonadIO m) => m a -> m a -retry action = +retry' :: Int -> (Text -> IO ()) -> MatrixIO a -> MatrixIO a +retry' limit logRetry action = Retry.recovering - (Retry.exponentialBackoff backoff <> Retry.limitRetries 5) - [handler] - (const action) + (Retry.exponentialBackoff backoff <> Retry.limitRetries limit) + [handler, rateLimitHandler] + (const checkAction) where - backoff = 500000 -- 500ms + checkAction = do + res <- action + case res of + Left (MatrixError "M_LIMIT_EXCEEDED" err delayMS) -> do + -- Reponse contains a retry_after_ms + logRetry $ "RateLimit: " <> err <> " (delay: " <> pack (show delayMS) <> ")" + threadDelay $ fromMaybe 5_000 delayMS * 1000 + throw MatrixRateLimit + _ -> pure res + + backoff = 1000000 -- 1sec + rateLimitHandler _ = Handler $ \case + MatrixRateLimit -> pure True -- Log network error handler (RetryStatus num _ _) = Handler $ \case HTTP.HttpExceptionRequest req ctx -> do let url = decodeUtf8 (HTTP.host req) <> ":" <> pack (show (HTTP.port req)) <> decodeUtf8 (HTTP.path req) arg = decodeUtf8 $ HTTP.queryString req loc = if num == 0 then url <> arg else url - liftIO $ - hPutStrLn stderr $ - "NetworkFailure: " - <> pack (show num) - <> "/5 " - <> loc - <> " failed: " - <> pack (show ctx) + logRetry $ + "NetworkFailure: " + <> pack (show num) + <> "/5 " + <> loc + <> " failed: " + <> pack (show ctx) pure True HTTP.InvalidUrlException _ _ -> pure False + +retry :: MatrixIO a -> MatrixIO a +retry = retry' 7 (hPutStrLn stderr) diff --git a/src/Network/Matrix/Tutorial.hs b/src/Network/Matrix/Tutorial.hs --- a/src/Network/Matrix/Tutorial.hs +++ b/src/Network/Matrix/Tutorial.hs @@ -21,6 +21,9 @@ -- * Create a session -- $session + + -- * Lookup identity + -- $identity ) where @@ -53,3 +56,18 @@ -- > > sess <- createSession "https://matrix.org" token -- > > getTokenOwner sess -- > Right (WhoAmI "@tristanc_:matrix.org") + +-- $identity +-- To use the Identity api you need another token. Get it by running these commands: +-- +-- > $ MATRIX_OPENID=$(curl -XPOST https://matrix.org/_matrix/client/r0/user/${USER}/openid/request_token -H "Authorization: Bearer ${MATRIX_TOKEN}" -d '{}') +-- > $ export MATRIX_IDENTITY_TOKEN=$(curl -XPOST https://matrix.org/_matrix/identity/v2/account/register -d "${MATRIX_OPENID}" | jq -r '.access_token') +-- +-- Then here is how to lookup a matrix identity: +-- +-- > > import Network.Matrix.Identity +-- > > tokenId <- getTokenFromEnv "MATRIX_IDENTITY_TOKEN" +-- > > sessId <- createIdentitySession "https://matrix.org" tokenId +-- > > Right hd <- hashDetails sessId +-- > > identityLookup sessId hd (Email "tdecacqu@redhat.com") +-- > Right (Just (UserID "@tristanc_:matrix.org")) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -- | The matrix client specification tests module Main (main) where -import Data.Aeson (encode) +import Control.Monad (void) +import qualified Data.Aeson.Encode.Pretty as Aeson +import Data.Text (Text) +import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Network.Matrix.Client -import Network.Matrix.Events import Network.Matrix.Internal import Test.Hspec @@ -14,12 +17,42 @@ spec :: Spec spec = describe "unit tests" $ do + it "decode unknown" $ + (decodeResp "" :: Maybe (Either MatrixError String)) + `shouldBe` Nothing it "decode error" $ - (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Either MatrixError String) - `shouldBe` Left (MatrixError "TEST" "a error" Nothing) + (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Maybe (Either MatrixError String)) + `shouldBe` (Just . Left $ MatrixError "TEST" "a error" Nothing) it "decode response" $ decodeResp "{\"user_id\": \"@tristanc_:matrix.org\"}" - `shouldBe` Right (UserID "@tristanc_:matrix.org") + `shouldBe` (Just . Right $ UserID "@tristanc_:matrix.org") it "encode room message" $ - encode (RoomMessageText (MessageText "Hello" Nothing Nothing)) - `shouldBe` "{\"msgtype\":\"m.text\",\"body\":\"Hello\"}" + encodePretty (RoomMessageText (MessageText "Hello" Nothing Nothing)) + `shouldBe` "{\"body\":\"Hello\",\"msgtype\":\"m.text\"}" + it "does not retry on success" $ + checkPause (<=) $ do + let resp = Right True + res <- retry (pure resp) + res `shouldBe` resp + it "does not retry on regular failre" $ + checkPause (<=) $ do + let resp = Left $ MatrixError "test" "error" Nothing + res <- (retry (pure resp) :: MatrixIO Int) + res `shouldBe` resp + it "retry on rate limit failure" $ + checkPause (>=) $ do + let resp = Left $ MatrixError "M_LIMIT_EXCEEDED" "error" (Just 1000) + (retry' 1 (const $ pure ()) (pure resp) :: MatrixIO Int) + `shouldThrow` rateLimitSelector + where + rateLimitSelector :: MatrixException -> Bool + rateLimitSelector MatrixRateLimit = True + checkPause op action = do + MkSystemTime start _ <- getSystemTime + void action + MkSystemTime end _ <- getSystemTime + (end - start) `shouldSatisfy` (`op` 1) + encodePretty = + Aeson.encodePretty' + ( Aeson.defConfig {Aeson.confIndent = Aeson.Spaces 0, Aeson.confCompare = compare @Text} + )