├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── bin └── run-tests ├── flake.lock ├── flake.nix ├── matrix-client.cabal ├── src └── Network │ └── Matrix │ ├── Client.hs │ ├── Client │ └── Lens.hs │ ├── Events.hs │ ├── Identity.hs │ ├── Internal.hs │ ├── Room.hs │ └── Tutorial.hs └── test ├── Spec.hs └── data ├── message-edit.json └── message-reply.json /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'matrix-client.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250115 12 | # 13 | # REGENDATA ("0.19.20250115",["github","matrix-client.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.6.6 32 | compilerKind: ghc 33 | compilerVersion: 9.6.6 34 | setup-method: ghcup 35 | allow-failure: false 36 | fail-fast: false 37 | steps: 38 | - name: apt-get install 39 | run: | 40 | apt-get update 41 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 42 | - name: Install GHCup 43 | run: | 44 | mkdir -p "$HOME/.ghcup/bin" 45 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 46 | chmod a+x "$HOME/.ghcup/bin/ghcup" 47 | - name: Install cabal-install 48 | run: | 49 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 50 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 51 | - name: Install GHC (GHCup) 52 | if: matrix.setup-method == 'ghcup' 53 | run: | 54 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 55 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 56 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 57 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 58 | echo "HC=$HC" >> "$GITHUB_ENV" 59 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 60 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 61 | env: 62 | HCKIND: ${{ matrix.compilerKind }} 63 | HCNAME: ${{ matrix.compiler }} 64 | HCVER: ${{ matrix.compilerVersion }} 65 | - name: Set PATH and environment variables 66 | run: | 67 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 68 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 69 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 70 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 71 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 72 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 73 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 74 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 75 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 76 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 77 | env: 78 | HCKIND: ${{ matrix.compilerKind }} 79 | HCNAME: ${{ matrix.compiler }} 80 | HCVER: ${{ matrix.compilerVersion }} 81 | - name: env 82 | run: | 83 | env 84 | - name: write cabal config 85 | run: | 86 | mkdir -p $CABAL_DIR 87 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 120 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 121 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 122 | rm -f cabal-plan.xz 123 | chmod a+x $HOME/.cabal/bin/cabal-plan 124 | cabal-plan --version 125 | - name: checkout 126 | uses: actions/checkout@v4 127 | with: 128 | path: source 129 | - name: initial cabal.project for sdist 130 | run: | 131 | touch cabal.project 132 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 133 | cat cabal.project 134 | - name: sdist 135 | run: | 136 | mkdir -p sdist 137 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 138 | - name: unpack 139 | run: | 140 | mkdir -p unpacked 141 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 142 | - name: generate cabal.project 143 | run: | 144 | PKGDIR_matrix_client="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/matrix-client-[0-9.]*')" 145 | echo "PKGDIR_matrix_client=${PKGDIR_matrix_client}" >> "$GITHUB_ENV" 146 | rm -f cabal.project cabal.project.local 147 | touch cabal.project 148 | touch cabal.project.local 149 | echo "packages: ${PKGDIR_matrix_client}" >> cabal.project 150 | echo "package matrix-client" >> cabal.project 151 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 152 | cat >> cabal.project <> cabal.project.local 155 | cat cabal.project 156 | cat cabal.project.local 157 | - name: dump install plan 158 | run: | 159 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 160 | cabal-plan 161 | - name: restore cache 162 | uses: actions/cache/restore@v4 163 | with: 164 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 165 | path: ~/.cabal/store 166 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 167 | - name: install dependencies 168 | run: | 169 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 170 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 171 | - name: build w/o tests 172 | run: | 173 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 174 | - name: build 175 | run: | 176 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 177 | - name: tests 178 | run: | 179 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 180 | - name: cabal check 181 | run: | 182 | cd ${PKGDIR_matrix_client} || false 183 | ${CABAL} -vnormal check 184 | - name: haddock 185 | run: | 186 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 187 | - name: unconstrained build 188 | run: | 189 | rm -f cabal.project.local 190 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 191 | - name: save cache 192 | if: always() 193 | uses: actions/cache/save@v4 194 | with: 195 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 196 | path: ~/.cabal/store 197 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | ## 0.1.6.1 4 | 5 | - Use Unpadded base64 encoding, as it was done in v0.1.5.0 6 | 7 | ## 0.1.6.0 8 | 9 | - Support base64-1.0 10 | 11 | ## 0.1.5.0 12 | 13 | - Convert userDisplayName into a Maybe value [#30](https://github.com/softwarefactory-project/matrix-client-haskell/issues/30) 14 | - Improve empty response handling [#32](https://github.com/softwarefactory-project/matrix-client-haskell/issues/32) 15 | 16 | ## 0.1.4.3 17 | 18 | - Add missing export for Dir. 19 | 20 | ## 0.1.4.2 21 | 22 | - Support retry-0.9 23 | 24 | ## 0.1.4.1 25 | 26 | - Support aeson-2.0 27 | 28 | ## 0.1.4.0 29 | 30 | - Completes The Room API 31 | 32 | ## 0.1.3.0 33 | 34 | - Adds Lenses and Prisms 35 | - Adds login/logout functiosn for generating and destroying Matrix Tokens 36 | - Add functionality to set and retrieve non-room account data 37 | - Generalize retry to arbitrary MatrixM 38 | 39 | ## 0.1.2.0 40 | 41 | - Add filtering client function 42 | - Add sync client function 43 | - Add createRoom client function 44 | - Add retryWithLog and syncPoll utility function 45 | - Add mkReply helper utility function 46 | - Add reply and edit Event 47 | - Change MessageText to include the TextType 48 | - Change RoomEvent to use Author and EventID newtype 49 | 50 | ## 0.1.1.0 51 | 52 | - Ensure aeson encoding test is reproducible using aeson-pretty 53 | - Increase retry delay up to 2 minutes 54 | - Add leaveRoomById client function 55 | - Add joinRoom client function 56 | - Handle 400s error message returned by the API 57 | - Handle rate limit response in the retry helper 58 | 59 | ## 0.1.0.0 60 | 61 | - Initial release 62 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # matrix-client-haskell 2 | 3 | > [matrix] is an open network for secure, decentralized communication. 4 | 5 | This project contains Haskell libraries for [matrix.org](https://matrix.org). 6 | This allows you to rapidly integrate matrix events in your application. 7 | 8 | ## matrix-client 9 | 10 | [![Hackage](https://img.shields.io/hackage/v/matrix-client.svg)](https://hackage.haskell.org/package/matrix-client) 11 | 12 | A low level library to implements the [client-server spec](https://matrix.org/docs/spec/client_server/latest): 13 | 14 | ### Implemented 15 | 16 | - [x] Basic room membership to leave and join rooms 17 | - [x] Basic sync to read room's timeline 18 | - [x] Sending text events 19 | - [x] Identity lookup 20 | - [x] Invites 21 | 22 | ### Next/Missing 23 | 24 | - [ ] Rich messages 25 | - [ ] Decoders to support OLM with https://github.com/livmackintosh/matrix-sdk 26 | - [ ] The rest of the HTTP API... 27 | 28 | ## Contribute 29 | 30 | To work on this project you need a Haskell toolchain, for example on fedora: 31 | 32 | ```ShellSession 33 | $ sudo dnf install -y ghc cabal-install && cabal update 34 | ``` 35 | 36 | Run the tests: 37 | 38 | ```ShellSession 39 | $ ./bin/run-tests 40 | ``` 41 | 42 | Some tests requires a local matrix server, run integration service: 43 | 44 | ```ShellSession 45 | # In another terminal: 46 | $ nix develop -c conduit-start 47 | # Before running cabal test: 48 | $ export $(nix develop -c conduit-setup) 49 | $ cabal test all 50 | ``` 51 | 52 | Restart the commands to run the test on a fresh environment. 53 | 54 | If you experience any difficulties, please don't hesistate to raise an issue. 55 | -------------------------------------------------------------------------------- /bin/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh -e 2 | 3 | log() { 4 | /bin/echo -e "\n\x1b[1;33m[+] $*\x1b[0m"; 5 | } 6 | 7 | log "Building" 8 | cabal build -O0 --ghc-option=-Werror 9 | 10 | log "Testing" 11 | cabal test -O0 --test-show-details=direct 12 | cabal check 13 | 14 | log "Doctests" 15 | cabal repl --with-compiler=doctest --repl-options='-w -Wdefault -XOverloadedStrings' 16 | 17 | log "Formatting" 18 | fourmolu -i src/ test/ 19 | cabal-gild --io matrix-client.cabal 20 | nixfmt flake.nix 21 | 22 | log "Linting" 23 | hlint src/ test/ 24 | 25 | log "Check for diff" 26 | if [ ! -z "$(git status --porcelain)" ]; then 27 | git status 28 | exit 1 29 | fi 30 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1642700792, 6 | "narHash": "sha256-XqHrk7hFb+zBvRg6Ghl+AZDq03ov6OshJLiSWOoX5es=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "846b2ae0fc4cc943637d3d1def4454213e203cba", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "nixpkgs": { 19 | "locked": { 20 | "lastModified": 1735908276, 21 | "narHash": "sha256-U19gzGJFlGtyNonhg3jhhamQUex5ri3MgR1QKz6w/qg=", 22 | "owner": "NixOS", 23 | "repo": "nixpkgs", 24 | "rev": "d3780c92e64472e8f9aa54f7bbb0dd4483b98303", 25 | "type": "github" 26 | }, 27 | "original": { 28 | "owner": "NixOS", 29 | "repo": "nixpkgs", 30 | "rev": "d3780c92e64472e8f9aa54f7bbb0dd4483b98303", 31 | "type": "github" 32 | } 33 | }, 34 | "root": { 35 | "inputs": { 36 | "flake-utils": "flake-utils", 37 | "nixpkgs": "nixpkgs" 38 | } 39 | } 40 | }, 41 | "root": "root", 42 | "version": 7 43 | } 44 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | # Run tests with: 2 | # nix develop -c matrix-client-test 3 | { 4 | description = "The matrix-client library"; 5 | 6 | nixConfig.bash-prompt = "[nix]λ "; 7 | 8 | inputs = { 9 | nixpkgs.url = 10 | "github:NixOS/nixpkgs/d3780c92e64472e8f9aa54f7bbb0dd4483b98303"; 11 | flake-utils.url = "github:numtide/flake-utils"; 12 | }; 13 | 14 | outputs = { self, nixpkgs, flake-utils }: 15 | flake-utils.lib.eachSystem [ "x86_64-linux" ] (system: 16 | let 17 | config = { }; 18 | overlays = [ 19 | (final: prev: { 20 | myHaskellPackages = prev.haskellPackages.override { 21 | overrides = hpFinal: hpPrev: { 22 | base64 = hpPrev.base64_1_0; 23 | matrix-client = hpPrev.callCabal2nix "matrix-client" ./. { }; 24 | }; 25 | }; 26 | }) 27 | ]; 28 | pkgs = import nixpkgs { inherit config overlays system; }; 29 | conduitHome = "/tmp/conduit-home"; 30 | 31 | conduitConfig = pkgs.writeTextFile { 32 | name = "conduit.toml"; 33 | text = '' 34 | [global] 35 | server_name = "localhost" 36 | database_path = "${conduitHome}" 37 | database_backend = "rocksdb" 38 | port = 6167 39 | max_request_size = 20_000_000 40 | allow_registration = true 41 | allow_federation = false 42 | trusted_servers = [] 43 | #log = "info,state_res=warn,rocket=off,_=off,sled=off" 44 | address = "127.0.0.1" 45 | ''; 46 | }; 47 | 48 | # A script to start a local matrix server with conduit 49 | conduitStart = pkgs.writeScriptBin "conduit-start" '' 50 | #!/bin/sh -e 51 | rm -Rf ${conduitHome} 52 | mkdir -p ${conduitHome} 53 | exec env CONDUIT_CONFIG=${conduitConfig} ${pkgs.matrix-conduit}/bin/conduit 54 | ''; 55 | 56 | # A script to setup test environment 57 | conduitSetup = pkgs.writeScriptBin "conduit-setup" '' 58 | #!/bin/sh -e 59 | HOMESERVER_URL=http://localhost:6167 60 | export PATH=$PATH:${pkgs.jq}/bin:${pkgs.curl}/bin 61 | create_token () { 62 | REGISTER_TOKEN=$(curl -XPOST $HOMESERVER_URL/_matrix/client/v3/register -d '{"auth":{"type": "m.login.dummy"}, "username": "'$1'", "password": "'$2'"}' | jq -r ".access_token") 63 | if [ "$REGISTER_TOKEN" != "null" ]; then 64 | echo $REGISTER_TOKEN 65 | else 66 | curl -XPOST $HOMESERVER_URL/_matrix/client/v3/login -d '{"type": "m.login.password", "identifier": {"type": "m.id.user", "user": "'$1'"}, "password": "'$2'"}' | jq -r ".access_token" 67 | fi 68 | } 69 | echo HOMESERVER_URL=$HOMESERVER_URL 70 | echo PRIMARY_TOKEN=$(create_token "test-user" "test-pass") 71 | echo SECONDARY_TOKEN=$(create_token "other-user" "test-pass") 72 | ''; 73 | 74 | testScript = pkgs.writeScriptBin "matrix-client-test" '' 75 | #!/bin/sh -ex 76 | # running doctest in the haskellPackages.shellFor environment seems to be 77 | # more reliable 78 | doctest ./matrix-client/ -XOverloadedStrings 79 | hlint . 80 | cabal build all 81 | cabal test all 82 | ''; 83 | 84 | in rec { 85 | packages = with pkgs.myHaskellPackages; { inherit matrix-client; }; 86 | defaultPackage = packages.matrix-client; 87 | devShell = pkgs.myHaskellPackages.shellFor { 88 | packages = p: [ p.matrix-client ]; 89 | 90 | buildInputs = with pkgs.myHaskellPackages; [ 91 | cabal-install 92 | doctest 93 | cabal-gild 94 | hlint 95 | pkgs.haskell-language-server 96 | pkgs.ghcid 97 | testScript 98 | conduitStart 99 | conduitSetup 100 | ]; 101 | 102 | withHoogle = false; 103 | }; 104 | }); 105 | } 106 | -------------------------------------------------------------------------------- /matrix-client.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: matrix-client 3 | version: 0.1.6.1 4 | synopsis: A matrix client library 5 | description: 6 | Matrix client is a library to interface with https://matrix.org. 7 | . 8 | Use this library to interact with matrix server. 9 | . 10 | Read the "Network.Matrix.Tutorial" for a detailed tutorial. 11 | . 12 | Please see the README at https://github.com/softwarefactory-project/matrix-client-haskell#readme 13 | . 14 | 15 | homepage: https://github.com/softwarefactory-project/matrix-client-haskell#readme 16 | bug-reports: https://github.com/softwarefactory-project/matrix-client-haskell/issues 17 | license: Apache-2.0 18 | license-file: LICENSE 19 | author: Tristan de Cacqueray 20 | maintainer: tdecacqu@redhat.com 21 | copyright: 2021 Red Hat 22 | category: Network 23 | build-type: Simple 24 | extra-doc-files: CHANGELOG.md 25 | extra-source-files: test/data/*.json 26 | tested-with: ghc ==9.6.6 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/softwarefactory-project/matrix-client-haskell.git 31 | 32 | common common-options 33 | build-depends: 34 | aeson >=1.0.0.0 && <3, 35 | aeson-casing >=0.2.0.0 && <0.3.0.0, 36 | base >=4.11.0.0 && <5, 37 | 38 | ghc-options: 39 | -Wall 40 | -Wcompat 41 | -Widentities 42 | -Wincomplete-uni-patterns 43 | -Wincomplete-record-updates 44 | -Wredundant-constraints 45 | 46 | --write-ghc-environment-files=always 47 | if impl(ghc >=8.2) 48 | ghc-options: -fhide-source-paths 49 | 50 | if impl(ghc >=8.4) 51 | ghc-options: -Wmissing-export-lists 52 | default-language: Haskell2010 53 | 54 | common lib-depends 55 | build-depends: 56 | SHA ^>=1.6, 57 | base64 >=1.0 && <2, 58 | bytestring >=0.11.3 && <0.13, 59 | containers >=0.6.5 && <0.8, 60 | exceptions >=0.10.4 && <0.11, 61 | hashable >=1.4.0 && <1.5, 62 | http-client >=0.5.0 && <0.8, 63 | http-client-tls >=0.2.0 && <0.4, 64 | http-types >=0.10.0 && <0.13, 65 | network-uri >=2.6.4 && <2.7, 66 | profunctors >=5.6.2 && <5.7, 67 | retry >=0.8 && <0.10, 68 | text >=0.11.1.0 && <3, 69 | time >=1.11.1 && <1.13, 70 | unordered-containers >=0.2.17 && <0.3, 71 | 72 | library 73 | import: common-options, lib-depends 74 | hs-source-dirs: src 75 | exposed-modules: 76 | Network.Matrix.Client 77 | Network.Matrix.Client.Lens 78 | Network.Matrix.Identity 79 | Network.Matrix.Tutorial 80 | 81 | other-modules: 82 | Network.Matrix.Events 83 | Network.Matrix.Internal 84 | Network.Matrix.Room 85 | 86 | test-suite unit 87 | import: common-options, lib-depends 88 | type: exitcode-stdio-1.0 89 | hs-source-dirs: 90 | test 91 | src 92 | 93 | main-is: Spec.hs 94 | build-depends: 95 | aeson-pretty, 96 | base, 97 | bytestring, 98 | hspec >=2, 99 | matrix-client, 100 | text, 101 | -------------------------------------------------------------------------------- /src/Network/Matrix/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NumericUnderscores #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | 12 | {- | This module contains the client-server API 13 | https://matrix.org/docs/spec/client_server/r0.6.1 14 | -} 15 | module Network.Matrix.Client ( 16 | -- * Client 17 | ClientSession, 18 | LoginCredentials (..), 19 | MatrixToken (..), 20 | Username (..), 21 | DeviceId (..), 22 | InitialDeviceDisplayName (..), 23 | LoginSecret (..), 24 | LoginResponse (..), 25 | getTokenFromEnv, 26 | createSession, 27 | login, 28 | loginToken, 29 | logout, 30 | 31 | -- * API 32 | MatrixM, 33 | MatrixIO, 34 | MatrixError (..), 35 | retry, 36 | retryWithLog, 37 | 38 | -- * User data 39 | UserID (..), 40 | getTokenOwner, 41 | 42 | -- * Room Events 43 | Dir (..), 44 | EventType (..), 45 | MRCreate (..), 46 | MRCanonicalAlias (..), 47 | MRGuestAccess (..), 48 | MRHistoryVisibility (..), 49 | MRName (..), 50 | MRTopic (..), 51 | PaginatedRoomMessages (..), 52 | StateKey (..), 53 | StateEvent (..), 54 | StateContent (..), 55 | getRoomEvent, 56 | getRoomMembers, 57 | getRoomState, 58 | getRoomStateEvent, 59 | getRoomMessages, 60 | redact, 61 | sendRoomStateEvent, 62 | 63 | -- * Room management 64 | RoomCreatePreset (..), 65 | RoomCreateRequest (..), 66 | createRoom, 67 | 68 | -- * Room participation 69 | ResolvedRoomAlias (..), 70 | TxnID (..), 71 | sendMessage, 72 | mkReply, 73 | module Network.Matrix.Events, 74 | setRoomAlias, 75 | setRoomVisibility, 76 | resolveRoomAlias, 77 | deleteRoomAlias, 78 | getRoomAliases, 79 | 80 | -- * Room membership 81 | RoomID (..), 82 | RoomAlias (..), 83 | banUser, 84 | checkRoomVisibility, 85 | forgetRoom, 86 | getJoinedRooms, 87 | getPublicRooms, 88 | getPublicRooms', 89 | inviteToRoom, 90 | joinRoom, 91 | joinRoomById, 92 | leaveRoomById, 93 | kickUser, 94 | knockOnRoom, 95 | unbanUser, 96 | 97 | -- * Filter 98 | EventFormat (..), 99 | EventFilter (..), 100 | defaultEventFilter, 101 | eventFilterAll, 102 | RoomEventFilter (..), 103 | defaultRoomEventFilter, 104 | roomEventFilterAll, 105 | StateFilter (..), 106 | defaultStateFilter, 107 | stateFilterAll, 108 | RoomFilter (..), 109 | defaultRoomFilter, 110 | Filter (..), 111 | defaultFilter, 112 | FilterID (..), 113 | messageFilter, 114 | createFilter, 115 | getFilter, 116 | 117 | -- * Account data 118 | AccountData (accountDataType), 119 | getAccountData, 120 | getAccountData', 121 | setAccountData, 122 | setAccountData', 123 | 124 | -- * Events 125 | sync, 126 | getTimelines, 127 | syncPoll, 128 | Author (..), 129 | Presence (..), 130 | RoomEvent (..), 131 | RoomSummary (..), 132 | TimelineSync (..), 133 | InvitedRoomSync (..), 134 | JoinedRoomSync (..), 135 | SyncResult (..), 136 | SyncResultRoom (..), 137 | ) 138 | where 139 | 140 | import Control.Applicative 141 | import Control.Monad (mzero) 142 | import Control.Monad.IO.Class (MonadIO (liftIO)) 143 | import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object, String), encode, genericParseJSON, genericToJSON, object, withObject, withText, (.:), (.:?), (.=)) 144 | import qualified Data.Aeson as Aeson 145 | import Data.Aeson.Casing (aesonPrefix, snakeCase) 146 | import Data.Aeson.Types (Parser) 147 | import Data.Bifunctor (bimap) 148 | import qualified Data.ByteString as B 149 | import qualified Data.ByteString.Lazy as BL 150 | import Data.Coerce 151 | import Data.Hashable (Hashable) 152 | import Data.List (intersperse) 153 | import Data.List.NonEmpty (NonEmpty (..)) 154 | import Data.Map.Strict (Map, foldrWithKey) 155 | import Data.Maybe (catMaybes, fromMaybe) 156 | import Data.Proxy (Proxy (Proxy)) 157 | import qualified Data.Text as T 158 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 159 | import GHC.Generics 160 | import qualified Network.HTTP.Client as HTTP 161 | import Network.HTTP.Types.URI (urlEncode) 162 | import Network.Matrix.Events 163 | import Network.Matrix.Internal 164 | import Network.Matrix.Room 165 | import qualified Network.URI as URI 166 | 167 | {- $setup 168 | >>> import Data.Aeson (decode) 169 | -} 170 | 171 | data LoginCredentials = LoginCredentials 172 | { lUsername :: Username 173 | , lLoginSecret :: LoginSecret 174 | , lBaseUrl :: T.Text 175 | , lDeviceId :: Maybe DeviceId 176 | , lInitialDeviceDisplayName :: Maybe InitialDeviceDisplayName 177 | } 178 | 179 | mkLoginRequest :: LoginCredentials -> IO HTTP.Request 180 | mkLoginRequest LoginCredentials{..} = 181 | mkLoginRequest' lBaseUrl lDeviceId lInitialDeviceDisplayName lUsername lLoginSecret 182 | 183 | -- | 'login' allows you to generate a session token. 184 | login :: LoginCredentials -> IO ClientSession 185 | login = fmap fst . loginToken 186 | 187 | -- | 'loginToken' allows you to generate a session token and recover the Matrix auth token. 188 | loginToken :: LoginCredentials -> IO (ClientSession, MatrixToken) 189 | loginToken cred = do 190 | req <- mkLoginRequest cred 191 | manager <- mkManager 192 | resp' <- doRequest' manager req 193 | case resp' of 194 | Right LoginResponse{..} -> pure (ClientSession (lBaseUrl cred) (MatrixToken lrAccessToken) manager, MatrixToken lrAccessToken) 195 | Left err -> 196 | -- NOTE: There is nothing to recover after a failed login attempt 197 | fail $ show err 198 | 199 | mkLogoutRequest :: ClientSession -> IO HTTP.Request 200 | mkLogoutRequest ClientSession{..} = mkLogoutRequest' baseUrl token 201 | 202 | -- | 'logout' allows you to destroy a session token. 203 | logout :: ClientSession -> MatrixIO () 204 | logout session = do 205 | req <- mkLogoutRequest session 206 | doRequestExpectEmptyResponse session "logout" req 207 | 208 | -- | The session record, use 'createSession' to create it. 209 | data ClientSession = ClientSession 210 | { baseUrl :: T.Text 211 | , token :: MatrixToken 212 | , manager :: HTTP.Manager 213 | } 214 | 215 | -- | 'createSession' creates the session record. 216 | createSession :: 217 | -- | The matrix client-server base url, e.g. "https://matrix.org" 218 | T.Text -> 219 | -- | The user token 220 | MatrixToken -> 221 | IO ClientSession 222 | createSession baseUrl' token' = ClientSession baseUrl' token' <$> mkManager 223 | 224 | mkRequest :: ClientSession -> Bool -> T.Text -> IO HTTP.Request 225 | mkRequest ClientSession{..} = mkRequest' baseUrl token 226 | 227 | doRequest :: (FromJSON a) => ClientSession -> HTTP.Request -> MatrixIO a 228 | doRequest ClientSession{..} = doRequest' manager 229 | 230 | {- | Same as 'doRequest' but expect an empty JSON response @{}@ 231 | which is converted to an empty Haskell tuple @()@. 232 | -} 233 | doRequestExpectEmptyResponse :: ClientSession -> String -> HTTP.Request -> MatrixIO () 234 | doRequestExpectEmptyResponse sess apiName request = fmap ensureEmptyObject <$> doRequest sess request 235 | where 236 | ensureEmptyObject :: Value -> () 237 | ensureEmptyObject value = case value of 238 | Object xs | xs == mempty -> () 239 | _ -> error $ "Unknown " <> apiName <> " response: " <> show value 240 | 241 | -- | 'getTokenOwner' gets information about the owner of a given access token. 242 | getTokenOwner :: ClientSession -> MatrixIO UserID 243 | getTokenOwner session = 244 | doRequest session =<< mkRequest session True "/_matrix/client/r0/account/whoami" 245 | 246 | -- | A workaround data type to handle room create error being reported with a {message: "error"} response 247 | data CreateRoomResponse = CreateRoomResponse 248 | { crrMessage :: Maybe T.Text 249 | , crrID :: Maybe T.Text 250 | } 251 | 252 | instance FromJSON CreateRoomResponse where 253 | parseJSON (Object o) = CreateRoomResponse <$> o .:? "message" <*> o .:? "room_id" 254 | parseJSON _ = mzero 255 | 256 | ------------------------------------------------------------------------------- 257 | -- Room Event API Calls https://spec.matrix.org/v1.1/client-server-api/#getting-events-for-a-room 258 | 259 | getRoomEvent :: ClientSession -> RoomID -> EventID -> MatrixIO RoomEvent 260 | getRoomEvent session (RoomID rid) (EventID eid) = do 261 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/event/" <> eid 262 | doRequest session request 263 | 264 | data User = User {userDisplayName :: Maybe T.Text, userAvatarUrl :: Maybe T.Text} 265 | deriving (Show) 266 | 267 | instance FromJSON User where 268 | parseJSON = withObject "User" $ \o -> do 269 | userDisplayName <- o .:? "display_name" 270 | userAvatarUrl <- o .:? "avatar_url" 271 | pure $ User{..} 272 | 273 | -- | Unexported newtype to grant us a 'FromJSON' instance. 274 | newtype JoinedUsers = JoinedUsers (Map UserID User) 275 | 276 | instance FromJSON JoinedUsers where 277 | parseJSON = withObject "JoinedUsers" $ \o -> do 278 | users <- o .: "joined" 279 | pure $ JoinedUsers users 280 | 281 | {- | This API returns a map of MXIDs to member info objects for 282 | members of the room. The current user must be in the room for it to 283 | work. 284 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidjoined_members 285 | -} 286 | getRoomMembers :: ClientSession -> RoomID -> MatrixIO (Map UserID User) 287 | getRoomMembers session (RoomID rid) = do 288 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/joined_members" 289 | fmap coerce <$> doRequest @JoinedUsers session request 290 | 291 | newtype StateKey = StateKey T.Text 292 | deriving stock (Show) 293 | deriving newtype (FromJSON) 294 | 295 | newtype EventType = EventType T.Text 296 | deriving stock (Show) 297 | deriving newtype (FromJSON) 298 | 299 | data MRCreate = MRCreate {mrcCreator :: UserID, mrcRoomVersion :: Integer} 300 | deriving (Show) 301 | 302 | instance FromJSON MRCreate where 303 | parseJSON = withObject "RoomCreate" $ \o -> do 304 | mrcCreator <- o .: "creator" 305 | mrcRoomVersion <- o .: "room_version" 306 | pure $ MRCreate{..} 307 | 308 | newtype MRName = MRName {mrnName :: T.Text} 309 | deriving (Show) 310 | 311 | instance FromJSON MRName where 312 | parseJSON = withObject "RoomName" $ \o -> 313 | MRName <$> (o .: "name") 314 | 315 | newtype MRCanonicalAlias = MRCanonicalAlias {mrcAlias :: T.Text} 316 | deriving (Show) 317 | 318 | instance FromJSON MRCanonicalAlias where 319 | parseJSON = withObject "RoomCanonicalAlias" $ \o -> 320 | MRCanonicalAlias <$> (o .: "alias") 321 | 322 | newtype MRGuestAccess = MRGuestAccess {mrGuestAccess :: T.Text} 323 | deriving (Show) 324 | 325 | instance FromJSON MRGuestAccess where 326 | parseJSON = withObject "GuestAccess" $ \o -> 327 | MRGuestAccess <$> (o .: "guest_access") 328 | 329 | newtype MRHistoryVisibility = MRHistoryVisibility {mrHistoryVisibility :: T.Text} 330 | deriving (Show) 331 | 332 | instance FromJSON MRHistoryVisibility where 333 | parseJSON = withObject "HistoryVisibility" $ \o -> 334 | MRHistoryVisibility <$> (o .: "history_visibility") 335 | 336 | newtype MRTopic = MRTopic {mrTopic :: T.Text} 337 | deriving (Show) 338 | 339 | instance FromJSON MRTopic where 340 | parseJSON = withObject "RoomTopic" $ \o -> 341 | MRTopic <$> (o .: "topic") 342 | 343 | data StateContent 344 | = StRoomCreate MRCreate 345 | | -- | StRoomMember MRMember 346 | -- | StRoomPowerLevels MRPowerLevels 347 | -- | StRoomJoinRules MRJoinRules 348 | StRoomCanonicalAlias MRCanonicalAlias 349 | | StRoomGuestAccess MRGuestAccess 350 | | StRoomHistoryVisibility MRHistoryVisibility 351 | | StRoomName MRName 352 | | StRoomTopic MRTopic 353 | | StOther Value 354 | --- | StSpaceParent MRSpaceParent 355 | deriving (Show) 356 | 357 | pStRoomCreate :: Value -> Parser StateContent 358 | pStRoomCreate v = StRoomCreate <$> parseJSON v 359 | 360 | pStRoomCanonicAlias :: Value -> Parser StateContent 361 | pStRoomCanonicAlias v = StRoomCanonicalAlias <$> parseJSON v 362 | 363 | pStRoomGuestAccess :: Value -> Parser StateContent 364 | pStRoomGuestAccess v = StRoomGuestAccess <$> parseJSON v 365 | 366 | pStRoomHistoryVisibility :: Value -> Parser StateContent 367 | pStRoomHistoryVisibility v = StRoomHistoryVisibility <$> parseJSON v 368 | 369 | pStRoomName :: Value -> Parser StateContent 370 | pStRoomName v = StRoomName <$> parseJSON v 371 | 372 | pStRoomTopic :: Value -> Parser StateContent 373 | pStRoomTopic v = StRoomTopic <$> parseJSON v 374 | 375 | pStRoomOther :: Value -> Parser StateContent 376 | pStRoomOther v = StOther <$> parseJSON v 377 | 378 | instance FromJSON StateContent where 379 | parseJSON v = 380 | pStRoomCreate v 381 | <|> pStRoomCanonicAlias v 382 | <|> pStRoomGuestAccess v 383 | <|> pStRoomHistoryVisibility v 384 | <|> pStRoomName v 385 | <|> pStRoomTopic v 386 | <|> pStRoomOther v 387 | 388 | -- TODO(SOLOMON): Should This constructor be in 'Event'? 389 | data StateEvent = StateEvent 390 | { seContent :: StateContent 391 | , seEventId :: EventID 392 | , seOriginServerTimestamp :: Integer 393 | , sePreviousContent :: Maybe Value 394 | , seRoomId :: RoomID 395 | , seSender :: UserID 396 | , seStateKey :: StateKey 397 | , seEventType :: EventType 398 | , seUnsigned :: Maybe Value 399 | } 400 | deriving (Show) 401 | 402 | instance FromJSON StateEvent where 403 | parseJSON = withObject "StateEvent" $ \o -> do 404 | seContent <- o .: "content" 405 | seEventId <- fmap EventID $ o .: "event_id" 406 | seOriginServerTimestamp <- o .: "origin_server_ts" 407 | sePreviousContent <- o .:? "previous_content" 408 | seRoomId <- fmap RoomID $ o .: "room_id" 409 | seSender <- fmap UserID $ o .: "sender" 410 | seStateKey <- o .: "state_key" 411 | seEventType <- o .: "type" 412 | seUnsigned <- o .:? "unsigned" 413 | pure $ StateEvent{..} 414 | 415 | {- | Get the state events for the current state of a room. 416 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidstate 417 | -} 418 | getRoomState :: ClientSession -> RoomID -> MatrixIO [StateEvent] 419 | getRoomState session (RoomID rid) = do 420 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/state" 421 | doRequest session request 422 | 423 | {- | Looks up the contents of a state event in a room. If the user is 424 | joined to the room then the state is taken from the current state 425 | of the room. If the user has left the room then the state is taken 426 | from the state of the room when they left. 427 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidstateeventtypestatekey 428 | -} 429 | getRoomStateEvent :: ClientSession -> RoomID -> EventType -> StateKey -> MatrixIO StateEvent 430 | getRoomStateEvent session (RoomID rid) (EventType et) (StateKey key) = do 431 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/state" <> et <> "/" <> key 432 | doRequest session request 433 | 434 | data Dir 435 | = -- | Forward 436 | F 437 | | -- | Backward 438 | B 439 | 440 | renderDir :: Dir -> B.ByteString 441 | renderDir F = "f" 442 | renderDir B = "b" 443 | 444 | data PaginatedRoomMessages = PaginatedRoomMessages 445 | { chunk :: [RoomEvent] 446 | , end :: Maybe T.Text 447 | -- ^ A token corresponding to the end of chunk. 448 | , start :: T.Text 449 | -- ^ A token corresponding to the start of chunk. 450 | , state :: [StateEvent] 451 | -- ^ A list of state events relevant to showing the chunk. 452 | } 453 | deriving (Show) 454 | 455 | instance FromJSON PaginatedRoomMessages where 456 | parseJSON = withObject "PaginatedRoomMessages" $ \o -> do 457 | chunk <- o .: "chunk" 458 | end <- o .:? "end" 459 | start <- o .: "start" 460 | state <- fmap (fromMaybe []) $ o .:? "state" 461 | pure $ PaginatedRoomMessages{..} 462 | 463 | getRoomMessages :: 464 | ClientSession -> 465 | -- | The room to get events from. 466 | RoomID -> 467 | -- | The direction to return events from. 468 | Dir -> 469 | -- | A 'RoomEventFilter' to filter returned events with. 470 | Maybe RoomEventFilter -> 471 | -- | The Since value to start returning events from. 472 | T.Text -> 473 | -- | The maximum number of events to return. Default: 10. 474 | Maybe Int -> 475 | -- | The token to stop returning events at. 476 | Maybe Int -> 477 | MatrixIO PaginatedRoomMessages 478 | getRoomMessages session (RoomID rid) dir roomFilter fromToken limit toToken = do 479 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/messages" 480 | let dir' = "dir=" <> renderDir dir 481 | filter' = BL.toStrict . mappend "filter=" . encode <$> roomFilter 482 | from' = encodeUtf8 $ "from=" <> fromToken 483 | limit' = BL.toStrict . mappend "limit=" . encode <$> limit 484 | to' = BL.toStrict . mappend "from=" . encode <$> toToken 485 | queryString = mappend "?" $ mconcat $ intersperse "&" $ [dir', from'] <> catMaybes [to', limit', filter'] 486 | doRequest session $ request{HTTP.queryString = queryString} 487 | 488 | {- | Send arbitrary state events to a room. These events will be overwritten if 489 | , and all match. 490 | https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3roomsroomidstateeventtypestatekey 491 | -} 492 | sendRoomStateEvent :: ClientSession -> RoomID -> EventType -> StateKey -> Value -> MatrixIO EventID 493 | sendRoomStateEvent session (RoomID rid) (EventType et) (StateKey key) event = do 494 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> escapeUriComponent rid <> "/state/" <> escapeUriComponent et <> "/" <> escapeUriComponent key 495 | doRequest session $ 496 | request 497 | { HTTP.method = "PUT" 498 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode event 499 | } 500 | 501 | newtype TxnID = TxnID T.Text deriving (Show, Eq) 502 | 503 | {- | This endpoint is used to send a message event to a room. 504 | https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3roomsroomidsendeventtypetxnid 505 | -} 506 | sendMessage :: ClientSession -> RoomID -> Event -> TxnID -> MatrixIO EventID 507 | sendMessage session (RoomID roomId) event (TxnID txnId) = do 508 | request <- mkRequest session True path 509 | doRequest 510 | session 511 | ( request 512 | { HTTP.method = "PUT" 513 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode event 514 | } 515 | ) 516 | where 517 | path = "/_matrix/client/r0/rooms/" <> roomId <> "/send/" <> eventId <> "/" <> txnId 518 | eventId = eventType event 519 | 520 | redact :: ClientSession -> RoomID -> EventID -> TxnID -> T.Text -> MatrixIO EventID 521 | redact session (RoomID rid) (EventID eid) (TxnID txnid) reason = do 522 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/redact/" <> eid <> "/" <> txnid 523 | let body = object ["reason" .= String reason] 524 | doRequest session $ 525 | request 526 | { HTTP.method = "PUT" 527 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 528 | } 529 | 530 | ------------------------------------------------------------------------------- 531 | -- Room API Calls https://spec.matrix.org/v1.1/client-server-api/#rooms-1 532 | 533 | {- | Create a new room with various configuration options. 534 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3createroom 535 | -} 536 | createRoom :: ClientSession -> RoomCreateRequest -> MatrixIO RoomID 537 | createRoom session rcr = do 538 | request <- mkRequest session True "/_matrix/client/v3/createRoom" 539 | toRoomID 540 | <$> doRequest 541 | session 542 | ( request 543 | { HTTP.method = "POST" 544 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode rcr 545 | } 546 | ) 547 | where 548 | toRoomID :: Either MatrixError CreateRoomResponse -> Either MatrixError RoomID 549 | toRoomID resp = case resp of 550 | Left err -> Left err 551 | Right crr -> case (crrID crr, crrMessage crr) of 552 | (Just roomID, _) -> pure $ RoomID roomID 553 | (_, Just message) -> Left $ MatrixError "UNKNOWN" message Nothing 554 | _ -> Left $ MatrixError "UNKNOWN" "" Nothing 555 | 556 | newtype RoomAlias = RoomAlias T.Text deriving (Show, Eq, Ord, Hashable) 557 | 558 | data ResolvedRoomAlias = ResolvedRoomAlias 559 | { roomAlias :: RoomAlias 560 | , roomID :: RoomID 561 | -- ^ The room ID for this room alias. 562 | , servers :: [T.Text] 563 | -- ^ A list of servers that are aware of this room alias. 564 | } 565 | deriving (Show) 566 | 567 | -- | Boilerplate data type for an aeson instance 568 | data RoomAliasMetadata = RoomAliasMetadata 569 | { ramRoomID :: RoomID 570 | , ramServers :: [T.Text] 571 | } 572 | 573 | instance FromJSON RoomAliasMetadata where 574 | parseJSON = withObject "ResolvedRoomAlias" $ \o -> do 575 | ramRoomID <- fmap RoomID $ o .: "room_id" 576 | ramServers <- o .: "servers" 577 | pure $ RoomAliasMetadata{..} 578 | 579 | {- | Requests that the server resolve a room alias to a room ID. 580 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3directoryroomroomalias 581 | -} 582 | resolveRoomAlias :: ClientSession -> RoomAlias -> MatrixIO ResolvedRoomAlias 583 | resolveRoomAlias session r@(RoomAlias alias) = do 584 | request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias 585 | resp <- doRequest session $ request{HTTP.method = "GET"} 586 | case resp of 587 | Left err -> pure $ Left err 588 | Right RoomAliasMetadata{..} -> pure $ Right $ ResolvedRoomAlias r ramRoomID ramServers 589 | 590 | {- | Create a mapping of room alias to room ID. 591 | https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3directoryroomroomalias 592 | -} 593 | setRoomAlias :: ClientSession -> RoomAlias -> RoomID -> MatrixIO () 594 | setRoomAlias session (RoomAlias alias) (RoomID roomId) = do 595 | request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias 596 | doRequestExpectEmptyResponse session "set room alias" $ 597 | request 598 | { HTTP.method = "PUT" 599 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode $ object ["room_id" .= roomId] 600 | } 601 | 602 | {- | Delete a mapping of room alias to room ID. 603 | https://spec.matrix.org/v1.1/client-server-api/#delete_matrixclientv3directoryroomroomalias 604 | -} 605 | deleteRoomAlias :: ClientSession -> RoomAlias -> MatrixIO () 606 | deleteRoomAlias session (RoomAlias alias) = do 607 | request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias 608 | doRequestExpectEmptyResponse session "delete room alias" $ request{HTTP.method = "DELETE"} 609 | 610 | newtype ResolvedAliases = ResolvedAliases [RoomAlias] 611 | 612 | instance FromJSON ResolvedAliases where 613 | parseJSON = withObject "ResolvedAliases" $ \o -> do 614 | aliases <- o .: "aliases" 615 | pure $ ResolvedAliases (RoomAlias <$> aliases) 616 | 617 | {- | Get a list of aliases maintained by the local server for the given room. 618 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidaliases 619 | -} 620 | getRoomAliases :: ClientSession -> RoomID -> MatrixIO [RoomAlias] 621 | getRoomAliases session (RoomID rid) = do 622 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/aliases" 623 | resp <- 624 | doRequest 625 | session 626 | $ request{HTTP.method = "GET"} 627 | case resp of 628 | Left err -> pure $ Left err 629 | Right (ResolvedAliases aliases) -> pure $ Right aliases 630 | 631 | {- | A newtype wrapper to decoded nested list 632 | 633 | >>> decode "{\"joined_rooms\": [\"!foo:example.com\"]}" :: Maybe JoinedRooms 634 | Just (JoinedRooms {unRooms = [RoomID "!foo:example.com"]}) 635 | -} 636 | newtype JoinedRooms = JoinedRooms {unRooms :: [RoomID]} deriving (Show) 637 | 638 | instance FromJSON JoinedRooms where 639 | parseJSON (Object v) = do 640 | rooms <- v .: "joined_rooms" 641 | pure . JoinedRooms $ RoomID <$> rooms 642 | parseJSON _ = mzero 643 | 644 | {- | Returns a list of the user’s current rooms. 645 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3joined_rooms 646 | -} 647 | getJoinedRooms :: ClientSession -> MatrixIO [RoomID] 648 | getJoinedRooms session = do 649 | request <- mkRequest session True "/_matrix/client/r0/joined_rooms" 650 | response <- doRequest session request 651 | pure $ unRooms <$> response 652 | 653 | newtype RoomID = RoomID T.Text deriving (Show, Eq, Ord, Hashable) 654 | 655 | instance FromJSON RoomID where 656 | parseJSON (Object v) = RoomID <$> v .: "room_id" 657 | parseJSON _ = mzero 658 | 659 | {- | Invites a user to participate in a particular room. They do not 660 | start participating in the room until they actually join the room. 661 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidinvite 662 | -} 663 | inviteToRoom :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () 664 | inviteToRoom session (RoomID rid) (UserID uid) reason = do 665 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/invite" 666 | let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] 667 | doRequestExpectEmptyResponse session "invite" $ 668 | request 669 | { HTTP.method = "POST" 670 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 671 | } 672 | 673 | {- | Note that this API takes either a room ID or alias, unlike 'joinRoomById' 674 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3joinroomidoralias 675 | -} 676 | joinRoom :: ClientSession -> T.Text -> MatrixIO RoomID 677 | joinRoom session roomName = do 678 | request <- mkRequest session True $ "/_matrix/client/r0/join/" <> roomNameUrl 679 | doRequest session (request{HTTP.method = "POST"}) 680 | where 681 | roomNameUrl = decodeUtf8 . urlEncode True . encodeUtf8 $ roomName 682 | 683 | {- | Starts a user participating in a particular room, if that user is 684 | allowed to participate in that room. 685 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidjoin 686 | -} 687 | joinRoomById :: ClientSession -> RoomID -> MatrixIO RoomID 688 | joinRoomById session (RoomID roomId) = do 689 | request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/join" 690 | doRequest session (request{HTTP.method = "POST"}) 691 | 692 | {- | This API “knocks” on the room to ask for permission to join, if 693 | the user is allowed to knock on the room. 694 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3knockroomidoralias 695 | -} 696 | knockOnRoom :: ClientSession -> Either RoomID RoomAlias -> [T.Text] -> Maybe T.Text -> MatrixIO RoomID 697 | knockOnRoom session room servers reason = do 698 | request <- mkRequest session True $ " /_matrix/client/v3/knock/" <> indistinct (bimap coerce coerce room) 699 | let body = object $ catMaybes [fmap (("reason",) . toJSON) reason] 700 | doRequest session $ 701 | request 702 | { HTTP.method = "POST" 703 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 704 | , HTTP.queryString = encodeUtf8 $ "?server_name=" <> mconcat (intersperse "," servers) 705 | } 706 | 707 | {- | Stops remembering a particular room. 708 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidforget 709 | -} 710 | forgetRoom :: ClientSession -> RoomID -> MatrixIO () 711 | forgetRoom session (RoomID roomId) = do 712 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/forget" 713 | doRequestExpectEmptyResponse session "forget" (request{HTTP.method = "POST"}) 714 | 715 | {- | Stop participating in a particular room. 716 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidleave 717 | -} 718 | leaveRoomById :: ClientSession -> RoomID -> MatrixIO () 719 | leaveRoomById session (RoomID roomId) = do 720 | request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/leave" 721 | doRequestExpectEmptyResponse session "leave" (request{HTTP.method = "POST"}) 722 | 723 | {- | Kick a user from the room. 724 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidkick 725 | -} 726 | kickUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () 727 | kickUser session (RoomID roomId) (UserID uid) reason = do 728 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/kick" 729 | let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] 730 | doRequestExpectEmptyResponse session "kick" $ 731 | request 732 | { HTTP.method = "POST" 733 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 734 | } 735 | 736 | {- | Ban a user in the room. If the user is currently in the room, also kick them. 737 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidban 738 | -} 739 | banUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () 740 | banUser session (RoomID roomId) (UserID uid) reason = do 741 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/ban" 742 | let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] 743 | doRequestExpectEmptyResponse session "ban" $ 744 | request 745 | { HTTP.method = "POST" 746 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 747 | } 748 | 749 | {- | Unban a user from the room. This allows them to be invited to the 750 | room, and join if they would otherwise be allowed to join according 751 | to its join rules. 752 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidunban 753 | -} 754 | unbanUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () 755 | unbanUser session (RoomID roomId) (UserID uid) reason = do 756 | request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/unban" 757 | let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] 758 | doRequestExpectEmptyResponse session "unban" $ 759 | request 760 | { HTTP.method = "POST" 761 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 762 | } 763 | 764 | data Visibility = Public | Private 765 | deriving (Show) 766 | 767 | instance ToJSON Visibility where 768 | toJSON = \case 769 | Public -> String "public" 770 | Private -> String "private" 771 | 772 | instance FromJSON Visibility where 773 | parseJSON = withText "Visibility" $ \case 774 | "public" -> pure Public 775 | "private" -> pure Private 776 | _ -> mzero 777 | 778 | newtype GetVisibility = GetVisibility {getVisibility :: Visibility} 779 | 780 | instance FromJSON GetVisibility where 781 | parseJSON = withObject "GetVisibility" $ \o -> do 782 | getVisibility <- o .: "visibility" 783 | pure $ GetVisibility{..} 784 | 785 | {- | Gets the visibility of a given room on the server’s public room directory. 786 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3directorylistroomroomid 787 | -} 788 | checkRoomVisibility :: ClientSession -> RoomID -> MatrixIO Visibility 789 | checkRoomVisibility session (RoomID rid) = do 790 | request <- mkRequest session True $ "/_matrix/client/v3/directory/list/room/" <> rid 791 | fmap getVisibility <$> doRequest session request 792 | 793 | {- | Sets the visibility of a given room in the server’s public room directory. 794 | https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3directorylistroomroomid 795 | -} 796 | setRoomVisibility :: ClientSession -> RoomID -> Visibility -> MatrixIO () 797 | setRoomVisibility session (RoomID rid) visibility = do 798 | request <- mkRequest session True $ "/_matrix/client/v3/directory/list/room/" <> rid 799 | let body = object [("visibility", toJSON visibility)] 800 | doRequestExpectEmptyResponse session "set room visibility" $ 801 | request 802 | { HTTP.method = "PUT" 803 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 804 | } 805 | 806 | {- | A pagination token from a previous request, allowing clients to 807 | get the next (or previous) batch of rooms. The direction of 808 | pagination is specified solely by which token is supplied, rather 809 | than via an explicit flag. 810 | -} 811 | newtype PaginationChunk = PaginationChunk {getChunk :: T.Text} 812 | deriving stock (Show) 813 | deriving newtype (ToJSON, FromJSON) 814 | 815 | data Room = Room 816 | { aliases :: Maybe [T.Text] 817 | , avatarUrl :: Maybe T.Text 818 | , canonicalAlias :: Maybe T.Text 819 | , guestCanJoin :: Bool 820 | , joinRule :: Maybe T.Text 821 | , name :: Maybe T.Text 822 | , numJoinedMembers :: Int 823 | , roomId :: RoomID 824 | , topic :: Maybe T.Text 825 | , worldReadable :: Bool 826 | } 827 | deriving (Show) 828 | 829 | instance FromJSON Room where 830 | parseJSON = withObject "Room" $ \o -> do 831 | aliases <- o .:? "aliases" 832 | avatarUrl <- o .:? "avatar_url" 833 | canonicalAlias <- o .:? "canonical_alias" 834 | guestCanJoin <- o .: "guest_can_join" 835 | joinRule <- o .:? "join_rule" 836 | name <- o .:? "name" 837 | numJoinedMembers <- o .: "num_joined_members" 838 | roomId <- fmap RoomID $ o .: "room_id" 839 | topic <- o .:? "topic" 840 | worldReadable <- o .: "world_readable" 841 | pure $ Room{..} 842 | 843 | data PublicRooms = PublicRooms 844 | { prChunk :: [Room] 845 | , prNextBatch :: Maybe PaginationChunk 846 | , prPrevBatch :: Maybe PaginationChunk 847 | , prTotalRoomCountEstimate :: Maybe Int 848 | } 849 | deriving (Show) 850 | 851 | instance FromJSON PublicRooms where 852 | parseJSON = withObject "PublicRooms" $ \o -> do 853 | prChunk <- o .: "chunk" 854 | prNextBatch <- o .:? "next_batch" 855 | prPrevBatch <- o .:? "prev_batch" 856 | prTotalRoomCountEstimate <- o .:? "total_room_count_estimate" 857 | pure $ PublicRooms{..} 858 | 859 | {- | Lists the public rooms on the server. 860 | https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3publicrooms 861 | -} 862 | getPublicRooms :: ClientSession -> Maybe Int -> Maybe PaginationChunk -> MatrixIO PublicRooms 863 | getPublicRooms session limit chunk = do 864 | request <- mkRequest session True "/_matrix/client/v3/publicRooms" 865 | let since = fmap (mappend "since=" . getChunk) chunk 866 | limit' = fmap (mappend "limit=" . tshow) limit 867 | queryString = encodeUtf8 $ mconcat $ intersperse "&" $ catMaybes [since, limit'] 868 | doRequest session $ 869 | request{HTTP.queryString = queryString} 870 | 871 | newtype ThirdPartyInstanceId = ThirdPartyInstanceId T.Text 872 | deriving (FromJSON, ToJSON) 873 | 874 | {- | Lists the public rooms on the server, with optional filter. 875 | https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3publicrooms 876 | -} 877 | getPublicRooms' :: ClientSession -> Maybe Int -> Maybe PaginationChunk -> Maybe T.Text -> Maybe Bool -> Maybe ThirdPartyInstanceId -> MatrixIO PublicRooms 878 | getPublicRooms' session limit chunk searchTerm includeAllNetworks thirdPartyId = do 879 | request <- mkRequest session True "/_matrix/client/v3/publicRooms" 880 | let filter' = object $ catMaybes [fmap (("generic_search_term",) . toJSON) searchTerm] 881 | since = fmap (("since",) . toJSON) chunk 882 | limit' = fmap (("limit",) . toJSON) limit 883 | includeAllNetworks' = fmap (("include_all_networks",) . toJSON) includeAllNetworks 884 | thirdPartyId' = fmap (("third_party_instance_id",) . toJSON) thirdPartyId 885 | body = object $ [("filter", filter')] <> catMaybes [since, limit', includeAllNetworks', thirdPartyId'] 886 | doRequest session $ 887 | request 888 | { HTTP.method = "POST" 889 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 890 | } 891 | 892 | ------------------------------------------------------------------------------- 893 | -- https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter 894 | newtype FilterID = FilterID T.Text deriving (Show, Eq, Hashable) 895 | 896 | instance FromJSON FilterID where 897 | parseJSON (Object v) = FilterID <$> v .: "filter_id" 898 | parseJSON _ = mzero 899 | 900 | data EventFormat = Client | Federation deriving (Show, Eq) 901 | 902 | instance ToJSON EventFormat where 903 | toJSON ef = case ef of 904 | Client -> "client" 905 | Federation -> "federation" 906 | 907 | instance FromJSON EventFormat where 908 | parseJSON v = case v of 909 | (String "client") -> pure Client 910 | (String "federation") -> pure Federation 911 | _ -> mzero 912 | 913 | data EventFilter = EventFilter 914 | { efLimit :: Maybe Int 915 | , efNotSenders :: Maybe [T.Text] 916 | , efNotTypes :: Maybe [T.Text] 917 | , efSenders :: Maybe [T.Text] 918 | , efTypes :: Maybe [T.Text] 919 | } 920 | deriving (Show, Eq, Generic) 921 | 922 | defaultEventFilter :: EventFilter 923 | defaultEventFilter = EventFilter Nothing Nothing Nothing Nothing Nothing 924 | 925 | -- | A filter that should match nothing 926 | eventFilterAll :: EventFilter 927 | eventFilterAll = defaultEventFilter{efLimit = Just 0, efNotTypes = Just ["*"]} 928 | 929 | aesonOptions :: Aeson.Options 930 | aesonOptions = (aesonPrefix snakeCase){Aeson.omitNothingFields = True} 931 | 932 | instance ToJSON EventFilter where 933 | toJSON = genericToJSON aesonOptions 934 | 935 | instance FromJSON EventFilter where 936 | parseJSON = genericParseJSON aesonOptions 937 | 938 | data RoomEventFilter = RoomEventFilter 939 | { refLimit :: Maybe Int 940 | , refNotSenders :: Maybe [T.Text] 941 | , refNotTypes :: Maybe [T.Text] 942 | , refSenders :: Maybe [T.Text] 943 | , refTypes :: Maybe [T.Text] 944 | , refLazyLoadMembers :: Maybe Bool 945 | , refIncludeRedundantMembers :: Maybe Bool 946 | , refNotRooms :: Maybe [T.Text] 947 | , refRooms :: Maybe [T.Text] 948 | , refContainsUrl :: Maybe Bool 949 | } 950 | deriving (Show, Eq, Generic) 951 | 952 | defaultRoomEventFilter :: RoomEventFilter 953 | defaultRoomEventFilter = RoomEventFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing 954 | 955 | -- | A filter that should match nothing 956 | roomEventFilterAll :: RoomEventFilter 957 | roomEventFilterAll = defaultRoomEventFilter{refLimit = Just 0, refNotTypes = Just ["*"]} 958 | 959 | instance ToJSON RoomEventFilter where 960 | toJSON = genericToJSON aesonOptions 961 | 962 | instance FromJSON RoomEventFilter where 963 | parseJSON = genericParseJSON aesonOptions 964 | 965 | data StateFilter = StateFilter 966 | { sfLimit :: Maybe Int 967 | , sfNotSenders :: Maybe [T.Text] 968 | , sfNotTypes :: Maybe [T.Text] 969 | , sfSenders :: Maybe [T.Text] 970 | , sfTypes :: Maybe [T.Text] 971 | , sfLazyLoadMembers :: Maybe Bool 972 | , sfIncludeRedundantMembers :: Maybe Bool 973 | , sfNotRooms :: Maybe [T.Text] 974 | , sfRooms :: Maybe [T.Text] 975 | , sfContains_url :: Maybe Bool 976 | } 977 | deriving (Show, Eq, Generic) 978 | 979 | defaultStateFilter :: StateFilter 980 | defaultStateFilter = StateFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing 981 | 982 | stateFilterAll :: StateFilter 983 | stateFilterAll = defaultStateFilter{sfLimit = Just 0, sfNotTypes = Just ["*"]} 984 | 985 | instance ToJSON StateFilter where 986 | toJSON = genericToJSON aesonOptions 987 | 988 | instance FromJSON StateFilter where 989 | parseJSON = genericParseJSON aesonOptions 990 | 991 | data RoomFilter = RoomFilter 992 | { rfNotRooms :: Maybe [T.Text] 993 | , rfRooms :: Maybe [T.Text] 994 | , rfEphemeral :: Maybe RoomEventFilter 995 | , rfIncludeLeave :: Maybe Bool 996 | , rfState :: Maybe StateFilter 997 | , rfTimeline :: Maybe RoomEventFilter 998 | , rfAccountData :: Maybe RoomEventFilter 999 | } 1000 | deriving (Show, Eq, Generic) 1001 | 1002 | defaultRoomFilter :: RoomFilter 1003 | defaultRoomFilter = RoomFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing 1004 | 1005 | instance ToJSON RoomFilter where 1006 | toJSON = genericToJSON aesonOptions 1007 | 1008 | instance FromJSON RoomFilter where 1009 | parseJSON = genericParseJSON aesonOptions 1010 | 1011 | data Filter = Filter 1012 | { filterEventFields :: Maybe [T.Text] 1013 | , filterEventFormat :: Maybe EventFormat 1014 | , filterPresence :: Maybe EventFilter 1015 | , filterAccountData :: Maybe EventFilter 1016 | , filterRoom :: Maybe RoomFilter 1017 | } 1018 | deriving (Show, Eq, Generic) 1019 | 1020 | defaultFilter :: Filter 1021 | defaultFilter = Filter Nothing Nothing Nothing Nothing Nothing 1022 | 1023 | -- | A filter to keep all the messages 1024 | messageFilter :: Filter 1025 | messageFilter = 1026 | defaultFilter 1027 | { filterPresence = Just eventFilterAll 1028 | , filterAccountData = Just eventFilterAll 1029 | , filterRoom = Just roomFilter 1030 | } 1031 | where 1032 | roomFilter = 1033 | defaultRoomFilter 1034 | { rfEphemeral = Just roomEventFilterAll 1035 | , rfState = Just stateFilterAll 1036 | , rfTimeline = Just timelineFilter 1037 | , rfAccountData = Just roomEventFilterAll 1038 | } 1039 | timelineFilter = 1040 | defaultRoomEventFilter 1041 | { refTypes = Just ["m.room.message"] 1042 | } 1043 | 1044 | instance ToJSON Filter where 1045 | toJSON = genericToJSON aesonOptions 1046 | 1047 | instance FromJSON Filter where 1048 | parseJSON = genericParseJSON aesonOptions 1049 | 1050 | {- | Upload a new filter definition to the homeserver 1051 | https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter 1052 | -} 1053 | createFilter :: 1054 | -- | The client session, use 'createSession' to get one. 1055 | ClientSession -> 1056 | -- | The userID, use 'getTokenOwner' to get it. 1057 | UserID -> 1058 | -- | The filter definition, use 'defaultFilter' to create one or use the 'messageFilter' example. 1059 | Filter -> 1060 | -- | The function returns a 'FilterID' suitable for the 'sync' function. 1061 | MatrixIO FilterID 1062 | createFilter session (UserID userID) body = do 1063 | request <- mkRequest session True path 1064 | doRequest 1065 | session 1066 | ( request 1067 | { HTTP.method = "POST" 1068 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body 1069 | } 1070 | ) 1071 | where 1072 | path = "/_matrix/client/r0/user/" <> userID <> "/filter" 1073 | 1074 | getFilter :: ClientSession -> UserID -> FilterID -> MatrixIO Filter 1075 | getFilter session (UserID userID) (FilterID filterID) = 1076 | doRequest session =<< mkRequest session True path 1077 | where 1078 | path = "/_matrix/client/r0/user/" <> userID <> "/filter/" <> filterID 1079 | 1080 | ------------------------------------------------------------------------------- 1081 | -- https://matrix.org/docs/spec/client_server/latest#get-matrix-client-r0-sync 1082 | newtype Author = Author {unAuthor :: T.Text} 1083 | deriving (Show, Eq) 1084 | deriving newtype (FromJSON, ToJSON) 1085 | 1086 | data RoomEvent = RoomEvent 1087 | { reContent :: Event 1088 | , reType :: T.Text 1089 | , reEventId :: EventID 1090 | , reSender :: Author 1091 | } 1092 | deriving (Show, Eq, Generic) 1093 | 1094 | data RoomSummary = RoomSummary 1095 | { rsJoinedMemberCount :: Maybe Int 1096 | , rsInvitedMemberCount :: Maybe Int 1097 | } 1098 | deriving (Show, Eq, Generic) 1099 | 1100 | data TimelineSync = TimelineSync 1101 | { tsEvents :: Maybe [RoomEvent] 1102 | , tsLimited :: Maybe Bool 1103 | , tsPrevBatch :: Maybe T.Text 1104 | } 1105 | deriving (Show, Eq, Generic) 1106 | 1107 | data JoinedRoomSync = JoinedRoomSync 1108 | { jrsSummary :: Maybe RoomSummary 1109 | , jrsTimeline :: TimelineSync 1110 | } 1111 | deriving (Show, Eq, Generic) 1112 | 1113 | data Presence = Offline | Online | Unavailable deriving (Eq) 1114 | 1115 | instance Show Presence where 1116 | show = \case 1117 | Offline -> "offline" 1118 | Online -> "online" 1119 | Unavailable -> "unavailable" 1120 | 1121 | instance ToJSON Presence where 1122 | toJSON = String . tshow 1123 | 1124 | instance FromJSON Presence where 1125 | parseJSON v = case v of 1126 | (String "offline") -> pure Offline 1127 | (String "online") -> pure Online 1128 | (String "unavailable") -> pure Unavailable 1129 | _ -> mzero 1130 | 1131 | data SyncResult = SyncResult 1132 | { srNextBatch :: T.Text 1133 | , srRooms :: Maybe SyncResultRoom 1134 | } 1135 | deriving (Show, Eq, Generic) 1136 | 1137 | data SyncResultRoom = SyncResultRoom 1138 | { srrJoin :: Maybe (Map T.Text JoinedRoomSync) 1139 | , srrInvite :: Maybe (Map T.Text InvitedRoomSync) 1140 | } 1141 | deriving (Show, Eq, Generic) 1142 | 1143 | data InvitedRoomSync = InvitedRoomSync 1144 | deriving (Show, Eq, Generic) 1145 | 1146 | unFilterID :: FilterID -> T.Text 1147 | unFilterID (FilterID x) = x 1148 | 1149 | ------------------------------------------------------------------------------- 1150 | -- https://matrix.org/docs/spec/client_server/latest#forming-relationships-between-events 1151 | 1152 | {- | An helper to create a reply body 1153 | 1154 | >>> let sender = Author "foo@matrix.org" 1155 | >>> addReplyBody sender "Hello" "hi" 1156 | "> Hello\n\nhi" 1157 | 1158 | >>> addReplyBody sender "" "hey" 1159 | "> \n\nhey" 1160 | 1161 | >>> addReplyBody sender "a multi\nline" "resp" 1162 | "> a multi\n> line\n\nresp" 1163 | -} 1164 | addReplyBody :: Author -> T.Text -> T.Text -> T.Text 1165 | addReplyBody (Author author) old reply = 1166 | let oldLines = T.lines old 1167 | headLine = "> <" <> author <> ">" <> maybe "" (mappend " ") (headMaybe oldLines) 1168 | newBody = [headLine] <> map (mappend "> ") (tail' oldLines) <> [""] <> [reply] 1169 | in T.dropEnd 1 $ T.unlines newBody 1170 | 1171 | addReplyFormattedBody :: RoomID -> EventID -> Author -> T.Text -> T.Text -> T.Text 1172 | addReplyFormattedBody (RoomID roomID) (EventID eventID) (Author author) old reply = 1173 | T.unlines 1174 | [ "" 1175 | , "
" 1176 | , " roomID <> "/" <> eventID <> "\">In reply to" 1177 | , " author <> "\">" <> author <> "" 1178 | , "
" 1179 | , " " <> old 1180 | , "
" 1181 | , "" 1182 | , reply 1183 | ] 1184 | 1185 | {- | Convert body by encoding HTML special char 1186 | 1187 | >>> toFormattedBody "& " 1188 | "& <test>" 1189 | -} 1190 | toFormattedBody :: T.Text -> T.Text 1191 | toFormattedBody = T.concatMap char 1192 | where 1193 | char x = case x of 1194 | '<' -> "<" 1195 | '>' -> ">" 1196 | '&' -> "&" 1197 | _ -> T.singleton x 1198 | 1199 | -- | Prepare a reply event 1200 | mkReply :: 1201 | -- | The destination room, must match the original event 1202 | RoomID -> 1203 | -- | The original event 1204 | RoomEvent -> 1205 | -- | The reply message 1206 | MessageText -> 1207 | -- | The event to send 1208 | Event 1209 | mkReply room re mt = 1210 | let getFormattedBody mt' = fromMaybe (toFormattedBody $ mtBody mt') (mtFormattedBody mt') 1211 | eventID = reEventId re 1212 | author = reSender re 1213 | updateText oldMT = 1214 | oldMT 1215 | { mtFormat = Just "org.matrix.custom.html" 1216 | , mtBody = addReplyBody author (mtBody oldMT) (mtBody mt) 1217 | , mtFormattedBody = 1218 | Just $ 1219 | addReplyFormattedBody 1220 | room 1221 | eventID 1222 | author 1223 | (getFormattedBody oldMT) 1224 | (getFormattedBody mt) 1225 | } 1226 | 1227 | newMessage = case reContent re of 1228 | EventRoomMessage (RoomMessageText oldMT) -> updateText oldMT 1229 | EventRoomReply _ (RoomMessageText oldMT) -> updateText oldMT 1230 | EventRoomEdit _ (RoomMessageText oldMT) -> updateText oldMT 1231 | EventUnknown x -> error $ "Can't reply to " <> show x 1232 | in EventRoomReply eventID (RoomMessageText newMessage) 1233 | 1234 | sync :: ClientSession -> Maybe FilterID -> Maybe T.Text -> Maybe Presence -> Maybe Int -> MatrixIO SyncResult 1235 | sync session filterM sinceM presenceM timeoutM = do 1236 | request <- mkRequest session True "/_matrix/client/r0/sync" 1237 | doRequest session (HTTP.setQueryString qs request) 1238 | where 1239 | toQs name = \case 1240 | Nothing -> [] 1241 | Just v -> [(name, Just . encodeUtf8 $ v)] 1242 | qs = 1243 | toQs "filter" (unFilterID <$> filterM) 1244 | <> toQs "since" sinceM 1245 | <> toQs "set_presence" (tshow <$> presenceM) 1246 | <> toQs "timeout" (tshow <$> timeoutM) 1247 | 1248 | syncPoll :: 1249 | (MonadIO m) => 1250 | -- | The client session, use 'createSession' to get one. 1251 | ClientSession -> 1252 | -- | A sync filter, use 'createFilter' to get one. 1253 | Maybe FilterID -> 1254 | -- | A since value, get it from a previous sync result using the 'srNextBatch' field. 1255 | Maybe T.Text -> 1256 | -- | Set the session presence. 1257 | Maybe Presence -> 1258 | -- | Your callback to handle sync result. 1259 | (SyncResult -> m ()) -> 1260 | -- | This function does not return unless there is an error. 1261 | MatrixM m () 1262 | syncPoll session filterM sinceM presenceM cb = go sinceM 1263 | where 1264 | go since = do 1265 | syncResultE <- liftIO $ retry $ sync session filterM since presenceM (Just 10_000) 1266 | case syncResultE of 1267 | Left err -> pure (Left err) 1268 | Right sr -> cb sr >> go (Just (srNextBatch sr)) 1269 | 1270 | -- | Extract room events from a sync result 1271 | getTimelines :: SyncResult -> [(RoomID, NonEmpty RoomEvent)] 1272 | getTimelines sr = foldrWithKey getEvents [] joinedRooms 1273 | where 1274 | getEvents :: T.Text -> JoinedRoomSync -> [(RoomID, NonEmpty RoomEvent)] -> [(RoomID, NonEmpty RoomEvent)] 1275 | getEvents roomID jrs acc = case tsEvents (jrsTimeline jrs) of 1276 | Just (x : xs) -> (RoomID roomID, x :| xs) : acc 1277 | _ -> acc 1278 | joinedRooms = fromMaybe mempty $ srRooms sr >>= srrJoin 1279 | 1280 | ------------------------------------------------------------------------------- 1281 | -- Derived JSON instances 1282 | instance ToJSON RoomEvent where 1283 | toJSON RoomEvent{..} = 1284 | object 1285 | [ "content" .= reContent 1286 | , "type" .= reType 1287 | , "event_id" .= unEventID reEventId 1288 | , "sender" .= reSender 1289 | ] 1290 | 1291 | instance FromJSON RoomEvent where 1292 | parseJSON (Object o) = do 1293 | eventId <- o .: "event_id" 1294 | RoomEvent <$> o .: "content" <*> o .: "type" <*> pure (EventID eventId) <*> o .: "sender" 1295 | parseJSON _ = mzero 1296 | 1297 | instance ToJSON RoomSummary where 1298 | toJSON = genericToJSON aesonOptions 1299 | 1300 | instance FromJSON RoomSummary where 1301 | parseJSON = genericParseJSON aesonOptions 1302 | 1303 | instance ToJSON TimelineSync where 1304 | toJSON = genericToJSON aesonOptions 1305 | 1306 | instance FromJSON TimelineSync where 1307 | parseJSON = genericParseJSON aesonOptions 1308 | 1309 | instance ToJSON JoinedRoomSync where 1310 | toJSON = genericToJSON aesonOptions 1311 | 1312 | instance FromJSON JoinedRoomSync where 1313 | parseJSON = genericParseJSON aesonOptions 1314 | 1315 | instance ToJSON InvitedRoomSync where 1316 | toJSON _ = object [] 1317 | 1318 | instance FromJSON InvitedRoomSync where 1319 | parseJSON _ = pure InvitedRoomSync 1320 | 1321 | instance ToJSON SyncResult where 1322 | toJSON = genericToJSON aesonOptions 1323 | 1324 | instance FromJSON SyncResult where 1325 | parseJSON = genericParseJSON aesonOptions 1326 | 1327 | instance ToJSON SyncResultRoom where 1328 | toJSON = genericToJSON aesonOptions 1329 | 1330 | instance FromJSON SyncResultRoom where 1331 | parseJSON = genericParseJSON aesonOptions 1332 | 1333 | getAccountData' :: (FromJSON a) => ClientSession -> UserID -> T.Text -> MatrixIO a 1334 | getAccountData' session userID t = 1335 | mkRequest session True (accountDataPath userID t) >>= doRequest session 1336 | 1337 | setAccountData' :: (ToJSON a) => ClientSession -> UserID -> T.Text -> a -> MatrixIO () 1338 | setAccountData' session userID t value = do 1339 | request <- mkRequest session True $ accountDataPath userID t 1340 | doRequestExpectEmptyResponse session "set account data" $ 1341 | request 1342 | { HTTP.method = "PUT" 1343 | , HTTP.requestBody = HTTP.RequestBodyLBS $ encode value 1344 | } 1345 | 1346 | accountDataPath :: UserID -> T.Text -> T.Text 1347 | accountDataPath (UserID userID) t = 1348 | "/_matrix/client/r0/user/" <> userID <> "/account_data/" <> t 1349 | 1350 | class (FromJSON a, ToJSON a) => AccountData a where 1351 | accountDataType :: proxy a -> T.Text 1352 | 1353 | getAccountData :: forall a. (AccountData a) => ClientSession -> UserID -> MatrixIO a 1354 | getAccountData session userID = 1355 | getAccountData' session userID $ 1356 | accountDataType (Proxy :: Proxy a) 1357 | 1358 | setAccountData :: forall a. (AccountData a) => ClientSession -> UserID -> a -> MatrixIO () 1359 | setAccountData session userID = 1360 | setAccountData' session userID $ 1361 | accountDataType (Proxy :: Proxy a) 1362 | 1363 | ------------------------------------------------------------------------------- 1364 | -- Utils 1365 | 1366 | headMaybe :: [a] -> Maybe a 1367 | headMaybe xs = case xs of 1368 | [] -> Nothing 1369 | (x : _) -> Just x 1370 | 1371 | tail' :: [a] -> [a] 1372 | tail' xs = case xs of 1373 | [] -> [] 1374 | (_ : rest) -> rest 1375 | 1376 | indistinct :: Either x x -> x 1377 | indistinct = id `either` id 1378 | 1379 | tshow :: (Show a) => a -> T.Text 1380 | tshow = T.pack . show 1381 | 1382 | escapeUriComponent :: T.Text -> T.Text 1383 | escapeUriComponent = T.pack . URI.escapeURIString URI.isUnreserved . T.unpack 1384 | -------------------------------------------------------------------------------- /src/Network/Matrix/Client/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Network.Matrix.Client.Lens ( 4 | -- MessageText 5 | _mtBody, 6 | _mtType, 7 | _mtFormat, 8 | _mtFormattedBody, 9 | -- RoomMessage 10 | _RoomMessageText, 11 | -- Event 12 | _EventRoomMessage, 13 | _EventRoomReply, 14 | _EventRoomEdit, 15 | _EventUnknown, 16 | -- EventFilter 17 | efLimit, 18 | _efNotSenders, 19 | _efNotTypes, 20 | _efSenders, 21 | _efTypes, 22 | -- PaginatedRoomMessages 23 | _chunk, 24 | _end, 25 | _start, 26 | _state, 27 | -- ResolvedRoomAlias 28 | _roomAlias, 29 | _roomID, 30 | _servers, 31 | -- RoomEventFilter 32 | _refLimit, 33 | _refNotSenders, 34 | _refNotTypes, 35 | _refSenders, 36 | _refTypes, 37 | _refLazyLoadMembers, 38 | _refIncludeRedundantMembers, 39 | _refNotRooms, 40 | _refRooms, 41 | _refContainsUrl, 42 | -- StateContent 43 | _StateContentMRCreate, 44 | _StateContentMRCanonicalAlias, 45 | _StateContentMRGuestAccess, 46 | _StateContentMRHistoryVisibility, 47 | _StateContentMRName, 48 | _StateContentMRTopic, 49 | _StateContentMROther, 50 | -- StateEvent 51 | _seContent, 52 | _seEventId, 53 | _seOriginServerTimestamp, 54 | _sePreviousContent, 55 | _seRoomId, 56 | _seSender, 57 | _seStateKey, 58 | _seEventType, 59 | _seUnsigned, 60 | -- StateFilter 61 | _sfLimit, 62 | _sfNotSenders, 63 | _sfTypes, 64 | _sfLazyLoadMembers, 65 | _sfIncludeRedundantMembers, 66 | _sfNotRooms, 67 | _sfRooms, 68 | _sfContainsUrl, 69 | -- RoomFilter 70 | _rfNotRooms, 71 | _rfRooms, 72 | _rfEphemeral, 73 | _rfIncludeLeave, 74 | _rfState, 75 | _rfTimeline, 76 | _rfAccountData, 77 | -- Filter 78 | _filterEventFields, 79 | _filterEventFormat, 80 | _filterPresence, 81 | _filterAccountData, 82 | _filterRoom, 83 | -- RoomEvent 84 | _reContent, 85 | _reType, 86 | _reEventId, 87 | _reSender, 88 | -- RoomSummary 89 | _rsJoinedMemberCount, 90 | _rsInvitedMemberCount, 91 | -- TimelineSync 92 | _tsEvents, 93 | _tsLimited, 94 | _tsPrevBatch, 95 | -- JoinedRoomSync 96 | _jrsSummary, 97 | _jrsTimeline, 98 | -- SyncResult 99 | _srNextBatch, 100 | _srRooms, 101 | -- SyncResultRoom 102 | _srrJoin, 103 | _srrInvite, 104 | ) where 105 | 106 | import Network.Matrix.Client 107 | 108 | import qualified Data.Aeson as J 109 | import Data.Coerce 110 | import qualified Data.Map.Strict as M 111 | import Data.Profunctor (Choice, dimap, right') 112 | import qualified Data.Text as T 113 | 114 | type Lens' s a = forall f. (Functor f) => (a -> f a) -> s -> f s 115 | type Prism' s a = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s) 116 | 117 | lens :: (s -> a) -> (s -> a -> s) -> Lens' s a 118 | lens sa sbt afb s = sbt s <$> afb (sa s) 119 | {-# INLINE lens #-} 120 | 121 | prism :: (a -> s) -> (s -> Either s a) -> Prism' s a 122 | prism bt seta = dimap seta (either pure (fmap bt)) . right' 123 | 124 | prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a 125 | prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) 126 | {-# INLINE prism' #-} 127 | 128 | _mtBody :: Lens' MessageText T.Text 129 | _mtBody = lens getter setter 130 | where 131 | getter = mtBody 132 | setter mt t = mt{mtBody = t} 133 | 134 | _mtType :: Lens' MessageText MessageTextType 135 | _mtType = lens getter setter 136 | where 137 | getter = mtType 138 | setter mt t = mt{mtType = t} 139 | 140 | _mtFormat :: Lens' MessageText (Maybe T.Text) 141 | _mtFormat = lens getter setter 142 | where 143 | getter = mtFormat 144 | setter mt t = mt{mtFormat = t} 145 | 146 | _mtFormattedBody :: Lens' MessageText (Maybe T.Text) 147 | _mtFormattedBody = lens getter setter 148 | where 149 | getter = mtFormattedBody 150 | setter mt t = mt{mtFormattedBody = t} 151 | 152 | _RoomMessageText :: Lens' RoomMessage MessageText 153 | _RoomMessageText = lens getter setter 154 | where 155 | getter = coerce 156 | setter _ = RoomMessageText 157 | 158 | _EventRoomMessage :: Prism' Event RoomMessage 159 | _EventRoomMessage = prism' to from 160 | where 161 | to = EventRoomMessage 162 | from (EventRoomMessage msg) = Just msg 163 | from _ = Nothing 164 | 165 | _EventRoomReply :: Prism' Event (EventID, RoomMessage) 166 | _EventRoomReply = prism' to from 167 | where 168 | to (eid, rm) = EventRoomReply eid rm 169 | from (EventRoomReply eid rm) = Just (eid, rm) 170 | from _ = Nothing 171 | 172 | _EventRoomEdit :: Prism' Event ((EventID, RoomMessage), RoomMessage) 173 | _EventRoomEdit = prism' to from 174 | where 175 | to (oldEvent, newMsg) = EventRoomEdit oldEvent newMsg 176 | from (EventRoomEdit oldEvent newMsg) = Just (oldEvent, newMsg) 177 | from _ = Nothing 178 | 179 | _EventUnknown :: Prism' Event J.Object 180 | _EventUnknown = prism' to from 181 | where 182 | to = EventUnknown 183 | from (EventUnknown obj) = Just obj 184 | from _ = Nothing 185 | 186 | _efLimit :: Lens' EventFilter (Maybe Int) 187 | _efLimit = lens getter setter 188 | where 189 | getter = efLimit 190 | setter ef lim = ef{efLimit = lim} 191 | 192 | _efNotSenders :: Lens' EventFilter (Maybe [T.Text]) 193 | _efNotSenders = lens getter setter 194 | where 195 | getter = efNotSenders 196 | setter ef ns = ef{efNotSenders = ns} 197 | 198 | _efNotTypes :: Lens' EventFilter (Maybe [T.Text]) 199 | _efNotTypes = lens getter setter 200 | where 201 | getter = efNotTypes 202 | setter ef nt = ef{efNotTypes = nt} 203 | 204 | _efSenders :: Lens' EventFilter (Maybe [T.Text]) 205 | _efSenders = lens getter setter 206 | where 207 | getter = efSenders 208 | setter ef s = ef{efSenders = s} 209 | 210 | _efTypes :: Lens' EventFilter (Maybe [T.Text]) 211 | _efTypes = lens getter setter 212 | where 213 | getter = efTypes 214 | setter ef t = ef{efTypes = t} 215 | 216 | _chunk :: Lens' PaginatedRoomMessages [RoomEvent] 217 | _chunk = lens getter setter 218 | where 219 | getter = chunk 220 | setter prm c = prm{chunk = c} 221 | 222 | _end :: Lens' PaginatedRoomMessages (Maybe T.Text) 223 | _end = lens getter setter 224 | where 225 | getter = end 226 | setter prm e = prm{end = e} 227 | 228 | _start :: Lens' PaginatedRoomMessages T.Text 229 | _start = lens getter setter 230 | where 231 | getter = start 232 | setter prm s = prm{start = s} 233 | 234 | _state :: Lens' PaginatedRoomMessages [StateEvent] 235 | _state = lens getter setter 236 | where 237 | getter = state 238 | setter prm s = prm{state = s} 239 | 240 | _roomAlias :: Lens' ResolvedRoomAlias RoomAlias 241 | _roomAlias = lens getter setter 242 | where 243 | getter = roomAlias 244 | setter rra ra = rra{roomAlias = ra} 245 | 246 | _roomID :: Lens' ResolvedRoomAlias RoomID 247 | _roomID = lens getter setter 248 | where 249 | getter = roomID 250 | setter rra rid = rra{roomID = rid} 251 | 252 | _servers :: Lens' ResolvedRoomAlias [T.Text] 253 | _servers = lens getter setter 254 | where 255 | getter = servers 256 | setter rra s = rra{servers = s} 257 | 258 | _refLimit :: Lens' RoomEventFilter (Maybe Int) 259 | _refLimit = lens getter setter 260 | where 261 | getter = refLimit 262 | setter ref rl = ref{refLimit = rl} 263 | 264 | _refNotSenders :: Lens' RoomEventFilter (Maybe [T.Text]) 265 | _refNotSenders = lens getter setter 266 | where 267 | getter = refNotSenders 268 | setter ref ns = ref{refNotSenders = ns} 269 | 270 | _refNotTypes :: Lens' RoomEventFilter (Maybe [T.Text]) 271 | _refNotTypes = lens getter setter 272 | where 273 | getter = refNotTypes 274 | setter ref rnt = ref{refNotTypes = rnt} 275 | 276 | _refSenders :: Lens' RoomEventFilter (Maybe [T.Text]) 277 | _refSenders = lens getter setter 278 | where 279 | getter = refSenders 280 | setter ref rs = ref{refSenders = rs} 281 | 282 | _refTypes :: Lens' RoomEventFilter (Maybe [T.Text]) 283 | _refTypes = lens getter setter 284 | where 285 | getter = refTypes 286 | setter ref rt = ref{refTypes = rt} 287 | 288 | _refLazyLoadMembers :: Lens' RoomEventFilter (Maybe Bool) 289 | _refLazyLoadMembers = lens getter setter 290 | where 291 | getter = refLazyLoadMembers 292 | setter ref rldm = ref{refLazyLoadMembers = rldm} 293 | 294 | _refIncludeRedundantMembers :: Lens' RoomEventFilter (Maybe Bool) 295 | _refIncludeRedundantMembers = lens getter setter 296 | where 297 | getter = refIncludeRedundantMembers 298 | setter ref rirm = ref{refIncludeRedundantMembers = rirm} 299 | 300 | _refNotRooms :: Lens' RoomEventFilter (Maybe [T.Text]) 301 | _refNotRooms = lens getter setter 302 | where 303 | getter = refNotRooms 304 | setter ref rnr = ref{refNotRooms = rnr} 305 | 306 | _refRooms :: Lens' RoomEventFilter (Maybe [T.Text]) 307 | _refRooms = lens getter setter 308 | where 309 | getter = refRooms 310 | setter ref rr = ref{refRooms = rr} 311 | 312 | _refContainsUrl :: Lens' RoomEventFilter (Maybe Bool) 313 | _refContainsUrl = lens getter setter 314 | where 315 | getter = refContainsUrl 316 | setter ref rcu = ref{refContainsUrl = rcu} 317 | 318 | _StateContentMRCreate :: Prism' StateContent MRCreate 319 | _StateContentMRCreate = prism' to from 320 | where 321 | to = StRoomCreate 322 | from (StRoomCreate create) = Just create 323 | from _ = Nothing 324 | 325 | _StateContentMRCanonicalAlias :: Prism' StateContent MRCanonicalAlias 326 | _StateContentMRCanonicalAlias = prism' to from 327 | where 328 | to = StRoomCanonicalAlias 329 | from (StRoomCanonicalAlias alias) = Just alias 330 | from _ = Nothing 331 | 332 | _StateContentMRGuestAccess :: Prism' StateContent MRGuestAccess 333 | _StateContentMRGuestAccess = prism' to from 334 | where 335 | to = StRoomGuestAccess 336 | from (StRoomGuestAccess guest) = Just guest 337 | from _ = Nothing 338 | 339 | _StateContentMRHistoryVisibility :: Prism' StateContent MRHistoryVisibility 340 | _StateContentMRHistoryVisibility = prism' to from 341 | where 342 | to = StRoomHistoryVisibility 343 | from (StRoomHistoryVisibility history) = Just history 344 | from _ = Nothing 345 | 346 | _StateContentMRName :: Prism' StateContent MRName 347 | _StateContentMRName = prism' to from 348 | where 349 | to = StRoomName 350 | from (StRoomName name) = Just name 351 | from _ = Nothing 352 | 353 | _StateContentMRTopic :: Prism' StateContent MRTopic 354 | _StateContentMRTopic = prism' to from 355 | where 356 | to = StRoomTopic 357 | from (StRoomTopic topic) = Just topic 358 | from _ = Nothing 359 | 360 | _StateContentMROther :: Prism' StateContent J.Value 361 | _StateContentMROther = prism' to from 362 | where 363 | to = StOther 364 | from (StOther other) = Just other 365 | from _ = Nothing 366 | 367 | _seContent :: Lens' StateEvent StateContent 368 | _seContent = lens getter setter 369 | where 370 | getter = seContent 371 | setter sec c = sec{seContent = c} 372 | 373 | _seEventId :: Lens' StateEvent EventID 374 | _seEventId = lens getter setter 375 | where 376 | getter = seEventId 377 | setter sec eid = sec{seEventId = eid} 378 | 379 | _seOriginServerTimestamp :: Lens' StateEvent Integer 380 | _seOriginServerTimestamp = lens getter setter 381 | where 382 | getter = seOriginServerTimestamp 383 | setter sec ts = sec{seOriginServerTimestamp = ts} 384 | 385 | _sePreviousContent :: Lens' StateEvent (Maybe J.Value) 386 | _sePreviousContent = lens getter setter 387 | where 388 | getter = sePreviousContent 389 | setter sec c = sec{sePreviousContent = c} 390 | 391 | _seRoomId :: Lens' StateEvent RoomID 392 | _seRoomId = lens getter setter 393 | where 394 | getter = seRoomId 395 | setter sec rid = sec{seRoomId = rid} 396 | 397 | _seSender :: Lens' StateEvent UserID 398 | _seSender = lens getter setter 399 | where 400 | getter = seSender 401 | setter sec uid = sec{seSender = uid} 402 | 403 | _seStateKey :: Lens' StateEvent StateKey 404 | _seStateKey = lens getter setter 405 | where 406 | getter = seStateKey 407 | setter sec key = sec{seStateKey = key} 408 | 409 | _seEventType :: Lens' StateEvent EventType 410 | _seEventType = lens getter setter 411 | where 412 | getter = seEventType 413 | setter sec et = sec{seEventType = et} 414 | 415 | _seUnsigned :: Lens' StateEvent (Maybe J.Value) 416 | _seUnsigned = lens getter setter 417 | where 418 | getter = seUnsigned 419 | setter sec val = sec{seUnsigned = val} 420 | 421 | _sfLimit :: Lens' StateFilter (Maybe Int) 422 | _sfLimit = lens getter setter 423 | where 424 | getter = sfLimit 425 | setter sf sfl = sf{sfLimit = sfl} 426 | 427 | _sfNotSenders :: Lens' StateFilter (Maybe [T.Text]) 428 | _sfNotSenders = lens getter setter 429 | where 430 | getter = sfNotSenders 431 | setter sf sfns = sf{sfNotSenders = sfns} 432 | 433 | _sfTypes :: Lens' StateFilter (Maybe [T.Text]) 434 | _sfTypes = lens getter setter 435 | where 436 | getter = sfTypes 437 | setter sf sft = sf{sfTypes = sft} 438 | 439 | _sfLazyLoadMembers :: Lens' StateFilter (Maybe Bool) 440 | _sfLazyLoadMembers = lens getter setter 441 | where 442 | getter = sfLazyLoadMembers 443 | setter sf sflm = sf{sfLazyLoadMembers = sflm} 444 | 445 | _sfIncludeRedundantMembers :: Lens' StateFilter (Maybe Bool) 446 | _sfIncludeRedundantMembers = lens getter setter 447 | where 448 | getter = sfIncludeRedundantMembers 449 | setter sf sfirm = sf{sfIncludeRedundantMembers = sfirm} 450 | 451 | _sfNotRooms :: Lens' StateFilter (Maybe [T.Text]) 452 | _sfNotRooms = lens getter setter 453 | where 454 | getter = sfNotRooms 455 | setter sf sfnr = sf{sfNotRooms = sfnr} 456 | 457 | _sfRooms :: Lens' StateFilter (Maybe [T.Text]) 458 | _sfRooms = lens getter setter 459 | where 460 | getter = sfRooms 461 | setter sf sfr = sf{sfRooms = sfr} 462 | 463 | _sfContainsUrl :: Lens' StateFilter (Maybe Bool) 464 | _sfContainsUrl = lens getter setter 465 | where 466 | getter = sfContains_url 467 | setter sf cu = sf{sfContains_url = cu} 468 | 469 | _rfNotRooms :: Lens' RoomFilter (Maybe [T.Text]) 470 | _rfNotRooms = lens getter setter 471 | where 472 | getter = rfNotRooms 473 | setter rm rfnr = rm{rfNotRooms = rfnr} 474 | 475 | _rfRooms :: Lens' RoomFilter (Maybe [T.Text]) 476 | _rfRooms = lens getter setter 477 | where 478 | getter = rfRooms 479 | setter rm rfr = rm{rfRooms = rfr} 480 | 481 | _rfEphemeral :: Lens' RoomFilter (Maybe RoomEventFilter) 482 | _rfEphemeral = lens getter setter 483 | where 484 | getter = rfEphemeral 485 | setter rm rfe = rm{rfEphemeral = rfe} 486 | 487 | _rfIncludeLeave :: Lens' RoomFilter (Maybe Bool) 488 | _rfIncludeLeave = lens getter setter 489 | where 490 | getter = rfIncludeLeave 491 | setter rm rfil = rm{rfIncludeLeave = rfil} 492 | 493 | _rfState :: Lens' RoomFilter (Maybe StateFilter) 494 | _rfState = lens getter setter 495 | where 496 | getter = rfState 497 | setter rm rfs = rm{rfState = rfs} 498 | 499 | _rfTimeline :: Lens' RoomFilter (Maybe RoomEventFilter) 500 | _rfTimeline = lens getter setter 501 | where 502 | getter = rfTimeline 503 | setter rm rft = rm{rfTimeline = rft} 504 | 505 | _rfAccountData :: Lens' RoomFilter (Maybe RoomEventFilter) 506 | _rfAccountData = lens getter setter 507 | where 508 | getter = rfAccountData 509 | setter rm rfad = rm{rfAccountData = rfad} 510 | 511 | _filterEventFields :: Lens' Filter (Maybe [T.Text]) 512 | _filterEventFields = lens getter setter 513 | where 514 | getter = filterEventFields 515 | setter fltr fef = fltr{filterEventFields = fef} 516 | 517 | _filterEventFormat :: Lens' Filter (Maybe EventFormat) 518 | _filterEventFormat = lens getter setter 519 | where 520 | getter = filterEventFormat 521 | setter fltr fef = fltr{filterEventFormat = fef} 522 | 523 | _filterPresence :: Lens' Filter (Maybe EventFilter) 524 | _filterPresence = lens getter setter 525 | where 526 | getter = filterPresence 527 | setter fltr fp = fltr{filterPresence = fp} 528 | 529 | _filterAccountData :: Lens' Filter (Maybe EventFilter) 530 | _filterAccountData = lens getter setter 531 | where 532 | getter = filterAccountData 533 | setter fltr fac = fltr{filterAccountData = fac} 534 | 535 | _filterRoom :: Lens' Filter (Maybe RoomFilter) 536 | _filterRoom = lens getter setter 537 | where 538 | getter = filterRoom 539 | setter fltr fr = fltr{filterRoom = fr} 540 | 541 | _reContent :: Lens' RoomEvent Event 542 | _reContent = lens getter setter 543 | where 544 | getter = reContent 545 | setter rEvent rc = rEvent{reContent = rc} 546 | 547 | _reType :: Lens' RoomEvent T.Text 548 | _reType = lens getter setter 549 | where 550 | getter = reType 551 | setter rEvent rt = rEvent{reType = rt} 552 | 553 | _reEventId :: Lens' RoomEvent EventID 554 | _reEventId = lens getter setter 555 | where 556 | getter = reEventId 557 | setter rEvent reid = rEvent{reEventId = reid} 558 | 559 | _reSender :: Lens' RoomEvent Author 560 | _reSender = lens getter setter 561 | where 562 | getter = reSender 563 | setter rEvent res = rEvent{reSender = res} 564 | 565 | _rsJoinedMemberCount :: Lens' RoomSummary (Maybe Int) 566 | _rsJoinedMemberCount = lens getter setter 567 | where 568 | getter = rsJoinedMemberCount 569 | setter rs rsjmc = rs{rsJoinedMemberCount = rsjmc} 570 | 571 | _rsInvitedMemberCount :: Lens' RoomSummary (Maybe Int) 572 | _rsInvitedMemberCount = lens getter setter 573 | where 574 | getter = rsInvitedMemberCount 575 | setter rs rsimc = rs{rsInvitedMemberCount = rsimc} 576 | 577 | _tsEvents :: Lens' TimelineSync (Maybe [RoomEvent]) 578 | _tsEvents = lens getter setter 579 | where 580 | getter = tsEvents 581 | setter ts tse = ts{tsEvents = tse} 582 | 583 | _tsLimited :: Lens' TimelineSync (Maybe Bool) 584 | _tsLimited = lens getter setter 585 | where 586 | getter = tsLimited 587 | setter ts tsl = ts{tsLimited = tsl} 588 | 589 | _tsPrevBatch :: Lens' TimelineSync (Maybe T.Text) 590 | _tsPrevBatch = lens getter setter 591 | where 592 | getter = tsPrevBatch 593 | setter ts tspb = ts{tsPrevBatch = tspb} 594 | 595 | _jrsSummary :: Lens' JoinedRoomSync (Maybe RoomSummary) 596 | _jrsSummary = lens getter setter 597 | where 598 | getter = jrsSummary 599 | setter jrs jrss = jrs{jrsSummary = jrss} 600 | 601 | _jrsTimeline :: Lens' JoinedRoomSync TimelineSync 602 | _jrsTimeline = lens getter setter 603 | where 604 | getter = jrsTimeline 605 | setter jrs jrst = jrs{jrsTimeline = jrst} 606 | 607 | _srNextBatch :: Lens' SyncResult T.Text 608 | _srNextBatch = lens getter setter 609 | where 610 | getter = srNextBatch 611 | setter sr srnb = sr{srNextBatch = srnb} 612 | 613 | _srRooms :: Lens' SyncResult (Maybe SyncResultRoom) 614 | _srRooms = lens getter setter 615 | where 616 | getter = srRooms 617 | setter sr srr = sr{srRooms = srr} 618 | 619 | _srrJoin :: Lens' SyncResultRoom (Maybe (M.Map T.Text JoinedRoomSync)) 620 | _srrJoin = lens getter setter 621 | where 622 | getter = srrJoin 623 | setter srr srrj = srr{srrJoin = srrj} 624 | 625 | _srrInvite :: Lens' SyncResultRoom (Maybe (M.Map T.Text InvitedRoomSync)) 626 | _srrInvite = lens getter setter 627 | where 628 | getter = srrInvite 629 | setter srr srri = srr{srrInvite = srri} 630 | -------------------------------------------------------------------------------- /src/Network/Matrix/Events.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Matrix event data type 4 | module Network.Matrix.Events ( 5 | MessageTextType (..), 6 | MessageText (..), 7 | RoomMessage (..), 8 | Event (..), 9 | EventID (..), 10 | eventType, 11 | ) 12 | where 13 | 14 | import Control.Applicative ((<|>)) 15 | import Control.Monad (mzero) 16 | import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (Object, String), object, (.:), (.:?), (.=)) 17 | import Data.Aeson.Types (Pair) 18 | import Data.Text (Text) 19 | 20 | data MessageTextType 21 | = TextType 22 | | EmoteType 23 | | NoticeType 24 | deriving (Eq, Show) 25 | 26 | instance FromJSON MessageTextType where 27 | parseJSON (String name) = case name of 28 | "m.text" -> pure TextType 29 | "m.emote" -> pure EmoteType 30 | "m.notice" -> pure NoticeType 31 | _ -> mzero 32 | parseJSON _ = mzero 33 | 34 | instance ToJSON MessageTextType where 35 | toJSON mt = String $ case mt of 36 | TextType -> "m.text" 37 | EmoteType -> "m.emote" 38 | NoticeType -> "m.notice" 39 | 40 | data MessageText = MessageText 41 | { mtBody :: Text 42 | , mtType :: MessageTextType 43 | , mtFormat :: Maybe Text 44 | , mtFormattedBody :: Maybe Text 45 | } 46 | deriving (Show, Eq) 47 | 48 | instance FromJSON MessageText where 49 | parseJSON (Object v) = 50 | MessageText 51 | <$> v .: "body" 52 | <*> v .: "msgtype" 53 | <*> v .:? "format" 54 | <*> v .:? "formatted_body" 55 | parseJSON _ = mzero 56 | 57 | messageTextAttr :: MessageText -> [Pair] 58 | messageTextAttr msg = 59 | ["body" .= mtBody msg, "msgtype" .= mtType msg] <> format <> formattedBody 60 | where 61 | omitNull k = maybe [] (\v -> [k .= v]) 62 | format = omitNull "format" $ mtFormat msg 63 | formattedBody = omitNull "formatted_body" $ mtFormattedBody msg 64 | 65 | instance ToJSON MessageText where 66 | toJSON = object . messageTextAttr 67 | 68 | newtype RoomMessage 69 | = RoomMessageText MessageText 70 | deriving (Show, Eq) 71 | 72 | roomMessageAttr :: RoomMessage -> [Pair] 73 | roomMessageAttr rm = case rm of 74 | RoomMessageText mt -> messageTextAttr mt 75 | 76 | instance ToJSON RoomMessage where 77 | toJSON msg = case msg of 78 | RoomMessageText mt -> toJSON mt 79 | 80 | instance FromJSON RoomMessage where 81 | parseJSON x = RoomMessageText <$> parseJSON x 82 | 83 | data RelatedMessage = RelatedMessage 84 | { rmMessage :: RoomMessage 85 | , rmRelatedTo :: EventID 86 | } 87 | deriving (Show, Eq) 88 | 89 | data Event 90 | = EventRoomMessage RoomMessage 91 | | -- | A reply defined by the parent event id and the reply message 92 | EventRoomReply EventID RoomMessage 93 | | -- | An edit defined by the original message and the new message 94 | EventRoomEdit (EventID, RoomMessage) RoomMessage 95 | | EventUnknown Object 96 | deriving (Eq, Show) 97 | 98 | instance ToJSON Event where 99 | toJSON event = case event of 100 | EventRoomMessage msg -> toJSON msg 101 | EventRoomReply eventID msg -> 102 | let replyAttr = 103 | [ "m.relates_to" 104 | .= object 105 | [ "m.in_reply_to" .= toJSON eventID 106 | ] 107 | ] 108 | in object $ replyAttr <> roomMessageAttr msg 109 | EventRoomEdit (EventID eventID, msg) newMsg -> 110 | let editAttr = 111 | [ "m.relates_to" 112 | .= object 113 | [ "rel_type" .= ("m.replace" :: Text) 114 | , "event_id" .= eventID 115 | ] 116 | , "m.new_content" .= object (roomMessageAttr newMsg) 117 | ] 118 | in object $ editAttr <> roomMessageAttr msg 119 | EventUnknown v -> Object v 120 | 121 | instance FromJSON Event where 122 | parseJSON (Object content) = 123 | parseRelated <|> parseMessage <|> pure (EventUnknown content) 124 | where 125 | parseMessage = EventRoomMessage <$> parseJSON (Object content) 126 | parseRelated = do 127 | relateM <- content .: "m.relates_to" 128 | case relateM of 129 | Object relate -> parseReply relate <|> parseReplace relate 130 | _ -> mzero 131 | parseReply relate = 132 | EventRoomReply <$> relate .: "m.in_reply_to" <*> parseJSON (Object content) 133 | parseReplace relate = do 134 | rel_type <- relate .: "rel_type" 135 | if rel_type == ("m.replace" :: Text) 136 | then do 137 | ev <- EventID <$> relate .: "event_id" 138 | msg <- parseJSON (Object content) 139 | EventRoomEdit (ev, msg) <$> content .: "m.new_content" 140 | else mzero 141 | parseJSON _ = mzero 142 | 143 | eventType :: Event -> Text 144 | eventType event = case event of 145 | EventRoomMessage _ -> "m.room.message" 146 | EventRoomReply _ _ -> "m.room.message" 147 | EventRoomEdit _ _ -> "m.room.message" 148 | EventUnknown _ -> error $ "Event is not implemented: " <> show event 149 | 150 | newtype EventID = EventID {unEventID :: Text} deriving (Show, Eq, Ord) 151 | 152 | instance FromJSON EventID where 153 | parseJSON (Object v) = EventID <$> v .: "event_id" 154 | parseJSON _ = mzero 155 | 156 | instance ToJSON EventID where 157 | toJSON (EventID v) = object ["event_id" .= v] 158 | -------------------------------------------------------------------------------- /src/Network/Matrix/Identity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | {- | This module contains the Identity service API 6 | https://matrix.org/docs/spec/identity_service/r0.3.0.html 7 | -} 8 | module Network.Matrix.Identity ( 9 | -- * Client 10 | IdentitySession, 11 | MatrixToken (..), 12 | getTokenFromEnv, 13 | createIdentitySession, 14 | 15 | -- * API 16 | MatrixIO, 17 | MatrixError (..), 18 | retry, 19 | retryWithLog, 20 | 21 | -- * User data 22 | UserID (..), 23 | getIdentityTokenOwner, 24 | 25 | -- * Association lookup 26 | HashDetails (..), 27 | hashDetails, 28 | Identity (..), 29 | identityLookup, 30 | HashedAddress, 31 | IdentityLookupRequest, 32 | IdentityLookupResponse, 33 | identitiesLookup, 34 | mkIdentityLookupRequest, 35 | toHashedAddress, 36 | lookupIdentity, 37 | ) 38 | where 39 | 40 | import Control.Monad (mzero) 41 | import Data.Aeson (FromJSON (..), Value (Object, String), encode, object, (.:), (.=)) 42 | import Data.Base64.Types (extractBase64) 43 | import Data.ByteString.Lazy (fromStrict) 44 | import Data.ByteString.Lazy.Base64.URL (encodeBase64Unpadded) 45 | import Data.Digest.Pure.SHA (bytestringDigest, sha256) 46 | #if MIN_VERSION_aeson(2,0,0) 47 | import qualified Data.Aeson.KeyMap as KeyMap 48 | #endif 49 | import qualified Data.HashMap.Strict as HM 50 | import Data.List (lookup) 51 | import Data.List.NonEmpty (NonEmpty) 52 | import Data.Maybe (mapMaybe) 53 | import Data.Text (Text) 54 | import Data.Text.Encoding (encodeUtf8) 55 | import Data.Text.Lazy (toStrict) 56 | import qualified Network.HTTP.Client as HTTP 57 | import Network.Matrix.Internal 58 | 59 | #if MIN_VERSION_aeson(2,0,0) 60 | toKVList :: KeyMap.KeyMap v -> [(Text, v)] 61 | toKVList = HM.toList . KeyMap.toHashMapText 62 | #else 63 | toKVList :: HM.HashMap Text v -> [(Text, v)] 64 | toKVList = HM.toList 65 | #endif 66 | 67 | {- $setup 68 | >>> import Data.Aeson (decode) 69 | -} 70 | 71 | -- | The session record, use 'createSession' to create it. 72 | data IdentitySession = IdentitySession 73 | { baseUrl :: Text 74 | , token :: MatrixToken 75 | , manager :: HTTP.Manager 76 | } 77 | 78 | -- | 'createSession' creates the session record. 79 | createIdentitySession :: 80 | -- | The matrix identity base url, e.g. "https://matrix.org" 81 | Text -> 82 | -- | The user identity token 83 | MatrixToken -> 84 | IO IdentitySession 85 | createIdentitySession baseUrl' token' = IdentitySession baseUrl' token' <$> mkManager 86 | 87 | mkRequest :: IdentitySession -> Bool -> Text -> IO HTTP.Request 88 | mkRequest IdentitySession{..} = mkRequest' baseUrl token 89 | 90 | doRequest :: (FromJSON a) => IdentitySession -> HTTP.Request -> MatrixIO a 91 | doRequest IdentitySession{..} = doRequest' manager 92 | 93 | -- | 'getIdentityTokenOwner' gets information about the owner of a given access token. 94 | getIdentityTokenOwner :: IdentitySession -> MatrixIO UserID 95 | getIdentityTokenOwner session = 96 | doRequest session =<< mkRequest session True "/_matrix/identity/v2/account" 97 | 98 | data HashDetails = HashDetails 99 | { hdAlgorithms :: NonEmpty Text 100 | , hdPepper :: Text 101 | } 102 | deriving (Show, Eq) 103 | 104 | instance FromJSON HashDetails where 105 | parseJSON (Object v) = HashDetails <$> v .: "algorithms" <*> v .: "lookup_pepper" 106 | parseJSON _ = mzero 107 | 108 | hashDetails :: IdentitySession -> MatrixIO HashDetails 109 | hashDetails session = 110 | doRequest session =<< mkRequest session True "/_matrix/identity/v2/hash_details" 111 | 112 | -- | Use 'identityLookup' to lookup a single identity, otherwise uses the full 'identitiesLookup'. 113 | identityLookup :: IdentitySession -> HashDetails -> Identity -> MatrixIO (Maybe UserID) 114 | identityLookup session hd ident = do 115 | fmap toUserIDM <$> identitiesLookup session ilr 116 | where 117 | toUserIDM = lookupIdentity address 118 | address = toHashedAddress hd ident 119 | ilr = mkIdentityLookupRequest hd [address] 120 | 121 | data IdentityLookupRequest = IdentityLookupRequest 122 | { ilrHash :: Text 123 | , ilrPepper :: Text 124 | , ilrAddresses :: [HashedAddress] 125 | } 126 | deriving (Show, Eq) 127 | 128 | newtype HashedAddress = HashedAddress Text deriving (Show, Eq) 129 | 130 | {- | A newtype wrapper to decoded nested list 131 | 132 | >>> decode "{\"mappings\": {\"hash\": \"user\"}}" :: Maybe IdentityLookupResponse 133 | Just (IdentityLookupResponse [(HashedAddress "hash",UserID "user")]) 134 | -} 135 | newtype IdentityLookupResponse = IdentityLookupResponse [(HashedAddress, UserID)] 136 | deriving (Show) 137 | 138 | instance FromJSON IdentityLookupResponse where 139 | parseJSON (Object v) = do 140 | mappings <- v .: "mappings" 141 | case mappings of 142 | (Object kv) -> pure . IdentityLookupResponse $ mapMaybe toTuple (toKVList kv) 143 | _ -> mzero 144 | where 145 | toTuple (k, String s) = Just (HashedAddress k, UserID s) 146 | toTuple _ = Nothing 147 | parseJSON _ = mzero 148 | 149 | identitiesLookup :: IdentitySession -> IdentityLookupRequest -> MatrixIO IdentityLookupResponse 150 | identitiesLookup session ilr = do 151 | request <- mkRequest session True "/_matrix/identity/v2/lookup" 152 | doRequest 153 | session 154 | ( request 155 | { HTTP.method = "POST" 156 | , HTTP.requestBody = HTTP.RequestBodyLBS body 157 | } 158 | ) 159 | where 160 | getAddr (HashedAddress x) = x 161 | body = 162 | encode $ 163 | object 164 | [ "addresses" .= map getAddr (ilrAddresses ilr) 165 | , "algorithm" .= ilrHash ilr 166 | , "pepper" .= ilrPepper ilr 167 | ] 168 | 169 | {- | Hash encoding for lookup 170 | >>> encodeSHA256 "alice@example.com email matrixrocks" 171 | "4kenr7N9drpCJ4AfalmlGQVsOn3o2RHjkADUpXJWZUc" 172 | -} 173 | encodeSHA256 :: Text -> Text 174 | encodeSHA256 = toStrict . extractBase64 . encodeBase64Unpadded . bytestringDigest . sha256 . fromStrict . encodeUtf8 175 | 176 | data Identity = Email Text | Msisdn Text deriving (Show, Eq) 177 | 178 | toHashedAddress :: HashDetails -> Identity -> HashedAddress 179 | toHashedAddress hd ident = HashedAddress $ encodeSHA256 $ val <> " " <> hdPepper hd 180 | where 181 | val = case ident of 182 | Email x -> x <> " email" 183 | Msisdn x -> x <> " msisdn" 184 | 185 | mkIdentityLookupRequest :: HashDetails -> [HashedAddress] -> IdentityLookupRequest 186 | mkIdentityLookupRequest hd = IdentityLookupRequest hash (hdPepper hd) 187 | where 188 | hash = 189 | if "sha256" `elem` hdAlgorithms hd 190 | then "sha256" 191 | else error "Only sha256 is supported" 192 | 193 | lookupIdentity :: HashedAddress -> IdentityLookupResponse -> Maybe UserID 194 | lookupIdentity x (IdentityLookupResponse xs) = Data.List.lookup x xs 195 | -------------------------------------------------------------------------------- /src/Network/Matrix/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE NumericUnderscores #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# OPTIONS_GHC -Wno-missing-export-lists #-} 6 | 7 | -- | This module contains low-level HTTP utility 8 | module Network.Matrix.Internal where 9 | 10 | import Control.Concurrent (threadDelay) 11 | import Control.Exception (Exception, throw, throwIO) 12 | import Control.Monad (mzero, unless, void) 13 | import Control.Monad.Catch (Handler (Handler), MonadMask) 14 | import Control.Monad.IO.Class (MonadIO, liftIO) 15 | import Control.Retry (RetryStatus (..)) 16 | import qualified Control.Retry as Retry 17 | import Data.Aeson (FromJSON (..), FromJSONKey (..), Value (Object), eitherDecode, encode, object, withObject, (.:), (.:?), (.=)) 18 | import Data.ByteString.Lazy (ByteString, toStrict) 19 | import Data.Hashable (Hashable) 20 | import Data.Maybe (catMaybes, fromMaybe) 21 | import Data.Text (Text, pack, unpack) 22 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 23 | import Data.Text.IO (hPutStrLn) 24 | import qualified Network.HTTP.Client as HTTP 25 | import Network.HTTP.Client.TLS (tlsManagerSettings) 26 | import Network.HTTP.Types (Status (..)) 27 | import Network.HTTP.Types.Status (statusIsSuccessful) 28 | import System.Environment (getEnv) 29 | import System.IO (stderr) 30 | 31 | newtype MatrixToken = MatrixToken Text 32 | newtype Username = Username {username :: Text} 33 | newtype DeviceId = DeviceId {deviceId :: Text} 34 | newtype InitialDeviceDisplayName = InitialDeviceDisplayName {initialDeviceDisplayName :: Text} 35 | data LoginSecret = Password Text | Token Text 36 | 37 | data LoginResponse = LoginResponse 38 | { lrUserId :: Text 39 | , lrAccessToken :: Text 40 | , lrHomeServer :: Text 41 | , lrDeviceId :: Text 42 | } 43 | 44 | instance FromJSON LoginResponse where 45 | parseJSON = withObject "LoginResponse" $ \v -> do 46 | userId' <- v .: "user_id" 47 | accessToken' <- v .: "access_token" 48 | homeServer' <- v .: "home_server" 49 | deviceId' <- v .: "device_id" 50 | pure $ LoginResponse userId' accessToken' homeServer' deviceId' 51 | 52 | getTokenFromEnv :: 53 | -- | The envirnoment variable name 54 | Text -> 55 | IO MatrixToken 56 | getTokenFromEnv env = MatrixToken . pack <$> getEnv (unpack env) 57 | 58 | mkManager :: IO HTTP.Manager 59 | mkManager = HTTP.newManager tlsManagerSettings 60 | 61 | checkMatrixResponse :: HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO () 62 | checkMatrixResponse req res = 63 | unless (200 <= code && code < 500) $ do 64 | chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024 65 | throwResponseError req res chunk 66 | where 67 | Status code _ = HTTP.responseStatus res 68 | 69 | throwResponseError :: HTTP.Request -> HTTP.Response body -> ByteString -> IO a 70 | throwResponseError req res chunk = 71 | throwIO $ HTTP.HttpExceptionRequest req ex 72 | where 73 | ex = HTTP.StatusCodeException (void res) (toStrict chunk) 74 | 75 | mkRequest' :: Text -> MatrixToken -> Bool -> Text -> IO HTTP.Request 76 | mkRequest' baseUrl (MatrixToken token) auth path = do 77 | initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) 78 | pure $ 79 | initRequest 80 | { HTTP.requestHeaders = 81 | [("Content-Type", "application/json")] <> authHeaders 82 | , HTTP.checkResponse = checkMatrixResponse 83 | } 84 | where 85 | authHeaders = 86 | [("Authorization", "Bearer " <> encodeUtf8 token) | auth] 87 | 88 | mkLoginRequest' :: Text -> Maybe DeviceId -> Maybe InitialDeviceDisplayName -> Username -> LoginSecret -> IO HTTP.Request 89 | mkLoginRequest' baseUrl did idn (Username name) secret' = do 90 | let path = "/_matrix/client/r0/login" 91 | initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) 92 | 93 | let (secretKey, secret, secretType) = case secret' of 94 | Password pass -> ("password", pass, "m.login.password") 95 | Token tok -> ("token", tok, "m.login.token") 96 | 97 | let body = 98 | HTTP.RequestBodyLBS $ 99 | encode $ 100 | object $ 101 | [ "identifier" .= object ["type" .= ("m.id.user" :: Text), "user" .= name] 102 | , secretKey .= secret 103 | , "type" .= (secretType :: Text) 104 | ] 105 | <> catMaybes 106 | [ fmap (("device_id" .=) . deviceId) did 107 | , fmap (("initial_device_display_name" .=) . initialDeviceDisplayName) idn 108 | ] 109 | 110 | pure $ initRequest{HTTP.method = "POST", HTTP.requestBody = body, HTTP.requestHeaders = [("Content-Type", "application/json")]} 111 | 112 | mkLogoutRequest' :: Text -> MatrixToken -> IO HTTP.Request 113 | mkLogoutRequest' baseUrl (MatrixToken token) = do 114 | let path = "/_matrix/client/r0/logout" 115 | initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) 116 | let headers = [("Authorization", encodeUtf8 $ "Bearer " <> token)] 117 | pure $ initRequest{HTTP.method = "POST", HTTP.requestHeaders = headers} 118 | 119 | doRequest' :: (FromJSON a) => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a) 120 | doRequest' manager request = do 121 | response <- HTTP.httpLbs request manager 122 | case decodeResp $ HTTP.responseBody response of 123 | Right x -> pure x 124 | Left e -> 125 | if statusIsSuccessful $ HTTP.responseStatus response 126 | then fail e 127 | else throwResponseError request response (HTTP.responseBody response) 128 | 129 | decodeResp :: (FromJSON a) => ByteString -> Either String (Either MatrixError a) 130 | decodeResp resp = case eitherDecode resp of 131 | Right a -> Right $ pure a 132 | Left e -> case eitherDecode resp of 133 | Right me -> Right $ Left me 134 | Left _ -> Left e 135 | 136 | newtype UserID = UserID Text 137 | deriving (Show, Eq, Ord, Hashable, FromJSONKey) 138 | 139 | instance FromJSON UserID where 140 | parseJSON (Object v) = UserID <$> v .: "user_id" 141 | parseJSON _ = mzero 142 | 143 | data MatrixError = MatrixError 144 | { meErrcode :: Text 145 | , meError :: Text 146 | , meRetryAfterMS :: Maybe Int 147 | } 148 | deriving (Show, Eq) 149 | 150 | data MatrixException = MatrixRateLimit deriving (Show) 151 | 152 | instance Exception MatrixException 153 | 154 | instance FromJSON MatrixError where 155 | parseJSON (Object v) = 156 | MatrixError 157 | <$> v .: "errcode" 158 | <*> v .: "error" 159 | <*> v .:? "retry_after_ms" 160 | parseJSON _ = mzero 161 | 162 | -- | 'MatrixIO' is a convenient type alias for server response 163 | type MatrixIO a = MatrixM IO a 164 | 165 | type MatrixM m a = m (Either MatrixError a) 166 | 167 | -- | Retry a network action 168 | retryWithLog :: 169 | (MonadMask m, MonadIO m) => 170 | -- | Maximum number of retry 171 | Int -> 172 | -- | A log function, can be used to measure errors 173 | (Text -> m ()) -> 174 | -- | The action to retry 175 | MatrixM m a -> 176 | MatrixM m a 177 | retryWithLog limit logRetry action = 178 | Retry.recovering 179 | (Retry.exponentialBackoff backoff <> Retry.limitRetries limit) 180 | [handler, rateLimitHandler] 181 | (const checkAction) 182 | where 183 | checkAction = do 184 | res <- action 185 | case res of 186 | Left (MatrixError "M_LIMIT_EXCEEDED" err delayMS) -> do 187 | -- Reponse contains a retry_after_ms 188 | logRetry $ "RateLimit: " <> err <> " (delay: " <> pack (show delayMS) <> ")" 189 | liftIO $ threadDelay $ fromMaybe 5_000 delayMS * 1000 190 | throw MatrixRateLimit 191 | _ -> pure res 192 | 193 | backoff = 1_000_000 -- 1sec 194 | rateLimitHandler _ = Handler $ \case 195 | MatrixRateLimit -> pure True 196 | -- Log network error 197 | handler (RetryStatus num _ _) = Handler $ \case 198 | HTTP.HttpExceptionRequest req ctx -> do 199 | let url = decodeUtf8 (HTTP.host req) <> ":" <> pack (show (HTTP.port req)) <> decodeUtf8 (HTTP.path req) 200 | arg = decodeUtf8 $ HTTP.queryString req 201 | loc = if num == 0 then url <> arg else url 202 | logRetry $ 203 | "NetworkFailure: " 204 | <> pack (show num) 205 | <> "/5 " 206 | <> loc 207 | <> " failed: " 208 | <> pack (show ctx) 209 | pure True 210 | HTTP.InvalidUrlException _ _ -> pure False 211 | 212 | retry :: (MonadIO m, MonadMask m) => MatrixM m a -> MatrixM m a 213 | retry = retryWithLog 7 (liftIO . hPutStrLn stderr) 214 | -------------------------------------------------------------------------------- /src/Network/Matrix/Room.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Matrix room related data types 5 | module Network.Matrix.Room (RoomCreatePreset (..), RoomCreateRequest (..)) where 6 | 7 | import Data.Aeson (ToJSON (..), Value (..), genericToJSON) 8 | import qualified Data.Aeson as Aeson 9 | import Data.Aeson.Casing (aesonPrefix, snakeCase) 10 | import Data.Text (Text) 11 | import GHC.Generics (Generic) 12 | 13 | -- | https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-createroom 14 | data RoomCreatePreset 15 | = PrivateChat 16 | | TrustedPrivateChat 17 | | PublicChat 18 | deriving (Eq, Show) 19 | 20 | instance ToJSON RoomCreatePreset where 21 | toJSON preset = String $ case preset of 22 | PrivateChat -> "private_chat" 23 | TrustedPrivateChat -> "trusted_private_chat" 24 | PublicChat -> "public_chat" 25 | 26 | data RoomCreateRequest = RoomCreateRequest 27 | { rcrPreset :: RoomCreatePreset 28 | , rcrRoomAliasName :: Text 29 | , rcrName :: Text 30 | , rcrTopic :: Text 31 | } 32 | deriving (Eq, Show, Generic) 33 | 34 | instance ToJSON RoomCreateRequest where 35 | toJSON = genericToJSON $ (aesonPrefix snakeCase){Aeson.omitNothingFields = True} 36 | -------------------------------------------------------------------------------- /src/Network/Matrix/Tutorial.hs: -------------------------------------------------------------------------------- 1 | {- | The @matrix-client@ library provides a simple interface for interacting with Matrix servers. 2 | 3 | This tutorial introduces how to use the @matrix-client@ library. 4 | 5 | You will need a token to create a session, if you already have an account, you can get it with the @element@ client 6 | by visiting the account @Settings@ page, @Help & About@ panel, then click @Access Token@. 7 | 8 | Alternatively, you can setup a test service by running these commands in a terminal: 9 | 10 | > git clone https://github.com/matrix-org/dendrite 11 | > cd dendrite; ./build.sh; ./bin/generate-keys --private-key matrix_key.pem; cp dendrite-config.yaml dendrite.yaml 12 | > ./bin/dendrite-monolith-server --config dendrite.yaml 13 | > curl -XPOST http://localhost:8008/_matrix/client/r0/register -d'{"username": "tristanC", "password": "supersecret", "auth": {"type": "m.login.dummy"}}' 14 | 15 | To avoid manipulating the token directly, put it in your environment: 16 | 17 | > export MATRIX_TOKEN="THE_ACCESS_TOKEN" 18 | -} 19 | module Network.Matrix.Tutorial ( 20 | -- * Introduction 21 | -- $intro 22 | 23 | -- * Create a session 24 | -- $session 25 | 26 | -- * Get messages 27 | -- $sync 28 | 29 | -- * Lookup identity 30 | -- $identity 31 | ) 32 | where 33 | 34 | {- $intro 35 | To start using this library you need a haskell toolchain, on fedora run: 36 | 37 | > $ sudo dnf install -y ghc cabal-install && cabal update 38 | 39 | Then get a copy of the library by running: 40 | 41 | > $ git clone https://github.com/softwarefactory-project/matrix-client-haskell 42 | > $ cd matrix-client-haskell 43 | 44 | Start a REPL: 45 | 46 | > $ cabal repl 47 | > Prelude> import Network.Matrix.Client 48 | > Prelude Netowrk.Matrix.Client> :set prompt "> " 49 | > > :set -XOverloadedStrings 50 | > > :type getTokenOwner 51 | > getTokenOwner :: ClientSession -> MatrixIO WhoAmI 52 | -} 53 | 54 | {- $session 55 | Most functions require 'Network.Matrix.Client.ClientSession' which carries the 56 | endpoint url and the http client manager. 57 | 58 | The only way to get the client is through the 'Network.Matrix.Client.createSession' function: 59 | 60 | > > token <- getTokenFromEnv "MATRIX_TOKEN" 61 | > > sess <- createSession "https://matrix.org" token 62 | > > getTokenOwner sess 63 | > Right (WhoAmI "@tristanc_:matrix.org") 64 | -} 65 | 66 | {- $sync 67 | Create a filter to limit the sync result using the 'Network.Matrix.Client.createFilter' function. 68 | To keep room message only, use the 'Network.Matrix.Client.messageFilter' default filter: 69 | 70 | > > Right userId <- getTokenOwner sess 71 | > > Right filterId <- createFilter sess userId messageFilter 72 | > > getFilter sess (UserID "@gerritbot:matrix.org") filterId 73 | > Right (Filter {filterEventFields = ...}) 74 | 75 | Call the 'Network.Matrix.Client.sync' function to synchronize your client state: 76 | 77 | > > Right syncResult <- sync sess (Just filterId) Nothing (Just Online) Nothing 78 | > > putStrLn $ take 512 $ show (getTimelines syncResult) 79 | > SyncResult {srNextBatch = ...} 80 | 81 | Get next batch with a 300 second timeout using the @since@ argument: 82 | 83 | > > Right syncResult' <- sync sess (Just filterId) (Just (srNextBatch syncResult)) (Just Online) (Just 300000) 84 | 85 | Here are some helpers function to format the messages from sync results, copy them in your REPL: 86 | 87 | > > import qualified Data.Text.IO as Text 88 | > > :{ 89 | > let printEvent re = Text.putStrLn $ case reContent re of 90 | > EventRoomMessage (RoomMessageText mt) -> unAuthor (reSender re) <> ": " <> mtBody mt 91 | > _ -> "" 92 | > :} 93 | > > let printRoomEvent room event = Text.putStr room >> putStr "| " >> printEvent event 94 | > > let printRoomEvents (RoomID room, events) = traverse (printRoomEvent room) events 95 | > > let printTimelines sr = mapM_ printRoomEvents (getTimelines sr) 96 | > > printTimelines syncResult 97 | > ... 98 | 99 | Use the 'Network.Matrix.Client.syncPoll' utility function to continuously get events, 100 | here is an example to print new messages, similar to a @tail -f@ process: 101 | 102 | > > syncPoll sess (Just filterId) (Just (srNextBatch syncResult)) (Just Online) printTimelines 103 | > room1| test-user: Hello world! 104 | > ... 105 | -} 106 | 107 | {- $identity 108 | To use the Identity api you need another token. Get it by running these commands: 109 | 110 | > $ MATRIX_OPENID=$(curl -XPOST https://matrix.org/_matrix/client/r0/user/${USER}/openid/request_token -H "Authorization: Bearer ${MATRIX_TOKEN}" -d '{}') 111 | > $ export MATRIX_IDENTITY_TOKEN=$(curl -XPOST https://matrix.org/_matrix/identity/v2/account/register -d "${MATRIX_OPENID}" | jq -r '.access_token') 112 | 113 | Then here is how to lookup a matrix identity: 114 | 115 | > > import Network.Matrix.Identity 116 | > > tokenId <- getTokenFromEnv "MATRIX_IDENTITY_TOKEN" 117 | > > sessId <- createIdentitySession "https://matrix.org" tokenId 118 | > > Right hd <- hashDetails sessId 119 | > > identityLookup sessId hd (Email "tdecacqu@redhat.com") 120 | > Right (Just (UserID "@tristanc_:matrix.org")) 121 | -} 122 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- | The matrix client specification tests 5 | module Main (main) where 6 | 7 | import Control.Monad (void) 8 | import qualified Data.Aeson.Encode.Pretty as Aeson 9 | import qualified Data.ByteString.Lazy as BS 10 | import Data.Either (isLeft) 11 | import Data.Text (Text, pack) 12 | import Data.Time.Clock.System (SystemTime (..), getSystemTime) 13 | import Network.Matrix.Client 14 | import Network.Matrix.Internal 15 | import System.Environment (lookupEnv) 16 | import Test.Hspec 17 | 18 | main :: IO () 19 | main = do 20 | env <- fmap (fmap pack) <$> traverse lookupEnv ["HOMESERVER_URL", "PRIMARY_TOKEN", "SECONDARY_TOKEN"] 21 | runIntegration <- case env of 22 | [Just url, Just tok1, Just tok2] -> do 23 | sess1 <- createSession url (MatrixToken tok1) 24 | sess2 <- createSession url (MatrixToken tok2) 25 | pure $ integration sess1 sess2 26 | _ -> do 27 | putStrLn "Skipping integration test" 28 | pure $ pure mempty 29 | hspec (parallel spec >> runIntegration) 30 | 31 | integration :: ClientSession -> ClientSession -> Spec 32 | integration sess1 sess2 = do 33 | describe "integration tests" $ do 34 | it "create room" $ do 35 | resp <- 36 | createRoom 37 | sess1 38 | ( RoomCreateRequest 39 | { rcrPreset = PublicChat 40 | , rcrRoomAliasName = "test" 41 | , rcrName = "matrix-client-haskell-test" 42 | , rcrTopic = "Testing matrix-client-haskell" 43 | } 44 | ) 45 | case resp of 46 | Left err -> meError err `shouldBe` "Alias already exists" 47 | Right (RoomID room) -> room `shouldSatisfy` (/= mempty) 48 | it "join room" $ do 49 | resp <- joinRoom sess1 "#test:localhost" 50 | case resp of 51 | Left err -> error (show err) 52 | Right (RoomID room) -> room `shouldSatisfy` (/= mempty) 53 | resp' <- joinRoom sess2 "#test:localhost" 54 | case resp' of 55 | Left err -> error (show err) 56 | Right (RoomID room) -> room `shouldSatisfy` (/= mempty) 57 | it "send message and reply" $ do 58 | -- Flush previous events 59 | Right sr <- sync sess2 Nothing Nothing Nothing Nothing 60 | Right (room : _) <- getJoinedRooms sess1 61 | let msg body = RoomMessageText $ MessageText body TextType Nothing Nothing 62 | let since = srNextBatch sr 63 | Right eventID <- sendMessage sess1 room (EventRoomMessage $ msg "Hello") (TxnID since) 64 | Right reply <- sendMessage sess2 room (EventRoomReply eventID $ msg "Hi!") (TxnID since) 65 | reply `shouldNotBe` eventID 66 | 67 | it "invite private room" $ do 68 | Right room <- createRoom sess1 $ RoomCreateRequest PrivateChat "private" "private-test" "A test" 69 | Right user <- getTokenOwner sess2 70 | Right inviteResult <- inviteToRoom sess1 room user (Just "Welcome!") 71 | inviteResult `shouldBe` () 72 | 73 | spec :: Spec 74 | spec = describe "unit tests" $ do 75 | it "decode unknown" $ 76 | (decodeResp "" :: Either String (Either MatrixError String)) 77 | `shouldSatisfy` isLeft 78 | it "decode error" $ 79 | (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Either String (Either MatrixError String)) 80 | `shouldBe` (Right . Left $ MatrixError "TEST" "a error" Nothing) 81 | it "decode response" $ 82 | decodeResp "{\"user_id\": \"@tristanc_:matrix.org\"}" 83 | `shouldBe` (Right . Right $ UserID "@tristanc_:matrix.org") 84 | it "decode reply" $ do 85 | resp <- decodeResp <$> BS.readFile "test/data/message-reply.json" 86 | case resp of 87 | Right (Right (EventRoomReply eventID (RoomMessageText message))) -> do 88 | eventID `shouldBe` EventID "$eventID" 89 | mtBody message `shouldBe` "> <@tristanc_:matrix.org> :hello\n\nHello there!" 90 | _ -> error $ show resp 91 | it "decode edit" $ do 92 | resp <- decodeResp <$> BS.readFile "test/data/message-edit.json" 93 | case resp of 94 | Right (Right (EventRoomEdit (eventID, RoomMessageText srcMsg) (RoomMessageText message))) -> do 95 | eventID `shouldBe` EventID "$eventID" 96 | mtBody srcMsg `shouldBe` " * > :typo" 97 | mtBody message `shouldBe` "> :hello" 98 | _ -> error $ show resp 99 | it "encode room message" $ 100 | encodePretty (RoomMessageText (MessageText "Hello" TextType Nothing Nothing)) 101 | `shouldBe` "{\"body\":\"Hello\",\"msgtype\":\"m.text\"}" 102 | it "does not retry on success" $ 103 | checkPause (<=) $ do 104 | let resp = Right True 105 | res <- retry (pure resp) 106 | res `shouldBe` resp 107 | it "does not retry on regular failre" $ 108 | checkPause (<=) $ do 109 | let resp = Left $ MatrixError "test" "error" Nothing 110 | res <- (retry (pure resp) :: MatrixIO Int) 111 | res `shouldBe` resp 112 | it "retry on rate limit failure" $ 113 | checkPause (>=) $ do 114 | let resp = Left $ MatrixError "M_LIMIT_EXCEEDED" "error" (Just 1000) 115 | (retryWithLog 1 (const $ pure ()) (pure resp) :: MatrixIO Int) 116 | `shouldThrow` rateLimitSelector 117 | where 118 | rateLimitSelector :: MatrixException -> Bool 119 | rateLimitSelector MatrixRateLimit = True 120 | checkPause op action = do 121 | MkSystemTime startTS _ <- getSystemTime 122 | void action 123 | MkSystemTime endTS _ <- getSystemTime 124 | (endTS - startTS) `shouldSatisfy` (`op` 1) 125 | encodePretty = 126 | Aeson.encodePretty' 127 | ( Aeson.defConfig{Aeson.confIndent = Aeson.Spaces 0, Aeson.confCompare = compare @Text} 128 | ) 129 | -------------------------------------------------------------------------------- /test/data/message-edit.json: -------------------------------------------------------------------------------- 1 | { 2 | "body": " * > :typo", 3 | "format": "org.matrix.custom.html", 4 | "formatted_body": " *
\n:typo\n
\n", 5 | "m.new_content": { 6 | "body": "> :hello", 7 | "format": "org.matrix.custom.html", 8 | "formatted_body": "
\n:hello\n
\n", 9 | "msgtype": "m.text" 10 | }, 11 | "m.relates_to": { 12 | "event_id": "$eventID", 13 | "rel_type": "m.replace" 14 | }, 15 | "msgtype": "m.text" 16 | } 17 | -------------------------------------------------------------------------------- /test/data/message-reply.json: -------------------------------------------------------------------------------- 1 | { 2 | "body": "> <@tristanc_:matrix.org> :hello\n\nHello there!", 3 | "format": "org.matrix.custom.html", 4 | "formatted_body": "
In reply to @tristanc_:matrix.org
:hello
Hello there!", 5 | "m.relates_to": { 6 | "m.in_reply_to": { 7 | "event_id": "$eventID" 8 | } 9 | }, 10 | "msgtype": "m.text" 11 | } 12 | --------------------------------------------------------------------------------