diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.1.0.0 (next) + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# matrix-client-haskell + +[![Hackage](https://img.shields.io/hackage/v/matrix-client.svg)](https://hackage.haskell.org/package/matrix-client) + +A client library for [matrix.org](https://matrix.org) + +## Contribute + +To work on this project you need a Haskell toolchain, for example on fedora: + +```ShellSession +$ sudo dnf install -y ghc cabal-install && cabal update +``` + +Run the tests: + +```ShellSession +$ cabal test +``` + +If you experience any difficulties, please don't hesistate to raise an issue. diff --git a/matrix-client.cabal b/matrix-client.cabal new file mode 100644 --- /dev/null +++ b/matrix-client.cabal @@ -0,0 +1,84 @@ +cabal-version: 2.4 +name: matrix-client +version: 0.1.0.0 +synopsis: A matrix client library +description: + Matrix client is a library to interface with https://matrix.org. + . + Use this library to interact with matrix server. + . + Read the "Network.Matrix.Tutorial" for a detailed tutorial. + . +homepage: https://github.com/softwarefactory-project/matrix-client-haskell#readme +bug-reports: https://github.com/softwarefactory-project/matrix-client-haskell/issues +license: Apache-2.0 +license-file: LICENSE +author: Tristan de Cacqueray +maintainer: tdecacqu@redhat.com +copyright: 2021 Red Hat +category: Network +build-type: Simple +extra-doc-files: CHANGELOG.md + README.md +tested-with: GHC == 8.10.4 + +source-repository head + type: git + location: https://github.com/softwarefactory-project/matrix-client-haskell.git + +common common-options + build-depends: base >= 4.11.0.0 && < 5 + , aeson >= 1.0.0.0 && < 1.6 + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + --write-ghc-environment-files=always + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + + default-language: Haskell2010 + +common lib-depends + build-depends: SHA ^>= 1.6 + , base64 + , bytestring + , exceptions + , hashable + , http-client >= 0.5.0 && < 0.8 + , http-client-tls >= 0.2.0 && < 0.4 + , retry ^>= 0.8 + , text >= 0.11.1.0 && < 1.3 + , time + , unordered-containers + +library + import: common-options, lib-depends + hs-source-dirs: src + exposed-modules: Network.Matrix.Client + , Network.Matrix.Identity + , Network.Matrix.Tutorial + other-modules: Network.Matrix.Events + , Network.Matrix.Internal + +test-suite unit + import: common-options, lib-depends + type: exitcode-stdio-1.0 + hs-source-dirs: test, src + main-is: Spec.hs + build-depends: base + , matrix-client + , hspec >= 2 + +test-suite doctest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -threaded -Wall + main-is: Doctest.hs + build-depends: base + , doctest >= 0.9.3 diff --git a/src/Network/Matrix/Client.hs b/src/Network/Matrix/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/Matrix/Client.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module contains the client-server API +-- https://matrix.org/docs/spec/client_server/r0.6.1 +module Network.Matrix.Client + ( -- * Client + ClientSession, + MatrixToken (..), + getTokenFromEnv, + createSession, + + -- * API + MatrixIO, + MatrixError (..), + retry, + + -- * User data + UserID (..), + getTokenOwner, + + -- * Room participation + TxnID (..), + sendMessage, + module Network.Matrix.Events, + + -- * Room membership + RoomID (..), + getJoinedRooms, + joinRoomById, + ) +where + +import Control.Monad (mzero) +import Data.Aeson (FromJSON (..), Value (Object), encode, (.:)) +import Data.Hashable (Hashable) +import Data.Text (Text) +import qualified Network.HTTP.Client as HTTP +import Network.Matrix.Events +import Network.Matrix.Internal + +-- $setup +-- >>> import Data.Aeson (decode) + +-- | The session record, use 'createSession' to create it. +data ClientSession = ClientSession + { baseUrl :: Text, + token :: MatrixToken, + manager :: HTTP.Manager + } + +-- | 'createSession' creates the session record. +createSession :: + -- | The matrix client-server base url, e.g. "https://matrix.org" + Text -> + -- | The user token + MatrixToken -> + IO ClientSession +createSession baseUrl' token' = ClientSession baseUrl' token' <$> mkManager + +mkRequest :: ClientSession -> Bool -> Text -> IO HTTP.Request +mkRequest ClientSession {..} = mkRequest' baseUrl token + +doRequest :: FromJSON a => ClientSession -> HTTP.Request -> MatrixIO a +doRequest ClientSession {..} = doRequest' manager + +-- | 'getTokenOwner' gets information about the owner of a given access token. +getTokenOwner :: ClientSession -> MatrixIO UserID +getTokenOwner session = + doRequest session =<< mkRequest session True "/_matrix/client/r0/account/whoami" + +newtype TxnID = TxnID Text deriving (Show, Eq) + +sendMessage :: ClientSession -> RoomID -> Event -> TxnID -> MatrixIO EventID +sendMessage session (RoomID roomId) event (TxnID txnId) = do + request <- mkRequest session True path + doRequest + session + ( request + { HTTP.method = "PUT", + HTTP.requestBody = HTTP.RequestBodyLBS $ encode event + } + ) + where + path = "/_matrix/client/r0/rooms/" <> roomId <> "/send/" <> eventId <> "/" <> txnId + eventId = eventType event + +newtype RoomID = RoomID Text deriving (Show, Eq, Hashable) + +instance FromJSON RoomID where + parseJSON (Object v) = RoomID <$> v .: "room_id" + parseJSON _ = mzero + +-- | A newtype wrapper to decoded nested list +-- +-- >>> decode "{\"joined_rooms\": [\"!foo:example.com\"]}" :: Maybe JoinedRooms +-- Just (JoinedRooms {unRooms = [RoomID "!foo:example.com"]}) +newtype JoinedRooms = JoinedRooms {unRooms :: [RoomID]} deriving (Show) + +instance FromJSON JoinedRooms where + parseJSON (Object v) = do + rooms <- v .: "joined_rooms" + pure . JoinedRooms $ RoomID <$> rooms + parseJSON _ = mzero + +getJoinedRooms :: ClientSession -> MatrixIO [RoomID] +getJoinedRooms session = do + request <- mkRequest session True "/_matrix/client/r0/joined_rooms" + response <- doRequest session request + pure $ unRooms <$> response + +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"}) diff --git a/src/Network/Matrix/Events.hs b/src/Network/Matrix/Events.hs new file mode 100644 --- /dev/null +++ b/src/Network/Matrix/Events.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Matrix event data type +module Network.Matrix.Events + ( MessageText (..), + RoomMessage (..), + Event (..), + EventID (..), + eventType, + ) +where + +import Control.Monad (mzero) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object), object, (.:), (.=)) +import Data.Aeson.Types (Pair) +import Data.Text (Text) + +data MessageText = MessageText + { mtBody :: Text, + mtFormat :: Maybe Text, + mtFormattedBody :: Maybe Text + } + deriving (Show, Eq) + +messageTextAttr :: MessageText -> [Pair] +messageTextAttr msg = + ["body" .= mtBody msg] <> format <> formattedBody + where + omitNull k vM = maybe [] (\v -> [k .= v]) vM + format = omitNull "format" $ mtFormat msg + formattedBody = omitNull "formatted_body" $ mtFormattedBody msg + +data RoomMessage + = RoomMessageText MessageText + | RoomMessageEmote MessageText + | RoomMessageNotice MessageText + deriving (Show, Eq) + +roomMessageType :: RoomMessage -> Text +roomMessageType roomMessage = case roomMessage of + RoomMessageText _ -> "m.text" + RoomMessageEmote _ -> "m.emote" + RoomMessageNotice _ -> "m.notice" + +instance ToJSON RoomMessage where + toJSON msg = + let msgtype = roomMessageType msg + attr = case msg of + RoomMessageText mt -> messageTextAttr mt + RoomMessageEmote mt -> messageTextAttr mt + RoomMessageNotice mt -> messageTextAttr mt + in object (["msgtype" .= msgtype] <> attr) + +newtype Event = EventRoomMessage RoomMessage + +instance ToJSON Event where + toJSON event = case event of + EventRoomMessage msg -> toJSON msg + +eventType :: Event -> Text +eventType event = case event of + EventRoomMessage _ -> "m.room.message" + +newtype EventID = EventID Text deriving (Show) + +instance FromJSON EventID where + parseJSON (Object v) = EventID <$> v .: "event_id" + parseJSON _ = mzero diff --git a/src/Network/Matrix/Identity.hs b/src/Network/Matrix/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Network/Matrix/Identity.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module contains the Identity service API +-- https://matrix.org/docs/spec/identity_service/r0.3.0.html +module Network.Matrix.Identity + ( -- * Client + IdentitySession, + MatrixToken (..), + getTokenFromEnv, + createIdentitySession, + + -- * API + MatrixIO, + MatrixError (..), + retry, + + -- * User data + UserID (..), + getIdentityTokenOwner, + + -- * Association lookup + HashDetails (..), + hashDetails, + Identity (..), + identityLookup, + HashedAddress, + IdentityLookupRequest, + IdentityLookupResponse, + identitiesLookup, + mkIdentityLookupRequest, + toHashedAddress, + lookupIdentity, + ) +where + +import Control.Monad (mzero) +import Data.Aeson (FromJSON (..), Value (Object, String), encode, object, (.:), (.=)) +import Data.ByteString.Lazy (fromStrict) +import Data.ByteString.Lazy.Base64.URL (encodeBase64Unpadded) +import Data.Digest.Pure.SHA (bytestringDigest, sha256) +import qualified Data.HashMap.Strict as HM +import Data.List (lookup) +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Text.Lazy (toStrict) +import qualified Network.HTTP.Client as HTTP +import Network.Matrix.Internal + +-- $setup +-- >>> import Data.Aeson (decode) + +-- | The session record, use 'createSession' to create it. +data IdentitySession = IdentitySession + { baseUrl :: Text, + token :: MatrixToken, + manager :: HTTP.Manager + } + +-- | 'createSession' creates the session record. +createIdentitySession :: + -- | The matrix identity base url, e.g. "https://matrix.org" + Text -> + -- | The user identity token + MatrixToken -> + IO IdentitySession +createIdentitySession baseUrl' token' = IdentitySession baseUrl' token' <$> mkManager + +mkRequest :: IdentitySession -> Bool -> Text -> IO HTTP.Request +mkRequest IdentitySession {..} = mkRequest' baseUrl token + +doRequest :: FromJSON a => IdentitySession -> HTTP.Request -> MatrixIO a +doRequest IdentitySession {..} = doRequest' manager + +-- | 'getIdentityTokenOwner' gets information about the owner of a given access token. +getIdentityTokenOwner :: IdentitySession -> MatrixIO UserID +getIdentityTokenOwner session = + doRequest session =<< mkRequest session True "/_matrix/identity/v2/account" + +data HashDetails = HashDetails + { hdAlgorithms :: NonEmpty Text, + hdPepper :: Text + } + deriving (Show, Eq) + +instance FromJSON HashDetails where + parseJSON (Object v) = HashDetails <$> v .: "algorithms" <*> v .: "lookup_pepper" + parseJSON _ = mzero + +hashDetails :: IdentitySession -> MatrixIO HashDetails +hashDetails session = + doRequest session =<< mkRequest session True "/_matrix/identity/v2/hash_details" + +-- | Use 'identityLookup' to lookup a single identity, otherwise uses the full 'identitiesLookup'. +identityLookup :: IdentitySession -> HashDetails -> Identity -> MatrixIO (Maybe UserID) +identityLookup session hd ident = do + fmap toUserIDM <$> identitiesLookup session ilr + where + toUserIDM = lookupIdentity address + address = toHashedAddress hd ident + ilr = mkIdentityLookupRequest hd [address] + +data IdentityLookupRequest = IdentityLookupRequest + { ilrHash :: Text, + ilrPepper :: Text, + ilrAddresses :: [HashedAddress] + } + deriving (Show, Eq) + +newtype HashedAddress = HashedAddress Text deriving (Show, Eq) + +-- | A newtype wrapper to decoded nested list +-- +-- >>> decode "{\"mappings\": {\"hash\": \"user\"}}" :: Maybe IdentityLookupResponse +-- Just (IdentityLookupResponse [(HashedAddress "hash",UserID "user")]) +newtype IdentityLookupResponse = IdentityLookupResponse [(HashedAddress, UserID)] + deriving (Show) + +instance FromJSON IdentityLookupResponse where + parseJSON (Object v) = do + mappings <- v .: "mappings" + case mappings of + (Object kv) -> pure . IdentityLookupResponse $ mapMaybe toTuple (HM.toList kv) + _ -> mzero + where + toTuple (k, String s) = Just (HashedAddress k, UserID s) + toTuple _ = Nothing + parseJSON _ = mzero + +identitiesLookup :: IdentitySession -> IdentityLookupRequest -> MatrixIO IdentityLookupResponse +identitiesLookup session ilr = do + request <- mkRequest session True "/_matrix/identity/v2/lookup" + doRequest + session + ( request + { HTTP.method = "POST", + HTTP.requestBody = HTTP.RequestBodyLBS body + } + ) + where + getAddr (HashedAddress x) = x + body = + encode $ + object + [ "addresses" .= map getAddr (ilrAddresses ilr), + "algorithm" .= ilrHash ilr, + "pepper" .= ilrPepper ilr + ] + +-- | Hash encoding for lookup +-- >>> encodeSHA256 "alice@example.com email matrixrocks" +-- "4kenr7N9drpCJ4AfalmlGQVsOn3o2RHjkADUpXJWZUc" +encodeSHA256 :: Text -> Text +encodeSHA256 = toStrict . encodeBase64Unpadded . bytestringDigest . sha256 . fromStrict . encodeUtf8 + +data Identity = Email Text | Msisdn Text deriving (Show, Eq) + +toHashedAddress :: HashDetails -> Identity -> HashedAddress +toHashedAddress hd ident = HashedAddress $ encodeSHA256 $ val <> " " <> hdPepper hd + where + val = case ident of + Email x -> x <> " email" + Msisdn x -> x <> " msisdn" + +mkIdentityLookupRequest :: HashDetails -> [HashedAddress] -> IdentityLookupRequest +mkIdentityLookupRequest hd = IdentityLookupRequest hash (hdPepper hd) + where + hash = + if "sha256" `elem` hdAlgorithms hd + then "sha256" + else error "Only sha256 is supported" + +lookupIdentity :: HashedAddress -> IdentityLookupResponse -> Maybe UserID +lookupIdentity x (IdentityLookupResponse xs) = Data.List.lookup x xs diff --git a/src/Network/Matrix/Internal.hs b/src/Network/Matrix/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Matrix/Internal.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE LambdaCase #-} +{-# 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.Retry (RetryStatus (..)) +import qualified Control.Retry as Retry +import Data.Aeson (FromJSON (..), Value (Object), eitherDecode, (.:), (.:?)) +import Data.ByteString.Lazy (ByteString) +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 System.Environment (getEnv) +import System.IO (stderr) + +newtype MatrixToken = MatrixToken Text + +getTokenFromEnv :: + -- | The envirnoment variable name + Text -> + IO MatrixToken +getTokenFromEnv env = MatrixToken . pack <$> getEnv (unpack env) + +mkManager :: IO HTTP.Manager +mkManager = HTTP.newManager tlsManagerSettings + +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 + } + where + authHeaders = + [("Authorization", "Bearer " <> encodeUtf8 token) | auth] + +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) + +decodeResp :: FromJSON a => ByteString -> 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 + +newtype UserID = UserID Text deriving (Show, Eq) + +instance FromJSON UserID where + parseJSON (Object v) = UserID <$> v .: "user_id" + parseJSON _ = mzero + +data MatrixError = MatrixError + { meErrcode :: Text, + meError :: Text, + meRetryAfterMS :: Maybe Int + } + deriving (Show, Eq) + +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 = 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.recovering + (Retry.exponentialBackoff backoff <> Retry.limitRetries 5) + [handler] + (const action) + where + backoff = 500000 -- 500ms + -- 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) + pure True + HTTP.InvalidUrlException _ _ -> pure False diff --git a/src/Network/Matrix/Tutorial.hs b/src/Network/Matrix/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Network/Matrix/Tutorial.hs @@ -0,0 +1,55 @@ +-- | The @matrix-client@ library provides a simple interface for interacting with Matrix servers. +-- +-- This tutorial introduces how to use the @matrix-client@ library. +-- +-- You will need a token to create a session, if you already have an account, you can get it with the @element@ client +-- by visiting the account @Settings@ page, @Help & About@ panel, then click @Access Token@. +-- +-- Alternatively, you can setup a test service by running these commands in a terminal: +-- +-- > git clone https://github.com/matrix-org/dendrite +-- > cd dendrite; ./build.sh; ./bin/generate-keys --private-key matrix_key.pem; cp dendrite-config.yaml dendrite.yaml +-- > ./bin/dendrite-monolith-server --config dendrite.yaml +-- > curl -XPOST http://localhost:8008/_matrix/client/r0/register -d'{"username": "tristanC", "password": "supersecret", "auth": {"type": "mlogin.dummy"}} +-- +-- To avoid manipulating the token directly, put it in your environment: +-- +-- > export MATRIX_TOKEN="THE_ACCESS_TOKEN" +module Network.Matrix.Tutorial + ( -- * Introduction + -- $intro + + -- * Create a session + -- $session + ) +where + +-- $intro +-- To start using this library you need a haskell toolchain, on fedora run: +-- +-- > $ sudo dnf install -y ghc cabal-install && cabal update +-- +-- Then get a copy of the library by running: +-- +-- > $ git clone https://github.com/softwarefactory-project/matrix-client-haskell +-- > $ cd matrix-client-haskell +-- +-- Start a REPL: +-- +-- > $ cabal repl +-- > Prelude> import Network.Matrix.Client +-- > Prelude Netowrk.Matrix.Client> :set prompt "> " +-- > > :set -XOverloadedStrings +-- > > :type getTokenOwner +-- > getTokenOwner :: ClientSession -> MatrixIO WhoAmI + +-- $session +-- Most functions require 'ClientSession' which carries the +-- endpoint url and the http client manager. +-- +-- The only way to get the client is through the 'Client.createSession' function: +-- +-- > > token <- getTokenFromEnv "MATRIX_TOKEN" +-- > > sess <- createSession "https://matrix.org" token +-- > > getTokenOwner sess +-- > Right (WhoAmI "@tristanc_:matrix.org") diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Test.DocTest + +main :: IO () +main = doctest ["src/", "-XOverloadedStrings"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The matrix client specification tests +module Main (main) where + +import Data.Aeson (encode) +import Network.Matrix.Client +import Network.Matrix.Events +import Network.Matrix.Internal +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "unit tests" $ do + it "decode error" $ + (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Either MatrixError String) + `shouldBe` Left (MatrixError "TEST" "a error" Nothing) + it "decode response" $ + decodeResp "{\"user_id\": \"@tristanc_:matrix.org\"}" + `shouldBe` Right (UserID "@tristanc_:matrix.org") + it "encode room message" $ + encode (RoomMessageText (MessageText "Hello" Nothing Nothing)) + `shouldBe` "{\"msgtype\":\"m.text\",\"body\":\"Hello\"}"