Update login API, use DeriveGeneric, remove aeson-casing

Author: nvmd

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:

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
 

src/Network/Matrix/Internal.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
@@ -7,14 +8,15 @@
 -- | 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)
 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,27 +29,26 @@ 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}
 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

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