diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog +## 0.1.9.0 + +- Add support for login API v3 [#50](https://github.com/softwarefactory-project/matrix-client-haskell/pull/50) + ## 0.1.8.0 - Add support for reaction [#48](https://github.com/softwarefactory-project/matrix-client-haskell/pull/48) 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.8.0 +version: 0.1.9.0 synopsis: A matrix client library description: Matrix client is a library to interface with https://matrix.org. @@ -32,7 +32,6 @@ 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 --- a/src/Network/Matrix/Client.hs +++ b/src/Network/Matrix/Client.hs @@ -141,8 +141,6 @@ 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 @@ } 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 @@ -925,9 +924,6 @@ -- | A filter that should match 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 --- 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.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 (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 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 @@ 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 @@ 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 @@ 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 @@ , 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 @@ 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 --- 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 @@ deriving (Eq, Show, Generic) instance ToJSON RoomCreateRequest where - toJSON = genericToJSON $ (aesonPrefix snakeCase){Aeson.omitNothingFields = True} + toJSON = genericToJSON aesonOptions