Net-Async-Matrix-0.19000755001750001750 013070735710 13232 5ustar00leoleo000000000000Net-Async-Matrix-0.19/Build.PL000444001750001750 204613070735710 14665 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Net::Async::Matrix', requires => { 'Data::Dump' => 0, 'Future::Utils' => 0, 'IO::Async::Notifier' => '0.63', 'JSON::MaybeXS' => 0, 'List::Util' => '1.29', 'Net::Async::HTTP' => '0.36', 'POSIX' => 0, 'String::Tagged' => '0.12', 'Struct::Dumb' => 0, 'URI' => 0, }, recommends => { 'Digest::HMAC_MD5' => 0, # For formatted message support 'Convert::Color::HTML' => 0, 'HTML::TreeBuilder' => '5', 'String::Tagged::HTML' => 0, }, test_requires => { 'Test::More' => '0.88', # done_testing 'Test::Async::HTTP' => '0.02', }, configure_requires => { 'Module::Build' => '0.4004', # test_requires }, license => 'perl', create_makefile_pl => 'small', create_license => 1, create_readme => 1, meta_merge => { resources => { x_IRC => "irc://irc.perl.org/#io-async", }, }, ); $build->create_build_script; Net-Async-Matrix-0.19/Changes000444001750001750 1474713070735710 14717 0ustar00leoleo000000000000Revision history for Net-Async-Matrix 0.19 2017/04/04 16:25:19 [CHANGES] * Rebuild internals to use /sync rather than /initialSync + /events * Add first-class exposed API to encapsulate "room state" * Improvements to formatted message utility functions * Added some simple one-method example scripts * Support sending and receiving m.read receipts * Configurable amount of initial backlog to request from homeserver at first sync * Have $state->members only return non-"leave" state members * Support monospace tags in build_formatted_message * Added ->convert_mxc_url 0.18 2015/07/22 16:44:56 [CHANGES] * Turn off HTTP pipelining by default * Include the Matrix user_id in the Notifier name, for logging identification [BUGFIXES] * Placate synapse bug involving duplicate rooms in initialSync result * Use JSON::MaybeXS also in unit tests 0.17 2015/04/30 16:07:30 [CHANGES] * Configurable longpoll timeout * Give Rooms a startup future so users can await the initialSync of a room * Allow message sending using transaction IDs * Use JSON::MaybeXS so we have a chance of faster JSON parsing [BUGFIXES] * Don't crash if ->stop is called twice * Avoid a race condition if a new room event arrives before we finish the room initialSync * Fix to optional dependency in test skip logic * Ensure that ->stop/re->start doesn't crash 0.16 2015/02/18 20:08:08 [CHANGES] * Support m.notice and the various attachment types (m.file, audio, video) in bundled client.pl * Added ->upload method 0.15 2015/02/03 16:33:49 [CHANGES] * Add an option to disable the evenstream for the case of lightweight send-only clients * Support m.notice 0.14 2015/01/09 19:25:06 [CHANGES] * Support typing notifications 0.13 2014/12/10 17:08:42 [CHANGES] * Initial start at some unit tests [BUGFIXES] * 'use URI' since it's needed * Clear the (global and room) initialSync futures if the operation fails so that the next call will re-attempt it 0.12 2014/12/02 15:50:18 [CHANGES] * Cope with new m.room.power_levels event format * Allow applications to handle new/unrecognised events by adding 'on_unknown_events' event [BUGFIXES] * Don't emit rich formatted messages if there are no actual formatting tags set on the String::Tagged instance 0.11 2014/11/14 18:25:06 [CHANGES] * Support formatted messages in the "org.matrix.custom.html" format by conversion to/from String::Tagged::Formatting instances * Display formatted messages and image URLs in the client 0.10 2014/11/04 16:15:31 [CHANGES] * Extracted 'make_room' as a subclassable method * Use new Net::Async::HTTP 0.36 ability to store SSL parameters * Pass $event as another param in on{_back,}_message so that new timestamp API is visible [BUGFIXES] * Declare correct version of IaNotifier in Build.PL * Not all '/register' alternatives will have 'stages' * Fix to ->join_room ensuring that $room itself is always returned 0.09 2014/10/07 18:05:58 [CHANGES] * Many more events are handled and reported via on_state: + m.room.aliases + m.room.join_rules + m.room.*_level * Added ability to send invites and an event for incoming invites * Room membership change events now also include the member making the change as well as the member the change is about * Allow setting room names and topics, adding and removing aliases, and changing member and room power levels [BUGFIXES] * Fetch full room initial state on join or create before invoking on_state_synced event 0.08 2014/09/24 17:09:50 [CHANGES] * Added $room->joined_members, to allow filtering of other states (invitees, kicks/bans) * Fix ->register for new Registration API, including multi-stage flows * Added $room->leave * Client improvements + per-room commands: /me and /leave + display a user total count on the user list for a room 0.07 2014/09/22 17:05:01 [CHANGES] * Support /register Matrix API with user_id + password * Fix on_membership event argument order to match on_state_change 0.06 2014/09/19 17:35:40 [CHANGES] * New room event model to handle back-pagination as well as forward events * Support room names and topics * Much improvement to 'client.pl' - nicer formatting, room topics, put member joins/leaves/renames in the event log * Support /login Matrix API with user_id + password 0.05 2014/09/10 11:25:22 [CHANGES] * Split room 'on_member' events into separate events for membership vs. presence * Various neatenings and improvements in included 'client.pl' script [BUGFIXES] * Apply a timeout for longpoll so we don't end up waiting forever * Invoke ->log method of containing $matrix object, not toplevel main::log() 0.04 2014/09/04 18:10:00 [CHANGES] * Many and various improvements to the display of the sample client * Added 'on_synced_*' events to Room objects, removed 'on_room_synced' from Matrix object 0.03 2014/09/03 16:30:54 [CHANGES] * Many more updates for current Matrix API * Split 'on_room_add' into on_room_new + on_room_synced events * Support SSL 0.02 2014/08/27 19:30:34 [CHANGES] * Updates for latest Matrix REST API * ->create_room to return a new Room object * Document the user and membership structs * Initial sync of rooms when joining * Don't store room alias names * Added $room->members * Allow setting default on_room_* event handlers [BUGFIXES] * Remember to fill in request content body of event stream requests, so wrappers around NaHTTP still see it 0.01 2014/08/23 10:29:11 First version, released on an unsuspecting world. Net-Async-Matrix-0.19/LICENSE000444001750001750 4376213070735710 14430 0ustar00leoleo000000000000This software is copyright (c) 2017 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2017 by Paul Evans . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2017 by Paul Evans . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Net-Async-Matrix-0.19/MANIFEST000444001750001750 72713070735710 14506 0ustar00leoleo000000000000Build.PL Changes examples/events.pl examples/sync.pl lib/Net/Async/Matrix.pm lib/Net/Async/Matrix/Room.pm lib/Net/Async/Matrix/Room/State.pm lib/Net/Async/Matrix/Utils.pm LICENSE Makefile.PL MANIFEST This list of files META.json META.yml README t/00use.t t/01login.t t/02initial.t t/03events.t t/09upload.t t/10room-join.t t/11room-messages.t t/12room-state.t t/15room-typing.t t/16room-receipt.t t/50utils-format.t t/70fail-initial.t t/71restart.t t/99pod.t t/Util.pm Net-Async-Matrix-0.19/META.json000444001750001750 375213070735710 15017 0ustar00leoleo000000000000{ "abstract" : "use Matrix with L", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.422", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-Async-Matrix", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.4004" } }, "runtime" : { "recommends" : { "Convert::Color::HTML" : "0", "Digest::HMAC_MD5" : "0", "HTML::TreeBuilder" : "5", "String::Tagged::HTML" : "0" }, "requires" : { "Data::Dump" : "0", "Future::Utils" : "0", "IO::Async::Notifier" : "0.63", "JSON::MaybeXS" : "0", "List::Util" : "1.29", "Net::Async::HTTP" : "0.36", "POSIX" : "0", "String::Tagged" : "0.12", "Struct::Dumb" : "0", "URI" : "0" } }, "test" : { "requires" : { "Test::Async::HTTP" : "0.02", "Test::More" : "0.88" } } }, "provides" : { "Net::Async::Matrix" : { "file" : "lib/Net/Async/Matrix.pm", "version" : "0.19" }, "Net::Async::Matrix::Room" : { "file" : "lib/Net/Async/Matrix/Room.pm", "version" : "0.19" }, "Net::Async::Matrix::Room::State" : { "file" : "lib/Net/Async/Matrix/Room/State.pm", "version" : "0.19" }, "Net::Async::Matrix::Utils" : { "file" : "lib/Net/Async/Matrix/Utils.pm", "version" : "0.19" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "x_IRC" : "irc://irc.perl.org/#io-async" }, "version" : "0.19", "x_serialization_backend" : "JSON::PP version 2.27400" } Net-Async-Matrix-0.19/META.yml000444001750001750 241613070735710 14643 0ustar00leoleo000000000000--- abstract: 'use Matrix with L' author: - 'Paul Evans ' build_requires: Test::Async::HTTP: '0.02' Test::More: '0.88' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.422, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-Async-Matrix provides: Net::Async::Matrix: file: lib/Net/Async/Matrix.pm version: '0.19' Net::Async::Matrix::Room: file: lib/Net/Async/Matrix/Room.pm version: '0.19' Net::Async::Matrix::Room::State: file: lib/Net/Async/Matrix/Room/State.pm version: '0.19' Net::Async::Matrix::Utils: file: lib/Net/Async/Matrix/Utils.pm version: '0.19' recommends: Convert::Color::HTML: '0' Digest::HMAC_MD5: '0' HTML::TreeBuilder: '5' String::Tagged::HTML: '0' requires: Data::Dump: '0' Future::Utils: '0' IO::Async::Notifier: '0.63' JSON::MaybeXS: '0' List::Util: '1.29' Net::Async::HTTP: '0.36' POSIX: '0' String::Tagged: '0.12' Struct::Dumb: '0' URI: '0' resources: IRC: irc://irc.perl.org/#io-async license: http://dev.perl.org/licenses/ version: '0.19' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Net-Async-Matrix-0.19/Makefile.PL000444001750001750 42513070735710 15322 0ustar00leoleo000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4220 use Module::Build::Compat 0.02; Module::Build::Compat->run_build_pl(args => \@ARGV); require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build'); Net-Async-Matrix-0.19/README000444001750001750 2316113070735710 14272 0ustar00leoleo000000000000NAME Net::Async::Matrix - use Matrix with IO::Async SYNOPSIS use Net::Async::Matrix; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $matrix = Net::Async::Matrix->new( server => "my.home.server", ); $loop->add( $matrix ); $matrix->login( user_id => '@my-user:home.server', password => 'SeKr1t', )->get; DESCRIPTION Matrix is an new open standard for interoperable Instant Messaging and VoIP, providing pragmatic HTTP APIs and open source reference implementations for creating and running your own real-time communication infrastructure. This module allows an program to interact with a Matrix homeserver as a connected user client. http://matrix.org/ EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: on_log $message A request to write a debugging log message. This is provided temporarily for development and debugging purposes, but will at some point be removed when the code has reached a certain level of stability. on_presence $user, %changes Invoked on receipt of a user presence change event from the homeserver. %changes will map user state field names to 2-element ARRAY references, each containing the old and new values of that field. on_room_new $room Invoked when a new room first becomes known about. Passed an instance of Net::Async::Matrix::Room. on_room_del $room Invoked when the user has now left a room. on_invite $event Invoked on receipt of a room invite. The $event will contain the plain Matrix event as received; with at least the keys inviter and room_id. on_unknown_event $event Invoked on receipt of any sort of event from the event stream, that is not recognised by any of the other code. This can be used to handle new kinds of incoming events. PARAMETERS The following named parameters may be passed to new or configure. In addition, CODE references for event handlers using the event names listed above can also be given. server => STRING Hostname and port number to contact the homeserver at. Given in the form $hostname:$port This string will be interpolated directly into HTTP request URLs. SSL => BOOL Whether to use SSL/TLS to communicate with the homeserver. Defaults false. SSL_* => ... Any other parameters whose names begin SSL_ will be stored for passing to the HTTP user agent. See IO::Socket::SSL for more detail. path_prefix => STRING Optional. Gives the path prefix to find the Matrix client API at. Normally this should not need modification. on_room_member, on_room_message => CODE Optional. Sets default event handlers on new room objects. enable_events => BOOL Optional. Normally enabled, but if set to a defined-but-false value (i.e. 0 or empty string) the event stream will be disabled. This will cause none of the incoming event handlers to be invoked, because the server will not be polled for events. This may be useful in simple send-only cases where the client has no interest in receiveing any events, and wishes to reduce the load on the homeserver. longpoll_timeout => NUM Optional. Timeout in seconds for the /events longpoll operation. Defaults to 30 seconds if not supplied. first_sync_limit => NUM Optional. Number of events per room to fetch on the first /sync request on startup. Defaults to the server's builtin value if not defined, which is likely to be 10. METHODS The following methods documented with a trailing call to ->get return Future instances. login $matrix->login( %params )->get Performs the necessary steps required to authenticate with the configured Home Server, actually obtain an access token and starting the event stream (unless disabled by the enable_events option being false). The returned Future will eventually yield the $matrix object itself, so it can be easily chained. There are various methods of logging in supported by Matrix; the following sets of arguments determine which is used: user_id, password Log in via the m.login.password method. user_id, access_token Directly sets the user_id and access_token fields, bypassing the usual login semantics. This presumes you already have an existing access token to re-use, obtained by some other mechanism. This exists largely for testing purposes. register $matrix->register( %params )->get Performs the necessary steps required to create a new account on the configured Home Server. sync $matrix->sync( %params )->get Performs a single /sync request on the server, returning the raw results directly. Takes the following named parameters since => STRING Optional. Sync token from the previous request. start $f = $matrix->start Performs the initial sync on the server, and starts the event stream to begin receiving events. While this method does return a Future it is not required that the caller keep track of this; the object itself will store it. It will complete when the initial sync has fininshed, and the event stream has started. If the initial sync has already been requested, this method simply returns the future it returned the last time, ensuring that you can await the client starting up simply by calling it; it will not start a second time. stop $matrix->stop Stops the event stream. After calling this you will need to use start again to continue receiving events. myself $user = $matrix->myself Returns the user object representing the connected user. user $user = $matrix->user( $user_id ) Returns the user object representing a user of the given ID, if defined, or undef. get_displayname set_displayname $name = $matrix->get_displayname->get $matrix->set_displayname( $name )->get Accessor and mutator for the user account's "display name" profile field. get_presence set_presence ( $presence, $msg ) = $matrix->get_presence->get $matrix->set_presence( $presence, $msg )->get Accessor and mutator for the user's current presence state and optional status message string. create_room ( $room, $room_alias ) = $matrix->create_room( $alias_localpart )->get Requests the creation of a new room and associates a new alias with the given localpart on the server. The returned Future will return an instance of Net::Async::Matrix::Room and a string containing the full alias that was created. join_room $room = $matrix->join_room( $room_alias_or_id )->get Requests to join an existing room with the given alias name or plain room ID. If this room is already known by the $matrix object, this method simply returns it. add_alias delete_alias $matrix->add_alias( $alias, $room_id )->get $matrix->delete_alias( $alias )->get Performs a directory server request to create the given room alias name, to point at the room ID, or to remove it again. Note that this is likely only to be supported for alias names scoped within the homeserver the client is connected to, and that additionally some form of permissions system may be in effect on the server to limit access to the directory server. upload $content_uri = $matrix->upload( %params )->get Performs a post to the server's media content repository, to upload a new piece of content, returning the content URI that points to it. The content can be specified in any of three ways, with the following three mutually-exclusive arguments: content => STRING Gives the content directly as an immediate scalar value. file => STRING Gives the path to a readable file on the filesystem containing the content. fh => IO Gives an opened IO handle the content can be read from. The following additional arguments are also recognised: content_type => STRING Gives the MIME type of the content data. content_length => INT Optional. If the content is being delivered from an opened filehandle (via the fh argument), this gives the total length in bytes. This is required in cases such as reading from pipes, when the length of the content isn't immediately available such as by stat()ing the filehandle. convert_mxc_url $url = $matrix->convert_mxc_url( $mxc ) Given a plain string or URI instance containing a Matrix media URL (in the mxc: scheme), returns an http: or https: URL in the form of an URI instance pointing at the media repository on the user's local homeserver where it can be downloaded from. USER STRUCTURES Parameters documented as $user receive a user struct, which supports the following methods: $user_id = $user->user_id User ID of the user. $displayname = $user->displayname Profile displayname of the user. $presence = $user->presence Presence state. One of offline, unavailable or online. $last_active = $user->last_active Epoch time that the user was last active. SUBCLASSING METHODS The following methods are not normally required by users of this class, but are provided for the convenience of subclasses to override. $room = $matrix->make_room( %params ) Returns a new instance of Net::Async::Matrix::Room. SEE ALSO * http://matrix.org/ - matrix.org home page * https://github.com/matrix-org - matrix.org on github AUTHOR Paul Evans Net-Async-Matrix-0.19/examples000755001750001750 013070735710 15050 5ustar00leoleo000000000000Net-Async-Matrix-0.19/examples/events.pl000444001750001750 572113070735710 17053 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::Loop; use Net::Async::Matrix; use Net::Netrc; use Getopt::Long; use JSON::MaybeXS; my $JSON = JSON::MaybeXS->new( pretty => 1 ); STDOUT->binmode( ":encoding(UTF-8)" ); sub print_event { my ( $category, $event ) = @_; print "$category:\n"; print $JSON->encode( $event ) =~ s/^/ | /mgr; } my %NO; GetOptions( 'server=s' => \my $SERVER, 'SSL' => \my $SSL, 'user=s' => \my $USER, 'pass=s' => \my $PASS, 'no-presence' => \$NO{presence}, 'no-receipt' => \$NO{receipt}, 'no-typing' => \$NO{typing}, ) or exit 1; die "Require --server\n" unless defined $SERVER; if( !defined $PASS ) { my $ent = Net::Netrc->lookup( $SERVER, $USER ) or die "No --pass given and not found in .netrc\n"; $USER //= $ent->login; $PASS //= $ent->password; } my $loop = IO::Async::Loop->new; my $matrix = Net::Async::Matrix->new( server => $SERVER, SSL => $SSL, SSL_verify_mode => 0, on_presence => sub { my ( undef, $user, %changes ) = @_; return if $NO{presence}; ## TODO filter print_event( presence => { user_id => $user->user_id, changes => \%changes } ); }, on_room_new => sub { my ( undef, $room ) = @_; $room->configure( on_message => sub { my ( $room, $member, $content, $event ) = @_; print_event( message => { %$event, room_id => $room->room_id, } ); }, on_membership => sub { my ( $room, $member, $event, $subject, %changes ) = @_; print_event( membership => $event ); }, on_state_changed => sub { my ( $room, $member, $event, %changes ) = @_; print_event( state => $event ); }, on_typing => sub { my ( $room, $member, $is_typing ) = @_; return if $NO{typing}; ## TODO: filter print_event( typing => { room_id => $room->room_id, user_id => $member->user->user_id, typing => $is_typing, } ); }, on_read_receipt => sub { my ( $room, $member, $event_id, $content ) = @_; return if $NO{receipt}; print_event( read_receipt => { room_id => $room->room_id, user_id => $member->user->user_id, event_id => $event_id, ts => $content->{ts}, } ); }, ); }, ); $loop->add( $matrix ); print STDERR "Logging in to $SERVER as $USER...\n"; $matrix->login( user_id => $USER, password => $PASS, )->get; my %filter; $filter{presence} = { types => [] } if $NO{presence}; push @{ $filter{room}{ephemeral}{not_types} }, "m.receipt" if $NO{receipt}; push @{ $filter{room}{ephemeral}{not_types} }, "m.typing" if $NO{typing}; my $filter_json = JSON::MaybeXS->new->encode( \%filter ); print STDERR "Event stream started\n"; $loop->run; Net-Async-Matrix-0.19/examples/sync.pl000444001750001750 210713070735710 16516 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::Loop; use Net::Async::Matrix; use Net::Netrc; use Getopt::Long; GetOptions( 'server=s' => \my $SERVER, 'SSL' => \my $SSL, 'user=s' => \my $USER, 'pass=s' => \my $PASS, 'since=s' => \my $SINCE, ) or exit 1; die "Require --server\n" unless defined $SERVER; if( !defined $PASS ) { my $ent = Net::Netrc->lookup( $SERVER, $USER ) or die "No --pass given and not found in .netrc\n"; $USER //= $ent->login; $PASS //= $ent->password; } my $loop = IO::Async::Loop->new; my $matrix = Net::Async::Matrix->new( server => $SERVER, SSL => $SSL, SSL_verify_mode => 0, ); $loop->add( $matrix ); print STDERR "Logging in to $SERVER as $USER...\n"; $matrix->login( user_id => $USER, password => $PASS, _no_start => 1, )->get; print STDERR "Requesting sync...\n"; use JSON::MaybeXS; STDOUT->binmode( ":encoding(UTF-8)" ); print JSON::MaybeXS->new( pretty => 1 )->encode( scalar $matrix->sync( ( defined $SINCE ? ( since => $SINCE ) : () ) )->get ); Net-Async-Matrix-0.19/lib000755001750001750 013070735710 14000 5ustar00leoleo000000000000Net-Async-Matrix-0.19/lib/Net000755001750001750 013070735710 14526 5ustar00leoleo000000000000Net-Async-Matrix-0.19/lib/Net/Async000755001750001750 013070735710 15603 5ustar00leoleo000000000000Net-Async-Matrix-0.19/lib/Net/Async/Matrix.pm000444001750001750 7133313070735710 17571 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2014-2017 -- leonerd@leonerd.org.uk package Net::Async::Matrix; use strict; use warnings; use base qw( IO::Async::Notifier ); IO::Async::Notifier->VERSION( '0.63' ); # adopt_future our $VERSION = '0.19'; $VERSION = eval $VERSION; use Carp; use Future; use Future::Utils qw( repeat ); use JSON::MaybeXS qw( encode_json decode_json ); use Data::Dump 'pp'; use File::stat; use List::Util 1.29 qw( pairmap ); use Scalar::Util qw( blessed ); use Struct::Dumb; use Time::HiRes qw( time ); use URI; struct User => [qw( user_id displayname presence last_active )]; use Net::Async::Matrix::Room; use constant PATH_PREFIX => "/_matrix/client/r0"; use constant LONGPOLL_TIMEOUT => 30; # This is only needed for the (undocumented) recaptcha bypass feature use constant HAVE_DIGEST_HMAC_SHA1 => eval { require Digest::HMAC_SHA1; }; =head1 NAME C - use Matrix with L =head1 SYNOPSIS use Net::Async::Matrix; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $matrix = Net::Async::Matrix->new( server => "my.home.server", ); $loop->add( $matrix ); $matrix->login( user_id => '@my-user:home.server', password => 'SeKr1t', )->get; =head1 DESCRIPTION F is an new open standard for interoperable Instant Messaging and VoIP, providing pragmatic HTTP APIs and open source reference implementations for creating and running your own real-time communication infrastructure. This module allows an program to interact with a Matrix homeserver as a connected user client. L =cut =head1 EVENTS The following events are invoked, either using subclass methods or C references in parameters: =head2 on_log $message A request to write a debugging log message. This is provided temporarily for development and debugging purposes, but will at some point be removed when the code has reached a certain level of stability. =head2 on_presence $user, %changes Invoked on receipt of a user presence change event from the homeserver. C<%changes> will map user state field names to 2-element ARRAY references, each containing the old and new values of that field. =head2 on_room_new $room Invoked when a new room first becomes known about. Passed an instance of L. =head2 on_room_del $room Invoked when the user has now left a room. =head2 on_invite $event Invoked on receipt of a room invite. The C<$event> will contain the plain Matrix event as received; with at least the keys C and C. =head2 on_unknown_event $event Invoked on receipt of any sort of event from the event stream, that is not recognised by any of the other code. This can be used to handle new kinds of incoming events. =cut =head1 PARAMETERS The following named parameters may be passed to C or C. In addition, C references for event handlers using the event names listed above can also be given. =head2 server => STRING Hostname and port number to contact the homeserver at. Given in the form $hostname:$port This string will be interpolated directly into HTTP request URLs. =head2 SSL => BOOL Whether to use SSL/TLS to communicate with the homeserver. Defaults false. =head2 SSL_* => ... Any other parameters whose names begin C will be stored for passing to the HTTP user agent. See L for more detail. =head2 path_prefix => STRING Optional. Gives the path prefix to find the Matrix client API at. Normally this should not need modification. =head2 on_room_member, on_room_message => CODE Optional. Sets default event handlers on new room objects. =head2 enable_events => BOOL Optional. Normally enabled, but if set to a defined-but-false value (i.e. 0 or empty string) the event stream will be disabled. This will cause none of the incoming event handlers to be invoked, because the server will not be polled for events. This may be useful in simple send-only cases where the client has no interest in receiveing any events, and wishes to reduce the load on the homeserver. =head2 longpoll_timeout => NUM Optional. Timeout in seconds for the C longpoll operation. Defaults to 30 seconds if not supplied. =head2 first_sync_limit => NUM Optional. Number of events per room to fetch on the first C request on startup. Defaults to the server's builtin value if not defined, which is likely to be 10. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->SUPER::_init( $params ); $params->{ua} ||= do { require Net::Async::HTTP; Net::Async::HTTP->VERSION( '0.36' ); # SSL params my $ua = Net::Async::HTTP->new( fail_on_error => 1, max_connections_per_host => 3, # allow 2 longpolls + 1 actual command user_agent => __PACKAGE__, pipeline => 0, ); $self->add_child( $ua ); $ua }; # Injectable for unit tests, other event systems, etc.. # For now undocumented while I try to work out the wider design issues $self->{make_delay} = delete $params->{make_delay} || $self->_capture_weakself( sub { my ( $self, $secs ) = @_; $self->loop->delay_future( after => $secs ); } ); $self->{msgid_next} = 0; $self->{users_by_id} = {}; $self->{rooms_by_id} = {}; $self->{path_prefix} = PATH_PREFIX; $self->{longpoll_timeout} = LONGPOLL_TIMEOUT; } =head1 METHODS The following methods documented with a trailing call to C<< ->get >> return L instances. =cut sub configure { my $self = shift; my %params = @_; foreach (qw( server path_prefix ua SSL enable_events longpoll_timeout first_sync_limit on_log on_unknown_event on_presence on_room_new on_room_del on_invite on_room_member on_room_message )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } my $ua = $self->{ua}; foreach ( grep { m/^SSL_/ } keys %params ) { $ua->configure( $_ => delete $params{$_} ); } $self->SUPER::configure( %params ); } sub log { my $self = shift; my ( $message ) = @_; $self->{on_log}->( $message ) if $self->{on_log}; } sub _maybe_encode { my $v = shift; return $v if !ref $v or blessed $v; return $v if ref $v ne "HASH"; return encode_json( $v ); } sub _uri_for_path { my $self = shift; my ( $path, %params ) = @_; $path = "/$path" unless $path =~ m{^/}; my $uri = URI->new; $uri->scheme( $self->{SSL} ? "https" : "http" ); $uri->authority( $self->{server} ); $uri->path( $self->{path_prefix} . $path ); $params{access_token} = $self->{access_token} if defined $self->{access_token}; # Some parameter values can be JSON-encoded objects $uri->query_form( pairmap { $a => _maybe_encode $b } %params ); return $uri; } sub _do_GET_json { my $self = shift; my ( $path, %params ) = @_; $self->{ua}->GET( $self->_uri_for_path( $path, %params ) )->then( sub { my ( $response ) = @_; $response->content_type eq "application/json" or return Future->fail( "Expected application/json response", matrix => ); Future->done( decode_json( $response->content ), $response ); }); } sub _do_send_json { my $self = shift; my ( $method, $path, $content ) = @_; my $req = HTTP::Request->new( $method, $self->_uri_for_path( $path ) ); $req->content( encode_json( $content ) ); $req->header( Content_length => length $req->content ); # ugh $req->header( Content_type => "application/json" ); my $f = $self->{ua}->do_request( request => $req, )->then( sub { my ( $response ) = @_; $response->content_type eq "application/json" or return Future->fail( "Expected application/json response", matrix => ); my $content = $response->content; if( length $content and $content ne q("") ) { eval { $content = decode_json( $content ); 1; } or return Future->fail( "Unable to parse JSON response $content" ); return Future->done( $content, $response ); } else { # server yields empty strings sometimes... :/ return Future->done( undef, $response ); } }); return $self->adopt_future( $f ); } sub _do_PUT_json { shift->_do_send_json( PUT => @_ ) } sub _do_POST_json { shift->_do_send_json( POST => @_ ) } sub _do_DELETE { my $self = shift; my ( $path, %params ) = @_; $self->{ua}->do_request( method => "DELETE", uri => $self->_uri_for_path( $path, %params ), ); } sub _do_POST_file { my $self = shift; my ( $path, %params ) = @_; my $uri = $self->_uri_for_path( "" ); $uri->path( "/_matrix" . $path ); my $req = HTTP::Request->new( "POST" , $uri ); $req->header( Content_type => $params{content_type} ); my $body; if( defined $params{content} ) { $req->content( $params{content} ); $req->header( Content_length => length $req->content ); } elsif( defined $params{file} or defined $params{fh} ) { my $fh = $params{fh}; $fh or open $fh, "<", $params{file} or return Future->fail( "Cannot read $params{file} - $!", open => ); $body = sub { $fh->read( my $buffer, 65536 ) or return undef; return $buffer; }; $req->header( Content_length => $params{content_length} // ( stat $fh )->size ); } my $f = $self->{ua}->do_request( request => $req, request_body => $body, )->then( sub { my ( $response ) = @_; $response->content_type eq "application/json" or return Future->fail( "Expected application/json response", matrix => ); my $content = $response->content; my $uri; if( length $content and $content ne q("") ) { eval { $content = decode_json( $content ); 1; } or return Future->fail( "Unable to parse JSON response " ); return Future->done( $content, $response ); } else { return Future->done( undef, $response ); } }); return $self->adopt_future( $f ); } =head2 login $matrix->login( %params )->get Performs the necessary steps required to authenticate with the configured Home Server, actually obtain an access token and starting the event stream (unless disabled by the C option being false). The returned C will eventually yield the C<$matrix> object itself, so it can be easily chained. There are various methods of logging in supported by Matrix; the following sets of arguments determine which is used: =over 4 =item user_id, password Log in via the C method. =item user_id, access_token Directly sets the C and C fields, bypassing the usual login semantics. This presumes you already have an existing access token to re-use, obtained by some other mechanism. This exists largely for testing purposes. =back =cut sub login { my $self = shift; my %params = @_; if( defined $params{user_id} and defined $params{access_token} ) { $self->{$_} = $params{$_} for qw( user_id access_token ); $self->configure( notifier_name => "uid=$params{user_id}" ); return ( ( $self->{enable_events} // 1 ) ? $self->start : Future->done )->then( sub { Future->done( $self ) }); } # Otherwise; try to obtain the login flow information $self->_do_GET_json( "/login" )->then( sub { my ( $response ) = @_; my $flows = $response->{flows}; my @supported; foreach my $flow ( @$flows ) { next unless my ( $type ) = $flow->{type} =~ m/^m\.login\.(.*)$/; push @supported, $type; next unless my $code = $self->can( "_login_with_$type" ); next unless my $f = $code->( $self, %params ); return $f; } Future->fail( "Unsure how to log in (server supports @supported)", matrix => ); }); } sub _login_with_password { my $self = shift; my %params = @_; return unless defined $params{user_id} and defined $params{password}; $self->_do_POST_json( "/login", { type => "m.login.password", user => $params{user_id}, password => $params{password} } )->then( sub { my ( $resp ) = @_; return $self->login( %$resp, %params ) if defined $resp->{access_token}; return Future->fail( "Expected server to respond with 'access_token'", matrix => ); }); } =head2 register $matrix->register( %params )->get Performs the necessary steps required to create a new account on the configured Home Server. =cut sub register { my $self = shift; my %params = @_; $self->_do_GET_json( "/register" )->then( sub { my ( $response ) = @_; my $flows = $response->{flows}; my @supported; # Try to find a flow for which we can support all the stages FLOW: foreach my $flow ( @$flows ) { # Might or might not find a 'stages' key my @stages = $flow->{stages} ? @{ $flow->{stages} } : ( $flow->{type} ); push @supported, join ",", @stages; my @flowcode; foreach my $stage ( @stages ) { next FLOW unless my ( $type ) = $stage =~ m/^m\.login\.(.*)$/; $type =~ s/\./_/g; next FLOW unless my $method = $self->can( "_register_with_$type" ); next FLOW unless my $code = $method->( $self, %params ); push @flowcode, $code; } # If we've got this far then we know we can implement all the stages my $start = Future->new; my $tail = $start; $tail = $tail->then( $_ ) for @flowcode; $start->done(); return $tail->then( sub { my ( $resp ) = @_; return $self->login( %$resp ) if defined $resp->{access_token}; return Future->fail( "Expected server to respond with 'access_token'", matrix => ); }); } Future->fail( "Unsure how to register (server supports @supported)", matrix => ); }); } sub _register_with_password { my $self = shift; my %params = @_; return unless defined( my $password = $params{password} ); return sub { my ( $resp ) = @_; $self->_do_POST_json( "/register", { type => "m.login.password", session => $resp->{session}, user => $params{user_id}, password => $password, } ); } } sub _register_with_recaptcha { my $self = shift; my %params = @_; return unless defined( my $secret = $params{captcha_bypass_secret} ) and defined $params{user_id}; warn "Cannot use captcha_bypass_secret to bypass m.register.recaptcha without Digest::HMAC_SHA1\n" and return if !HAVE_DIGEST_HMAC_SHA1; my $digest = Digest::HMAC_SHA1::hmac_sha1_hex( $params{user_id}, $secret ); return sub { my ( $resp ) = @_; $self->_do_POST_json( "/register", { type => "m.login.recaptcha", session => $resp->{session}, user => $params{user_id}, captcha_bypass_hmac => $digest, } ); }; } =head2 sync $matrix->sync( %params )->get Performs a single C request on the server, returning the raw results directly. Takes the following named parameters =over 4 =item since => STRING Optional. Sync token from the previous request. =back =cut sub sync { my $self = shift; my ( %params ) = @_; $self->_do_GET_json( "/sync", %params ); } sub await_synced { my $self = shift; return $self->{synced_future} //= $self->loop->new_future; } =head2 start $f = $matrix->start Performs the initial sync on the server, and starts the event stream to begin receiving events. While this method does return a C it is not required that the caller keep track of this; the object itself will store it. It will complete when the initial sync has fininshed, and the event stream has started. If the initial sync has already been requested, this method simply returns the future it returned the last time, ensuring that you can await the client starting up simply by calling it; it will not start a second time. =cut sub start { my $self = shift; defined $self->{access_token} or croak "Cannot ->start without an access token"; return $self->{start_f} ||= do { undef $self->{synced_future}; foreach my $room ( values %{ $self->{rooms_by_id} } ) { $room->_reset_for_sync; } my %first_sync_args; $first_sync_args{filter}{room}{timeline}{limit} = $self->{first_sync_limit} if defined $self->{first_sync_limit}; $self->sync( %first_sync_args )->then( sub { my ( $sync ) = @_; $self->_incoming_sync( $sync ); $self->start_longpoll( since => $sync->{next_batch} ); return $self->await_synced->done; })->on_fail( sub { undef $self->{start_f} }); }; } =head2 stop $matrix->stop Stops the event stream. After calling this you will need to use C again to continue receiving events. =cut sub stop { my $self = shift; ( delete $self->{start_f} )->cancel if $self->{start_f}; $self->stop_longpoll; } ## Longpoll events sub start_longpoll { my $self = shift; my %args = @_; $self->stop_longpoll; $self->{longpoll_last_token} = $args{since}; my $f = $self->{longpoll_f} = repeat { my $last_token = $self->{longpoll_last_token}; Future->wait_any( $self->{make_delay}->( $self->{longpoll_timeout} + 5 ) ->else_fail( "Longpoll timed out" ), $self->sync( since => $last_token, timeout => $self->{longpoll_timeout} * 1000, # msec )->then( sub { my ( $sync ) = @_; $self->_incoming_sync( $sync ); $self->{longpoll_last_token} = $sync->{next_batch}; Future->done(); }), )->else( sub { my ( $failure ) = @_; warn "Longpoll failed - $failure\n"; $self->{make_delay}->( 3 ) }); } while => sub { !shift->failure }; # Don't ->adopt_future this one as it makes it hard to grab to cancel it # again, but apply the same on_fail => invoke_error logic $f->on_fail( $self->_capture_weakself( sub { my $self = shift; $self->invoke_error( @_ ); })); } sub stop_longpoll { my $self = shift; ( delete $self->{longpoll_f} )->cancel if $self->{longpoll_f}; } sub _get_or_make_user { my $self = shift; my ( $user_id ) = @_; return $self->{users_by_id}{$user_id} ||= User( $user_id, undef, undef, undef ); } sub _make_room { my $self = shift; my ( $room_id ) = @_; $self->{rooms_by_id}{$room_id} and croak "Already have a room with ID '$room_id'"; my @args; foreach (qw( message member )) { push @args, "on_$_" => $self->{"on_room_$_"} if $self->{"on_room_$_"}; } my $room = $self->{rooms_by_id}{$room_id} = $self->make_room( matrix => $self, room_id => $room_id, @args, ); $self->add_child( $room ); $self->maybe_invoke_event( on_room_new => $room ); return $room; } sub make_room { my $self = shift; return Net::Async::Matrix::Room->new( @_ ); } sub _get_or_make_room { my $self = shift; my ( $room_id ) = @_; return $self->{rooms_by_id}{$room_id} // $self->_make_room( $room_id ); } =head2 myself $user = $matrix->myself Returns the user object representing the connected user. =cut sub myself { my $self = shift; return $self->_get_or_make_user( $self->{user_id} ); } =head2 user $user = $matrix->user( $user_id ) Returns the user object representing a user of the given ID, if defined, or C. =cut sub user { my $self = shift; my ( $user_id ) = @_; return $self->{users_by_id}{$user_id}; } sub _incoming_sync { my $self = shift; my ( $sync ) = @_; foreach my $category (qw( invite join leave )) { my $rooms = $sync->{rooms}{$category} or next; foreach my $room_id ( keys %$rooms ) { my $roomsync = $rooms->{$room_id}; my $room = $self->_get_or_make_room( $room_id ); $room->${\"_incoming_sync_$category"}( $roomsync ); } } foreach my $event ( @{ $sync->{presence}{events} } ) { $self->_handle_event_m_presence( $event ); } # TODO: account_data } sub _on_self_leave { my $self = shift; my ( $room ) = @_; $self->maybe_invoke_event( on_room_del => $room ); delete $self->{rooms_by_id}{$room->room_id}; } =head2 get_displayname =head2 set_displayname $name = $matrix->get_displayname->get $matrix->set_displayname( $name )->get Accessor and mutator for the user account's "display name" profile field. =cut sub get_displayname { my $self = shift; my ( $user_id ) = @_; $user_id //= $self->{user_id}; $self->_do_GET_json( "/profile/$user_id/displayname" )->then( sub { my ( $content ) = @_; Future->done( $content->{displayname} ); }); } sub set_displayname { my $self = shift; my ( $name ) = @_; $self->_do_PUT_json( "/profile/$self->{user_id}/displayname", { displayname => $name } ); } =head2 get_presence =head2 set_presence ( $presence, $msg ) = $matrix->get_presence->get $matrix->set_presence( $presence, $msg )->get Accessor and mutator for the user's current presence state and optional status message string. =cut sub get_presence { my $self = shift; $self->_do_GET_json( "/presence/$self->{user_id}/status" )->then( sub { my ( $status ) = @_; Future->done( $status->{presence}, $status->{status_msg} ); }); } sub set_presence { my $self = shift; my ( $presence, $msg ) = @_; my $status = { presence => $presence, }; $status->{status_msg} = $msg if defined $msg; $self->_do_PUT_json( "/presence/$self->{user_id}/status", $status ) } sub get_presence_list { my $self = shift; $self->_do_GET_json( "/presence_list/$self->{user_id}" )->then( sub { my ( $events ) = @_; my @users; foreach my $event ( @$events ) { my $user = $self->_get_or_make_user( $event->{user_id} ); foreach (qw( presence displayname )) { $user->$_ = $event->{$_} if defined $event->{$_}; } push @users, $user; } Future->done( @users ); }); } sub invite_presence { my $self = shift; my ( $remote ) = @_; $self->_do_POST_json( "/presence_list/$self->{user_id}", { invite => [ $remote ] } ); } sub drop_presence { my $self = shift; my ( $remote ) = @_; $self->_do_POST_json( "/presence_list/$self->{user_id}", { drop => [ $remote ] } ); } =head2 create_room ( $room, $room_alias ) = $matrix->create_room( $alias_localpart )->get Requests the creation of a new room and associates a new alias with the given localpart on the server. The returned C will return an instance of L and a string containing the full alias that was created. =cut sub create_room { my $self = shift; my ( $room_alias ) = @_; my $body = {}; $body->{room_alias_name} = $room_alias if defined $room_alias; # TODO: visibility? $self->_do_POST_json( "/createRoom", $body )->then( sub { my ( $content ) = @_; my $room = $self->_get_or_make_room( $content->{room_id} ); $room->initial_sync ->then_done( $room, $content->{room_alias} ); }); } =head2 join_room $room = $matrix->join_room( $room_alias_or_id )->get Requests to join an existing room with the given alias name or plain room ID. If this room is already known by the C<$matrix> object, this method simply returns it. =cut sub join_room { my $self = shift; my ( $room_alias ) = @_; $self->_do_POST_json( "/join/$room_alias", {} )->then( sub { my ( $content ) = @_; my $room_id = $content->{room_id}; if( my $room = $self->{rooms_by_id}{$room_id} ) { return Future->done( $room ); } else { my $room = $self->_make_room( $room_id ); return $room->await_synced->then_done( $room ); } }); } sub room_list { my $self = shift; $self->_do_GET_json( "/users/$self->{user_id}/rooms/list" ) ->then( sub { my ( $response ) = @_; Future->done( pp($response) ); }); } =head2 add_alias =head2 delete_alias $matrix->add_alias( $alias, $room_id )->get $matrix->delete_alias( $alias )->get Performs a directory server request to create the given room alias name, to point at the room ID, or to remove it again. Note that this is likely only to be supported for alias names scoped within the homeserver the client is connected to, and that additionally some form of permissions system may be in effect on the server to limit access to the directory server. =cut sub add_alias { my $self = shift; my ( $alias, $room_id ) = @_; $self->_do_PUT_json( "/directory/room/$alias", { room_id => $room_id }, )->then_done(); } sub delete_alias { my $self = shift; my ( $alias ) = @_; $self->_do_DELETE( "/directory/room/$alias" ) ->then_done(); } =head2 upload $content_uri = $matrix->upload( %params )->get Performs a post to the server's media content repository, to upload a new piece of content, returning the content URI that points to it. The content can be specified in any of three ways, with the following three mutually-exclusive arguments: =over 4 =item content => STRING Gives the content directly as an immediate scalar value. =item file => STRING Gives the path to a readable file on the filesystem containing the content. =item fh => IO Gives an opened IO handle the content can be read from. =back The following additional arguments are also recognised: =over 4 =item content_type => STRING Gives the MIME type of the content data. =item content_length => INT Optional. If the content is being delivered from an opened filehandle (via the C argument), this gives the total length in bytes. This is required in cases such as reading from pipes, when the length of the content isn't immediately available such as by Cing the filehandle. =back =cut sub upload { my $self = shift; my %params = @_; defined $params{content_type} or croak "Require 'content_type'"; defined $params{content} or defined $params{file} or defined $params{fh} or croak "Require 'content', 'file' or 'fh'"; # This one takes ~full URL paths $self->_do_POST_file( "/media/v1/upload", %params )->then( sub { my ( $content, $response ) = @_; Future->done( $content->{content_uri} ); }); } =head2 convert_mxc_url $url = $matrix->convert_mxc_url( $mxc ) Given a plain string or L instance containing a Matrix media URL (in the C scheme), returns an C or C URL in the form of an L instance pointing at the media repository on the user's local homeserver where it can be downloaded from. =cut sub convert_mxc_url { my $self = shift; my ( $mxc ) = @_; ( blessed $mxc and $mxc->isa( "URI" ) ) or $mxc = URI->new( $mxc ); $mxc->scheme eq "mxc" or croak "Require an mxc:// scheme"; my $uri = URI->new; $uri->scheme( $self->{SSL} ? "https" : "http" ); $uri->authority( $self->{server} ); $uri->path( "/_matrix/media/v1/download/" . $mxc->authority . $mxc->path ); return $uri; } ## Incoming events sub _handle_event_m_presence { my $self = shift; my ( $event ) = @_; my $content = $event->{content}; my $user = $self->_get_or_make_user( $event->{sender} ); my %changes; foreach (qw( presence displayname )) { next unless defined $content->{$_}; next if defined $user->$_ and $content->{$_} eq $user->$_; $changes{$_} = [ $user->$_, $content->{$_} ]; $user->$_ = $content->{$_}; } if( defined $content->{last_active_ago} ) { my $new_last_active = time() - ( $content->{last_active_ago} / 1000 ); $changes{last_active} = [ $user->last_active, $new_last_active ]; $user->last_active = $new_last_active; } $self->maybe_invoke_event( on_presence => $user, %changes ); foreach my $room ( values %{ $self->{rooms_by_id} } ) { $room->_handle_event_m_presence( $user, %changes ); } } =head1 USER STRUCTURES Parameters documented as C<$user> receive a user struct, which supports the following methods: =head2 $user_id = $user->user_id User ID of the user. =head2 $displayname = $user->displayname Profile displayname of the user. =head2 $presence = $user->presence Presence state. One of C, C or C. =head2 $last_active = $user->last_active Epoch time that the user was last active. =cut =head1 SUBCLASSING METHODS The following methods are not normally required by users of this class, but are provided for the convenience of subclasses to override. =head2 $room = $matrix->make_room( %params ) Returns a new instance of L. =cut =head1 SEE ALSO =over 4 =item * L - matrix.org home page =item * L - matrix.org on github =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Matrix-0.19/lib/Net/Async/Matrix000755001750001750 013070735710 17047 5ustar00leoleo000000000000Net-Async-Matrix-0.19/lib/Net/Async/Matrix/Room.pm000444001750001750 7277013070735710 20513 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2014-2016 -- leonerd@leonerd.org.uk package Net::Async::Matrix::Room; use strict; use warnings; # Not really a Notifier but we like the ->maybe_invoke_event style use base qw( IO::Async::Notifier ); our $VERSION = '0.19'; $VERSION = eval $VERSION; use Carp; use Future; use Future::Utils qw( repeat ); use List::Util qw( pairmap ); use Time::HiRes qw( time ); use Net::Async::Matrix::Room::State; # TEMPORARY hack *Member = \&Net::Async::Matrix::Room::State::Member; use Data::Dump 'pp'; use constant TYPING_RESEND_SECONDS => 30; =head1 NAME C - a single Matrix room =head1 DESCRIPTION An instances in this class are used by L to represent a single Matrix room. =cut =head1 EVENTS The following events are invoked, either using subclass methods or C references in parameters: =head2 on_synced_state Invoked after the initial sync of the room has been completed as far as the state. =head2 on_message $member, $content, $event =head2 on_back_message $member, $content, $event Invoked on receipt of a new message from the given member, either "live" from the event stream, or from backward pagination. =head2 on_membership $member, $event, $subject_member, %changes =head2 on_back_membership $member, $event, $subject_member, %changes Invoked on receipt of a membership change event for the given member, either "live" from the event stream, or from backward pagination. C<%changes> will be a key/value list of state field names that were changed, whose values are 2-element ARRAY references containing the before/after values of those fields. on_membership: $field_name => [ $old_value, $new_value ] on_back_membership: $field_name => [ $new_value, $old_value ] Note carefully that the second value in each array gives the "updated" value, in the direction of the change - that is, for C it gives the new value after the change but for C it gives the old value before. Fields whose values did not change are not present in the C<%changes> list; the values of these can be inspected on the C<$member> object. It is unspecified what values the C<$member> object has for fields present in the change list - client code should not rely on these fields. In most cases when users change their own membership status (such as normal join or leave), the C<$member> and C<$subject_member> parameters refer to the same object. In other cases, such as invites or kicks, the C<$member> parameter refers to the member performing the change, and the C<$subject_member> refers to member that the change is about. =head2 on_state_changed $member, $event, %changes =head2 on_back_state_changed $member, $event, %changes Invoked on receipt of a change of room state (such as name or topic). In the special case of room aliases, because they are considered "state" but are stored per-homeserver, the changes value will consist of three fields; the old and new values I, and a list of the known aliases from all the other servers: on_state_changed: aliases => [ $old, $new, $other ] on_back_state_changed: aliases => [ $new, $old, $other ] This allows a client to detect deletions and additions by comparing the before and after lists, while still having access to the full set of before or after aliases, should it require it. =head2 on_presence $member, %changes Invoked when a member of the room changes membership or presence state. The C<$member> object will already be in the new state. C<%changes> will be a key/value list of state fields names that were changed, and references to 2-element ARRAYs containing the old and new values for this field. =head2 on_typing $member, $is_typing Invoked on receipt of a typing notification change, when the given member either starts or stops typing. =head2 on_members_typing @members Invoked on receipt of a typing notification change to give the full set of currently-typing members. This is invoked after the individual C events. =head2 on_read_receipt $member, $event_id, $content Invoked on receipt of a C type of receipt message. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->SUPER::_init( $params ); $self->{matrix} = delete $params->{matrix}; $self->{room_id} = delete $params->{room_id}; # Server gives us entire sets of typing user_ids all at once. We have to # remember state $self->{typing_members} = {}; $self->{live_state} = Net::Async::Matrix::Room::State->new( $self ); } sub configure { my $self = shift; my %params = @_; foreach (qw( on_message on_back_message on_membership on_back_membership on_presence on_synced_state on_state_changed on_back_state_changed on_typing on_members_typing on_read_receipt )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } $self->SUPER::configure( %params ); } =head1 METHODS =cut # FUNCTION sub _delete_null_changes { my ( $changes ) = @_; foreach ( keys %$changes ) { my ( $old, $new ) = @{ $changes->{$_} }; delete $changes->{$_} if !defined $old and !defined $new or defined $old and defined $new and $old eq $new; } } # FUNCTION sub _pushdown_changes { my ( $ch ) = @_; my ( $oldhash, $newhash ) = @$ch; my %changes; foreach ( keys %$oldhash ) { my $old = $oldhash->{$_}; if( !exists $newhash->{$_} ) { $changes{$_} = [ $old, undef ] if defined $old; next; } my $new = $newhash->{$_}; $changes{$_} = [ $old, $new ] unless !defined $old and !defined $new or defined $old and defined $new and $old eq $new; } foreach ( keys %$newhash ) { my $new = $newhash->{$_}; next if exists $oldhash->{$_}; $changes{$_} = [ undef, $new ] if defined $new; } return keys %changes ? \%changes : undef; } sub _do_GET_json { my $self = shift; my ( $path, @args ) = @_; $self->{matrix}->_do_GET_json( "/rooms/$self->{room_id}" . $path, @args ); } sub _do_PUT_json { my $self = shift; my ( $path, $content ) = @_; $self->{matrix}->_do_PUT_json( "/rooms/$self->{room_id}" . $path, $content ); } sub _do_POST_json { my $self = shift; my ( $path, $content ) = @_; $self->{matrix}->_do_POST_json( "/rooms/$self->{room_id}" . $path, $content ); } =head2 await_synced $f = $room->await_synced Returns a L stored within the room that will complete (with no value) once the room initial state sync has been completed. This completes just I the C event. =cut sub _reset_for_sync { my $self = shift; undef $self->{synced_future}; } sub _incoming_sync_invite { my $self = shift; my ( $sync ) = @_; warn "TODO handle incoming sync data in invite state"; } sub _incoming_sync_join { my $self = shift; my ( $sync ) = @_; my $initial = not $self->await_synced->is_done; # Toplevel fields for now I'm ignoring # account_data # unread_notifications my $live_state = $self->live_state; if( $sync->{state} and $sync->{state}{events} and @{ $sync->{state}{events} } ) { foreach my $event ( @{ $sync->{state}{events} } ) { $live_state->handle_event( $event ); } } foreach my $event ( @{ $sync->{timeline}{events} } ) { if( defined $event->{state_key} ) { my $old_event = $live_state->get_event( $event->{type}, $event->{state_key} ); $live_state->handle_event( $event ); $self->_handle_state_event( $old_event, $event, $live_state ); } else { $self->_handle_event( forward => $event ); } } foreach my $event ( @{ $sync->{ephemeral}{events} } ) { $self->_handle_event( ephemeral => $event ); } if( $initial ) { $self->await_synced->done; $self->maybe_invoke_event( on_synced_state => ); } } sub _incoming_sync_leave { my $self = shift; my ( $sync ) = @_; # don't care for now } sub await_synced { my $self = shift; return $self->{synced_future} //= $self->loop->new_future; } =head2 live_state $state = $room->live_state Returns a L instance representing the current live-tracking state of the room. This instance will mutate and change as new state events are received. =cut sub live_state { my $self = shift; return $self->{live_state}; } sub _handle_state_event { my $self = shift; my ( $old_event, $new_event, $state ) = @_; my $old_content = $old_event->{content}; my $new_content = $new_event->{content}; my %changes; $changes{$_}->[0] = $old_content->{$_} for keys %$old_content; $changes{$_}->[1] = $new_content->{$_} for keys %$new_content; $_->[1] //= undef for values %changes; # Ensure deleted key values become undef _delete_null_changes \%changes; my $member = $state->member( $new_event->{sender} ); my $type = $new_event->{type}; $type =~ m/^m\.room\.(.*)$/; my $method = $1 ? "_handle_state_event_" . join( "_", split m/\./, $1 ) : undef; if( $method and my $code = $self->can( $method ) ) { $self->$code( $member, $new_event, $state, %changes ); } else { $self->maybe_invoke_event( on_state_changed => $member, $new_event, %changes ); } } sub _handle_event { my $self = shift; my ( $direction, $event ) = @_; $event->{type} =~ m/^(m\.room\.)?(.*)$/ or return; my $base = $1 ? "_handle_roomevent_" : "_handle_event_"; my $method = $base . join( "_", split( m/\./, $2 ), $direction ); if( my $code = $self->can( $method ) ) { $code->( $self, $event ); } else { warn "TODO: $direction event $event->{type}\n"; } } sub _handle_state_backward { my $self = shift; my ( $field, $event ) = @_; my $newvalue = $event->{content}{$field}; my $oldvalue = $event->{prev_content}{$field}; $self->maybe_invoke_event( on_back_state_changed => $self->{back_members_by_userid}{$event->{user_id}}, $event, $field => [ $newvalue, $oldvalue ] ); } =head2 room_id $id = $room->room_id Returns the opaque room ID string for the room. Usually this would not be required, except for long-term persistence uniqueness purposes, or for inclusion in direct protocol URLs. =cut sub room_id { my $self = shift; return $self->{room_id}; } =head2 name $name = $room->name Returns the room name, if defined, otherwise the opaque room ID. =cut sub _handle_roomevent_name_backward { my $self = shift; my ( $event ) = @_; $self->_handle_state_backward( name => $event ); } sub name { my $self = shift; return $self->live_state->name || $self->room_id; } =head2 set_name $room->set_name( $name )->get Requests to set a new room name. =cut sub set_name { my $self = shift; my ( $name ) = @_; $self->_do_PUT_json( "/state/m.room.name", { name => $name } ) ->then_done(); } =head2 aliases @aliases = $room->aliases Returns a list of all the known room alias names taken from the C events. Note that these are simply names I to have aliases from the alias events; a client ought to still check that these are valid before presenting them to the user as such, or in other ways relying on their values. =cut sub _handle_state_event_aliases { my $self = shift; my ( $member, $event, $state, %changes ) = @_; my $homeserver = $event->{state_key}; my @others = map { $_->{content}{aliases} } grep { $_->{state_key} ne $homeserver } values %{ $state->get_events( "m.room.aliases" ) }; $changes{aliases}[2] = \@others; $self->maybe_invoke_event( on_state_changed => $member, $event, %changes ); } sub _handle_roomevent_aliases_backward { my $self = shift; my ( $event ) = @_; my $homeserver = $event->{state_key}; my $new = $event->{prev_content}{aliases} // []; my $old = $event->{content}{aliases} // []; $self->{back_aliases_by_hs}{$homeserver} = [ @$new ]; my @others = map { @{ $self->{back_aliases_by_hs}{$_} } } grep { $_ ne $homeserver } keys %{ $self->{back_aliases_by_hs} }; $self->maybe_invoke_event( on_back_state_changed => $self->{back_members_by_userid}{$event->{user_id}}, $event, aliases => [ $old, $new, \@others ] ); } sub aliases { my $self = shift; return $self->live_state->aliases; } =head2 join_rule $rule = $room->join_rule Returns the current C for the room; a string giving the type of access new members may get: =over 4 =item * public Any user may join without further permission =item * invite Users may only join if explicitly invited =item * knock Any user may send a knock message to request access; may only join if invited =item * private No new users may join the room =back =cut sub _handle_roomevent_join_rules_backward { my $self = shift; my ( $event ) = @_; $self->_handle_state_backward( join_rule => $event ); } sub join_rule { my $self = shift; return $self->live_state->join_rule; } =head2 topic $topic = $room->topic Returns the room topic, if defined =cut sub _handle_roomevent_topic_backward { my $self = shift; my ( $event ) = @_; $self->_handle_state_backward( topic => $event ); } sub topic { my $self = shift; return $self->live_state->topic; } =head2 set_topic $room->set_topic( $topic )->get Requests to set a new room topic. =cut sub set_topic { my $self = shift; my ( $topic ) = @_; $self->_do_PUT_json( "/state/m.room.topic", { topic => $topic } ) ->then_done(); } =head2 levels %levels = $room->levels Returns a key/value list of the room levels; that is, the member power level required to perform each of the named actions. =cut sub _handle_generic_level { my $self = shift; my ( $phase, $level, $convert, $event ) = @_; foreach my $k (qw( content prev_content )) { next unless my $levels = $event->{$k}; $event->{$k} = { map { $convert->{$_} => $levels->{$_} } keys %$convert }; } if( $phase eq "initial" ) { my $levels = $event->{content}; $self->{levels}{$_} = $levels->{$_} for keys %$levels; } elsif( $phase eq "forward" ) { my $newlevels = $event->{content}; my $oldlevels = $event->{prev_content}; my %changes; foreach ( keys %$newlevels ) { $self->{levels}{$_} = $newlevels->{$_}; $changes{"level.$_"} = [ $oldlevels->{$_}, $newlevels->{$_} ] if !defined $oldlevels->{$_} or $oldlevels->{$_} != $newlevels->{$_}; } my $member = $self->member( $event->{sender} ); $self->maybe_invoke_event( on_state_changed => $member, $event, %changes ); } elsif( $phase eq "backward" ) { my $newlevels = $event->{content}; my $oldlevels = $event->{prev_content}; my %changes; foreach ( keys %$newlevels ) { $changes{"level.$_"} = [ $newlevels->{$_}, $oldlevels->{$_} ] if !defined $oldlevels->{$_} or $oldlevels->{$_} != $newlevels->{$_}; } my $member = $self->{back_members_by_userid}{$event->{user_id}}; $self->maybe_invoke_event( on_back_state_changed => $member, $event, %changes ); } } sub levels { my $self = shift; return %{ $self->{levels} }; } =head2 change_levels $room->change_levels( %levels )->get Performs a room levels change, submitting new values for the given keys while leaving other keys unchanged. =cut sub change_levels { my $self = shift; my %levels = @_; # Delete null changes foreach ( keys %levels ) { delete $levels{$_} if $self->{levels}{$_} == $levels{$_}; } my %events; # These go in their own event with the content key 'level' foreach (qw( send_event add_state )) { $events{"${_}_level"} = { level => $levels{$_} } if exists $levels{$_}; } # These go in an 'ops_levels' event foreach (qw( ban kick redact )) { $events{ops_levels}{"${_}_level"} = $levels{$_} if exists $levels{$_}; } # Fill in remaining 'ops_levels' keys if( $events{ops_levels} ) { $events{ops_levels}{"${_}_level"} //= $self->{levels}{$_} for qw( ban kick redact ); } Future->needs_all( map { $self->_do_PUT_json( "/state/m.room.$_", $events{$_} ) } keys %events )->then_done(); } =head2 members @members = $room->members Returns a list of member structs containing the currently known members of the room, in no particular order. This list will include users who are not yet members of the room, but simply have been invited. =cut sub _handle_roomevent_member_backward { my $self = shift; my ( $event ) = @_; # $self->_handle_roomevent_member( on_back_membership => $event, # $self->{back_members_by_userid}, $event->{content}, $event->{prev_content} ); } sub _handle_state_event_member { my $self = shift; my ( $member, $event, $state, %changes ) = @_; # Currently, the server "deletes" users from the room by setting their # membership to "leave". It's neater if we consider an empty content in # that case. foreach my $idx ( 0, 1 ) { next unless ( $changes{membership}[$idx] // "" ) eq "leave"; undef $changes{$_}[$idx] for keys %changes; } my $user_id = $event->{state_key}; # == user the change applies to my $target_member = $state->member( $user_id ) or warn "ARGH: roomevent_member with unknown user id '$user_id'" and return; _delete_null_changes \%changes; $self->maybe_invoke_event( on_membership => $member, $event, $target_member, %changes ); } sub members { my $self = shift; return $self->live_state->members; } sub member { my $self = shift; my ( $user_id ) = @_; return $self->live_state->member( $user_id ); } =head2 joined_members @members = $room->joined_members Returns the subset of C who actually in the C<"join"> state - i.e. are not invitees, or have left. =cut sub joined_members { my $self = shift; return grep { ( $_->membership // "" ) eq "join" } $self->members; } =head2 member_level $level = $room->member_level( $user_id ) Returns the current cached value for the power level of the given user ID, or the default value if no specific value exists for the given ID. =cut sub _handle_roomevent_power_levels_backward { my $self = shift; my ( $event ) = @_; # $self->_handle_roomevent_power_levels( on_back_membership => # $event, $self->{back_members_by_userid}, $event->{content}, $event->{prev_content} # ); } sub _handle_state_event_power_levels { my $self = shift; my ( $member, $event, $state, %changes ) = @_; # Before we go any further we should also clean up null changes in 'users' # and 'events' hashes by pushing the 'old+new' diff ARRAYrefs down into the # hashes $_ and $_ = _pushdown_changes $_ for $changes{users}, $changes{events}; if( my $users = $changes{users} ) { # TODO: handle default changes my $default = $event->{content}{user_default}; foreach my $user_id ( keys %$users ) { my $target = $state->member( $user_id ) or next; my ( $oldlevel, $newlevel ) = @{ $users->{$user_id} }; $oldlevel //= $default; $newlevel //= $default; $self->maybe_invoke_event( on_membership => $member, $event, $target, level => [ $oldlevel, $newlevel ] ); } } } sub member_level { my $self = shift; my ( $user_id ) = @_; return $self->live_state->member_level( $user_id ); } =head2 change_member_levels $room->change_member_levels( %levels )->get Performs a member power level change, submitting new values for user IDs to the home server. As there is no server API to make individual mutations, this is done by taking the currently cached values, applying the changes given by the C<%levels> key/value list, and submitting the resulting whole as the new value for the C room state. The C<%levels> key/value list should provide new values for keys giving user IDs, or the special user ID of C to change the overall default value for users not otherwise mentioned. Setting the special value of C for a user ID will remove that ID from the set, reverting them to the default. =cut sub change_member_levels { my $self = shift; # Can't just edit the local cache as maybe the server will reject it. Clone # it and if the server accepts our modification the cache will be updated # on the incoming event. my %user_levels = %{ $self->{powerlevels}{users} }; while( @_ ) { my $user_id = shift; my $value = shift; if( defined $value ) { $user_levels{$user_id} = $value; } else { delete $user_levels{$user_id}; } } $self->_do_PUT_json( "/state/m.room.power_levels", { %{ $self->{powerlevels} }, users => \%user_levels } )->then_done(); } =head2 leave $room->leave->get Requests to leave the room. After this completes, the user will no longer be a member of the room. =cut sub leave { my $self = shift; $self->_do_POST_json( "/leave", {} ); } =head2 invite $room->invite( $user_id )->get Sends an invitation for the user with the given User ID to join the room. =cut sub invite { my $self = shift; my ( $user_id ) = @_; $self->_do_POST_json( "/invite", { user_id => $user_id } ) ->then_done(); } =head2 kick $room->kick( $user_id, $reason )->get Requests to remove the user with the given User ID from the room. Optionally, a textual description reason can also be provided. =cut sub kick { my $self = shift; my ( $user_id, $reason ) = @_; $self->_do_POST_json( "/kick", { user_id => $user_id, reason => $reason } ) ->then_done(); } =head2 send_message $event_id = $room->send_message( %args )->get Sends a new message to the room. Requires a C named argument giving the message type. Depending on the type, further keys will be required that specify the message contents: =over 4 =item m.text, m.emote, m.notice Require C =item m.image, m.audio, m.video, m.file Require C =item m.location Require C =back If an additional argument called C is provided, this is used as the transaction ID for the message, which is then sent as a C request instead of a C. $event_id = $room->send_message( $text )->get A convenient shortcut to sending an C message with a body string and no additional content. =cut my %MSG_REQUIRED_FIELDS = ( 'm.text' => [qw( body )], 'm.emote' => [qw( body )], 'm.notice' => [qw( body )], 'm.image' => [qw( url )], 'm.audio' => [qw( url )], 'm.video' => [qw( url )], 'm.file' => [qw( url )], 'm.location' => [qw( geo_uri )], ); sub send_message { my $self = shift; my %args = ( @_ == 1 ) ? ( type => "m.text", body => shift ) : @_; my $type = $args{msgtype} = delete $args{type} or croak "Require a 'type' field"; $MSG_REQUIRED_FIELDS{$type} or croak "Unrecognised message type '$type'"; foreach (@{ $MSG_REQUIRED_FIELDS{$type} } ) { $args{$_} or croak "'$type' messages require a '$_' field"; } if( defined( my $txn_id = $args{txn_id} ) ) { $self->_do_PUT_json( "/send/m.room.message/$txn_id", \%args )->then( sub { my ( $response ) = @_; Future->done( $response->{event_id} ); }); } else { $self->_do_POST_json( "/send/m.room.message", \%args )->then( sub { my ( $response ) = @_; Future->done( $response->{event_id} ); }); } } =head2 paginate_messages $room->paginate_messages( limit => $n )->get Requests more messages of back-pagination history. There is no need to maintain a reference on the returned C; it will be adopted by the room object. =cut sub paginate_messages { my $self = shift; my %args = @_; my $limit = $args{limit} // 20; my $from = $self->{pagination_token} // "END"; croak "Cannot paginate_messages any further since we're already at the start" if $from eq "START"; # Since we're now doing pagination, we'll need a second set of member # objects $self->{back_members_by_userid} //= { pairmap { $a => Member( $b->user, $b->displayname, $b->membership ) } %{ $self->{members_by_userid} } }; $self->{back_aliases_by_hs} //= { pairmap { $a => [ @$b ] } %{ $self->{aliases_by_hs} } }; my $f = $self->_do_GET_json( "/messages", from => $from, dir => "b", limit => $limit, )->then( sub { my ( $response ) = @_; foreach my $event ( @{ $response->{chunk} } ) { next unless my ( $subtype ) = ( $event->{type} =~ m/^m\.room\.(.*)$/ ); $subtype =~ s/\./_/g; if( my $code = $self->can( "_handle_roomevent_${subtype}_backward" ) ) { $code->( $self, $event ); } else { $self->{matrix}->log( "TODO: Handle room pagination event $subtype" ); } } $self->{pagination_token} = $response->{end}; Future->done( $self ); }); $self->adopt_future( $f ); } =head2 typing_start $room->typing_start Sends a typing notification that the user is currently typing in this room. This notification will periodically be re-sent as required by the protocol until the C method is called. =cut sub typing_start { my $self = shift; return if $self->{typing_timer}; my $user_id = $self->{matrix}->myself->user_id; my $f = $self->{typing_timer} = repeat { $self->_do_PUT_json( "/typing/$user_id", { typing => 1, timeout => ( TYPING_RESEND_SECONDS + 5 ) * 1000, # msec })->then( sub { $self->{matrix}->{make_delay}->( TYPING_RESEND_SECONDS ); }); } while => sub { !shift->failure }; $f->on_fail( $self->_capture_weakself( sub { my $self = shift; $self->invoke_error( @_ ); })); } =head2 typing_stop $room->typing_stop Sends a typing notification that the user is no longer typing in this room. This method also cancels the repeating re-send behaviour created by C. =cut sub typing_stop { my $self = shift; return unless my $f = $self->{typing_timer}; $f->cancel; undef $self->{typing_timer}; my $user_id = $self->{matrix}->myself->user_id; $self->adopt_future( $self->_do_PUT_json( "/typing/$user_id", { typing => 0, }) ); } =head2 send_read_receipt $room->send_read_receipt( event_id => $event_id, ... )->get Sends a C receipt to the given room for the given event ID. =cut sub send_read_receipt { my $self = shift; my %args = @_; my $event_id = $args{event_id} or croak "Require event_id"; $self->_do_POST_json( "/receipt/m.read/$event_id", {} ); } sub _handle_roomevent_create_forward { my $self = shift; my ( $event ) = @_; # Nothing interesting here... } *_handle_roomevent_create_initial = \&_handle_roomevent_create_forward; sub _handle_roomevent_create_backward { my $self = shift; # Stop now $self->{pagination_token} = "START"; } sub _handle_roomevent_message_forward { my $self = shift; my ( $event ) = @_; my $user_id = $event->{sender}; my $member = $self->member( $user_id ) or warn "TODO: Unknown member '$user_id' for forward message" and return; $self->maybe_invoke_event( on_message => $member, $event->{content}, $event ); } sub _handle_roomevent_message_backward { my $self = shift; my ( $event ) = @_; my $user_id = $event->{user_id}; my $member = $self->{back_members_by_userid}{$user_id} or warn "TODO: Unknown member '$user_id' for backward message" and return; $self->maybe_invoke_event( on_back_message => $member, $event->{content}, $event ); } sub _handle_event_m_presence { my $self = shift; my ( $user, %changes ) = @_; my $member = $self->member( $user->user_id ) or return; $changes{$_} and $member->$_ = $changes{$_}[1] for qw( displayname ); $self->maybe_invoke_event( on_presence => $member, %changes ); } sub _handle_event_m_typing_ephemeral { my $self = shift; my ( $event ) = @_; my $typing = $self->{typing_members}; my %not_typing = %$typing; foreach my $user_id ( @{ $event->{content}{user_ids} } ) { delete $not_typing{$user_id}; next if $typing->{$user_id}; $typing->{$user_id}++; my $member = $self->member( $user_id ) or next; $self->maybe_invoke_event( on_typing => $member, 1 ); } foreach my $user_id ( keys %not_typing ) { my $member = $self->member( $user_id ) or next; $self->maybe_invoke_event( on_typing => $member, 0 ); delete $typing->{$user_id}; } my @members = map { $self->member( $_ ) } keys %$typing; $self->maybe_invoke_event( on_members_typing => grep { defined } @members ); } sub _handle_event_m_receipt_ephemeral { my $self = shift; my ( $event ) = @_; my $content = $event->{content}; foreach my $event_id ( keys %$content ) { my $receipt = $content->{$event_id}; my $read_receipt = $receipt->{"m.read"} or next; foreach my $user_id ( keys %$read_receipt ) { my $content = $read_receipt->{$user_id}; my $member = $self->member( $user_id ) or next; $self->maybe_invoke_event( on_read_receipt => $member, $event_id, $content ); } } } =head1 MEMBERSHIP STRUCTURES Parameters documented as C<$member> receive a membership struct, which supports the following methods: =head2 $user = $member->user User object of the member. =head2 $displayname = $member->displayname Profile displayname of the user. =head2 $membership = $member->membership Membership state. One of C or C. =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Matrix-0.19/lib/Net/Async/Matrix/Utils.pm000444001750001750 1144213070735710 20664 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2014-2017 -- leonerd@leonerd.org.uk package Net::Async::Matrix::Utils; use strict; use warnings; our $VERSION = '0.19'; $VERSION = eval $VERSION; use Exporter 'import'; our @EXPORT_OK = qw( parse_formatted_message build_formatted_message ); use String::Tagged 0.11; # Optionally parse HTML rich-formatted body; but don't get too upset if we # don't have these installed use constant CAN_PARSE_HTML => eval { require HTML::TreeBuilder; require Convert::Color::HTML; }; # Optionally build HTML rich-formatted body; but don't get too upset if we # don't have this installed use constant CAN_BUILD_HTML => eval { require String::Tagged::HTML; require Convert::Color::HTML; }; =head1 NAME C - support utilities for L =head1 DESCRIPTION =cut =head1 FUNCTIONS =cut =head2 parse_formatted_message $st = parse_formatted_message( $content ) Given the content of a C event of C or C type, returns a L instance containing the text of the message with formatting in L style. If the message is not formatted, or the formatting is of a kind not recognised, the plain-text body is returned in an instance with no tags. The following formats are recognised: =over 4 =item org.matrix.custom.html This format requires the presence of L to parse; it will be ignored if this module is not available. HTML | String::Tagged::Formatting ------------------+--------------------------- , | 'bold' , | 'italic' | 'under' | 'strike' , | 'monospace' {format} ) { last if !$format; return _parse_html_body( $content->{formatted_body} ) if CAN_PARSE_HTML and $format eq "org.matrix.custom.html"; } return String::Tagged->new( $content->{body} ); } sub _parse_html_body { my ( $formatted ) = @_; return _traverse_html( HTML::TreeBuilder->new_from_content( $formatted ) ->find_by_tag_name( 'body' ) ); } sub _traverse_html { my ( $node ) = @_; # Plain text return String::Tagged->new( $node ) if !ref $node; my %tags; for ( $node->tag ) { ( $_ eq "b" || $_ eq "strong" ) and $tags{bold}++, last; ( $_ eq "i" || $_ eq "em" ) and $tags{italic}++, last; $_ eq "u" and $tags{under}++, last; $_ eq "strike" and $tags{strike}++, last; ( $_ eq "tt" || $_ eq "code" ) and $tags{monospace}++, last; if( $_ eq "font" ) { my %attrs = $node->all_attr; my $fg = defined $attrs{color} ? eval { Convert::Color::HTML->new( $attrs{color} ) } : undef; $tags{fg} = $fg if defined $fg; last; } } my $ret = String::Tagged->new; $ret .= _traverse_html( $_ ) for $node->content_list; $ret->apply_tag( 0, length $ret, $_, $tags{$_} ) for keys %tags; return $ret; } =head2 build_formatted_message $content = build_formatted_message( $str ) Given a L instance or plain string, returns a content HASH reference encoding the formatting the message. Plain strings are returned simply as a plain-text body; formatted instances will be output as formatted content if possible: =over 4 =item org.matrix.custom.html This format is output for formatted messages if L is available. String::Tagged::Formatting | HTML ---------------------------+-------------------- 'bold' | 'italic' | 'under' | 'strike' | 'monospace' | 'fg' | =back =cut sub build_formatted_message { my ( $str ) = @_; return { body => $str } if !ref $str; if( $str->tagnames and CAN_BUILD_HTML ) { my $html = String::Tagged::HTML->clone( $str, only_tags => [qw( bold italic under strike monospace fg )], convert_tags => { bold => "strong", italic => "em", under => "u", strike => "strike", monospace => "code", fg => sub { font => { color => $_[1]->as_html->name } }, }, ); return { body => $str->str, format => "org.matrix.custom.html", formatted_body => $html->as_html, }; } else { return { body => $str->str }; } } =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Matrix-0.19/lib/Net/Async/Matrix/Room000755001750001750 013070735710 17763 5ustar00leoleo000000000000Net-Async-Matrix-0.19/lib/Net/Async/Matrix/Room/State.pm000444001750001750 1201513070735710 21555 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2016-2017 -- leonerd@leonerd.org.uk package Net::Async::Matrix::Room::State; use strict; use warnings; use List::Util qw( pairmap ); use Struct::Dumb; struct Member => [qw( user displayname membership )]; our $VERSION = '0.19'; $VERSION = eval $VERSION; =head1 NAME C - represents the state events in a matrix room =head1 DESCRIPTION Instances of this class represent all of the known state events in a L at some instant in time. These objects are mutable so a "live" state object obtained from a room will change to keep track of newly received state events. =cut sub new { my $class = shift; my ( $room ) = @_; return bless { events => {}, matrix => $room->{matrix}, }, $class; } sub handle_event { my $self = shift; my ( $event ) = @_; defined $event->{state_key} or return; my $type = $event->{type}; my $state_key = $event->{state_key} // ""; $self->{events}{$type}{$state_key} = $event; } =head1 METHODS =cut =head2 get_event $event = $state->get_event( $type, $state_key ) Returns a HASH reference containing the raw event stored for the given type name and optional state key. =cut sub get_event { my $self = shift; my ( $type, $state_key ) = @_; $state_key //= ""; return $self->{events}{$type}{$state_key}; } =head2 get_events $events = $state->get_events( $type ) Returns a multi-level HASH reference mapping all of the known state keys for a given event type name to their raw stored events. Typically this is useful for C events as the state keys will be user IDs. =cut sub get_events { my $self = shift; my ( $type ) = @_; return $self->{events}{$type} // {}; } =head1 CONVENIENCE ACCESSORS The following accessors all fetch single values out of certain events, as they are commonly used. =cut =head2 name $name = $state->name Returns the C field of the C event, if it exists. =cut sub name { my $self = shift; my $event = $self->get_event( "m.room.name" ) or return undef; return $event->{content}{name}; } =head2 join_rule $join_rule = $state->join_rule Returns the C field of the C event, if it exists. =cut sub join_rule { my $self = shift; my $event = $self->get_event( "m.room.join_rules" ) or return undef; return $event->{content}{join_rule}; } =head2 topic $topic = $state->topic Returns the C field of the C event, if it exists. =cut sub topic { my $self = shift; my $event = $self->get_event( "m.room.topic" ) or return undef; return $event->{content}{topic}; } =head2 aliases @aliases = $state->aliases Returns a list of the room alias from all the C events, in no particular order. =cut sub aliases { my $self = shift; return map { @{ $_->{content}{aliases} } } values %{ $self->get_events( "m.room.aliases" ) }; } =head2 members @members = $state->members Returns a list of Member instances representing all of the members of the room from the C events whose membership state is not C. =cut sub members { my $self = shift; my ( $with_leaves ) = @_; return pairmap { my ( $user_id, $event ) = ( $a, $b ); my $content = $event->{content}; return () if $content->{membership} eq "leave" and !$with_leaves; my $user = $self->{matrix}->_get_or_make_user( $user_id ); Member( $user, $content->{displayname}, $content->{membership} ); } %{ $self->get_events( "m.room.member" ) }; } =head2 all_members @members = $state->members Similar to L but even includes members in C state. This is not normally what you want. =cut sub all_members { my $self = shift; return $self->members( 1 ); } =head2 member $member = $state->member( $user_id ) Returns a Member instance representing a room member of the given user ID, or C if none exists. =cut sub member { my $self = shift; my ( $user_id ) = @_; my $event = $self->get_event( "m.room.member", $user_id ) or return undef; my $user = $self->{matrix}->_get_or_make_user( $user_id ); my $content = $event->{content}; return Member( $user, $content->{displayname}, $content->{membership} ); } =head2 member_level $level = $state->member_level( $user_id ) Returns a number indicating the power level that the given user ID would have according to room state, taken from the C event. This takes into account the C field, if no specific level exists for the given user ID. =cut sub member_level { my $self = shift; my ( $user_id ) = @_; my $event = $self->get_event( "m.room.power_levels" ) or return undef; my $levels = $event->{content}; return $levels->{users}{$user_id} // $levels->{users_default}; } =head1 AUTHOR Paul Evans =cut 0x55AA; Net-Async-Matrix-0.19/t000755001750001750 013070735710 13475 5ustar00leoleo000000000000Net-Async-Matrix-0.19/t/00use.t000444001750001750 27713070735710 14741 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use_ok( 'Net::Async::Matrix' ); use_ok( 'Net::Async::Matrix::Room' ); use_ok( 'Net::Async::Matrix::Room::State' ); done_testing; Net-Async-Matrix-0.19/t/01login.t000444001750001750 573313070735710 15300 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use HTTP::Response; use JSON::MaybeXS qw( decode_json ); use IO::Async::Loop; use Net::Async::Matrix; my $ua = Test::Async::HTTP->new; my $matrix = Net::Async::Matrix->new( ua => $ua, server => "localserver.test", make_delay => sub { return Future->new }, ); ok( defined $matrix, '$matrix defined' ); ok( !defined $ua->next_pending, '$ua is idle initially' ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future # direct user_id + access_token { my $login_f = $matrix->login( user_id => '@my-user-id:localserver.test', access_token => "0123456789ABCDEF", ); ok( my $p = $ua->next_pending, '->login ID + token sends an HTTP request' ); my $uri = $p->request->uri; is( $uri->authority, "localserver.test", '$req->uri->authority' ); is( $uri->path, "/_matrix/client/r0/sync", '$req->uri->path' ); is( { $uri->query_form }->{access_token}, "0123456789ABCDEF", '$req->uri->query_form access_token' ); $p->respond( HTTP::Response->new( 200, "OK", [ "Content-Type" => "application/json" ], '{}' ) ); ok( $login_f->is_ready, '->login ready with immediate user_id/access_token' ); # clean up $matrix->stop; $ua->next_pending; # event stream } # user_id + password { my $login_f = $matrix->login( user_id => '@my-user-id:localserver.test', password => 's3kr1t', ); ok( my $p = $ua->next_pending, '->login ID + password sends an HTTP request' ); is( $p->request->method, "GET", '$req->method' ); is( $p->request->uri->path, "/_matrix/client/r0/login", '$req->uri->path' ); respond_json( $p, { flows => [ { type => "m.login.password", stages => [ "m.login.password" ] }, ], }); ok( $p = $ua->next_pending, 'Second HTTP request' ); is( $p->request->method, "POST", '$req->method' ); is( $p->request->uri->path, "/_matrix/client/r0/login", '$req->uri->path' ); is_deeply( decode_json( $p->request->decoded_content ), { user => '@my-user-id:localserver.test', type => 'm.login.password', password => 's3kr1t', }, '$req->content' ); respond_json( $p, { user_id => '@my-user-id:localserver.test', access_token => "0123456789ABCDEF" }); ok( $p = $ua->next_pending, 'Third HTTP request' ); my $uri = $p->request->uri; is( $uri->authority, "localserver.test", '$req->uri->authority' ); is( $uri->path, "/_matrix/client/r0/sync", '$req->uri->path' ); is( { $uri->query_form }->{access_token}, "0123456789ABCDEF", '$req->uri->query_form access_token' ); $p->respond( HTTP::Response->new( 200, "OK", [ "Content-Type" => "application/json" ], '{}' ) ); ok( $login_f->is_ready, '->login ready after server responds to POST' ); # cleanup $matrix->stop; $ua->next_pending; } done_testing; Net-Async-Matrix-0.19/t/02initial.t000444001750001750 416413070735710 15617 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $ua = Test::Async::HTTP->new; my @rooms; my $matrix = Net::Async::Matrix->new( ua => $ua, server => "localserver.test", first_sync_limit => 20, on_room_new => sub { push @rooms, $_[1]; }, make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future my $login_f = $matrix->login( user_id => '@my-test-user:localserver.test', access_token => "0123456789ABCDEF", ); ok( my $p = $ua->next_pending, '->start sends an HTTP request' ); my $uri = $p->request->uri; is( $uri->authority, "localserver.test", '$req->uri->authority' ); is( $uri->path, "/_matrix/client/r0/sync", '$req->uri->path' ); is_deeply( { $uri->query_form }, { access_token => "0123456789ABCDEF", filter => '{"room":{"timeline":{"limit":20}}}' }, '$req->uri->query_form' ); respond_json( $p, { next_batch => "next_token_here", rooms => { join => { "!id-for-a-room:localserver.test" => { timeline => { limited => '', prev_batch => '', events => [], }, state => { events => [], }, account_data => { events => [], }, ephemeral => { events => [], }, }, }, }, presence => { events => [], }, }); ok( $login_f->is_ready, '->login ready after initial sync' ); $login_f->get; ok( $matrix->start->is_ready, '->start is already ready' ); is( scalar @rooms, 1, '@rooms has a room object' ); is( $rooms[0]->room_id, "!id-for-a-room:localserver.test", '$rooms[0]->room_id' ); # Should make a start on GET /events ok( $p = $ua->next_pending, 'another request after initialSync' ); is( $p->request->method, "GET", 'request method is GET' ); is( $p->request->uri->path, "/_matrix/client/r0/sync", 'request path is /sync' ); # Just leave it dangling at EOF done_testing; Net-Async-Matrix-0.19/t/03events.t000444001750001750 245413070735710 15473 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); # presence event { my ( $user, %presence ); $matrix->configure( on_presence => sub { shift; ( $user, %presence ) = @_ }, ); send_sync( $ua, presence => { events => [ { type => "m.presence", sender => '@some_user:server', content => { presence => "online", }, } ] }, ); is( $user->user_id, '@some_user:server', '$user for on_presence event' ); is( $presence{presence}[1], "online", '{presence} for on_presence event' ); # cleanup $matrix->stop; $ua->next_pending; } # enable_events = false { $matrix->configure( enable_events => 0, ); matrix_login( $matrix, $ua ); my $p; ok( !( $p = $ua->next_pending ), 'UA is now idle after login with enable_events false' ) or diag( "Request was for " . $p->request->uri ); } done_testing; Net-Async-Matrix-0.19/t/09upload.t000444001750001750 271413070735710 15460 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); # ->upload { my $f = $matrix->upload( content => "Here is the content", content_type => "text/plain", ); ok( my $p = next_pending_not_sync( $ua ), '->upload sends an HTTP request' ); is( $p->request->method, "POST", '$req->method' ); my $uri = $p->request->uri; is( $uri->authority, "localserver.test", '$req->uri->authority' ); is( $uri->path, "/_matrix/media/v1/upload", '$req->uri->path' ); is( $p->request->content_type, "text/plain", '$req->content_type' ); is( $p->request->content, "Here is the content" , '$req->content' ); respond_json( $p, { content_uri => "mxc://localserver.test/abcd1234" } ); ok( $f->is_ready, '$f now ready after /upload response' ); is( $f->get, "mxc://localserver.test/abcd1234", '$f->get returns content URI' ); } # ->convert_mxc_url { is( $matrix->convert_mxc_url( "mxc://localserver.test/abcd1234" ) . "", "http://localserver.test/_matrix/media/v1/download/localserver.test/abcd1234", '$matrix->convert_mxc_url' ); } done_testing; Net-Async-Matrix-0.19/t/10room-join.t000444001750001750 271713070735710 16100 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); # join by direct ID { my $f = $matrix->join_room( "!abcdef12345:localserver.test" ); ok( defined $f, '$f from ->join_room' ); ok( my $p = next_pending_not_sync( $ua ), '->join_room ID sends an HTTP request' ); is( $p->request->method, "POST", '$req->method' ); my $uri = $p->request->uri; is( $uri->authority, "localserver.test", '$req->uri->authority' ); is( $uri->path, "/_matrix/client/r0/join/!abcdef12345:localserver.test", '$req->uri->path' ); respond_json( $p, { room_id => "!abcdef12345:localserver.test" } ); send_sync( $ua, rooms => { join => { '!abcdef12345:localserver.test' => { timeline => {}, state => { events => [], }, } } } ); ok( $f->is_ready, '$f now ready after /state response' ); isa_ok( my $room = $f->get, "Net::Async::Matrix::Room", '$f->get returns a room' ); ok( $room->await_synced->is_ready, '$room->await_synced is already ready' ); } done_testing; Net-Async-Matrix-0.19/t/11room-messages.t000444001750001750 565313070735710 16753 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use JSON::MaybeXS qw( decode_json ); use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); my $room = matrix_join_room( $matrix, $ua, { type => "m.room.member", room_id => "!room:localserver.test", state_key => '@sender:localserver.test', membership => "join", }, ); # send message { my $f = $room->send_message( type => "m.text", body => "Here is the message", ); my $p = next_pending_not_sync( $ua ); is( $p->request->method, "POST", '$req->method' ); is( $p->request->uri->path, "/_matrix/client/r0/rooms/!room:localserver.test/send/m.room.message", '$req->uri->path' ); is_deeply( decode_json( $p->request->decoded_content ), { msgtype => "m.text", body => "Here is the message" }, '$req->content' ); respond_json( $p, { event_id => "!ABCDE:localserver.test" } ); ok( $f->is_ready, '$f is ready' ); is( $f->get, "!ABCDE:localserver.test", '$f->get returns event ID' ); } # send with txn_id { my $f = $room->send_message( type => "m.text", body => "Here is another message", txn_id => "123ABCD", ); my $p = next_pending_not_sync( $ua ); is( $p->request->method, "PUT", '$req->method' ); is( $p->request->uri->path, "/_matrix/client/r0/rooms/!room:localserver.test/send/m.room.message/123ABCD", '$req->uri->path' ); respond_json( $p, { event_id => "!FGHIJ:localserver.test" } ); ok( $f->is_ready, '$f is ready' ); is( $f->get, "!FGHIJ:localserver.test", '$f->get returns event ID' ); } # receive message { my @messages; $room->configure( on_message => sub { shift; push @messages, [ @_ ]; }, ); send_sync( $ua, rooms => { join => { "!room:localserver.test" => { timeline => { events => [ { type => "m.room.message", room_id => "!room:localserver.test", sender => '@sender:localserver.test', content => { msgtype => "m.text", body => "And here is the response", }, }, ] } } } } ); ok( scalar @messages, 'Received a room message' ); my $e = shift @messages; is( $e->[0]->user->user_id, '@sender:localserver.test', 'event $sender' ); is_deeply( $e->[1], { msgtype => "m.text", body => "And here is the response" }, 'event $content' ); } done_testing; Net-Async-Matrix-0.19/t/12room-state.t000444001750001750 1732613070735710 16305 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); use constant { ROOM_ID => "!room:localserver.test", USER_ID => '@sender:localserver.test', }; sub _mksync { my ( $event ) = @_; return ( rooms => { join => { ROOM_ID() => { timeline => { events => [ { %$event, sender => USER_ID, }, ] } } } } ); } my $room = matrix_join_room( $matrix, $ua, { type => "m.room.member", room_id => ROOM_ID, state_key => USER_ID, content => { membership => "join", }, sender => USER_ID, }, { type => "m.room.name", content => { name => "Initial name" }, room_id => ROOM_ID, state_key => "", sender => USER_ID, }, { type => "m.room.aliases", content => { aliases => [ '#room1:localserver.test' ] }, room_id => ROOM_ID, state_key => "localserver.test", sender => USER_ID, }, { type => "m.room.join_rules", content => { join_rule => "private" }, room_id => ROOM_ID, state_key => "", sender => USER_ID, }, { type => "m.room.topic", content => { topic => "Initial topic" }, room_id => ROOM_ID, state_key => "", sender => USER_ID, }, { type => "m.room.power_levels", content => { users => { USER_ID() => 100, }, users_default => 50, }, room_id => ROOM_ID, state_key => "", sender => USER_ID, }, ); my @state_changes; my @member_changes; $room->configure( on_state_changed => sub { shift; push @state_changes, [ @_ ]; }, on_membership => sub { shift; push @member_changes, [ @_ ]; }, ); # room name { is( $room->name, "Initial name", '$room->name initially' ); send_sync( $ua, _mksync { type => "m.room.name", state_key => "", content => { name => "A new name", }, }, ); is( $room->name, "A new name", '$room->name after event' ); ok( my $ch = shift @state_changes, 'on_state_changed invoked' ); my ( $member, $event, %changes ) = @$ch; is( $member->user->user_id, USER_ID, '[0] is $member' ); is( $event->{type}, "m.room.name", '[1] is $event' ); is_deeply( \%changes, { name => [ "Initial name", "A new name" ] }, '[2..] is %changes' ); } # aliases { is_deeply( [ $room->aliases ], [ '#room1:localserver.test' ], '$room->aliases initially' ); send_sync( $ua, _mksync { type => "m.room.aliases", state_key => "localserver.test", content => { aliases => [ '#room1:localserver.test', '#room2:localserver.test' ], }, }, ); is_deeply( [ $room->aliases ], [ '#room1:localserver.test', '#room2:localserver.test' ], '$room->aliases after event' ); ok( my $ch = shift @state_changes, 'on_state_changed invoked' ); my ( $member, $event, %changes ) = @$ch; is( $member->user->user_id, USER_ID, '[0] is $member' ); is( $event->{type}, "m.room.aliases", '[1] is $event' ); is_deeply( \%changes, { aliases => [ [ '#room1:localserver.test' ], [ '#room1:localserver.test', '#room2:localserver.test' ], [] ] }, '[2..] is %changes' ); } # join rule { is( $room->join_rule, "private", '$room->join_rule initially' ); send_sync( $ua, _mksync { type => "m.room.join_rules", # sic state_key => "", content => { join_rule => "public", }, }, ); is( $room->join_rule, "public", '$room->join_rule after event' ); ok( my $ch = shift @state_changes, 'on_state_changed invoked' ); my ( $member, $event, %changes ) = @$ch; is( $member->user->user_id, USER_ID, '[0] is $member' ); is( $event->{type}, "m.room.join_rules", '[1] is $event' ); is_deeply( \%changes, { join_rule => [ "private", "public" ] }, '[2..] is %changes' ); } # topic { is( $room->topic, "Initial topic", '$room->topic initially' ); send_sync( $ua, _mksync { type => "m.room.topic", state_key => "", content => { topic => "A new topic", }, }, ); is( $room->topic, "A new topic", '$room->topic after event' ); ok( my $ch = shift @state_changes, 'on_state_changed invoked' ); my ( $member, $event, %changes ) = @$ch; is( $member->user->user_id, USER_ID, '[0] is $member' ); is( $event->{type}, "m.room.topic", '[1] is $event' ); is_deeply( \%changes, { topic => [ "Initial topic", "A new topic" ] }, '[2..] is %changes' ); } # members - joining { is_deeply( [ map { $_->user->user_id } $room->members ], [ USER_ID ], 'user ID of $room->members initially' ); send_sync( $ua, _mksync { type => "m.room.member", state_key => '@new-user:localserver.test', content => { membership => "join", }, }, ); is_deeply( [ sort map { $_->user->user_id } $room->members ], [ '@new-user:localserver.test', USER_ID ], 'user ID of $room->members after event' ); ok( my $ch = shift @member_changes, 'on_membership invoked' ); my ( $member, $event, $subject, %changes ) = @$ch; is( $member->user->user_id, USER_ID, '[0] is $member' ); is( $event->{type}, "m.room.member", '[1] is $event' ); is( $subject->user->user_id, '@new-user:localserver.test', '[2] is $subject' ); is_deeply( \%changes, { membership => [ undef, "join" ] }, '[3..] is %changes' ); } # members - changing name { send_sync( $ua, _mksync { type => "m.room.member", state_key => '@new-user:localserver.test', content => { membership => "join", displayname => "Your Name Here", }, }, ); is_deeply( [ grep { defined } map { $_->displayname } $room->members ], [ "Your Name Here" ], 'displayname of $room->members after event' ); ok( my $ch = shift @member_changes, 'on_membership invoked' ); my ( $member, $event, $subject, %changes ) = @$ch; is( $member->user->user_id, USER_ID, '[0] is $member' ); is( $event->{type}, "m.room.member", '[1] is $event' ); is( $subject->user->user_id, '@new-user:localserver.test', '[2] is $subject' ); is_deeply( \%changes, { displayname => [ undef, "Your Name Here" ], }, '[3..] is %changes' ); } # member levels { is( $room->member_level( USER_ID ), 100, 'member_level initially' ); send_sync( $ua, _mksync { type => "m.room.power_levels", content => { users => { USER_ID() => 80, }, users_default => 50, }, state_key => "", } ); is( $room->member_level( USER_ID ), 80, 'member_level after event' ); ok( my $ch = shift @member_changes, 'on_membership invoked' ); my ( $member, $event, $subject, %changes ) = @$ch; is( $member->user->user_id, USER_ID, '[0] is $member' ); is( $event->{type}, "m.room.power_levels", '[1] is $event' ); is( $subject->user->user_id, USER_ID, '[2] is $subject' ); is_deeply( \%changes, { level => [ 100, 80 ] }, '[3..] is %changes' ); } done_testing; Net-Async-Matrix-0.19/t/15room-typing.t000444001750001750 530413070735710 16453 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use JSON::MaybeXS qw( decode_json ); use List::Util qw( min ); use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my @timers; sub warp_time { my ( $secs ) = @_; while( $secs ) { my $advance = min map { $_->[0] } @timers; $advance = $secs if $advance > $secs; $_->[0] -= $advance for @timers; $secs -= $advance; $_->[0] or $_->[1]->done() for @timers; @timers = grep { $_->[0] > 0 } @timers; } } my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { my ( $secs ) = @_; push @timers, [ $secs, my $f = Future->new ]; return $f; }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); my $room = matrix_join_room( $matrix, $ua, { type => "m.room.member", room_id => "!room:localserver.test", state_key => '@sender:localserver.test', membership => "join", }, ); my $TIMEOUT = Net::Async::Matrix::Room->TYPING_RESEND_SECONDS; # start typing { $room->typing_start; my $p = next_pending_not_sync( $ua ); is( $p->request->method, "PUT", '$req->method' ); is( $p->request->uri->path, "/_matrix/client/r0/rooms/!room:localserver.test/typing/\@my-test-user:localserver.test", '$req->uri->path' ); is_deeply( decode_json( $p->request->decoded_content ), { typing => 1, timeout => ( $TIMEOUT + 5 ) * 1000 }, '$req->content' ); respond_json( $p, {} ); } # timer expires { # We ought to have a timer in the list of $TIMEOUT seconds ok( scalar( grep { $_->[0] == $TIMEOUT } @timers ), 'A timer exists for the appropriate timeout' ); warp_time( $TIMEOUT ); ok( my $p = next_pending_not_sync( $ua ), 'Second request sent after timeout' ); is( $p->request->method, "PUT", '$req->method' ); is( $p->request->uri->path, "/_matrix/client/r0/rooms/!room:localserver.test/typing/\@my-test-user:localserver.test", '$req->uri->path' ); is_deeply( decode_json( $p->request->decoded_content ), { typing => 1, timeout => ( $TIMEOUT + 5 ) * 1000 }, '$req->content' ); respond_json( $p, {} ); } # stop typing { $room->typing_stop; my $p = next_pending_not_sync( $ua ); is( $p->request->method, "PUT", '$req->method' ); is( $p->request->uri->path, "/_matrix/client/r0/rooms/!room:localserver.test/typing/\@my-test-user:localserver.test", '$req->uri->path' ); is_deeply( decode_json( $p->request->decoded_content ), { typing => 0 }, '$req->content' ); respond_json( $p, {} ); } done_testing; Net-Async-Matrix-0.19/t/16room-receipt.t000444001750001750 462013070735710 16575 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use JSON::MaybeXS qw( decode_json ); use List::Util qw( min ); use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); my $room = matrix_join_room( $matrix, $ua, { type => "m.room.member", room_id => "!room:localserver.test", state_key => '@sender:localserver.test', membership => "join", }, { type => "m.room.member", room_id => "!room:localserver.test", state_key => '@reader:localserver.test', membership => "join", }, ); # receiving receipts { my @events; $room->configure( on_read_receipt => sub { shift; push @events, [ @_ ]; }, ); send_sync( $ua, rooms => { join => { '!room:localserver.test' => { ephemeral => { events => [ { type => "m.receipt", content => { '$123456789:localserver.test' => { 'm.read' => { '@reader:localserver.test' => { ts => 12345 } }, } }, } ], }, } } } ); is( scalar @events, 1, 'One event received' ); my ( $member, $event_id, $content ) = @{ shift @events }; is( $member->user->user_id, '@reader:localserver.test', 'member user ID' ); is( $event_id, '$123456789:localserver.test', 'event ID' ); is_deeply( $content, { ts => 12345 }, 'content' ); } # sending receipts { my $f = $room->send_read_receipt( event_id => '$987654321:localserver.test' ); my $p = next_pending_not_sync( $ua ); is( $p->request->method, "POST", '$req->method' ); is( $p->request->uri->path, '/_matrix/client/r0/rooms/!room:localserver.test/receipt/m.read/$987654321:localserver.test', '$req->uri->path' ); respond_json( $p, {} ); ok( $f->is_ready, '$f->is_ready' ); } done_testing; Net-Async-Matrix-0.19/t/50utils-format.t000444001750001750 424313070735710 16615 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Net::Async::Matrix::Utils qw( parse_formatted_message build_formatted_message ); # unformatted { my $body = parse_formatted_message( { body => "Here is some plain text", } ); isa_ok( $body, "String::Tagged", '$body' ); is( $body->str, "Here is some plain text", 'body string' ); is( scalar $body->tagnames, 0, 'body has no tags' ); my $content = build_formatted_message( "A plain text reply", ); is_deeply( $content, { body => "A plain text reply" }, 'content of plain string' ); is_deeply( build_formatted_message( String::Tagged->new( "No actual tags" ) ), { body => "No actual tags" }, 'content of String::Tagged with no tags' ); } # HTML formatted SKIP: { skip "No HTML::TreeBuilder", 1 unless Net::Async::Matrix::Utils::CAN_PARSE_HTML; my $body = parse_formatted_message( { body => "A body with bold and green text", format => "org.matrix.custom.html", formatted_body => 'A body with bold and green text', } ); isa_ok( $body, "String::Tagged", '$body' ); is( $body->str, "A body with bold and green text", 'body string' ); ok( $body->get_tags_at( index $body, "bold" )->{bold}, 'body has bold' ); is( $body->get_tag_extent( index( $body, "bold" ), "bold" )->length, 4, 'bold tag correct length' ); ok( my $fg = $body->get_tags_at( index $body, "green" )->{fg}, 'body has fg' ); is( $fg->name, "green", '$fg colour name' ); } SKIP: { skip "No String::Tagged::HTML", 1 unless Net::Async::Matrix::Utils::CAN_BUILD_HTML; my $content = build_formatted_message( String::Tagged->new ->append ( "Response with " ) ->append_tagged( "italic", italic => 1 ) ->append ( " and " ) ->append_tagged( "green", fg => Convert::Color->new( 'vga:green' ) ) ); is_deeply( $content, { body => "Response with italic and green", format => "org.matrix.custom.html", formatted_body => 'Response with italic and green', }, 'content of HTML formatted string' ); } done_testing; Net-Async-Matrix-0.19/t/70fail-initial.t000444001750001750 261513070735710 16534 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; my $ua = Test::Async::HTTP->new; my $matrix = Net::Async::Matrix->new( ua => $ua, server => "localserver.test", on_error => sub {}, ); IO::Async::Loop->new->add( $matrix ); # Fail the first one { my $login_f = $matrix->login( user_id => '@my-test-user:localserver.test', access_token => "0123456789ABCDEF", ); my $start_f = $matrix->start; my $p = $ua->next_pending; $p->fail( "Server doesn't want to", http => undef, $p->request ); ok( $login_f->is_ready, '->login is ready' ); # Start is ready but failed ok( $start_f->is_ready, '->start is ready' ); ok( $start_f->failure, '->start failed' ); } # Second should still be attempted { my $start_f = $matrix->start; ok( !$start_f->is_ready, 'Second ->start is not yet ready' ); my $p = $ua->next_pending; ok( $p, 'Second request is made' ); is( $p->request->uri->path, "/_matrix/client/r0/sync", 'Second request URI' ); respond_json( $p, { next_batch => "next_token_here", presence => {}, rooms => {}, }); ok( $start_f->is_ready, 'Second ->start is now ready' ); ok( !$start_f->failure, 'Second ->start did not die' ) or diag( "Failure was: ". $start_f->failure ); } done_testing; Net-Async-Matrix-0.19/t/71restart.t000444001750001750 260413070735710 15655 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Async::HTTP 0.02; # ->GET use lib "."; use t::Util; use IO::Async::Loop; use Net::Async::Matrix; use Future; my $matrix = Net::Async::Matrix->new( ua => my $ua = Test::Async::HTTP->new, server => "localserver.test", make_delay => sub { Future->new }, ); IO::Async::Loop->new->add( $matrix ); # for ->loop->new_future matrix_login( $matrix, $ua ); my $room = matrix_join_room( $matrix, $ua, { type => "m.room.member", room_id => "!room:localserver.test", state_key => '@sender:localserver.test', membership => "join", }, ); $matrix->stop; pass( '$matrix->stop' ); $matrix->start; my $p = $ua->next_pending; is( $p->request->uri->path, "/_matrix/client/r0/sync", '$req->uri->path' ); respond_json( $p, { next_batch => "next_token_here", presence => { events => [], }, rooms => { join => { '!room:localserver.test' => { timeline => { limited => '', prev_batch => '', events => [], }, state => { events => [], }, account_data => { events => [], }, ephemeral => { events => [], }, }, } }, }); pass( '$matrix->start does not fail' ); done_testing; Net-Async-Matrix-0.19/t/99pod.t000444001750001750 25713070735710 14747 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Net-Async-Matrix-0.19/t/Util.pm000444001750001750 504613070735710 15112 0ustar00leoleo000000000000package t::Util; use strict; use warnings; use Carp; use Exporter 'import'; our @EXPORT = qw( respond_json next_pending_not_sync next_pending_sync send_sync matrix_login matrix_join_room ); use HTTP::Response; use JSON::MaybeXS qw( encode_json ); use constant SYNC_PATH => "/_matrix/client/r0/sync"; sub respond_json { my ( $p, $content ) = @_; ref $content or croak "respond_json() called with non-reference"; $p->respond( HTTP::Response->new( 200, "OK", [ "Content-Type" => "application/json" ], encode_json $content ) ); } my $sync_p; sub next_pending_not_sync { my ( $ua ) = @_; while(1) { my $p = $ua->next_pending or return; my $req = $p->request; return $p if $req->method ne "GET" or $req->uri->path ne SYNC_PATH; die "Received a second /sync request before the first finished" if $sync_p; $sync_p = $p; $sync_p->response->on_cancel( sub { undef $sync_p } ); } } sub next_pending_sync { my ( $ua ) = @_; if( $sync_p ) { my $p = $sync_p; undef $sync_p; return $p; } my $p = $ua->next_pending; my $req = $p->request; return $p if $req->method eq "GET" and $req->uri->path eq SYNC_PATH; die "Received a different request while waiting for an /sync request"; } my $next_event_token = 0; sub send_sync { my ( $ua, %fields ) = @_; respond_json( next_pending_sync( $ua ), { next_batch => $next_event_token, %fields, }); $next_event_token++; } sub matrix_login { my ( $matrix, $ua ) = @_; my $login_f = $matrix->login( user_id => '@my-test-user:localserver.test', access_token => "0123456789ABCDEF", ); # respond to initial /sync request if( my $p = $ua->next_pending ) { respond_json( $p, { next_batch => "next_token_here", presence => { events => [] }, rooms => {}, }); } $login_f->get; } sub matrix_join_room { my ( $matrix, $ua, @initial_state ) = @_; my $join_f = $matrix->join_room( "!room:localserver.test" ); my $p = next_pending_not_sync( $ua ); respond_json( $p, { room_id => "!room:localserver.test" } ); # Server sends new room initial state in the next /sync response send_sync( $ua, rooms => { join => { "!room:localserver.test" => { timeline => {}, state => { events => [ @initial_state ], }, }, }, }, ); return $join_f->get; } 0x55AA;