From a4ea8a9a23377c8e528cce0051b17bf4bb9affd6 Mon Sep 17 00:00:00 2001 From: Sergey Kazenyuk Date: Wed, 11 Mar 2026 03:00:21 +0100 Subject: [PATCH] Update login API, use DeriveGeneric, remove aeson-casing --- matrix-client.cabal | 1 - src/Network/Matrix/Client.hs | 10 ++---- src/Network/Matrix/Internal.hs | 61 +++++++++++++++++++++------------- src/Network/Matrix/Room.hs | 5 ++- 4 files changed, 42 insertions(+), 35 deletions(-) diff --git a/matrix-client.cabal b/matrix-client.cabal index aaa081a..e15bb33 100644 --- a/matrix-client.cabal +++ b/matrix-client.cabal @@ -32,7 +32,6 @@ source-repository head common common-options build-depends: aeson >=1.0.0.0 && <3, - aeson-casing >=0.2.0.0 && <0.3.0.0, base >=4.11.0.0 && <5, ghc-options: diff --git a/src/Network/Matrix/Client.hs b/src/Network/Matrix/Client.hs index c1d951b..d3e9f2d 100644 --- a/src/Network/Matrix/Client.hs +++ b/src/Network/Matrix/Client.hs @@ -141,8 +141,6 @@ import Control.Applicative import Control.Monad (mzero) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object, String), encode, genericParseJSON, genericToJSON, object, withObject, withText, (.:), (.:?), (.=)) -import qualified Data.Aeson as Aeson -import Data.Aeson.Casing (aesonPrefix, snakeCase) import Data.Aeson.Types (Parser) import Data.Bifunctor (bimap) import qualified Data.ByteString as B @@ -177,8 +175,9 @@ data LoginCredentials = LoginCredentials } mkLoginRequest :: LoginCredentials -> IO HTTP.Request -mkLoginRequest LoginCredentials{..} = - mkLoginRequest' lBaseUrl lDeviceId lInitialDeviceDisplayName lUsername lLoginSecret +mkLoginRequest LoginCredentials{..} = let + enableRefreshTokens = False + in mkLoginRequest' lBaseUrl lDeviceId lInitialDeviceDisplayName enableRefreshTokens lUsername lLoginSecret -- | 'login' allows you to generate a session token. login :: LoginCredentials -> IO ClientSession @@ -926,9 +925,6 @@ defaultEventFilter = EventFilter Nothing Nothing Nothing Nothing Nothing eventFilterAll :: EventFilter eventFilterAll = defaultEventFilter{efLimit = Just 0, efNotTypes = Just ["*"]} -aesonOptions :: Aeson.Options -aesonOptions = (aesonPrefix snakeCase){Aeson.omitNothingFields = True} - instance ToJSON EventFilter where toJSON = genericToJSON aesonOptions diff --git a/src/Network/Matrix/Internal.hs b/src/Network/Matrix/Internal.hs index d17ee6b..0a84e68 100644 --- a/src/Network/Matrix/Internal.hs +++ b/src/Network/Matrix/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} @@ -7,6 +8,7 @@ -- | This module contains low-level HTTP utility module Network.Matrix.Internal where +import GHC.Generics (Generic) import Control.Concurrent (threadDelay) import Control.Exception (Exception, throw, throwIO) import Control.Monad (mzero, unless, void) @@ -14,7 +16,7 @@ import Control.Monad.Catch (Handler (Handler), MonadMask) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Retry (RetryStatus (..)) import qualified Control.Retry as Retry -import Data.Aeson (FromJSON (..), FromJSONKey (..), Value (Object), eitherDecode, encode, object, withObject, (.:), (.:?), (.=)) +import Data.Aeson (FromJSON (..), FromJSONKey (..), Value (Object), eitherDecode, encode, object, (.:), (.=), defaultOptions, Options (..), camelTo2, genericParseJSON) import Data.ByteString.Lazy (ByteString, toStrict) import Data.Hashable (Hashable) import Data.Maybe (catMaybes, fromMaybe) @@ -27,6 +29,7 @@ import Network.HTTP.Types (Status (..)) import Network.HTTP.Types.Status (statusIsSuccessful) import System.Environment (getEnv) import System.IO (stderr) +import Data.Char (isUpper) newtype MatrixToken = MatrixToken Text newtype Username = Username {username :: Text} @@ -34,20 +37,18 @@ newtype DeviceId = DeviceId {deviceId :: Text} newtype InitialDeviceDisplayName = InitialDeviceDisplayName {initialDeviceDisplayName :: Text} data LoginSecret = Password Text | Token Text +-- https://spec.matrix.org/v1.17/client-server-api/#post_matrixclientv3login data LoginResponse = LoginResponse - { lrUserId :: Text - , lrAccessToken :: Text - , lrHomeServer :: Maybe Text + { lrAccessToken :: Text , lrDeviceId :: Text - } + , lrExpiresInMs :: Maybe Int -- Added in v1.3 + , lrHomeServer :: Maybe Text + , lrRefreshToken :: Maybe Text -- Added in v1.3 + , lrUserId :: Text + } deriving (Generic, Show) instance FromJSON LoginResponse where - parseJSON = withObject "LoginResponse" $ \v -> do - userId' <- v .: "user_id" - accessToken' <- v .: "access_token" - homeServer' <- v .:? "home_server" - deviceId' <- v .: "device_id" - pure $ LoginResponse userId' accessToken' homeServer' deviceId' + parseJSON = genericParseJSON aesonOptions getTokenFromEnv :: -- | The envirnoment variable name @@ -85,9 +86,10 @@ mkRequest' baseUrl (MatrixToken token) auth path = do authHeaders = [("Authorization", "Bearer " <> encodeUtf8 token) | auth] -mkLoginRequest' :: Text -> Maybe DeviceId -> Maybe InitialDeviceDisplayName -> Username -> LoginSecret -> IO HTTP.Request -mkLoginRequest' baseUrl did idn (Username name) secret' = do - let path = "/_matrix/client/r0/login" +-- https://spec.matrix.org/v1.17/client-server-api/#post_matrixclientv3login +mkLoginRequest' :: Text -> Maybe DeviceId -> Maybe InitialDeviceDisplayName -> Bool -> Username -> LoginSecret -> IO HTTP.Request +mkLoginRequest' baseUrl did idn enableRefreshTokens (Username name) secret' = do + let path = "/_matrix/client/v3/login" initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) let (secretKey, secret, secretType) = case secret' of @@ -100,6 +102,7 @@ mkLoginRequest' baseUrl did idn (Username name) secret' = do object $ [ "identifier" .= object ["type" .= ("m.id.user" :: Text), "user" .= name] , secretKey .= secret + , "refresh_token" .= enableRefreshTokens -- Added in v1.3 , "type" .= (secretType :: Text) ] <> catMaybes @@ -111,7 +114,7 @@ mkLoginRequest' baseUrl did idn (Username name) secret' = do mkLogoutRequest' :: Text -> MatrixToken -> IO HTTP.Request mkLogoutRequest' baseUrl (MatrixToken token) = do - let path = "/_matrix/client/r0/logout" + let path = "/_matrix/client/v3/logout" initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) let headers = [("Authorization", encodeUtf8 $ "Bearer " <> token)] pure $ initRequest{HTTP.method = "POST", HTTP.requestHeaders = headers} @@ -145,20 +148,15 @@ data MatrixError = MatrixError , meError :: Text , meRetryAfterMS :: Maybe Int } - deriving (Show, Eq) + deriving (Generic, Show, Eq) + +instance FromJSON MatrixError where + parseJSON = genericParseJSON aesonOptions data MatrixException = MatrixRateLimit deriving (Show) instance Exception MatrixException -instance FromJSON MatrixError where - parseJSON (Object v) = - MatrixError - <$> v .: "errcode" - <*> v .: "error" - <*> v .:? "retry_after_ms" - parseJSON _ = mzero - -- | 'MatrixIO' is a convenient type alias for server response type MatrixIO a = MatrixM IO a @@ -211,3 +209,18 @@ retryWithLog limit logRetry action = retry :: (MonadIO m, MonadMask m) => MatrixM m a -> MatrixM m a retry = retryWithLog 7 (liftIO . hPutStrLn stderr) + +------------------------------------------------------------------------------- +-- Utils + +aesonOptions :: Options +aesonOptions = defaultOptions + { fieldLabelModifier = camelTo2 '_' . dropPrefix + , omitNothingFields = True + } + where + -- drops lower case prefix + dropPrefix :: String -> String + dropPrefix [] = [] + dropPrefix (x:xs) | isUpper x = x : xs + | otherwise = dropPrefix xs diff --git a/src/Network/Matrix/Room.hs b/src/Network/Matrix/Room.hs index 27cc17b..9d42524 100644 --- a/src/Network/Matrix/Room.hs +++ b/src/Network/Matrix/Room.hs @@ -4,9 +4,8 @@ -- | Matrix room related data types module Network.Matrix.Room (RoomCreatePreset (..), RoomCreateRequest (..)) where +import Network.Matrix.Internal (aesonOptions) import Data.Aeson (ToJSON (..), Value (..), genericToJSON) -import qualified Data.Aeson as Aeson -import Data.Aeson.Casing (aesonPrefix, snakeCase) import Data.Text (Text) import GHC.Generics (Generic) @@ -32,4 +31,4 @@ data RoomCreateRequest = RoomCreateRequest deriving (Eq, Show, Generic) instance ToJSON RoomCreateRequest where - toJSON = genericToJSON $ (aesonPrefix snakeCase){Aeson.omitNothingFields = True} + toJSON = genericToJSON aesonOptions