pax_global_header00006660000000000000000000000064145200011520014500gustar00rootroot0000000000000052 comment=a8c80d25b7790746a439ae6c2deea3dc6bcac710 mastodon.el/000077500000000000000000000000001452000115200132675ustar00rootroot00000000000000mastodon.el/.elpaignore000066400000000000000000000001251452000115200154130ustar00rootroot00000000000000*.*~ .woodpecker.yml lisp/.dir-locals.el Cask fixture Makefile stubfile.plstore test mastodon.el/.gitignore000066400000000000000000000003251452000115200152570ustar00rootroot00000000000000# Compiled *.elc # Packaging .cask # Other .DS_Store stubfile.plstore *~ dist/ /mastodon.org # ELPA-generted files /mastodon-pkg.el /mastodon-autoloads.el /lisp/mastodon-autoloads.el # ELSA files /lisp/.elsa/ mastodon.el/.woodpecker.yml000066400000000000000000000006161452000115200162350ustar00rootroot00000000000000pipeline: current: image: silex/emacs:cask commands: - emacs --version - cask install - cask emacs -batch -l test/ert-helper.el -f ert-run-tests-batch-and-exit last: image: silex/emacs:27-ci-cask commands: - emacs --version - cask install - cask emacs -batch -l test/ert-helper.el -f ert-run-tests-batch-and-exit branches: [ main, develop ] mastodon.el/Cask000066400000000000000000000003641452000115200140760ustar00rootroot00000000000000(source gnu) (source melpa) (package-file "lisp/mastodon.el") (files "lisp/*.el") (development (depends-on "ert-runner") (depends-on "el-mock") (depends-on "ecukes") (depends-on "package-lint") (depends-on "elsa") (depends-on "async")) mastodon.el/LICENSE000066400000000000000000001045121452000115200142770ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), 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 prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey 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; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU 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 that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. 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. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 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. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS 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 the public, 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 state 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) 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 3 of the License, 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, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program 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, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read .mastodon.el/Makefile000066400000000000000000000021321452000115200147250ustar00rootroot00000000000000PKG = mastodon CP = cp LN = ln EMACS = emacs MAKEINFO = makeinfo INSTALL-INFO = install-info ORG_DIR = $(word 1,$(wildcard $(HOME)/.emacs.d/elpa/org-9*)) ORG_PATH = -L $(ORG_DIR) ORG_ARGS = --batch $(ORG_PATH) -l org -l ol-man ORG_EVAL1 = --funcall org-texinfo-export-to-texinfo ORG_EVAL2 = --funcall org-texinfo-export-to-info ## ################################################################ .PHONY: infoclean tests testsclean all: $(PKG).info dir infoclean: rm -f $(PKG).org $(PKG).texi $(PKG).info dir tests: cask emacs -batch -load test/ert-helper.el -f ert-run-tests-batch-and-exit testsclean: rm -f stubfile.plstore~ ## ################################################################ # May look at this in the future # # %.info: %.texi # @printf "Generating $@\n" # $(MAKEINFO) --no-split $< -o $@ # # %.texi: %.org # @printf "Generating $@\n" # $(EMACS) $(ORG_ARGS) $@ $(ORG_EVAL1) %.info: %.org @printf "Generating $@\n" $(EMACS) $(ORG_ARGS) $< $(ORG_EVAL2) dir: $(PKG).info printf "Generating $@\n" echo $^ | xargs -n 1 $(INSTALL-INFO) --dir=$@ $(PKG).org: README.org $(CP) $< $@ mastodon.el/README.org000066400000000000000000000554471452000115200147540ustar00rootroot00000000000000#+TEXINFO_DIR_CATEGORY: Emacs #+TEXINFO_DIR_TITLE: Mastodon: (mastodon). #+TEXINFO_DIR_DESC: Client for Mastodon on ActivityPub networks. @@html: ELPA@@ @@html: MELPA@@ # @@html: Build Status@@ * README =mastodon.el= is an Emacs client for the AcitivityPub social networks that implement the Mastodon API. For info see [[https://joinmastodon.org/][joinmastodon.org]]. ** Installation You can install =mastodon.el= from ELPA, MELPA, or directly from this repo. It is also available as a GUIX package. *** ELPA You should be able to directly install with: =M-x package-refresh-contents RET= =M-x package-install RET mastodon RET= *** MELPA Add =MELPA= to your archives: #+BEGIN_SRC emacs-lisp (require 'package) (add-to-list 'package-archives '("melpa" . "http://melpa.org/packages/") t) #+END_SRC Update and install: =M-x package-refresh-contents RET= =M-x package-install RET mastodon RET= *** Repo Clone this repository and add the lisp directory to your load path. Then, require it and go. #+BEGIN_SRC emacs-lisp (add-to-list 'load-path "/path/to/mastodon.el/lisp") (require 'mastodon) #+END_SRC Or, with =use-package=: #+BEGIN_SRC emacs-lisp (use-package mastodon :ensure t) #+END_SRC The minimum Emacs version is now 27.1. But if you are running an older version it shouldn't be very hard to get it working. *** Emoji =mastodon-mode= will enable [[https://github.com/iqbalansari/emacs-emojify][Emojify]] if it is loaded in your Emacs environment, so there's no need to write your own hook anymore. =emojify-mode= is not required. *** Discover =mastodon-mode= can provide a context menu for its keybindings if [[https://github.com/mickeynp/discover.el][Discover]] is installed. It is not required. if you have Discover, add the following to your Emacs init configuration: #+BEGIN_SRC emacs-lisp (require 'mastodon-discover) (with-eval-after-load 'mastodon (mastodon-discover)) #+END_SRC Or, with =use-package=: #+BEGIN_SRC emacs-lisp (use-package mastodon :ensure t :config (mastodon-discover)) #+END_SRC ** Usage *** Logging in to your instance You need to set 2 variables in your init file to get started: 1. =mastodon-instance-url= 2. =mastodon-active-user= (see their doc strings for details). For example If you want to post toots as "example_user@social.instance.org", then put this in your init file: #+BEGIN_SRC emacs-lisp (setq mastodon-instance-url "https://social.instance.org" mastodon-active-user "example_user") #+END_SRC Then *restart* Emacs and run =M-x mastodon=. Make sure you are connected to internet before you do this. If you have multiple mastodon accounts you can activate one at a time by changing those two variables and restarting Emacs. If you were using mastodon.el before 2FA was implemented and the above steps do not work, delete the old file specified by =mastodon-client--token-file= and restart Emacs and follow the steps again. *** Timelines =M-x mastodon= Opens a =*mastodon-home*= buffer in the major mode and displays toots. If your credentials are not yet saved, you will be prompted for email and password. The app registration process will take place if your =mastodon-token-file= does not contain =:client_id= and =:client_secret=. **** Keybindings |----------------+---------------------------------------------------------------------------------| | Key | Action | |----------------+---------------------------------------------------------------------------------| | | *Help* | | =?= | Show discover menu of all bindings, if =discover= is available | |----------------+---------------------------------------------------------------------------------| | | *Timeline actions* | | =n= | Go to next item (toot, notification, user) | | =p= | Go to previous item (toot, notification, user) | | =M-n=/== | Go to the next interesting thing that has an action | | =M-p=/== | Go to the previous interesting thing that has an action | | =F= | Open federated timeline (1 prefix arg: hide-replies, 2 prefix args: media only) | | =H= | Open home timeline (1 prefix arg: hide-replies) | | =L= | Open local timeline (1 prefix arg: hide-replies, 2 prefix args: media only) | | =N= | Open notifications timeline | | =@= | Open mentions-only notifications timeline | | =u= | Update current timeline | | =T= | Open thread for toot at point | | =#= | Prompt for tag and open its timeline | | =A= | Open author profile of toot at point | | =P= | Open profile of user attached to toot at point | | =O= | View own profile | | =U= | update your profile bio note | | =;= | view instance description for toot at point | | =:= | view followed tags and load a tag timeline | | =C-:= | view timeline of all followed tags | | =,= | view favouriters of toot at point | | =.= | view boosters of toot at point | | =/= | switch between mastodon buffers | | =Z= | report user/toot at point to instances moderators | |----------------+---------------------------------------------------------------------------------| | | *Other views* | | =s= | search (posts, users, tags) (NB: only posts you have interacted with) | | =I=, =c=, =d= | view, create, and delete filters | | =R=, =a=, =j= | view/accept/reject follow requests | | =G= | view follow suggestions | | =V= | view your favourited toots | | =K= | view bookmarked toots | | =X= | view/edit/create/delete lists | | =S= | view your scheduled toots | |----------------+---------------------------------------------------------------------------------| | | *Toot actions* | | =t= | Compose a new toot | | =c= | Toggle content warning content | | =b= | Boost toot under =point= | | =f= | Favourite toot under =point= | | =k= | toggle bookmark of toot at point | | =r= | Reply to toot under =point= | | =v= | Vote on poll at point | | =C= | copy url of toot at point | | =C-RET= | play video/gif at point (requires =mpv=) | | =e= | edit your toot at point | | =E= | view edits of toot at point | | =i= | (un)pin your toot at point | | =d= | delete your toot at point, and reload current timeline | | =D= | delete and redraft toot at point, preserving reply/CW/visibility | | (=S-C-=) =W=, =M=, =B= | (un)follow, (un)mute, (un)block author of toot at point | |----------------+---------------------------------------------------------------------------------| | | *Profile view* | | =C-c C-c= | cycle between statuses, statuses without boosts, followers, and following | | | =mastodon-profile--account-account-to-list= (see lists view) | |----------------+---------------------------------------------------------------------------------| | | *Notifications view* | | =a=, =j= | accept/reject follow request | | =C-k= | clear notification at point | | | see =mastodon-notifications--get-*= functions for filtered views | |----------------+---------------------------------------------------------------------------------| | | *Quitting* | | =q= | Quit mastodon buffer, leave window open | | =Q= | Quit mastodon buffer and kill window | | =C-M-q= | Quit and kill all mastodon buffers | |----------------+---------------------------------------------------------------------------------| **** Toot byline legend |---------------+------------------------| | Marker | Meaning | |---------------+------------------------| | =(🔁)= (or =(B)=) | I boosted this toot | | =(⭐)= (or =(F)=) | I favourited this toot | | =(🔖)= (or (=K=)) | I bookmarked this toot | |---------------+------------------------| *** Composing toots =M-x mastodon-toot= (or =t= from a mastodon.el buffer) opens a new buffer/window in =text-mode= and =mastodon-toot= minor mode. Enter the contents of your toot here. =C-c C-c= sends the toot. =C-c C-k= cancels. Both actions kill the buffer and window. Further keybindings are displayed in the buffer, and in the following subsection. Replies preserve visibility status/content warnings, and include boosters by default. Server's max toot length, and attachment previews, are shown. You can download and use your instance's custom emoji (=mastodon-toot--download-custom-emoji=, =mastodon-toot--enable-custom-emoji=). The compose buffer uses =text-mode= so any configuration you have for that mode will be enabled. If any of your existing config conflicts with =mastodon-toot=, you can disable it in the =mastodon-toot-mode-hook=. For example, the default value of that hook is as follows: #+begin_src emacs-lisp (add-hook 'mastodon-toot-mode-hook (lambda () (auto-fill-mode -1))) #+end_src **** Keybindings |---------+----------------------------------| | Key | Action | |---------+----------------------------------| | =C-c C-c= | Send toot | | =C-c C-k= | Cancel toot | | =C-c C-w= | Add content warning | | =C-c C-v= | Change toot visibility | | =C-c C-n= | Add sensitive media/nsfw flag | | =C-c C-a= | Upload attachment(s) | | =C-c != | Remove all attachments | | =C-c C-e= | Add emoji (if =emojify= installed) | | =C-c C-p= | Create a poll | | =C-c C-l= | Set toot language | |---------+----------------------------------| **** Autocompletion of mentions and tags Autocompletion of mentions and tags is provided by =completion-at-point-functions= (capf) backends. =mastodon-toot--enable-completion= is enabled by default. If you want to enable =company-mode= in the toot compose buffer, set =mastodon-toot--use-company-for-completion= to =t=. (=mastodon.el= used to run its own native company backends, but these have been removed in favour of capfs.) If you don’t run =company= and want immediate, keyless completion, you’ll need to have another completion engine running that handles capfs. A common combination is =consult= and =corfu=. **** Draft toots - Compose buffer text is saved as you type, kept in =mastodon-toot-current-toot-text=. - =mastodon-toot--save-draft=: save the current toot as a draft. - =mastodon-toot--open-draft-toot=: Open a compose buffer and insert one of your draft toots. - =mastodon-toot--delete-draft-toot=: Delete a draft toot. - =mastodon-toot--delete-all-drafts=: Delete all your drafts. *** Other commands and account settings: In addition to =mastodon=, the following three functions are autoloaded and should work without first loading =mastodon.el=: - =mastodon-toot=: Compose new toot - =mastodon-notifications-get=: View all notifications - =mastodon-url-lookup=: Attempt to load a URL in =mastodon.el=. URL may be at point or provided in the minibuffer. - =mastodon-tl--view-instance-description=: View information about the instance that the author of the toot at point is on. - =mastodon-tl--view-own-instance=: View information about your own instance. - =mastodon-search--trending-tags=: View a list of trending hashtags on your instance. - =mastodon-search--trending-statuses=: View a list of trending statuses on your instance. - =mastodon-tl--add-toot-account-at-point-to-list=: Add the account of the toot at point to a list. - =mastodon-tl--dm-user=: Send a direct message to one of the users at point. - =mastodon-profile--add-private-note-to-account=: Add a private note to another user’s account. - =mastodon-profile--view-account-private-note=: View a private note on a user’s account. - =mastodon-profile--show-familiar-followers=: Show a list of “familiar followers” for a given account. Familiar followers are accounts that you follow, and that follow the account. - =mastodon-tl--follow-tag=: Follow a tag (works like following a user) - =mastodon-tl--unfollow-tag=: Unfollow a tag - =mastodon-tl--list-followed-tags=: View a list of tags you're following. - =mastodon-tl--followed-tags-timeline=: View a timeline of all your followed tags. - =mastodon-tl--some-followed-tags-timleine=: View a timeline of multiple tags, from your followed tags or any other. - =mastodon-switch-to-buffer=: switch between mastodon buffers. - =mastodon-profile--update-display-name=: Update the display name for your account. - =mastodon-profile--update-user-profile-note=: Update your bio note. - =mastodon-profile--update-meta-fields=: Update your metadata fields. - =mastodon-profile--set-default-toot-visibility=: Set the default visibility for your toots. - =mastodon-profile--account-locked-toggle=: Toggle the locked status of your account. Locked accounts have to manually approve follow requests. - =mastodon-profile--account-discoverable-toggle=: Toggle the discoverable status of your account. Non-discoverable accounts are not listed in the profile directory. - =mastodon-profile--account-bot-toggle=: Toggle whether your account is flagged as a bot. - =mastodon-profile--account-sensitive-toggle=: Toggle whether your posts are marked as sensitive (nsfw) by default. *** Customization See =M-x customize-group RET mastodon= to view all customize options. - Timeline options: - Use proportional fonts - Default number of posts displayed - Timestamp format - Relative timestamps - Display user avatars - Avatar image height - Enable image caching - Hide replies in timelines - Show toot stats in byline - Compose options: - Completion style for mentions and tags - Enable custom emoji - Display toot being replied to - Set default reply visibility *** Commands and variables index An index of all user-facing commands and custom variables is available here: [[file:mastodon-index.org][mastodon-index.org]]. *** Alternative timeline layout The incomparable Nicholas Rougier has written an alternative timeline layout for =mastodon.el=. The repo is at [[https://github.com/rougier/mastodon-alt][mastodon-alt]]. *** Live-updating timelines: =mastodon-async-mode= (code taken from [[https://github.com/alexjgriffith/mastodon-future.el][mastodon-future]].) Works for federated, local, and home timelines and for notifications. It's a little touchy, one thing to avoid is trying to load a timeline more than once at a time. It can go off the rails a bit, but it's still pretty cool. The current maintainer of =mastodon.el= is unable to debug or improve this feature. To enable, it, add =(require 'mastodon-async)= to your =init.el=. Then you can view a timeline with one of the commands that begin with =mastodon-async--stream-=. *** Translating toots You can translate toots with =mastodon-toot--translate-toot-text= (=a= in a timeline). At the moment this requires [[https://codeberg.org/martianh/lingva.el][lingva.el]], a little interface I wrote to [[https://lingva.ml][lingva.ml]], to be installed to work. You could easily modify the simple function to use your Emacs translator of choice (=libretrans.el= , =google-translate=, =babel=, =go-translate=, etc.), you just need to fetch the toot's content with =(mastodon-tl--content toot)= and pass it to your translator function as its text argument. Here's what =mastodon-toot--translate-toot-text= looks like: #+begin_src emacs-lisp (defun mastodon-toot--translate-toot-text () "Translate text of toot at point. Uses `lingva.el'." (interactive) (let* ((toot (mastodon-tl--property 'item-json))) (if toot (lingva-translate nil (mastodon-tl--content toot)) (message "No toot to translate?")))) #+end_src *** Bookmarks and =mastodon.el= =mastodon.el= doesn’t currently implement its own bookmark record and handler, which means that emacs bookmarks will not work as is. Until we implement them, you can get bookmarks going immediately by using [[https://github.com/emacsmirror/emacswiki.org/blob/master/bookmark%2b.el][bookmark+.el]]. ** Dependencies Hard dependencies (should all install with =mastodon.el=): - =request= (for uploading attachments), [[https://github.com/tkf/emacs-request][emacs-request]] - =persist= for storing some settings across sessions Optional dependencies (install yourself, =mastodon.el= can use them): - =emojify= for inserting and viewing emojis - =mpv= and =mpv.el= for viewing videos and gifs - =lingva.el= for translating toots ** Network compatibility =mastodon.el= should work with ActivityPub servers that implement the Mastodon API. Apart from Mastodon itself, it is currently known to work with: - Pleroma ([[https://pleroma.social/][pleroma.social]]) - Akkoma ([[https://akkoma.social/][akkoma.social]]) - Gotosocial ([[https://gotosocial.org/][gotosocial.org]]) It does not support the non-Mastodon API servers Misskey ([[https://misskey.io/][misskey.io]]), Firefish ([[https://joinfirefish.org/][joinfirefish.org]], formerly Calkey) and Friendica, but it should fully support displaying and interacting with posts and users on those platforms. If you attempt to use =mastodon.el= with a server and run into problems, feel free to open an issue. ** Contributing PRs, issues, feature requests, and general feedback are very welcome! If you prefer emailing patches to the process described below, feel free to send them on. Ideally they'd be patches that can be applied with =git am=, if you want to actually contribute a commit. *** Bug reports 1. =mastodon.el= has bugs, as well as lots of room for improvement. 2. I receive very little feedback, so if I don't run into the bug it often doesn't get fixed. 3. If you run into something that seems broken, first try running =mastodon.el= in emacs with no init file (i.e. =emacs -q= (instructions and code for doing this are [[https://codeberg.org/martianh/mastodon.el/issues/300][here]]) to see if it also happens independently of your own config (it probably does). 4. Else enable debug on error (=toggle-debug-on-error=), make the bug happen again, and copy the backtrace that appears. 5. Open an issue here and explain what is going on. Provide your emacs version and what kind of server your account is on. *** Fixes and features 1. Create an [[https://codeberg.org/martianh/mastodon.el/issues][issue]] detailing what you'd like to do. 2. Fork the repository and create a branch off of =develop=. 3. Run the tests and ensure that your code doesn't break any of them. 4. Create a pull request (to develop) referencing the issue created in step 1. *** Coding style - This library uses an unconvential double dash (=--=) between file namespaces and function names, which contradicts normal Elisp style. This needs to be respected until the whole library is changed. - Use =aggressive-indent-mode= or similar to keep your code indented. - Single spaces end sentences in docstrings. - There's no need for a blank line after the first docstring line (one is added automatically when documentation is displayed). ** Supporting =mastodon.el= If you'd like to support continued development of =mastodon.el=, I accept donations via paypal: [[https://paypal.me/martianh][paypal.me/martianh]]. If you would prefer a different payment method, please write to me at and I can provide IBAN or other bank account details. I don't have a tech worker's income, so even a small tip would help out. ** Contributors =mastodon.el= is the work of a number of people. Some significant contributors are: - https://github.com/jdenen [original author] - http://atomized.org - https://alexjgriffith.itch.io - https://github.com/hdurer - https://codeberg.org/Red_Starfish mastodon.el/dir000066400000000000000000000011611452000115200137670ustar00rootroot00000000000000This is the file .../info/dir, which contains the topmost node of the Info hierarchy, called (dir)Top. The first time you invoke Info you start off looking at this node.  File: dir, Node: Top This is the top of the INFO tree This (the Directory node) gives a menu of major topics. Typing "q" exits, "H" lists all Info commands, "d" returns here, "h" gives a primer for first-timers, "mEmacs" visits the Emacs manual, etc. In Emacs, you can click mouse button 2 on a menu item or cross reference to select it. * Menu: Emacs * Mastodon: (mastodon). Client for Mastodon on ActivityPub networks. mastodon.el/fixture/000077500000000000000000000000001452000115200147555ustar00rootroot00000000000000mastodon.el/fixture/client.plstore000066400000000000000000000012621452000115200176460ustar00rootroot00000000000000;;; public entries -*- mode: plstore -*- (("mastodon-http://other.example" :client_id "id1" :client_secret "secret1") ("mastodon-http://mastodon.example" :client_id "id2" :client_secret "secret2") ("user-test8000@mastodon.example" :username "test8000@mastodon.example" :instance "http://mastodon.example" :client_id "id2" :client_secret "secret2" :access_token "token2") ("active-user" :username "test9000@other.example" :instance "http://other.example" :client_id "id1" :client_secret "secret1" :access_token "token1") ("user-test9000@other.example" :username "test9000@other.example" :instance "http://other.example" :client_id "id1" :client_secret "secret1" :access_token "token1")) mastodon.el/fixture/empty.plstore000066400000000000000000000001371452000115200175260ustar00rootroot00000000000000;;; public entries -*- mode: plstore -*- (("ignore" :client_id "id" :client_secret "secret")) mastodon.el/lisp/000077500000000000000000000000001452000115200142365ustar00rootroot00000000000000mastodon.el/lisp/.dir-locals.el000066400000000000000000000003451452000115200166710ustar00rootroot00000000000000;;; Directory Local Variables ;;; For more information see (info "(emacs) Directory Variables") ;; setting this makes package-lint look in the main file for deps: ((emacs-lisp-mode . ((package-lint-main-file . "mastodon.el")))) mastodon.el/lisp/mastodon-async.el000066400000000000000000000345371452000115200175330ustar00rootroot00000000000000;;; mastodon-async.el --- Async streaming functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2017 Alex J. Griffith ;; Author: Alex J. Griffith ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Package-Requires: ((emacs "27.1")) ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; Rework sync code so it does not mess up the async-buffer ;;; Code: (require 'mastodon-tl) (require 'json) (require 'url-http) (defvar url-http-end-of-headers) (autoload 'mastodon-auth--access-token "mastodon-auth") (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--get-json "mastodon-http") (autoload 'mastodon-mode "mastodon") (autoload 'mastodon-notifications--timeline "mastodon-notifications") (autoload 'mastodon-tl--timeline "mastodon-tl") (defgroup mastodon-async nil "An async module for mastodon streams." :prefix "mastodon-async-" :group 'external) ;;;###autoload (define-minor-mode mastodon-async-mode "Async Mastodon." :lighter " MasA") (defvar mastodon-instance-url) (defvar mastodon-tl--enable-relative-timestamps) (defvar mastodon-tl--display-media-p) (defvar mastodon-tl--buffer-spec) (defvar-local mastodon-async--queue "" ;;"*mastodon-async-queue*" "The intermediate queue buffer name.") (defvar-local mastodon-async--buffer "" ;;"*mastodon-async-buffer*" "User facing output buffer name.") (defvar-local mastodon-async--http-buffer "" ;;"" "Buffer variable bound to http output.") (defun mastodon-async--display-http () "Display the async HTTP input buffer." (display-buffer mastodon-async--http-buffer)) (defun mastodon-async--display-buffer () "Display the async user facing buffer." (interactive) (display-buffer mastodon-async--buffer)) (defun mastodon-async--display-queue () "Display the async queue buffer." (display-buffer mastodon-async--queue)) (defun mastodon-async--stop-http () "Stop the http processs and close the async and http buffer." (interactive) (let ((inhibit-read-only t)) (stop-process (get-buffer-process mastodon-async--http-buffer)) (delete-process (get-buffer-process mastodon-async--http-buffer)) (kill-buffer mastodon-async--http-buffer) (setq mastodon-async--http-buffer "") (when (not (equal "" mastodon-async--queue)) ; error handle on kill async buffer (kill-buffer mastodon-async--queue)))) (defun mastodon-async--stream-notifications () "Open a stream of user notifications." (interactive) (mastodon-async--mastodon "user" "home" "notifications" 'mastodon-async--process-queue-string-notifications)) (defun mastodon-async--stream-home () "Open a stream of the home timeline." (interactive) (mastodon-async--mastodon "user" "home" "home" 'mastodon-async--process-queue-string)) (defun mastodon-async--stream-federated () "Open a stream of Federated." (interactive) (mastodon-async--mastodon "public" "public" "federated" 'mastodon-async--process-queue-string)) (defun mastodon-async--stream-local () "Open a stream of Local." (interactive) ;; Need to add another layer of filtering for this to work ;; apparently it the local flag does not work (mastodon-async--mastodon "public" "public?local=true" "local" 'mastodon-async--process-queue-local-string)) (defun mastodon-async--mastodon (endpoint timeline name filter) "Make sure that the previous async process has been closed. Then start an async stream at ENDPOINT filtering toots using FILTER. TIMELINE is a specific target, such as federated or home. NAME is the center portion of the buffer name for *mastodon-async-buffer and *mastodon-async-queue." (ignore timeline) ;; TODO: figure out what this is meant to be used for (let ((buffer (mastodon-async--start-process endpoint filter name))) (with-current-buffer buffer (mastodon-async--display-buffer) (goto-char (point-max)) (goto-char 1)))) (defun mastodon-async--get (url callback) "An async GET request to URL with CALLBACK." (let ((url-request-method "GET") (url-request-extra-headers `(("Authorization" . ,(concat "Bearer " (mastodon-auth--access-token)))))) (url-retrieve url callback))) (defun mastodon-async--set-http-buffer (buffer http-buffer) "Initialize for BUFFER a local variable `mastodon-async--http-buffer'. HTTP-BUFFER is the initializing value. Use this funcion if HTTP-BUFFER is not known when `mastodon-async--setup-buffer' is called." (with-current-buffer (get-buffer-create buffer) (setq mastodon-async--http-buffer http-buffer))) (defun mastodon-async--set-local-variables (buffer http-buffer buffer-name queue-name) "Set local variables for BUFFER, HTTP-BUFFER, BUFFER-NAME, and QUEUE-NAME." (with-current-buffer (get-buffer-create buffer) (let ((value mastodon-instance-url)) (make-local-variable 'mastodon-instance-url) (setq-local mastodon-instance-url value)) (setq mastodon-async--http-buffer http-buffer) (setq mastodon-async--buffer buffer-name) (setq mastodon-async--queue queue-name))) (defun mastodon-async--setup-http (http-buffer name) "Add local variables to HTTP-BUFFER. NAME is used to generate the display buffer and the queue." (let ((queue-name (concat " *mastodon-async-queue-" name "-" mastodon-instance-url "*")) (buffer-name (concat "*mastodon-async-display-" name "-" mastodon-instance-url "*"))) (mastodon-async--set-local-variables http-buffer http-buffer buffer-name queue-name))) (defun mastodon-async--setup-queue (http-buffer name) "Set up HTTP-BUFFER buffer for the async queue. NAME is used to generate the display buffer and the queue." (let ((queue-name (concat " *mastodon-async-queue-" name "-" mastodon-instance-url "*")) (buffer-name(concat "*mastodon-async-display-" name "-" mastodon-instance-url "*"))) (mastodon-async--set-local-variables queue-name http-buffer buffer-name queue-name) queue-name)) (defun mastodon-async--setup-buffer (http-buffer name endpoint) "Set up the buffer timeline like `mastodon-tl--init'. HTTP-BUFFER the name of the http-buffer, if unknown, set to... NAME is the name of the stream for the buffer name. ENDPOINT is the endpoint for the stream and timeline." (let ((queue-name (concat " *mastodon-async-queue-" name "-" mastodon-instance-url "*")) (buffer-name (concat "*mastodon-async-display-" name "-" mastodon-instance-url "*")) ;; if user stream, we need "timelines/home" not "timelines/user" ;; if notifs, we need "notifications" not "timelines/notifications" (endpoint (cond ((equal name "notifications") "notifications") ((equal name "home") "timelines/home") (t (format "timelines/%s" endpoint))))) (mastodon-async--set-local-variables buffer-name http-buffer buffer-name queue-name) ;; Similar to timeline init. (with-current-buffer (get-buffer-create buffer-name) (setq inhibit-read-only t) ; for home timeline? (make-local-variable 'mastodon-tl--enable-relative-timestamps) (make-local-variable 'mastodon-tl--display-media-p) (message (mastodon-http--api endpoint)) (if (equal name "notifications") (mastodon-notifications--timeline (mastodon-http--get-json (mastodon-http--api "notifications"))) (mastodon-tl--timeline (mastodon-http--get-json (mastodon-http--api endpoint)))) (mastodon-mode) (mastodon-tl--set-buffer-spec buffer-name endpoint (if (equal name "notifications") 'mastodon-notifications--timeline 'mastodon-tl--timeline)) (setq-local mastodon-tl--enable-relative-timestamps nil) (setq-local mastodon-tl--display-media-p t) (current-buffer)))) (defun mastodon-async--start-process (endpoint filter &optional name) "Start an async mastodon stream at ENDPOINT. Filter the toots using FILTER. NAME is used for the queue and display buffer." (let* ((stream (concat "streaming/" endpoint)) (async-queue (mastodon-async--setup-queue "" (or name stream))) (async-buffer (mastodon-async--setup-buffer "" (or name stream) endpoint)) (http-buffer (mastodon-async--get (mastodon-http--api stream) (lambda (status) (ignore status) (message "HTTP SOURCE CLOSED"))))) (mastodon-async--setup-http http-buffer (or name stream)) (mastodon-async--set-http-buffer async-buffer http-buffer) (mastodon-async--set-http-buffer async-queue http-buffer) (set-process-filter (get-buffer-process http-buffer) (mastodon-async--http-hook filter)) http-buffer)) (defun mastodon-async--http-hook (filter) "Return a lambda with a custom FILTER for processing toots." (let ((filter filter)) (lambda (proc data) (with-current-buffer (process-buffer proc) (let* ((string (mastodon-async--stream-filter (mastodon-async--http-layer proc data))) (queue-string (mastodon-async--cycle-queue string))) (when queue-string (mastodon-async--output-toot (funcall filter queue-string)))))))) (defun mastodon-async--process-queue-string (string) "Parse the output STRING of the queue buffer, returning only update events." (let ((split-strings (split-string string "\n" t))) (when split-strings ; do nothing if we get nothing; just postpones the error (let ((event-type (replace-regexp-in-string "^event: " "" (car split-strings))) (data (replace-regexp-in-string "^data: " "" (cadr split-strings)))) (when (equal "update" event-type) ;; in some casses the data is not fully formed ;; for now return nil if malformed using `ignore-errors' (ignore-errors (json-read-from-string data))))))) (defun mastodon-async--process-queue-string-notifications (string) "Parse the output STRING of the queue buffer, returning only notification events." ;; NB notification events in streams include follow requests (let* ((split-strings (split-string string "\n" t)) (event-type (replace-regexp-in-string "^event: " "" (car split-strings))) (data (replace-regexp-in-string "^data: " "" (cadr split-strings)))) (when (equal "notification" event-type) ;; in some casses the data is not fully formed ;; for now return nil if malformed using `ignore-errors' (ignore-errors (json-read-from-string data))))) (defun mastodon-async--process-queue-local-string (string) "Use STRING to limit the public endpoint to displaying local steams only." (let ((json (mastodon-async--process-queue-string string))) (when json (when (mastodon-async--account-local-p json) json)))) (defun mastodon-async--account-local-p (json) "Test JSON to see if account is local." (not (string-match-p "@" (alist-get 'acct (alist-get 'account json))))) (defun mastodon-async--output-toot (toot) "Process TOOT and prepend it to the async user-facing buffer." (if (not (bufferp (get-buffer mastodon-async--buffer))) (mastodon-async--stop-http) (when toot (with-current-buffer mastodon-async--buffer (let* ((inhibit-read-only t) (old-max (point-max)) (previous (point)) (mastodon-tl--enable-relative-timestamps t) (mastodon-tl--display-media-p t)) (goto-char (point-min)) (if (equal (buffer-name) (concat "*mastodon-async-display-notifications-" mastodon-instance-url "*")) (mastodon-notifications--timeline (list toot)) (mastodon-tl--timeline (list toot))) (if (equal previous 1) (goto-char 1) (goto-char (+ previous (- (point-max) old-max))))))))) (defun mastodon-async--cycle-queue (string) "Append the most recent STRING from http buffer to queue buffer. Then determine if a full message has been recived. If so return it. Full messages are seperated by two newlines" (with-current-buffer mastodon-async--queue (goto-char (max-char)) (insert (decode-coding-string string 'utf-8)) (goto-char 0) (let ((next (re-search-forward "\n\n" nil t))) (when next (let ((return-string (buffer-substring 1 next)) (inhibit-read-only t)) (delete-region 1 next) return-string))))) (defun mastodon-async--http-layer (proc data) "Passes PROC and DATA to ‘url-http-generic-filter’. It then processes its output." (with-current-buffer (process-buffer proc) (let ((start (max 1 (- (point-max) 2)))) (url-http-generic-filter proc data) (when (> url-http-end-of-headers start) (setq start url-http-end-of-headers)) (let ((end (- (point-max) 2))) (buffer-substring start end))))) (defun mastodon-async--stream-filter (string) "Remove comments from STRING." (replace-regexp-in-string "^:.*\n" "" string)) (provide 'mastodon-async) ;;; mastodon-async.el ends here mastodon.el/lisp/mastodon-auth.el000066400000000000000000000211401452000115200173410ustar00rootroot00000000000000;;; mastodon-auth.el --- Auth functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2021 Abhiseck Paira ;; Author: Johnson Denen ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-auth.el supports authorizing and authenticating with Mastodon. ;;; Code: (require 'plstore) (require 'auth-source) (require 'json) (eval-when-compile (require 'subr-x)) ; for if-let (autoload 'mastodon-client "mastodon-client") (autoload 'mastodon-client--active-user "mastodon-client") (autoload 'mastodon-client--form-user-from-vars "mastodon-client") (autoload 'mastodon-client--make-user-active "mastodon-client") (autoload 'mastodon-client--store-access-token "mastodon-client") (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--concat-params-to-url "mastodon-http") (autoload 'mastodon-http--get-json "mastodon-http") (autoload 'mastodon-http--post "mastodon-http") (autoload 'mastodon-return-credential-account "mastodon") (defvar mastodon-instance-url) (defvar mastodon-client-scopes) (defvar mastodon-client-redirect-uri) (defvar mastodon-active-user) (defgroup mastodon-auth nil "Authenticate with Mastodon." :prefix "mastodon-auth-" :group 'mastodon) (defvar mastodon-auth-source-file nil "This variable is obsolete. This variable currently serves no purpose and will be removed in the future.") (defvar mastodon-auth--token-alist nil "Alist of User access tokens keyed by instance url.") (defvar mastodon-auth--acct-alist nil "Alist of account accts (name@domain) keyed by instance url.") (defvar mastodon-auth--user-unaware " ** MASTODON.EL - NOTICE ** It appears that you are not aware of the recent developments in mastodon.el. In short we now require that you also set the variable `mastodon-active-user' in your init file in addition to `mastodon-instance-url'. Please see its documentation to understand what value it accepts by running M-x describe-variable on it or visiting our web page: https://codeberg.org/martianh/mastodon.el We apologize for the inconvenience. ") (defun mastodon-auth--get-browser-login-url () "Return properly formed browser login url." (mastodon-http--concat-params-to-url (concat mastodon-instance-url "/oauth/authorize/") `(("response_type" . "code") ("redirect_uri" . ,mastodon-client-redirect-uri) ("scope" . ,mastodon-client-scopes) ("client_id" . ,(plist-get (mastodon-client) :client_id))))) (defvar mastodon-auth--explanation (format " 1. A URL has been copied to your clipboard. Open this URL in a javascript capable browser and your browser will take you to your Mastodon instance's login page. 2. Login to your account (%s) and authorize \"mastodon.el\". 3. After authorization you will be presented an authorization code. Copy this code and paste it in the minibuffer prompt." (mastodon-client--form-user-from-vars))) (defun mastodon-auth--show-notice (notice buffer-name &optional ask) "Display NOTICE to user. NOTICE is displayed in vertical split occupying 50% of total width. The buffer name of the buffer being displayed in the window is BUFFER-NAME. When optional argument ASK is given which should be a string, use ASK as the minibuffer prompt. Return whatever user types in response to the prompt. When ASK is absent return nil." (let ((buffer (get-buffer-create buffer-name)) (inhibit-read-only t) ask-value window) (set-buffer buffer) (erase-buffer) (insert notice) (fill-region (point-min) (point-max)) (read-only-mode) (setq window (select-window (split-window (frame-root-window) nil 'left) t)) (switch-to-buffer buffer t) (when ask (setq ask-value (read-string ask)) (kill-buffer buffer) (delete-window window)) ask-value)) (defun mastodon-auth--request-authorization-code () "Ask authorization code and return it." (let ((url (mastodon-auth--get-browser-login-url)) (select-enable-clipboard t) authorization-code) (kill-new url) (message "%s" url) (setq authorization-code (mastodon-auth--show-notice mastodon-auth--explanation "*mastodon-notice*" "Authorization Code: ")) authorization-code)) (defun mastodon-auth--generate-token () "Generate access_token for the user. Return response buffer." (let ((authorization-code (mastodon-auth--request-authorization-code))) (mastodon-http--post (concat mastodon-instance-url "/oauth/token") `(("grant_type" . "authorization_code") ("client_secret" . ,(plist-get (mastodon-client) :client_secret)) ("client_id" . ,(plist-get (mastodon-client) :client_id)) ("code" . ,authorization-code) ("redirect_uri" . ,mastodon-client-redirect-uri)) nil :unauthenticated))) (defun mastodon-auth--get-token () "Make a request to generate an auth token and return JSON response." (with-current-buffer (mastodon-auth--generate-token) (goto-char (point-min)) (re-search-forward "^$" nil 'move) (let ((json-object-type 'plist) (json-key-type 'keyword) (json-array-type 'vector) (json-string (buffer-substring-no-properties (point) (point-max)))) (json-read-from-string json-string)))) (defun mastodon-auth--access-token () "Return the access token to use with `mastodon-instance-url'. Generate/save token if none known yet." (cond (mastodon-auth--token-alist ;; user variables are known and initialised. (alist-get mastodon-instance-url mastodon-auth--token-alist)) ((plist-get (mastodon-client--active-user) :access_token) ;; user variables need to be read from plstore. (push (cons mastodon-instance-url (plist-get (mastodon-client--active-user) :access_token)) mastodon-auth--token-alist) (alist-get mastodon-instance-url mastodon-auth--token-alist)) ((null mastodon-active-user) ;; user not aware of 2FA-related changes and has not set ;; `mastodon-active-user'. Make user aware and error out. (mastodon-auth--show-notice mastodon-auth--user-unaware "*mastodon-notice*") (error "Variables not set properly")) (t ;; user access-token needs to fetched from the server and ;; stored and variables initialised. (mastodon-auth--handle-token-response (mastodon-auth--get-token))))) (defun mastodon-auth--handle-token-response (response) "Add token RESPONSE to `mastodon-auth--token-alist'. The token is returned by `mastodon-auth--get-token'. Handle any errors from the server." (pcase response ((and (let token (plist-get response :access_token)) (guard token)) (mastodon-client--make-user-active (mastodon-client--store-access-token token)) (cdar (push (cons mastodon-instance-url token) mastodon-auth--token-alist))) (`(:error ,class :error_description ,error) (error "Mastodon-auth--access-token: %s: %s" class error)) (_ (error "Unknown response from mastodon-auth--get-token!")))) (defun mastodon-auth--get-account-name () "Request user credentials and return an account name." (alist-get 'acct (mastodon-return-credential-account))) (defun mastodon-auth--get-account-id () "Request user credentials and return an account name." (alist-get 'id (mastodon-return-credential-account))) (defun mastodon-auth--user-acct () "Return a mastodon user acct name." (or (cdr (assoc mastodon-instance-url mastodon-auth--acct-alist)) (let ((acct (mastodon-auth--get-account-name))) (push (cons mastodon-instance-url acct) mastodon-auth--acct-alist) acct))) (provide 'mastodon-auth) ;;; mastodon-auth.el ends here mastodon.el/lisp/mastodon-client.el000066400000000000000000000200241452000115200176560ustar00rootroot00000000000000;;; mastodon-client.el --- Client functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2021 Abhiseck Paira ;; Author: Johnson Denen ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-client.el supports registering the Emacs client with your Mastodon instance. ;;; Code: (require 'plstore) (require 'json) (require 'url) (defvar mastodon-instance-url) (defvar mastodon-active-user) (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--post "mastodon-http") (defcustom mastodon-client--token-file (concat user-emacs-directory "mastodon.plstore") "File path where Mastodon access tokens are stored." :group 'mastodon :type 'file) (defvar mastodon-client--client-details-alist nil "An alist of Client id and secrets keyed by the instance url.") (defvar mastodon-client--active-user-details-plist nil "A plist of active user details.") (defvar mastodon-client-scopes "read write follow" "Scopes to pass to oauth during registration.") (defvar mastodon-client-website "https://codeberg.org/martianh/mastodon.el" "Website of mastodon.el.") (defvar mastodon-client-redirect-uri "urn:ietf:wg:oauth:2.0:oob" "Redirect_uri as required by oauth.") (defun mastodon-client--register () "POST client to Mastodon." (mastodon-http--post (mastodon-http--api "apps") `(("client_name" . "mastodon.el") ("redirect_uris" . ,mastodon-client-redirect-uri) ("scopes" . ,mastodon-client-scopes) ("website" . ,mastodon-client-website)) nil :unauthenticated)) (defun mastodon-client--fetch () "Return JSON from `mastodon-client--register' call." (with-current-buffer (mastodon-client--register) (goto-char (point-min)) (re-search-forward "^$" nil 'move) (let ((json-object-type 'plist) (json-key-type 'keyword) (json-array-type 'vector) (json-string (buffer-substring-no-properties (point) (point-max)))) (json-read-from-string json-string)))) (defun mastodon-client--token-file () "Return `mastodon-client--token-file'." mastodon-client--token-file) (defun mastodon-client--store () "Store client_id and client_secret in `mastodon-client--token-file'. Make `mastodon-client--fetch' call to determine client values." (let ((plstore (plstore-open (mastodon-client--token-file))) (client (mastodon-client--fetch)) ;; alexgriffith reported seeing ellipses in the saved output ;; which indicate some output truncating. Nothing in `plstore-save' ;; seems to ensure this cannot happen so let's do that ourselves: (print-length nil) (print-level nil)) (plstore-put plstore (concat "mastodon-" mastodon-instance-url) client nil) (plstore-save plstore) (plstore-close plstore) client)) (defun mastodon-client--remove-key-from-plstore (plstore) "Remove KEY from PLSTORE." (cdr plstore)) ;; Actually it returns a plist with client-details if such details are ;; already stored in mastodon.plstore (defun mastodon-client--read () "Retrieve client_id and client_secret from `mastodon-client--token-file'." (let* ((plstore (plstore-open (mastodon-client--token-file))) (mastodon (plstore-get plstore (concat "mastodon-" mastodon-instance-url)))) (mastodon-client--remove-key-from-plstore mastodon))) (defun mastodon-client--general-read (key) "Retrieve the plstore item keyed by KEY. Return plist without the KEY." (let* ((plstore (plstore-open (mastodon-client--token-file))) (plstore-item (plstore-get plstore key))) (mastodon-client--remove-key-from-plstore plstore-item))) (defun mastodon-client--make-user-details-plist () "Make a plist with current user details. Return it." `(:username ,(mastodon-client--form-user-from-vars) :instance ,mastodon-instance-url :client_id ,(plist-get (mastodon-client) :client_id) :client_secret ,(plist-get (mastodon-client) :client_secret))) (defun mastodon-client--store-access-token (token) "Save TOKEN as :access_token in plstore of the current user. Return the plist after the operation." (let* ((user-details (mastodon-client--make-user-details-plist)) (plstore (plstore-open (mastodon-client--token-file))) (username (plist-get user-details :username)) (plstore-value (setq user-details (plist-put user-details :access_token token))) (print-length nil) (print-level nil)) (plstore-put plstore (concat "user-" username) plstore-value nil) (plstore-save plstore) (plstore-close plstore) plstore-value)) (defun mastodon-client--make-user-active (user-details) "USER-DETAILS is a plist consisting of user details." (let ((plstore (plstore-open (mastodon-client--token-file))) (print-length nil) (print-level nil)) (plstore-put plstore "active-user" user-details nil) (plstore-save plstore) (plstore-close plstore))) (defun mastodon-client--form-user-from-vars () "Create a username from user variable. Return that username. Username in the form user@instance.com is formed from the variables `mastodon-instance-url' and `mastodon-active-user'." (concat mastodon-active-user "@" (url-host (url-generic-parse-url mastodon-instance-url)))) (defun mastodon-client--make-current-user-active () "Make the user specified by user variables active user. Return the details (plist)." (let ((username (mastodon-client--form-user-from-vars)) user-plist) (when (setq user-plist (mastodon-client--general-read (concat "user-" username))) (mastodon-client--make-user-active user-plist)) user-plist)) (defun mastodon-client--current-user-active-p () "Return user-details if the current user is active. Otherwise return nil." (let ((username (mastodon-client--form-user-from-vars)) (user-details (mastodon-client--general-read "active-user"))) (when (and user-details (equal (plist-get user-details :username) username)) user-details))) (defun mastodon-client--active-user () "Return the details of the currently active user. Details is a plist." (let ((active-user-details mastodon-client--active-user-details-plist)) (unless active-user-details (setq active-user-details (or (mastodon-client--current-user-active-p) (mastodon-client--make-current-user-active))) (setq mastodon-client--active-user-details-plist active-user-details)) active-user-details)) (defun mastodon-client () "Return variable client secrets to use for `mastodon-instance-url'. Read plist from `mastodon-client--token-file' if variable is nil. Fetch and store plist if `mastodon-client--read' returns nil." (let ((client-details (cdr (assoc mastodon-instance-url mastodon-client--client-details-alist)))) (unless client-details (setq client-details (or (mastodon-client--read) (mastodon-client--store))) (push (cons mastodon-instance-url client-details) mastodon-client--client-details-alist)) client-details)) (provide 'mastodon-client) ;;; mastodon-client.el ends here mastodon.el/lisp/mastodon-discover.el000066400000000000000000000132631452000115200202250ustar00rootroot00000000000000;;; mastodon-discover.el --- Use Mastodon.el with discover.el -*- lexical-binding: t -*- ;; Copyright (C) 2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; This adds optional functionality that can be used if the dicover package ;; is present. ;; ;; See the README file for how to use this. ;;; Code: (declare-function discover-add-context-menu "discover") (defun mastodon-discover () "Plug Mastodon functionality into `discover'." (interactive) (when (require 'discover nil :noerror) (discover-add-context-menu :bind "?" :mode 'mastodon-mode :mode-hook 'mastodon-mode-hook :context-menu '(mastodon (description "Mastodon feed viewer") (actions ("Toots" ("A" "View profile of author" mastodon-profile--get-toot-author) ("b" "Boost" mastodon-toot--boost) ("f" "Favourite" mastodon-toot--favourite) ("c" "Toggle hidden text (CW)" mastodon-tl--toggle-spoiler-text-in-toot) ("k" "Bookmark toot" mastodon-toot--toggle-bookmark) ("v" "Vote on poll" mastodon-tl--poll-vote) ("n" "Next" mastodon-tl--goto-next-item) ("p" "Prev" mastodon-tl--goto-prev-item) ("TAB" "Next link item" mastodon-tl--next-tab-item) ("S-TAB" "Prev link item" mastodon-tl--previous-tab-item) ;; NB: (when (require 'mpv etc. calls don't work here ("C-RET" "Play media" mastodon-tl--mpv-play-video-at-point) ("t" "New toot" mastodon-toot) ("r" "Reply" mastodon-toot--reply) ("C" "Copy toot URL" mastodon-toot--copy-toot-url) ("d" "Delete (your) toot" mastodon-toot--delete-toot) ("D" "Delete and redraft (your) toot" mastodon-toot--delete-toot) ("e" "Edit (your) toot" mastodon-toot--edit-toot-at-point) ("E" "View edits of (your) toot" mastodon-toot--view-toot-edits) ("i" "Pin/Unpin (your) toot" mastodon-toot--pin-toot-toggle) ("P" "View user profile" mastodon-profile--show-user) ("a" "Translate toot at point" mastodon-toot--translate-toot-text) ("T" "View thread" mastodon-tl--thread) ("v" "Vote on poll" mastodon-tl--poll-vote) ("," "View toot's favouriters" mastodon-toot--list-toot-favouriters) ("." "View toot's boosters" mastodon-toot--list-toot-boosters) ("/" "Switch buffers" mastodon-switch-to-buffer)) ("Views" ("h/?" "View mode help/keybindings" describe-mode) ("#" "Tag search" mastodon-tl--get-tag-timeline) ("\"" "List followed tags" mastodon-tl--list-followed-tags) ("'" "Followed tags timeline" mastodon-tl--followed-tags-timeline) ("F" "Federated" mastodon-tl--get-federated-timeline) ("H" "Home" mastodon-tl--get-home-timeline) ("L" "Local" mastodon-tl--get-local-timeline) ("N" "Notifications" mastodon-notifications-get) ("@" "Notifications with mentions" mastodon-notifications--get-mentions) ("g/u" "Update timeline" mastodon-tl--update) ("s" "Search" mastodon-search--query) ("O" "Jump to your profile" mastodon-profile--my-profile) ("U" "Update your profile note" mastodon-profile--update-user-profile-note) ("K" "View bookmarks" mastodon-profile--view-bookmarks) ("V" "View favourites" mastodon-profile--view-favourites) ("R" "View follow requests" mastodon-profile--view-follow-requests) ("G" "View follow suggestions" mastodon-tl--get-follow-suggestions) ("I" "View filters" mastodon-tl--view-filters) ("X" "View lists" mastodon-tl--view-lists) ("S" "View scheduled toots" mastodon-tl--view-scheduled-toots) (";" "View instance description" mastodon-tl--view-instance-description)) ("Users" ("W" "Follow" mastodon-tl--follow-user) ("C-S-W" "Unfollow" mastodon-tl--unfollow-user) ("M" "Mute" mastodon-tl--mute-user) ("C-S-M" "Unmute" mastodon-tl--unmute-user) ("B" "Block" mastodon-tl--block-user) ("C-S-B" "Unblock" mastodon-tl--unblock-user)) ("Images" ;; RET errors here also :/ ("/i" "Load full image in browser" 'shr-browse-image) ("r" "rotate" 'image-rotate) ("+" "zoom in" 'image-increase-size) ("-" "zoom out" 'image-decrease-size) ("u" "copy URL" 'shr-maybe-probe-and-copy-url)) ("Profile view" ("C-c C-c" "Cycle profile views" mastodon-profile--account-view-cycle)) ("Quit" ("q" "Quit mastodon and bury buffer." kill-this-buffer) ("Q" "Quit mastodon buffer and kill window." kill-buffer-and-window) ("M-C-q" "Quit mastodon and kill all buffers." mastodon-kill-all-buffers))))))) (provide 'mastodon-discover) ;;; mastodon-discover.el ends here mastodon.el/lisp/mastodon-http.el000066400000000000000000000374021452000115200173670ustar00rootroot00000000000000;;; mastodon-http.el --- HTTP request/response functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-http.el provides HTTP request/response functions. ;;; Code: (require 'json) (require 'request) ; for attachments upload (require 'url) (require 'shr) (defvar mastodon-instance-url) (defvar mastodon-toot--media-attachment-ids) (defvar mastodon-toot--media-attachment-filenames) (autoload 'mastodon-auth--access-token "mastodon-auth") (autoload 'mastodon-toot--update-status-fields "mastodon-toot") (defvar mastodon-http--api-version "v1") (defconst mastodon-http--timeout 15 "HTTP request timeout, in seconds. Has no effect on Emacs < 26.1.") (defun mastodon-http--api (endpoint) "Return Mastodon API URL for ENDPOINT." (concat mastodon-instance-url "/api/" mastodon-http--api-version "/" endpoint)) (defun mastodon-http--api-search () "Return Mastodon API url for the /search endpoint (v2)." (format "%s/api/v2/search" mastodon-instance-url)) (defun mastodon-http--response () "Capture response buffer content as string." (with-current-buffer (current-buffer) (buffer-substring-no-properties (point-min) (point-max)))) (defun mastodon-http--response-body (pattern) "Return substring matching PATTERN from `mastodon-http--response'." (let ((resp (mastodon-http--response))) (string-match pattern resp) (match-string 0 resp))) (defun mastodon-http--status () "Return HTTP Response Status Code from `mastodon-http--response'." (let* ((status-line (mastodon-http--response-body "^HTTP/1.*$"))) (string-match "[0-9][0-9][0-9]" status-line) (match-string 0 status-line))) (defun mastodon-http--url-retrieve-synchronously (url &optional silent) "Retrieve URL asynchronously. This is a thin abstraction over the system `url-retrieve-synchronously'. Depending on which version of this is available we will call it with or without a timeout. SILENT means don't message." (if (< (cdr (func-arity 'url-retrieve-synchronously)) 4) (url-retrieve-synchronously url) (url-retrieve-synchronously url (or silent nil) nil mastodon-http--timeout))) (defun mastodon-http--triage (response success) "Determine if RESPONSE was successful. Call SUCCESS if successful. Message status and JSON error from RESPONSE if unsuccessful." (let ((status (with-current-buffer response (mastodon-http--status)))) (if (string-prefix-p "2" status) (funcall success response) (if (string-prefix-p "404" status) (message "Error %s: page not found" status) (let ((json-response (with-current-buffer response (mastodon-http--process-json)))) (message "Error %s: %s" status (alist-get 'error json-response))))))) (defun mastodon-http--read-file-as-string (filename) "Read a file FILENAME as a string. Used to generate image preview." (with-temp-buffer (insert-file-contents filename) (string-to-unibyte (buffer-string)))) (defmacro mastodon-http--authorized-request (method body &optional unauthenticated-p) "Make a METHOD type request using BODY, with Mastodon authorization. Unless UNAUTHENTICATED-P is non-nil." (declare (debug 'body) (indent 1)) `(let ((url-request-method ,method) (url-request-extra-headers (unless ,unauthenticated-p (list (cons "Authorization" (concat "Bearer " (mastodon-auth--access-token))))))) ,body)) (defun mastodon-http--build-params-string (params) "Build a request parameters string from parameters alist PARAMS." ;; (url-build-query-string args nil)) ;; url-build-query-string adds 'nil' for empty params so lets stick with our ;; own: (mapconcat (lambda (p) (when (cdr p) ; only when value (concat (url-hexify-string (car p)) "=" (url-hexify-string (cdr p))))) params "&")) (defun mastodon-http--build-array-params-alist (param-str array) "Return parameters alist using PARAM-STR and ARRAY param values. Used for API form data parameters that take an array." (cl-loop for x in array collect (cons param-str x))) (defun mastodon-http--post (url &optional params headers unauthenticated-p json) "POST synchronously to URL, optionally with PARAMS and HEADERS. Authorization header is included by default unless UNAUTHENTICATED-P is non-nil.If JSON, encode PARAMS as JSON for the request data." (mastodon-http--authorized-request "POST" (let* ((url-request-data (when params (if json (json-encode params) (mastodon-http--build-params-string params)))) (url-request-extra-headers (append url-request-extra-headers ; auth set in macro (unless (assoc "Content-Type" headers) ; pleroma compat: '(("Content-Type" . "application/x-www-form-urlencoded"))) headers))) (with-temp-buffer (mastodon-http--url-retrieve-synchronously url))) unauthenticated-p)) (defun mastodon-http--concat-params-to-url (url params) "Build a query string with PARAMS and concat to URL." (if params (concat url "?" (mastodon-http--build-params-string params)) url)) (defun mastodon-http--get (url &optional params silent) "Make synchronous GET request to URL. PARAMS is an alist of any extra parameters to send with the request. SILENT means don't message." (mastodon-http--authorized-request "GET" ;; url-request-data doesn't seem to work with GET requests?: (let ((url (mastodon-http--concat-params-to-url url params))) (mastodon-http--url-retrieve-synchronously url silent)))) (defun mastodon-http--get-response (url &optional params no-headers silent vector) "Make synchronous GET request to URL. Return JSON and response headers. PARAMS is an alist of any extra parameters to send with the request. SILENT means don't message. NO-HEADERS means don't collect http response headers. VECTOR means return json arrays as vectors." (with-current-buffer (mastodon-http--get url params silent) (mastodon-http--process-response no-headers vector))) (defun mastodon-http--get-json (url &optional params silent vector) "Return only JSON data from URL request. PARAMS is an alist of any extra parameters to send with the request. SILENT means don't message. VECTOR means return json arrays as vectors." (car (mastodon-http--get-response url params :no-headers silent vector))) (defun mastodon-http--process-json () "Return only JSON data from async URL request. Callback to `mastodon-http--get-json-async', usually `mastodon-tl--init*', is run on the result." (car (mastodon-http--process-response :no-headers))) (defun mastodon-http--render-html-err (string) "Render STRING as HTML in a temp buffer. STRING should be a HTML for a 404 errror." (with-temp-buffer (insert string) (shr-render-buffer (current-buffer)) (view-mode))) ; for 'q' to kill buffer and window ;; (error ""))) ; stop subsequent processing (defun mastodon-http--process-response (&optional no-headers vector) "Process http response. Return a cons of JSON list and http response headers. If NO-HEADERS is non-nil, just return the JSON. VECTOR means return json arrays as vectors. Callback to `mastodon-http--get-response-async', usually `mastodon-tl--init*', is run on the result." ;; view raw response: ;; (switch-to-buffer (current-buffer)) (let ((headers (unless no-headers (mastodon-http--process-headers)))) (goto-char (point-min)) (re-search-forward "^$" nil 'move) (let ((json-array-type (if vector 'vector 'list)) (json-string (decode-coding-string (buffer-substring-no-properties (point) (point-max)) 'utf-8))) (kill-buffer) (cond ((or (string-empty-p json-string) (null json-string)) nil) ;; if we get html, just render it and error: ;; ideally we should handle the status code in here rather than ;; this crappy hack? ((string-prefix-p "\n<" json-string) ; html hack (mastodon-http--render-html-err json-string)) ;; if no json or html, maybe we have a plain string error message ;; (misskey does this, but there are probably better ways to do ;; this): ((not (or (string-prefix-p "\n{" json-string) (string-prefix-p "\n[" json-string))) (error "%s" json-string)) (t `(,(json-read-from-string json-string) . ,headers)))))) (defun mastodon-http--process-headers () "Return an alist of http response headers." (switch-to-buffer (current-buffer)) (goto-char (point-min)) (let* ((head-str (buffer-substring-no-properties (point-min) (re-search-forward "^$" nil 'move))) (head-list (split-string head-str "\n"))) (mapcar (lambda (x) (let ((list (split-string x ": "))) (cons (car list) (cadr list)))) head-list))) (defun mastodon-http--delete (url &optional params) "Make DELETE request to URL. PARAMS is an alist of any extra parameters to send with the request." ;; url-request-data only works with POST requests? (let ((url (mastodon-http--concat-params-to-url url params))) (mastodon-http--authorized-request "DELETE" (with-temp-buffer (mastodon-http--url-retrieve-synchronously url))))) (defun mastodon-http--put (url &optional params headers) "Make PUT request to URL. PARAMS is an alist of any extra parameters to send with the request. HEADERS is an alist of any extra headers to send with the request." (mastodon-http--authorized-request "PUT" (let ((url-request-data (when params (mastodon-http--build-params-string params))) (url-request-extra-headers (append url-request-extra-headers ; auth set in macro (unless (assoc "Content-Type" headers) ; pleroma compat: '(("Content-Type" . "application/x-www-form-urlencoded"))) headers))) (with-temp-buffer (mastodon-http--url-retrieve-synchronously url))))) ;; profile update functions (defun mastodon-http--patch-json (url &optional params) "Make synchronous PATCH request to URL. Return JSON response. Optionally specify the PARAMS to send." (with-current-buffer (mastodon-http--patch url params) (mastodon-http--process-json))) (defun mastodon-http--patch (base-url &optional params) "Make synchronous PATCH request to BASE-URL. Optionally specify the PARAMS to send." (mastodon-http--authorized-request "PATCH" (let ((url (mastodon-http--concat-params-to-url base-url params))) (mastodon-http--url-retrieve-synchronously url)))) ;; Asynchronous functions (defun mastodon-http--get-async (url &optional params callback &rest cbargs) "Make GET request to URL. Pass response buffer to CALLBACK function with args CBARGS. PARAMS is an alist of any extra parameters to send with the request." (let ((url (mastodon-http--concat-params-to-url url params))) (mastodon-http--authorized-request "GET" (url-retrieve url callback cbargs)))) (defun mastodon-http--get-response-async (url &optional params callback &rest cbargs) "Make GET request to URL. Call CALLBACK with http response and CBARGS. PARAMS is an alist of any extra parameters to send with the request." (mastodon-http--get-async url params (lambda (status) (when status ; for flakey servers (apply callback (mastodon-http--process-response) cbargs))))) (defun mastodon-http--get-json-async (url &optional params callback &rest cbargs) "Make GET request to URL. Call CALLBACK with json-list and CBARGS. PARAMS is an alist of any extra parameters to send with the request." (mastodon-http--get-async url params (lambda (status) (when status ;; only when we actually get sth? (apply callback (mastodon-http--process-json) cbargs))))) (defun mastodon-http--post-async (url params _headers &optional callback &rest cbargs) "POST asynchronously to URL with PARAMS and HEADERS. Then run function CALLBACK with arguements CBARGS. Authorization header is included by default unless UNAUTHENTICED-P is non-nil." (mastodon-http--authorized-request "POST" (let (;(request-timeout 5) ; this is from request.el no url.el! (url-request-data (when params (mastodon-http--build-params-string params)))) (with-temp-buffer (url-retrieve url callback cbargs))))) ;; TODO: test for curl first? (defun mastodon-http--post-media-attachment (url filename caption) "Make POST request to upload FILENAME with CAPTION to the server's media URL. The upload is asynchronous. On succeeding, `mastodon-toot--media-attachment-ids' is set to the id(s) of the item uploaded, and `mastodon-toot--update-status-fields' is run." (let* ((file (file-name-nondirectory filename)) (request-backend 'curl) (cb (cl-function (lambda (&key data &allow-other-keys) (when data (push (alist-get 'id data) mastodon-toot--media-attachment-ids) ; add ID to list (message (alist-get 'id data)) (message "Uploading %s... (done)" file) (mastodon-toot--update-status-fields)))))) (request url :type "POST" :params `(("description" . ,caption)) :files `(("file" . (,file :file ,filename :mime-type "multipart/form-data"))) :parser 'json-read :headers `(("Authorization" . ,(concat "Bearer " (mastodon-auth--access-token)))) :sync nil :success (apply-partially cb) :error (cl-function (lambda (&key error-thrown &allow-other-keys) (cond ;; handle curl errors first (eg 26, can't read file/path) ;; because the '=' test below fails for them ;; they have the form (error . error message 24) ((not (proper-list-p error-thrown)) ; not dotted list (message "Got error: %s. Shit went south." (cdr error-thrown))) ;; handle mastodon api errors ;; they have the form (error http 401) ((= (car (last error-thrown)) 401) (message "Got error: %s Unauthorized: The access token is invalid" error-thrown)) ((= (car (last error-thrown)) 422) (message "Got error: %s Unprocessable entity: file or file\ type is unsupported or invalid" error-thrown)) (t (message "Got error: %s Shit went south" error-thrown)))))))) (provide 'mastodon-http) ;;; mastodon-http.el ends here mastodon.el/lisp/mastodon-inspect.el000066400000000000000000000111041452000115200200440ustar00rootroot00000000000000;;; mastodon-inspect.el --- Client for Mastodon -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; Some tools to help inspect / debug mastodon.el ;;; Code: (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--get-json "mastodon-http") (autoload 'mastodon-http--get-search-json "mastodon-http") (autoload 'mastodon-media--inline-images "mastodon-media") (autoload 'mastodon-mode "mastodon") (autoload 'mastodon-tl--as-string "mastodon-tl") (autoload 'mastodon-tl--property "mastodon-tl") (autoload 'mastodon-tl--toot "mastodon-tl") (defvar mastodon-instance-url) (defgroup mastodon-inspect nil "Tools to help inspect toots." :prefix "mastodon-inspect-" :group 'external) (defun mastodon-inspect--dump-json-in-buffer (name json) "Buffer NAME is opened and JSON in printed into it." (switch-to-buffer-other-window name) (erase-buffer) (let ((print-level nil) (print-length nil)) (insert (pp json t))) (goto-char (point-min)) (emacs-lisp-mode) (message "success")) (defun mastodon-inspect--toot () "Find next toot and dump its meta data into new buffer." (interactive) (mastodon-inspect--dump-json-in-buffer (concat "*mastodon-inspect-toot-" (mastodon-tl--as-string (mastodon-tl--property 'item-id)) "*") (mastodon-tl--property 'item-json))) (defun mastodon-inspect--download-single-toot (item-id) "Download the toot/status represented by ITEM-ID." (mastodon-http--get-json (mastodon-http--api (concat "statuses/" item-id)))) (defun mastodon-inspect--view-single-toot (item-id) "View the toot/status represented by ITEM-ID." (interactive "s Toot ID: ") (let ((buffer (get-buffer-create (concat "*mastodon-status-" item-id "*")))) (with-current-buffer buffer (let ((toot (mastodon-inspect--download-single-toot item-id ))) (mastodon-tl--toot toot) (goto-char (point-min)) (while (search-forward "\n\n\n | " nil t) (replace-match "\n | ")) (mastodon-media--inline-images (point-min) (point-max)))) (switch-to-buffer-other-window buffer) (mastodon-mode))) (defun mastodon-inspect--view-single-toot-source (item-id) "View the ess source of a toot/status represented by ITEM-ID." (interactive "s Toot ID: ") (mastodon-inspect--dump-json-in-buffer (concat "*mastodon-status-raw-" item-id "*") (mastodon-inspect--download-single-toot item-id))) (defvar mastodon-inspect--search-query-accounts-result) (defvar mastodon-inspect--single-account-json) (defvar mastodon-inspect--search-query-full-result) (defvar mastodon-inspect--search-result-tags) (defun mastodon-inspect--get-search-result (query) "Inspect function for a search result for QUERY." (interactive) (setq mastodon-inspect--search-query-full-result (append ; convert vector to list (mastodon-http--get-search-json (format "%s/api/v2/search" mastodon-instance-url) query) nil)) (setq mastodon-inspect--search-result-tags (append (cdr (caddr mastodon-inspect--search-query-full-result)) nil))) (defun mastodon-inspect--get-search-account (query) "Return JSON for a single account after search QUERY." (interactive) (setq mastodon-inspect--search-query-accounts-result (append ; convert vector to list (mastodon-http--get-search-json (format "%s/api/v1/accounts/search" mastodon-instance-url) query) nil)) (setq mastodon-inspect--single-account-json (car mastodon-inspect--search-query-accounts-result))) (provide 'mastodon-inspect) ;;; mastodon-inspect.el ends here mastodon.el/lisp/mastodon-iso.el000066400000000000000000000144611452000115200172020ustar00rootroot00000000000000;;; mastodon-iso.el --- ISO language code lists for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2022 Marty Hiatt ;; Author: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;;; Code: ;; via ;; https://github.com/VyrCossont/mastodon/blob/0836f4a656d5486784cadfd7d0cd717bb67ede4c/app/helpers/languages_helper.rb ;; and ;; https://github.com/Shinmera/language-codes/blob/master/data/iso-639-3.lisp (defvar mastodon-iso-639-1 '(("Abkhazian" . "ab") ("Afar" . "aa") ("Afrikaans" . "af") ("Akan" . "ak") ("Albanian" . "sq") ("Amharic" . "am") ("Arabic" . "ar") ("Aragonese" . "an") ("Armenian" . "hy") ("Assamese" . "as") ("Avaric" . "av") ("Avestan" . "ae") ("Aymara" . "ay") ("Azerbaijani" . "az") ("Bambara" . "bm") ("Bashkir" . "ba") ("Basque" . "eu") ("Belarusian" . "be") ("Bengali" . "bn") ("Bihari languages" . "bh") ("Bislama" . "bi") ("Bosnian" . "bs") ("Breton" . "br") ("Bulgarian" . "bg") ("Burmese" . "my") ("Central Khmer" . "km") ("Chamorro" . "ch") ("Chechen" . "ce") ("Chinese" . "zh") ("Chuvash" . "cv") ("Cornish" . "kw") ("Corsican" . "co") ("Cree" . "cr") ("Croatian" . "hr") ("Czech" . "cs") ("Danish" . "da") ("Dzongkha" . "dz") ("English" . "en") ("Esperanto" . "eo") ("Estonian" . "et") ("Ewe" . "ee") ("Faroese" . "fo") ("Fijian" . "fj") ("Finnish" . "fi") ("Dutch" . "nl") ("French" . "fr") ("Fulah" . "ff") ("Galician" . "gl") ("Ganda" . "lg") ("Georgian" . "ka") ("German" . "de") ("Greek" . "el") ("Guarani" . "gn") ("Gujarati" . "gu") ("Haitian" . "ht") ("Hausa" . "ha") ("Hebrew" . "he") ("Herero" . "hz") ("Hindi" . "hi") ("Hiri Motu" . "ho") ("Hungarian" . "hu") ("Icelandic" . "is") ("Ido" . "io") ("Igbo" . "ig") ("Indonesian" . "id") ("Interlingua" . "ia") ("Inuktitut" . "iu") ("Inupiaq" . "ik") ("Irish" . "ga") ("Italian" . "it") ("Japanese" . "ja") ("Japanese" . "jp") ("Javanese" . "jv") ("Kalaallisut" . "kl") ("Kannada" . "kn") ("Kanuri" . "kr") ("Kashmiri" . "ks") ("Kazakh" . "kk") ("Kikuyu" . "ki") ("Kinyarwanda" . "rw") ("Komi" . "kv") ("Kongo" . "kg") ("Korean" . "ko") ("Kurdish" . "ku") ("Kuanyama" . "kj") ("Kirghiz" . "ky") ("Lao" . "lo") ("Latin" . "la") ("Latvian" . "lv") ("Limburgan" . "li") ("Lingala" . "ln") ("Lithuanian" . "lt") ("Luba-Katanga" . "lu") ("Luxembourgish" . "lb") ("Macedonian" . "mk") ("Malagasy" . "mg") ("Malay" . "ms") ("Malayalam" . "ml") ("Divehi" . "dv") ("Maltese" . "mt") ("Manx" . "gv") ("Maori" . "mi") ("Marathi" . "mr") ("Marshallese" . "mh") ("Mongolian" . "mn") ("Nauru" . "na") ("Navajo" . "nv") ("Ndonga" . "ng") ("Nepali" . "ne") ("Ndebele, North" . "nd") ("Northern Sami" . "se") ("Norwegian" . "no") ("Bokmål, Norwegian" . "nb") ("Chichewa" . "ny") ("Norwegian Nynorsk" . "nn") ("Interlingue" . "ie") ("Occitan" . "oc") ("Ojibwa" . "oj") ("Church Slavic" . "cu") ("Oriya" . "or") ("Oromo" . "om") ("Ossetian" . "os") ("Pali" . "pi") ("Persian" . "fa") ("Polish" . "pl") ("Portuguese" . "pt") ("Panjabi" . "pa") ("Pushto" . "ps") ("Quechua" . "qu") ("Romanian" . "ro") ("Romansh" . "rm") ("Rundi" . "rn") ("Russian" . "ru") ("Samoan" . "sm") ("Sango" . "sg") ("Sanskrit" . "sa") ("Sardinian" . "sc") ("Gaelic" . "gd") ("Serbian" . "sr") ("Shona" . "sn") ("Sichuan Yi" . "ii") ("Sindhi" . "sd") ("Sinhala" . "si") ("Slovak" . "sk") ("Slovenian" . "sl") ("Somali" . "so") ("Sotho, Southern" . "st") ("Ndebele, South" . "nr") ("Spanish" . "es") ("Sundanese" . "su") ("Swahili" . "sw") ("Swati" . "ss") ("Swedish" . "sv") ("Tagalog" . "tl") ("Tahitian" . "ty") ("Tajik" . "tg") ("Tamil" . "ta") ("Tatar" . "tt") ("Telugu" . "te") ("Thai" . "th") ("Tibetan" . "bo") ("Tigrinya" . "ti") ("Tonga (Tonga Islands)" . "to") ("Tsonga" . "ts") ("Tswana" . "tn") ("Turkish" . "tr") ("Turkmen" . "tk") ("Twi" . "tw") ("Ukrainian" . "uk") ("Urdu" . "ur") ("Uighur" . "ug") ("Uzbek" . "uz") ("Catalan" . "ca") ("Venda" . "ve") ("Vietnamese" . "vi") ("Volapük" . "vo") ("Walloon" . "wa") ("Welsh" . "cy") ("Western Frisian" . "fy") ("Wolof" . "wo") ("Xhosa" . "xh") ("Yiddish" . "yi") ("Yoruba" . "yo") ("Zhuang" . "za") ("Zulu" . "zu"))) ;; web UI doesn't respect these for now (defvar mastodon-iso-639-regional '(("es-AR" "Español (Argentina)") ("es-MX" "Español (México)") ("pt-BR" "Português (Brasil)") ("pt-PT" "Português (Portugal)") ("sr-Latn" "Srpski (latinica)") ("zh-CN" "简体中文") ("zh-HK" "繁體中文（香港）") ("zh-TW" "繁體中文（臺灣）"))) (defvar mastodon-iso-639-3 '(("ast" "Asturian" "Asturianu") ("ckb" "Sorani (Kurdish)" "سۆرانی") ("jbo" "Lojban" "la .lojban.") ("kab" "Kabyle" "Taqbaylit") ("kmr" "Kurmanji (Kurdish)" "Kurmancî") ("ldn" "Láadan" "Láadan") ("lfn" "Lingua Franca Nova" "lingua franca nova") ("tok" "Toki Pona" "toki pona") ("zba" "Balaibalan" "باليبلن") ("zgh" "Standard Moroccan Tamazight" "ⵜⴰⵎⴰⵣⵉⵖⵜ"))) (provide 'mastodon-iso) ;;; mastodon-iso.el ends here mastodon.el/lisp/mastodon-media.el000066400000000000000000000405011452000115200174610ustar00rootroot00000000000000;;; mastodon-media.el --- Functions for inlining Mastodon media -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-media.el provides functions for inlining media. ;; Known bug gnutls -12 when trying to access images on some systems. ;; It looks like their may be a version mismatch between the encryption ;; required by the server and client. ;;; Code: (require 'url-cache) (autoload 'mastodon-tl--propertize-img-str-or-url "mastodon-tl") (defvar url-show-status) (defvar mastodon-tl--shr-image-map-replacement) (defgroup mastodon-media nil "Inline Mastadon media." :prefix "mastodon-media-" :group 'mastodon) (defcustom mastodon-media--avatar-height 20 "Height of the user avatar images (if shown)." :type 'integer) (defcustom mastodon-media--preview-max-height 250 "Max height of any media attachment preview to be shown in timelines." :type 'integer) (defcustom mastodon-media--enable-image-caching nil "Whether images should be cached." :type 'boolean) (defvar mastodon-media--generic-avatar-data (base64-decode-string "iVBORw0KGgoAAAANSUhEUgAAAGQAAABkCAIAAAD/gAIDAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA B3RJTUUH4QUIFCg2lVD1hwAAABZ0RVh0Q29tbWVudABHZW5lcmljIGF2YXRhcsyCnMsAAAcGSURB VHja7dzdT1J/HAfwcw7EQzMKW0pGRMK4qdRZbdrs6aIRbt506V1b/AV1U2td9l9UXnmhW6vgwuko SbcOD/a0RB4CCRCRg0AIR4Hz8LvgN2cKCMI5wOH7uXBuugO+eH8+fM/3HIFpmoZAVVYIIABYAAtg ASyABbAAAcACWAALYAEsgAUIABbAAlgAC2ABLEAAsAAWwAJYAAtgAQKAxUjxm+R50DRN0zRFUf+8 kggCwzAMwwDrfyOSJGmattlsdrvd5XLlcrndnyoUir6+vpGRkZMnT/J4vIarwY26MaTAZLVap6en fT7f9vY2QRA7Ozv/vJJ8vkgk4vP5XV1dWq1Wq9VKpdIGkjUGi6IoFEWnp6ddLlcymSRJsvzv83g8 kUikUCi0Wq1Opzt16lS7YBEE8ebNG6PRiGHYoUwHyW7cuPHo0SOlUsl9LIIgXrx4Ybfb//79e7Qj CIXC3t7ex48fX7lyhctYBSkURTOZTC3H4fF4SqXy6dOnLHuxh0VR1PPnz2uX2uv17Nmzy5cvc21R StP0q1ev7HZ7XaQgCCJJ0u/3T0xMBINBrmGhKGo0Go88p0p5Wa1Wg8GQSqW4g0XT9NTUFIZhdT9y Npudn59nLVwIO7FyuVxVrRIqr1AoZDab2QkXG1hTU1PJZJKhg5MkOT8/HwqFuIBF07TP52MoVrvh YqLHG4BlsVi2t7cZfQiSJB0OBwudyDiWzWYjCILpR1lZWeECltPp3LeXwEQFg8FoNNryWPl8noVp ws6jgG1lgAWwuI914cIFPp/xnX6ZTCYSiVoeq7+/n4U/Q61Wy+Xylse6desWC8kaGBiQSCQtjyWR SGQyGY/HY+4hpFJpV1cXRwa8TqdjtBOHh4fVajVHsLRarVKpZChcUqn07t27LPQgS1gSiUSn04nF 4rofGYbh4eHhgYEBTq2ztFrtyMhI3ZtRo9GMjY2xEyv2sCQSiV6vV6lUdWzGzs7O8fHxwcFBDq7g 5XL5kydPent76+LV2dmp1+vv37/P5gqe7SvSDofj5cuXteydwjAslUr1ev2DBw9YPt1pwL0ODodj YmLCYrEcYZ8LhmGNRjM+Ps5yphqGBUFQKBQyGo0mk2l1dTWfz5MkSVFUPp8/+GSEQiEMw8eOHYNh uLu7e2hoaGxsjM05tbfYvpkNx/FQKBSJRCAI6unpwTBsbW0tmUwWbtc6mCMEQSAIOn78+Llz586f P9/T05PL5QKBgEKh4GyyCkZfvnwJhULhcHhzczOTyRRuYMtms/l8PpPJZDKZnZ2dvc9HIBCIxeIT J04Uvil87ejoOH36tEwm02g0V69evXjxIkewCkZer/fr16+/f/+OxWKlrvQQBEEQxL7dYQRBhEJh 0fNwBEHEYrFMJlOpVP39/RqNhgU1prAKTDMzMy6XKxqNJhIJptY+CHLmzBmZTHbp0qXbt2+rVKpW wtplWl5eDofDTF803Bs0tVrNKFmdsXAcn52dnZ2dDQaD7DAVJRsdHb1z507dT93rhoXj+MrKytzc 3NLSEnNNVyHZ2bNnr127NjQ0NDg4WEey+mDhOP7u3bu5ubkyI5z9iMnl8nv37o2OjgoEgmbBisVi r1+/ttlsjQ1UmYg9fPiwo6OjwVg4jn///v3Dhw/Ly8vNEKiiXhKJpK+vT6fT1d6S/FqkUBSdnJz0 +/1QsxZFUclkEkXReDxOkuT169dr8TpisnAcN5lMb9++ZfP+11pKIBAUdgpv3rx55BGGtIMUBEG5 XM7tdhsMhoWFhb3/S8UsVitK1curaqzV1dX379+3nNQ+r42NjSPsPlaH5fP5mnyiV+Ll9XonJyfD 4XC1XkhVDTgzM/Pz50+oxSubzX779u3z58/VLneQyqUMBsOnT5+acz1V7XoiHo9//PjRZDKl0+n6 Y3k8HrPZ3Gxr9Fq81tfXl5aWAoFA5cO+IqxIJFLYSIA4VARBuN3uxcXFyoc9v5IGNJvNVquVAw14 sBktFkt3d7dUKq3k5BGpJFYLCwucacCizZhIJCoJF3JorBYXF//8+QNxtAiCKFwiqKRvkEPnOoqi HGvAfeFKJBIVTnqkfKx+/PjBsbleKlwej6cmLI/H43A4OByr3XClUimn03louMphra2teb1eqA0q m836fL6tra0jYkUiEb/fz8k3waLhikQiXq+3/NtiSayNjY1fv35BbVP5fN7pdG5tbR0Fy+12c360 Hxzz5a8KI6V6EMMwzo/2fZ2YTqej0WgqlSoVLqRUDwYCAajNiqKoYDBYphOLY8ViscItVG1VJEmu r6+XeU8sjhWPxzc3N9sNiyAIDMOqS1YbDqwKx1YRrFQqxc7HJDRnpdPpUuEqgoVhWL0+i6hFz6tL ja3iM4u1zw1qwhlfJihI0bfCNhxYe4NSqg3/A862hQAbrdtHAAAAAElFTkSuQmCC") "The PNG data for a generic 100x100 avatar.") (defvar mastodon-media--generic-broken-image-data (base64-decode-string "iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAYAAACtWK6eAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA B3RJTUUH4QUIFQUVFt+0LQAAABZ0RVh0Q29tbWVudABHZW5lcmljIGF2YXRhcsyCnMsAAAdoSURB VHja7d1NSFRrAIfx//iB6ZDSMJYVkWEk0ceYFUkkhhQlEUhEg0FlC1eBoRTUwlbRok0TgRQURZAE FgpjJmFajpK4kggxpXHRQEGWUJZizpy7uPfC5eKiV+dD5zw/mN05jrxnnjnfcxyWZVkCMKc0SXI4 HIwEMIcUhgAgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCAAgQAEAhAIQCAAgQA2kBaNP8Jt7ViM onErOWsQgEAAAgEIBCAQgEAAAgEIBCAQgEAAEAhAIACBAAQCEAhAIACBAAQCEAhAIAAIBCAQgEAA AgEIBCAQgEAAAgEIBACBAAQCEAhAIACBAAQCEAhAIACBAAQCgEAAAgEIBCAQgECAxSyNIYitz58/ a3BwUIODgxoZGVEoFFIoFNK3b980NTWlX79+SZIyMzOVlZWlVatWae3atSooKJDH49HOnTvl8XiU ksJ3WSI4LMuyHA7Hgv6IZVmM5D8mJyf1/PlzdXZ2qrOzU8FgcMF/0+126+DBg6qqqlJFRYXS0vhe +6MP9wI/1wQSJeFwWH6/X01NTWpra9PU1FTM3isvL0/nz5/XuXPntHz5ciqIcSCy/v50L+hlV+Pj 49a1a9esdevWLXgMTV8ul8u6c+eOFYlELMwtKmNNIOa+fv1qXbp0yXI6nXEP4/+v0tJS6+PHj9RA IIk3PT1tXb161crOzk54GP995ebmWt3d3RRBIInj9/utgoKCRRXGf18ZGRmW3++niigHwk56PHf4 Yiw9PV0dHR0qLy9nD52jWAQylxUrVmhgYEAbN24kkCgsM84+JZmJiQmdPn1akUiEweBE4eL/NsrN zVVZWZlKSkpUWFioTZs2yeVyKTs7W7Ozs5qYmNDExITev3+v/v5+9fX1qb+/f8FjevPmTdXW1rIG IZDFN9gbNmyQ1+uV1+uVx+MxXlAjIyNqbGzU3bt39fPnz3n9vytXrlQwGJTT6SQQThQm/ohIamqq VVlZaXV1dUXtPT98+GCVlZXNe7n4fD6OYnGYN7GDnZ6ebtXU1FhjY2Mxed9IJGLV19fPa7kUFRUR CIEkZrAdDod15syZmIXxf7W1tfNaNqOjowSygBdHseZh7969GhgY0IMHD5Sfnx+X97xx44Z2795t PF93dzcLjMO88TvHcP/+ffX19WnXrl3xXVApKbp9+7bxfSFv3rxhwRFI7B07dkxDQ0Oqrq5O2P9Q XFysffv2Gc0zOjrKwiOQ2Hv69Kny8vIS/n8cP37caPqxsTEWHoHYa//HxPfv3xk0ArGP1atXG03/ 7z3vIBBbyM3NNZo+KyuLQSMQ+5icnDSaPicnh0EjEPsYHh42mp7L3gnEVnp6eoymLyoqYtAIxD4e PXpkNP3+/fsZtAXgcvclpL29XUeOHPnj6Z1Op8bHx7Vs2TJ7fri5o9A+ZmZmdPHiRaN5vF6vbeNg E8tmGhoaNDQ0ZPTteeHCBQaOQJLfkydPdP36daN5Tp48qc2bNzN47IMkt9evX+vw4cOanp7+43ly cnI0PDy8KK4dYx8EMRMIBHT06FGjOCTJ5/PZPg42sZJce3u7Dh06pB8/fhjNV11dndBL8tnEYhMr 5lpaWuT1evX792+j+YqLixUIBLj+ik2s5NXc3KwTJ04Yx5Gfn69nz54RB5tYyaupqUlVVVWanZ01 ms/tdqujo4P9DgJJXg8fPtSpU6cUDoeN43j58qUKCwsZRAJJTvfu3dPZs2eNf0/X7Xarq6tL27dv ZxAJJDn5fD7V1NQYx7FmzRq9evVK27ZtYxAJJDk1NDSorq7O+ChgQUGBent7tWXLFgYxxniecILU 1dXJ5/MZz7d161a9ePHC+N50sAZZMq5cuTKvOEpKStTT00McccSJwji7devWvJ7bceDAAbW2ttr6 cQbGH26eD7K0BAIBlZeXG5/nqKioUEtLizIyMhhEAklOX758kcfj0adPn4zXHG1tbcSRoEDYB4mT y5cvG8exZ88etba2Egf7IMnt7du32rFjh9G5jvz8fA0MDBj/UBxYgyw5jY2NRnGkpqaqubmZOBYB AomxmZkZPX782Gie+vr6uD9/BGxiJURvb69KS0v/ePrMzEyFQiG5XC4Gj02s5BcIBIymr6ysJA42 sezj3bt3RtObPv8DBLKkBYNBo+m5r4NAbCUUChlNv379egaNQOzD9FdJ2P8gEFsxfQQaFyMuLhzm jfUAG45tOBw2fhY6ojP2rEGWwiqdONjEAggEIBCAQAACAUAgAIEA0cIPx8UYJ1FZgwAEAhAIAAIB CAQgEIBAAAIBFiNOFMaY6V1tnFhkDQIQCEAgAIEABAKAQAACAQgEIBCAQAACAQgEIBCAQABIXO4e c1y+zhoEIBCAQAAQCEAgAIEABAIQCEAgAIEABAIQCEAgAAgEIBCAQAACAQgEIBCAQAACAQgEAIEA BAIQCEAgAIEABAIsJVH58WqHw8FIgjUIQCAACAQgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCBA fKRJkmVZjAQwh78A6vCRWJE8K+8AAAAASUVORK5CYII=") "The PNG data for a generic 200x200 \"broken image\" view.") (defun mastodon-media--process-image-response (status-plist marker image-options region-length url) "Callback function processing the url retrieve response for URL. STATUS-PLIST is the usual plist of status events as per `url-retrieve'. IMAGE-OPTIONS are the precomputed options to apply to the image. MARKER is the marker to where the response should be visible. REGION-LENGTH is the length of the region that should be replaced with the image." (when (marker-buffer marker) ; if buffer hasn't been killed (let ((url-buffer (current-buffer)) (is-error-response-p (eq :error (car status-plist)))) (let* ((data (unless is-error-response-p (goto-char (point-min)) (search-forward "\n\n") (buffer-substring (point) (point-max)))) (image (when data (apply #'create-image data (if (version< emacs-version "27.1") (when image-options 'imagemagick) nil) ; inbuilt scaling in 27.1 t image-options)))) (when mastodon-media--enable-image-caching (unless (url-is-cached url) ; cache if not already cached (url-store-in-cache url-buffer))) (with-current-buffer (marker-buffer marker) ;; Save narrowing in our buffer (let ((inhibit-read-only t)) (save-restriction (widen) (put-text-property marker (+ marker region-length) 'media-state 'loaded) (when image ;; We only set the image to display if we could load ;; it; we already have set a default image when we ;; added the tag. (put-text-property marker (+ marker region-length) 'display image)) ;; We are done with the marker; release it: (set-marker marker nil))) (kill-buffer url-buffer)))))) (defun mastodon-media--load-image-from-url (url media-type start region-length) "Take a URL and MEDIA-TYPE and load the image asynchronously. MEDIA-TYPE is a symbol and either `avatar' or `media-link'. START is the position where we start loading the image. REGION-LENGTH is the range from start to propertize." (let ((image-options (when (or (image-type-available-p 'imagemagick) (image-transforms-p)) ; inbuilt scaling in 27.1 (cond ((eq media-type 'avatar) `(:height ,mastodon-media--avatar-height)) ((eq media-type 'media-link) `(:max-height ,mastodon-media--preview-max-height)))))) (let ((buffer (current-buffer)) (marker (copy-marker start)) (url-show-status nil)) ; stop url.el from spamming us about connecting (condition-case nil ;; catch any errors in url-retrieve so as to not abort ;; whatever called us (if (and mastodon-media--enable-image-caching (url-is-cached url)) ;; if image url is cached, decompress and use it (with-current-buffer (url-fetch-from-cache url) (set-buffer-multibyte nil) (goto-char (point-min)) (zlib-decompress-region (goto-char (search-forward "\n\n")) (point-max)) (mastodon-media--process-image-response nil marker image-options region-length url)) ;; else fetch as usual and process-image-response will cache it (url-retrieve url #'mastodon-media--process-image-response (list marker image-options region-length url))) (error (with-current-buffer buffer ;; TODO: Consider adding retries (put-text-property marker (+ marker region-length) 'media-state 'loading-failed) :loading-failed)))))) (defun mastodon-media--select-next-media-line (end-pos) "Find coordinates of the next media to load before END-POS. Returns the list of (`start' . `end', `media-symbol') points of that line and string found or nil no more media links were found." (let ((next-pos (point))) (while (and (setq next-pos (next-single-property-change next-pos 'media-state)) (or (not (eq 'needs-loading (get-text-property next-pos 'media-state))) (null (get-text-property next-pos 'media-url)) (null (get-text-property next-pos 'media-type)))) ;; do nothing - the loop will proceed ) (when (and next-pos (< next-pos end-pos)) (let ((media-type (get-text-property next-pos 'media-type))) (cond ((eq media-type 'avatar) ; avatars are one character (list next-pos (+ next-pos 1) 'avatar)) ((eq media-type 'media-link) ; media links are 5 characters: [img] (list next-pos (+ next-pos 5) 'media-link))))))) (defun mastodon-media--valid-link-p (link) "Check if LINK is valid. Checks to make sure the missing string has not been returned." (and link (> (length link) 8) (or (string= "http://" (substring link 0 7)) (string= "https://" (substring link 0 8))))) (defun mastodon-media--inline-images (search-start search-end) "Find all `Media_Links:' in the range from SEARCH-START to SEARCH-END. Replace them with the referenced image." (save-excursion (goto-char search-start) (let (line-details) (while (setq line-details (mastodon-media--select-next-media-line search-end)) (let* ((start (car line-details)) (end (cadr line-details)) (media-type (cadr (cdr line-details))) (type (get-text-property start 'mastodon-media-type)) (image-url (get-text-property start 'media-url))) (if (not (mastodon-media--valid-link-p image-url)) ;; mark it at least as not needing loading any more (put-text-property start end 'media-state 'invalid-url) ;; proceed to load this image asynchronously (put-text-property start end 'media-state 'loading) (mastodon-media--load-image-from-url image-url media-type start (- end start)) (when (or (equal type "gifv") (equal type "video")) (mastodon-media--moving-image-overlay start end)))))))) ;; (defvar-local mastodon-media--overlays nil ;; "Holds a list of overlays in the buffer.") (defun mastodon-media--moving-image-overlay (start end) "Add play symbol overlay to moving image media items." (let ((ov (make-overlay start end))) (overlay-put ov 'after-string (propertize "" 'help-echo "Video" 'face '((:height 3.5 :inherit font-lock-comment-face)))))) ;; (cl-pushnew ov mastodon-media--overlays))) (defun mastodon-media--get-avatar-rendering (avatar-url) "Return the string to be written that renders the avatar at AVATAR-URL." ;; We use just an empty space as the textual representation. ;; This is what a user will see on a non-graphical display ;; where not showing an avatar at all is preferable. (let ((image-options (when (or (image-type-available-p 'imagemagick) (image-transforms-p)) ; inbuilt scaling in 27.1 `(:height ,mastodon-media--avatar-height)))) (concat (propertize " " 'media-url avatar-url 'media-state 'needs-loading 'media-type 'avatar 'display (apply #'create-image mastodon-media--generic-avatar-data (if (version< emacs-version "27.1") (when image-options 'imagemagick) nil) ; inbuilt scaling in 27.1 t image-options)) " "))) (defun mastodon-media--get-media-link-rendering (media-url &optional full-remote-url type caption) "Return the string to be written that renders the image at MEDIA-URL. FULL-REMOTE-URL is used for `shr-browse-image'. TYPE is the attachment's type field on the server. CAPTION is the image caption if provided." (let* ((help-echo-base "RET/i: load full image (prefix: copy URL), +/-: zoom,\ r: rotate, o: save preview") (help-echo (if caption (concat help-echo-base "\n\"" caption "\"") help-echo-base))) (concat (mastodon-tl--propertize-img-str-or-url "[img]" media-url full-remote-url type help-echo (create-image mastodon-media--generic-broken-image-data nil t)) " "))) (provide 'mastodon-media) ;;; mastodon-media.el ends here mastodon.el/lisp/mastodon-notifications.el000066400000000000000000000322431452000115200212570ustar00rootroot00000000000000;;; mastodon-notifications.el --- Notification functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-notification.el provides notification functions for Mastodon. ;;; Code: (require 'mastodon) (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--get-params-async-json "mastodon-http") (autoload 'mastodon-http--post "mastodon-http") (autoload 'mastodon-http--triage "mastodon-http") (autoload 'mastodon-media--inline-images "mastodon-media") (autoload 'mastodon-tl--byline "mastodon-tl") (autoload 'mastodon-tl--byline-author "mastodon-tl") (autoload 'mastodon-tl--clean-tabs-and-nl "mastodon-tl") (autoload 'mastodon-tl--content "mastodon-tl") (autoload 'mastodon-tl--field "mastodon-tl") (autoload 'mastodon-tl--find-property-range "mastodon-tl") (autoload 'mastodon-tl--has-spoiler "mastodon-tl") (autoload 'mastodon-tl--init "mastodon-tl") (autoload 'mastodon-tl--insert-status "mastodon-tl") (autoload 'mastodon-tl--property "mastodon-tl") (autoload 'mastodon-tl--reload-timeline-or-profile "mastodon-tl") (autoload 'mastodon-tl--spoiler "mastodon-tl") (autoload 'mastodon-tl--item-id "mastodon-tl") (autoload 'mastodon-tl--update "mastodon-tl") (autoload 'mastodon-views--view-follow-requests "mastodon-views") (defvar mastodon-tl--buffer-spec) (defvar mastodon-tl--display-media-p) (defvar mastodon-notifications--types-alist '(("follow" . mastodon-notifications--follow) ("favourite" . mastodon-notifications--favourite) ("reblog" . mastodon-notifications--reblog) ("mention" . mastodon-notifications--mention) ("poll" . mastodon-notifications--poll) ("follow_request" . mastodon-notifications--follow-request) ("status" . mastodon-notifications--status) ("update" . mastodon-notifications--edit)) "Alist of notification types and their corresponding function.") (defvar mastodon-notifications--response-alist '(("Followed" . "you") ("Favourited" . "your status from") ("Boosted" . "your status from") ("Mentioned" . "you") ("Posted a poll" . "that has now ended") ("Requested to follow" . "you") ("Posted" . "a post") ("Edited" . "a post from")) "Alist of subjects for notification types.") (defvar mastodon-notifications--map (let ((map (make-sparse-keymap))) (set-keymap-parent map mastodon-mode-map) (define-key map (kbd "a") #'mastodon-notifications--follow-request-accept) (define-key map (kbd "j") #'mastodon-notifications--follow-request-reject) (define-key map (kbd "C-k") #'mastodon-notifications--clear-current) map) "Keymap for viewing notifications.") (defun mastodon-notifications--byline-concat (message) "Add byline for TOOT with MESSAGE." (concat " " (propertize message 'face 'highlight) " " (cdr (assoc message mastodon-notifications--response-alist)))) (defun mastodon-notifications--follow-request-process (&optional reject) "Process the follow request at point. With no argument, the request is accepted. Argument REJECT means reject the request. Can be called in notifications view or in follow-requests view." (if (not (mastodon-tl--find-property-range 'item-json (point))) (message "No follow request at point?") (let* ((item-json (mastodon-tl--property 'item-json)) (f-reqs-view-p (string= "follow_requests" (plist-get mastodon-tl--buffer-spec 'endpoint))) (f-req-p (or (string= "follow_request" (alist-get 'type item-json)) ;notifs f-reqs-view-p))) (if (not f-req-p) (message "No follow request at point?") (let-alist (or (alist-get 'account item-json) ;notifs item-json) ;f-reqs (if .id (let ((response (mastodon-http--post (concat (mastodon-http--api "follow_requests") (format "/%s/%s" .id (if reject "reject" "authorize")))))) (mastodon-http--triage response (lambda (_) (if f-reqs-view-p (mastodon-views--view-follow-requests) (mastodon-tl--reload-timeline-or-profile)) (message "Follow request of %s (@%s) %s!" .username .acct (if reject "rejected" "accepted"))))) (message "No account result at point?"))))))) (defun mastodon-notifications--follow-request-accept () "Accept a follow request. Can be called in notifications view or in follow-requests view." (interactive) (mastodon-notifications--follow-request-process)) (defun mastodon-notifications--follow-request-reject () "Reject a follow request. Can be called in notifications view or in follow-requests view." (interactive) (mastodon-notifications--follow-request-process :reject)) (defun mastodon-notifications--mention (note) "Format for a `mention' NOTE." (mastodon-notifications--format-note note 'mention)) (defun mastodon-notifications--follow (note) "Format for a `follow' NOTE." (mastodon-notifications--format-note note 'follow)) (defun mastodon-notifications--follow-request (note) "Format for a `follow-request' NOTE." (mastodon-notifications--format-note note 'follow-request)) (defun mastodon-notifications--favourite (note) "Format for a `favourite' NOTE." (mastodon-notifications--format-note note 'favourite)) (defun mastodon-notifications--reblog (note) "Format for a `boost' NOTE." (mastodon-notifications--format-note note 'boost)) (defun mastodon-notifications--status (note) "Format for a `status' NOTE. Status notifications are given when `mastodon-tl--enable-notify-user-posts' has been set." (mastodon-notifications--format-note note 'status)) (defun mastodon-notifications--poll (note) "Format for a `poll' NOTE." (mastodon-notifications--format-note note 'poll)) (defun mastodon-notifications--edit (note) "Format for an `edit' NOTE." (mastodon-notifications--format-note note 'edit)) (defun mastodon-notifications--format-note (note type) "Format for a NOTE of TYPE." (let ((id (alist-get 'id note)) (status (mastodon-tl--field 'status note)) (follower (alist-get 'username (alist-get 'account note)))) (mastodon-notifications--insert-status ;; toot (cond ((or (equal type 'follow) (equal type 'follow-request)) ;; Using reblog with an empty id will mark this as something ;; non-boostable/non-favable. (cons '(reblog (id . nil)) note)) ;; reblogs/faves use 'note' to process their own json ;; not the toot's. this ensures following etc. work on such notifs ((or (equal type 'favourite) (equal type 'boost)) note) (t status)) ;; body (if (or (equal type 'follow) (equal type 'follow-request)) (propertize (if (equal type 'follow) "Congratulations, you have a new follower!" (format "You have a follow request from... %s" follower)) 'face 'default) (mastodon-tl--clean-tabs-and-nl (if (mastodon-tl--has-spoiler status) (mastodon-tl--spoiler status) (mastodon-tl--content status)))) ;; author-byline (if (or (equal type 'follow) (equal type 'follow-request) (equal type 'mention)) 'mastodon-tl--byline-author (lambda (_status) (mastodon-tl--byline-author note))) ;; action-byline (lambda (_status) (mastodon-notifications--byline-concat (cond ((equal type 'boost) "Boosted") ((equal type 'favourite) "Favourited") ((equal type 'follow-request) "Requested to follow") ((equal type 'follow) "Followed") ((equal type 'mention) "Mentioned") ((equal type 'status) "Posted") ((equal type 'poll) "Posted a poll") ((equal type 'edit) "Edited")))) id ;; base toot (when (or (equal type 'favourite) (equal type 'boost)) status)))) (defun mastodon-notifications--insert-status (toot body author-byline action-byline id &optional base-toot) "Display the content and byline of timeline element TOOT. BODY will form the section of the toot above the byline. AUTHOR-BYLINE is an optional function for adding the author portion of the byline that takes one variable. By default it is `mastodon-tl--byline-author'. ACTION-BYLINE is also an optional function for adding an action, such as boosting favouriting and following to the byline. It also takes a single function. By default it is `mastodon-tl--byline-boosted'. ID is the notification's own id, which is attached as a property. If the status is a favourite or a boost, BASE-TOOT is the JSON of the toot responded to." (when toot ; handle rare blank notif server bug (mastodon-tl--insert-status toot body author-byline action-byline id base-toot))) (defun mastodon-notifications--by-type (note) "Filters NOTE for those listed in `mastodon-notifications--types-alist'." (let* ((type (mastodon-tl--field 'type note)) (fun (cdr (assoc type mastodon-notifications--types-alist))) (start-pos (point))) (when fun (funcall fun note) (when mastodon-tl--display-media-p (mastodon-media--inline-images start-pos (point)))))) (defun mastodon-notifications--timeline (json) "Format JSON in Emacs buffer." (if (seq-empty-p json) (message "Looks like you have no (more) notifications for the moment.") (mapc #'mastodon-notifications--by-type json) (goto-char (point-min)))) (defun mastodon-notifications--get-mentions () "Display mention notifications in buffer." (interactive) (mastodon-notifications-get "mention" "mentions")) (defun mastodon-notifications--get-favourites () "Display favourite notifications in buffer." (interactive) (mastodon-notifications-get "favourite" "favourites")) (defun mastodon-notifications--get-boosts () "Display boost notifications in buffer." (interactive) (mastodon-notifications-get "reblog" "boosts")) (defun mastodon-notifications--get-polls () "Display poll notifications in buffer." (interactive) (mastodon-notifications-get "poll" "polls")) (defun mastodon-notifications--get-statuses () "Display status notifications in buffer. Status notifications are created when you call `mastodon-tl--enable-notify-user-posts'." (interactive) (mastodon-notifications-get "status" "statuses")) (defun mastodon-notifications--filter-types-list (type) "Return a list of notification types with TYPE removed." (let ((types (mapcar #'car mastodon-notifications--types-alist))) (remove type types))) (defun mastodon-notifications--clear-all () "Clear all notifications." (interactive) (when (y-or-n-p "Clear all notifications?") (let ((response (mastodon-http--post (mastodon-http--api "notifications/clear")))) (mastodon-http--triage response (lambda (_) (when mastodon-tl--buffer-spec (mastodon-tl--reload-timeline-or-profile)) (message "All notifications cleared!")))))) (defun mastodon-notifications--clear-current () "Dismiss the notification at point." (interactive) (let* ((id (or (mastodon-tl--property 'item-id) (mastodon-tl--field 'id (mastodon-tl--property 'item-json)))) (response (mastodon-http--post (mastodon-http--api (format "notifications/%s/dismiss" id))))) (mastodon-http--triage response (lambda (_) (when mastodon-tl--buffer-spec (mastodon-tl--reload-timeline-or-profile)) (message "Notification dismissed!"))))) (provide 'mastodon-notifications) ;;; mastodon-notifications.el ends here mastodon.el/lisp/mastodon-profile.el000066400000000000000000001211361452000115200200460ustar00rootroot00000000000000;;; mastodon-profile.el --- Functions for inspecting Mastodon profiles -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-profile.el generates a stream of users toots. ;; To add ;; - Option to follow ;; - wheather they follow you or not ;; - Show only Media ;;; Code: (require 'seq) (require 'cl-lib) (require 'persist) (require 'parse-time) (eval-when-compile (require 'mastodon-tl)) (autoload 'mastodon-auth--get-account-id "mastodon-auth") (autoload 'mastodon-auth--get-account-name "mastodon-auth.el") (autoload 'mastodon-http--api "mastodon-http.el") (autoload 'mastodon-http--get-json "mastodon-http.el") (autoload 'mastodon-http--get-json-async "mastodon-http.el") (autoload 'mastodon-http--get-response "mastodon-http") (autoload 'mastodon-http--patch "mastodon-http") (autoload 'mastodon-http--patch-json "mastodon-http") (autoload 'mastodon-http--post "mastodon-http.el") (autoload 'mastodon-http--triage "mastodon-http.el") (autoload 'mastodon-media--get-media-link-rendering "mastodon-media.el") (autoload 'mastodon-media--inline-images "mastodon-media.el") (autoload 'mastodon-mode "mastodon.el") (autoload 'mastodon-notifications--follow-request-accept "mastodon-notifications") (autoload 'mastodon-notifications--follow-request-reject "mastodon-notifications") (autoload 'mastodon-search--insert-users-propertized "mastodon-search") (autoload 'mastodon-tl--as-string "mastodon-tl.el") (autoload 'mastodon-tl--buffer-type-eq "mastodon tl") (autoload 'mastodon-tl--byline-author "mastodon-tl.el") (autoload 'mastodon-tl--find-property-range "mastodon-tl.el") (autoload 'mastodon-tl--get-link-header-from-response "mastodon-tl") (autoload 'mastodon-tl--init "mastodon-tl.el") (autoload 'mastodon-tl--user-handles-get "mastodon-tl") (autoload 'mastodon-tl--map-alist "mastodon-tl") (autoload 'mastodon-tl--map-alist-vals-to-alist "mastodon-tl") (autoload 'mastodon-tl--profile-buffer-p "mastodon tl") (autoload 'mastodon-tl--property "mastodon-tl.el") (autoload 'mastodon-tl--render-text "mastodon-tl.el") (autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") (autoload 'mastodon-tl--set-face "mastodon-tl.el") (autoload 'mastodon-tl--symbol "mastodon-tl") (autoload 'mastodon-tl--timeline "mastodon-tl.el") (autoload 'mastodon-tl--toot "mastodon-tl") (autoload 'mastodon-tl--item-id "mastodon-tl") (autoload 'mastodon-toot--count-toot-chars "mastodon-toot") (autoload 'mastodon-toot--get-max-toot-chars "mastodon-toot") (autoload 'mastodon-views--add-account-to-list "mastodon-views") (autoload 'mastodon-return-credential-account "mastodon") (autoload 'mastodon-tl--buffer-property "mastodon-tl") (autoload 'mastodon-search--query "mastodon-search") (defvar mastodon-tl--horiz-bar) (defvar mastodon-tl--update-point) (defvar mastodon-toot--max-toot-chars) (defvar mastodon-toot--visibility) (defvar mastodon-toot--content-nsfw) (defvar mastodon-tl--timeline-posts-count) (defvar-local mastodon-profile--account nil "The data for the account being described in the current profile buffer.") (defvar mastodon-profile-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-c") #'mastodon-profile--account-view-cycle) (define-key map (kbd "C-c C-s") #'mastodon-profile--account-search) map) "Keymap for `mastodon-profile-mode'.") (define-minor-mode mastodon-profile-mode "Toggle mastodon profile minor mode. This minor mode is used for mastodon profile pages and adds a couple of extra keybindings." :init-value nil :lighter " Profile" :keymap mastodon-profile-mode-map :group 'mastodon :global nil) (defvar mastodon-profile-credential-account nil "Holds the JSON data of the CredentialAccount entity. It contains details of the current user's account.") (defvar mastodon-profile-acccount-preferences-data nil "Holds the JSON data of the current user's preferences.") (defvar mastodon-profile-update-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-c") #'mastodon-profile--user-profile-send-updated) (define-key map (kbd "C-c C-k") #'mastodon-profile--update-profile-note-cancel) map) "Keymap for `mastodon-profile-update-mode'.") (persist-defvar mastodon-profile-account-settings nil "An alist of account settings saved from the server. Other clients can change these settings on the server at any time, so this list is not the canonical source for settings. It is updated on entering mastodon mode and on toggle any setting it contains") (define-minor-mode mastodon-profile-update-mode "Minor mode to update Mastodon user profile." :group 'mastodon-profile :keymap mastodon-profile-update-mode-map :global nil) (defun mastodon-profile--item-json () "Get the next item-json." (mastodon-tl--property 'item-json)) (defun mastodon-profile--make-author-buffer (account &optional no-reblogs) "Take an ACCOUNT json and insert a user account into a new buffer. NO-REBLOGS means do not display boosts in statuses." (mastodon-profile--make-profile-buffer-for account "statuses" #'mastodon-tl--timeline no-reblogs)) ;; TODO: we shd just load all views' data then switch coz this is slow af: (defun mastodon-profile--account-view-cycle () "Cycle through profile view: toots, toot sans boosts, followers, and following." (interactive) (cond ((mastodon-tl--buffer-type-eq 'profile-statuses) (mastodon-profile--open-statuses-no-reblogs)) ((mastodon-tl--buffer-type-eq 'profile-statuses-no-boosts) (mastodon-profile--open-followers)) ((mastodon-tl--buffer-type-eq 'profile-followers) (mastodon-profile--open-following)) ((mastodon-tl--buffer-type-eq 'profile-following) (mastodon-profile--make-author-buffer mastodon-profile--account)))) (defun mastodon-profile--open-statuses-no-reblogs () "Open a profile buffer showing statuses without reblogs." (interactive) (if mastodon-profile--account (mastodon-profile--make-author-buffer mastodon-profile--account :no-reblogs) (user-error "Not in a mastodon profile"))) (defun mastodon-profile--open-following () "Open a profile buffer showing the accounts that current profile follows." (interactive) (if mastodon-profile--account (mastodon-profile--make-profile-buffer-for mastodon-profile--account "following" #'mastodon-profile--format-user nil :headers) (user-error "Not in a mastodon profile"))) (defun mastodon-profile--open-followers () "Open a profile buffer showing the accounts following the current profile." (interactive) (if mastodon-profile--account (mastodon-profile--make-profile-buffer-for mastodon-profile--account "followers" #'mastodon-profile--format-user nil :headers) (user-error "Not in a mastodon profile"))) (defun mastodon-profile--view-favourites () "Open a new buffer displaying the user's favourites." (interactive) (message "Loading your favourited toots...") (mastodon-tl--init "favourites" "favourites" 'mastodon-tl--timeline :headers)) (defun mastodon-profile--view-bookmarks () "Open a new buffer displaying the user's bookmarks." (interactive) (message "Loading your bookmarked toots...") (mastodon-tl--init "bookmarks" "bookmarks" 'mastodon-tl--timeline :headers)) (defun mastodon-profile--add-account-to-list () "Add account of current profile buffer to a list." (interactive) (when mastodon-profile--account (let* ((profile mastodon-profile--account) (id (alist-get 'id profile)) (handle (alist-get 'acct profile))) (mastodon-views--add-account-to-list nil id handle)))) (defun mastodon-profile--account-search (query) "Run a statuses search QUERY for the currently viewed account." (interactive "sSearch account for: ") (let* ((ep (mastodon-tl--buffer-property 'endpoint)) (id (nth 1 (split-string ep "/")))) (mastodon-search--query query "statuses" nil nil id))) ;;; ACCOUNT PREFERENCES (defun mastodon-profile--get-json-value (val) "Fetch current VAL ue from account." (let* ((response (mastodon-return-credential-account))) (if (eq (alist-get val response) :json-false) nil (alist-get val response)))) (defun mastodon-profile--get-source-values () "Return the \"source\" preferences from the server." (mastodon-profile--get-json-value 'source)) (defun mastodon-profile--get-source-value (pref) "Return account PREF erence from the \"source\" section on the server." (let ((source (mastodon-profile--get-source-values))) (if (eq (alist-get pref source) :json-false) nil (alist-get pref source)))) (defun mastodon-profile--update-user-profile-note () "Fetch user's profile note and display for editing." (interactive) (let* ((json (mastodon-return-credential-account)) (source (alist-get 'source json)) (note (alist-get 'note source)) (buffer (get-buffer-create "*mastodon-update-profile*")) (inhibit-read-only t) (msg-str (substitute-command-keys "Edit your profile note. \\`C-c C-c' to send, \\`C-c C-k' to cancel."))) (switch-to-buffer-other-window buffer) (text-mode) (mastodon-tl--set-buffer-spec (buffer-name buffer) "accounts/verify_credentials" nil) (setq-local header-line-format msg-str) (mastodon-profile-update-mode t) (insert (propertize (concat (propertize "0" 'note-counter t 'display nil) "/500 characters") 'read-only t 'face 'font-lock-comment-face 'note-header t) "\n") (make-local-variable 'after-change-functions) (cl-pushnew #'mastodon-profile--update-note-count after-change-functions) (let ((start-point (point))) (insert note) (goto-char start-point)) (delete-trailing-whitespace) ; remove all ^M's (message msg-str))) (defun mastodon-profile--update-note-count (&rest _args) "Display the character count of the profile note buffer." (let* ((inhibit-read-only t) (header-region (mastodon-tl--find-property-range 'note-header (point-min))) (count-region (mastodon-tl--find-property-range 'note-counter (point-min))) (count (number-to-string (mastodon-toot--count-toot-chars (buffer-substring-no-properties (cdr header-region) (point-max)))))) (add-text-properties (car count-region) (cdr count-region) (list 'display count)))) (defun mastodon-profile--update-profile-note-cancel () "Cancel updating user profile and kill buffer and window." (interactive) (when (y-or-n-p "Cancel updating your profile note?") (kill-buffer-and-window))) (defun mastodon-profile--note-remove-header () "Get the body of a toot from the current compose buffer." (let ((header-region (mastodon-tl--find-property-range 'note-header (point-min)))) (buffer-substring (cdr header-region) (point-max)))) (defun mastodon-profile--user-profile-send-updated () "Send PATCH request with the updated profile note. Ask for confirmation if length > 500 characters." (interactive) (let* ((note (mastodon-profile--note-remove-header)) (url (mastodon-http--api "accounts/update_credentials"))) (if (> (mastodon-toot--count-toot-chars note) 500) (when (y-or-n-p "Note is over mastodon's max for profile notes (500). Proceed?") (kill-buffer-and-window) (mastodon-profile--user-profile-send-updated-do url note)) (kill-buffer-and-window) (mastodon-profile--user-profile-send-updated-do url note)))) (defun mastodon-profile--user-profile-send-updated-do (url note) "Send PATCH request with the updated profile NOTE to URL." (let ((response (mastodon-http--patch url `(("note" . ,note))))) (mastodon-http--triage response (lambda (_) (message "Profile note updated!"))))) (defun mastodon-profile--update-preference (pref val &optional source) "Update account PREF erence to setting VAL. Both args are strings. SOURCE means that the preference is in the `source' part of the account JSON." (let* ((url (mastodon-http--api "accounts/update_credentials")) (pref-formatted (if source (concat "source[" pref "]") pref)) (response (mastodon-http--patch url `((,pref-formatted . ,val))))) (mastodon-http--triage response (lambda (_) (mastodon-profile--fetch-server-account-settings) (message "Account setting %s updated to %s!" pref val))))) (defun mastodon-profile--get-pref (pref) "Return PREF from `mastodon-profile-account-settings'." (plist-get mastodon-profile-account-settings pref)) (defun mastodon-profile--update-preference-plist (pref val) "Set local account preference plist preference PREF to VAL. This is done after changing the setting on the server." (setq mastodon-profile-account-settings (plist-put mastodon-profile-account-settings pref val))) ;; used in toot.el (defun mastodon-profile--fetch-server-account-settings-maybe () "Fetch account settings from the server. Only do so if `mastodon-profile-account-settings' is nil." (mastodon-profile--fetch-server-account-settings :no-force)) (defun mastodon-profile--fetch-server-account-settings (&optional no-force) "Fetch basic account settings from the server. Store the values in `mastodon-profile-account-settings'. Run in `mastodon-mode-hook'. If NO-FORCE, only fetch if `mastodon-profile-account-settings' is nil." (unless (and no-force mastodon-profile-account-settings) (let ((keys '(locked discoverable display_name bot)) (source-keys '(privacy sensitive language))) (mapc (lambda (k) (mastodon-profile--update-preference-plist k (mastodon-profile--get-json-value k))) keys) (mapc (lambda (sk) (mastodon-profile--update-preference-plist sk (mastodon-profile--get-source-value sk))) source-keys) ;; hack for max toot chars: (mastodon-toot--get-max-toot-chars :no-toot) (mastodon-profile--update-preference-plist 'max_toot_chars mastodon-toot--max-toot-chars) ;; TODO: remove now redundant vars, replace with fetchers from the plist (setq mastodon-toot--visibility (mastodon-profile--get-pref 'privacy) mastodon-toot--content-nsfw (mastodon-profile--get-pref 'sensitive)) mastodon-profile-account-settings))) (defun mastodon-profile--account-locked-toggle () "Toggle the locked status of your account. Locked means follow requests have to be approved." (interactive) (mastodon-profile--toggle-account-key 'locked)) (defun mastodon-profile--account-discoverable-toggle () "Toggle the discoverable status of your account. Discoverable means the account is listed in the server directory." (interactive) (mastodon-profile--toggle-account-key 'discoverable)) (defun mastodon-profile--account-bot-toggle () "Toggle the bot status of your account." (interactive) (mastodon-profile--toggle-account-key 'bot)) (defun mastodon-profile--account-sensitive-toggle () "Toggle the sensitive status of your account. When enabled, statuses are marked as sensitive by default." (interactive) (mastodon-profile--toggle-account-key 'sensitive :source)) (defun mastodon-profile--toggle-account-key (key &optional source) "Toggle the boolean account setting KEY. SOURCE means the setting is located under \"source\" in the account JSON. Current settings are fetched from the server." (let* ((val (if source (mastodon-profile--get-source-value key) (mastodon-profile--get-json-value key))) (prompt (format "Account setting %s is %s. Toggle?" key val))) (when (y-or-n-p prompt) (mastodon-profile--update-preference (symbol-name key) (if val "false" "true") source)))) (defun mastodon-profile--edit-string-value (key) "Edit the string for account preference KEY." (let* ((val (mastodon-profile--get-json-value key)) (new-val (read-string (format "Edit account setting %s: " key) val))) (mastodon-profile--update-preference (symbol-name key) new-val))) (defun mastodon-profile--update-display-name () "Update display name for your account." (interactive) (mastodon-profile--edit-string-value 'display_name)) (defun mastodon-profile--make-meta-fields-params (fields) "Construct a parameter query string from metadata alist FIELDS. Returns an alist." (let ((keys (cl-loop for count from 1 to 5 collect (cons (format "fields_attributes[%s][name]" count) (format "fields_attributes[%s][value]" count))))) (cl-loop for a-pair in keys for b-pair in fields append (list (cons (car a-pair) (car b-pair)) (cons (cdr a-pair) (cdr b-pair)))))) (defun mastodon-profile--update-meta-fields () "Prompt for new metadata fields information and PATCH the server." (interactive) (let* ((url (mastodon-http--api "accounts/update_credentials")) (fields-updated (mastodon-profile--update-meta-fields-alist)) (params (mastodon-profile--make-meta-fields-params fields-updated)) (response (mastodon-http--patch url params))) (mastodon-http--triage response (lambda (_) (mastodon-profile--fetch-server-account-settings) (message "Metadata fields updated to %s!" fields-updated))))) (defun mastodon-profile--update-meta-fields-alist () "Prompt for new metadata fields information. Returns the results as an alist." (let ((fields-old (mastodon-profile--fields-get nil ;; we must fetch the plaintext version: (mastodon-profile--get-source-value 'fields)))) ;; offer empty fields if user currently has less than four filled: (while (< (length fields-old) 4) (setq fields-old (append fields-old '(("" . ""))))) (let* ((f-str "Metadata %s [%s/4] (max. 255 chars): ") (alist (cl-loop for f in fields-old for x from 1 to 5 collect (cons (read-string (format f-str "key" x) (car f)) (read-string (format f-str "value" x) (cdr f)))))) (mapcar (lambda (x) (cons (mastodon-profile--limit-to-255 (car x)) (mastodon-profile--limit-to-255 (cdr x)))) alist)))) (defun mastodon-profile--limit-to-255 (x) "Limit string X to 255 chars max." (if (> (length x) 255) (substring x 0 255) x)) ;; used in tl.el (defun mastodon-profile--get-preferences-pref (pref) "Fetch PREF from the endpoint \"/preferences\". If `mastodon-profile-acccount-preferences-data' is set, fetch from that instead. The endpoint only holds a few preferences. For others, see `mastodon-profile--update-preference' and its endpoint, \"/accounts/update_credentials.\"" (alist-get pref (or mastodon-profile-acccount-preferences-data (setq mastodon-profile-acccount-preferences-data (mastodon-http--get-json (mastodon-http--api "preferences")))))) (defun mastodon-profile--view-preferences () "View user preferences in another window." (interactive) (let* ((url (mastodon-http--api "preferences")) (response (mastodon-http--get-json url)) (buf (get-buffer-create "*mastodon-preferences*"))) (with-mastodon-buffer buf #'special-mode :other-window (mastodon-tl--set-buffer-spec (buffer-name buf) "preferences" nil) (while response (let ((el (pop response))) (insert (format "%-30s %s" (prin1-to-string (car el)) (prin1-to-string (cdr el))) "\n\n"))) (goto-char (point-min))))) ;;; PROFILE VIEW DETAILS (defun mastodon-profile--relationships-get (id) "Fetch info about logged-in user's relationship to user with id ID." (let* ((their-id id) (args `(("id[]" . ,their-id))) (url (mastodon-http--api "accounts/relationships"))) (car (mastodon-http--get-json url args)))) ; API takes array, just get 1st (defun mastodon-profile--fields-get (&optional account fields) "Fetch the fields vector (aka profile metadata) from profile of ACCOUNT. Returns an alist. FIELDS means provide a fields vector fetched by other means." (let ((fields (or fields (alist-get 'fields account)))) (when fields (mastodon-tl--map-alist-vals-to-alist 'name 'value fields)))) (defun mastodon-profile--fields-insert (fields) "Format and insert field pairs (a.k.a profile metadata) in FIELDS." (let* ((car-fields (mapcar #'car fields)) (left-width (cl-reduce #'max (mapcar #'length car-fields)))) (mapconcat (lambda (field) (mastodon-tl--render-text (concat (format "_ %s " (car field)) (make-string (- (+ 1 left-width) (length (car field))) ?_) (format " :: %s" (cdr field))) field)) ; hack to make links tabstops fields ""))) (defun mastodon-profile--get-statuses-pinned (account) "Fetch the pinned toots for ACCOUNT." (let* ((id (alist-get 'id account)) (args `(("pinned" . "true"))) (url (mastodon-http--api (format "accounts/%s/statuses" id)))) (mastodon-http--get-json url args))) (defun mastodon-profile--insert-statuses-pinned (pinned-statuses) "Insert each of the PINNED-STATUSES for a given account." (mapc (lambda (pinned-status) (insert (mastodon-tl--set-face " :pinned: " 'success)) (mastodon-tl--toot pinned-status)) pinned-statuses)) (defun mastodon-profile--follows-p (list) "T if you have any relationship with the accounts in LIST." (let (result) (dolist (x list result) (when (not (equal :json-false x)) (setq result x))))) (defun mastodon-profile--make-profile-buffer-for (account endpoint-type update-function &optional no-reblogs headers) "Display profile of ACCOUNT, using ENDPOINT-TYPE and UPDATE-FUNCTION. NO-REBLOGS means do not display boosts in statuses. HEADERS means also fetch link headers for pagination." (let-alist account (let* ((args `(("limit" . ,mastodon-tl--timeline-posts-count))) (args (if no-reblogs (push '("exclude_reblogs" . "t") args) args)) (endpoint (format "accounts/%s/%s" .id endpoint-type)) (url (mastodon-http--api endpoint)) (buffer (concat "*mastodon-" .acct "-" (if no-reblogs (concat endpoint-type "-no-boosts") endpoint-type) "*")) (response (if headers (mastodon-http--get-response url args) (mastodon-http--get-json url args))) (json (if headers (car response) response)) (link-header (when headers (mastodon-tl--get-link-header-from-response (cdr response)))) (fields (mastodon-profile--fields-get account)) (pinned (mastodon-profile--get-statuses-pinned account)) (relationships (mastodon-profile--relationships-get .id))) (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-profile-mode) (remove-overlays) (setq mastodon-profile--account account) (mastodon-tl--set-buffer-spec buffer endpoint update-function link-header args) (let* ((inhibit-read-only t) (is-statuses (string= endpoint-type "statuses")) (is-followers (string= endpoint-type "followers")) (is-following (string= endpoint-type "following")) (endpoint-name (cond (is-statuses (if no-reblogs " TOOTS (no boosts)" " TOOTS ")) (is-followers " FOLLOWERS ") (is-following " FOLLOWING ")))) (insert (propertize (concat "\n" (mastodon-profile--image-from-account account 'avatar_static) (mastodon-profile--image-from-account account 'header_static) "\n" (propertize .display_name 'face 'mastodon-display-name-face) "\n" (propertize (concat "@" .acct) 'face 'default) (if (equal .locked t) (concat " " (mastodon-tl--symbol 'locked)) "") "\n " mastodon-tl--horiz-bar "\n" ;; profile note: (mastodon-tl--render-text .note account) ; account = tab-stops in profile ;; meta fields: (if fields (concat "\n" (mastodon-tl--set-face (mastodon-profile--fields-insert fields) 'success)) "") "\n" ;; Joined date: (propertize (mastodon-profile--format-joined-date-string .created_at) 'face 'success) "\n\n") 'profile-json account) ;; insert counts (mastodon-tl--set-face (concat " " mastodon-tl--horiz-bar "\n" " TOOTS: " (mastodon-tl--as-string .statuses_count) " | " "FOLLOWERS: " (mastodon-tl--as-string .followers_count) " | " "FOLLOWING: " (mastodon-tl--as-string .following_count) "\n" " " mastodon-tl--horiz-bar "\n\n") 'success) ;; insert relationship (follows) (let-alist relationships (let ((followsp (mastodon-profile--follows-p (list .requested_by .following .followed_by)))) (if followsp (mastodon-tl--set-face (concat (when (equal .following 't) " | FOLLOWED BY YOU") (when (equal .followed_by 't) " | FOLLOWS YOU") (when (equal .requested_by 't) " | REQUESTED TO FOLLOW YOU") "\n\n") 'success) ""))) ; for insert call ;; insert endpoint (mastodon-tl--set-face (concat " " mastodon-tl--horiz-bar "\n" endpoint-name "\n" " " mastodon-tl--horiz-bar "\n") 'success)) (setq mastodon-tl--update-point (point)) (mastodon-media--inline-images (point-min) (point)) ;; insert pinned toots first (when (and pinned (equal endpoint-type "statuses")) (mastodon-profile--insert-statuses-pinned pinned) (setq mastodon-tl--update-point (point))) ; updates after pinned toots (funcall update-function json))) (goto-char (point-min)) (message (substitute-command-keys ;; "\\[mastodon-profile--account-view-cycle]" ; not always bound? "\\`C-c C-c' to cycle profile views: toots, followers, following. \\`C-c C-s' to search user's toots."))))) (defun mastodon-profile--format-joined-date-string (joined) "Format a human-readable Joined string from timestamp JOINED. JOINED is the `created_at' field in profile account JSON, and of the format \"2000-01-31T00:00:00.000Z\"." (format-time-string "Joined: %d %B %Y" (parse-iso8601-time-string joined))) (defun mastodon-profile--get-toot-author () "Open profile of author of toot under point. If toot is a boost, opens the profile of the booster." (interactive) (mastodon-profile--make-author-buffer (alist-get 'account (mastodon-profile--item-json)))) (defun mastodon-profile--image-from-account (account img-type) "Return a avatar image from ACCOUNT. IMG-TYPE is the JSON key from the account data." (let ((img (alist-get img-type account))) (unless (equal img "/avatars/original/missing.png") (mastodon-media--get-media-link-rendering img)))) (defun mastodon-profile--show-user (user-handle) "Query for USER-HANDLE from current status and show that user's profile." (interactive (list (if (and (not (mastodon-tl--profile-buffer-p)) (not (mastodon-tl--property 'item-json :no-move))) (message "Looks like there's no toot or user at point?") (let ((user-handles (mastodon-profile--extract-users-handles (mastodon-profile--item-json)))) (completing-read "View profile of user [choose or enter any handle]: " user-handles nil ; predicate 'confirm))))) (if (not (or ; own profile has no need for item-json test: (equal user-handle (mastodon-auth--get-account-name)) (mastodon-tl--profile-buffer-p) (mastodon-tl--property 'item-json :no-move))) (message "Looks like there's no toot or user at point?") (let ((account (mastodon-profile--lookup-account-in-status user-handle (mastodon-profile--item-json)))) (if account (progn (message "Loading profile of user %s..." user-handle) (mastodon-profile--make-author-buffer account)) (message "Cannot find a user with handle %S" user-handle))))) (defun mastodon-profile--my-profile () "Show the profile of the currently signed in user." (interactive) (message "Loading your profile...") (mastodon-profile--show-user (mastodon-auth--get-account-name))) (defun mastodon-profile--format-user (tootv) "Convert TOOTV into author-bylines and insert. Also insert their profile note. Used to view a user's followers and those they're following." (let ((inhibit-read-only t)) (unless (seq-empty-p tootv) (mapc (lambda (toot) (let ((start-pos (point))) (insert "\n" (propertize (mastodon-tl--byline-author `((account . ,toot)) :avatar) 'byline 't 'item-id (alist-get 'id toot) 'base-item-id (mastodon-tl--item-id toot) 'item-json toot)) (mastodon-media--inline-images start-pos (point)) (insert "\n" (propertize (mastodon-tl--render-text (alist-get 'note toot) nil) 'item-json toot) "\n"))) tootv)))) (defun mastodon-profile--search-account-by-handle (handle) "Return an account based on a user's HANDLE. If the handle does not match a search return then retun NIL." (let* ((handle (if (string= "@" (substring handle 0 1)) (substring handle 1 (length handle)) handle)) (args `(("q" . ,handle))) (matching-account (seq-remove (lambda (x) (not (string= (alist-get 'acct x) handle))) (mastodon-http--get-json (mastodon-http--api "accounts/search") args)))) (when (equal 1 (length matching-account)) (elt matching-account 0)))) (defun mastodon-profile--account-from-id (user-id) "Request an account object relating to a USER-ID from Mastodon." (mastodon-http--get-json (mastodon-http--api (format "accounts/%s" user-id)))) (defun mastodon-profile--extract-users-handles (status) "Return all user handles found in STATUS. These include the author, author of reblogged entries and any user mentioned." (when status (let ((this-account (or (alist-get 'account status) ; status is a toot status)) ; status is a user listing (mentions (or (alist-get 'mentions (alist-get 'status status)) (alist-get 'mentions status))) (reblog (or (alist-get 'reblog (alist-get 'status status)) (alist-get 'reblog status)))) (seq-filter #'stringp (seq-uniq (seq-concatenate 'list (list (alist-get 'acct this-account)) (mastodon-profile--extract-users-handles reblog) (mastodon-tl--map-alist 'acct mentions))))))) (defun mastodon-profile--lookup-account-in-status (handle status) "Return account for HANDLE using hints in STATUS if possible." (let* ((this-account (alist-get 'account status)) (reblog-account (alist-get 'account (alist-get 'reblog status))) (mention-id (seq-some (lambda (mention) (when (string= handle (alist-get 'acct mention)) (alist-get 'id mention))) (alist-get 'mentions status)))) (cond ((string= handle (alist-get 'acct this-account)) this-account) ((string= handle (alist-get 'acct reblog-account)) reblog-account) (mention-id (mastodon-profile--account-from-id mention-id)) (t (mastodon-profile--search-account-by-handle handle))))) (defun mastodon-profile--remove-user-from-followers (&optional id) "Remove a user from your followers. Optionally provide the ID of the account to remove." (interactive) (let* ((account (unless id (mastodon-tl--property 'item-json :no-move))) (id (or id (alist-get 'id account))) (handle (if account (alist-get 'acct account) (let ((account (mastodon-profile--account-from-id id))) (alist-get 'acct account)))) (url (mastodon-http--api (format "accounts/%s/remove_from_followers" id)))) (when (y-or-n-p (format "Remove follower %s? " handle)) (let ((response (mastodon-http--post url))) (mastodon-http--triage response (lambda (_) (message "Follower %s removed!" handle))))))) (defun mastodon-profile--remove-from-followers-at-point () "Prompt for a user in the item at point and remove from followers." (interactive) (let* ((handles (mastodon-profile--extract-users-handles (mastodon-profile--item-json))) (handle (completing-read "Remove from followers: " handles nil)) (account (mastodon-profile--lookup-account-in-status handle (mastodon-profile--item-json))) (id (alist-get 'id account))) (mastodon-profile--remove-user-from-followers id))) (defun mastodon-profile--remove-from-followers-list () "Select a user from your followers and remove from followers. Currently limited to 100 handles. If not found, try `mastodon-search--query'." (interactive) (let* ((endpoint (format "accounts/%s/followers" (mastodon-auth--get-account-id))) (url (mastodon-http--api endpoint)) (response (mastodon-http--get-json url `(("limit" . "100")))) (handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id response)) (choice (completing-read "Remove from followers: " handles)) (id (alist-get choice handles))) (mastodon-profile--remove-user-from-followers id))) (defun mastodon-profile--add-private-note-to-account () "Add a private note to an account. Can be called from a profile page or normal timeline. Send an empty note to clear an existing one." (interactive) (mastodon-profile--add-or-view-private-note 'mastodon-profile--post-private-note-to-account "add a note to")) (defun mastodon-profile--post-private-note-to-account (id handle note-old) "POST a private note onto an account ID with user HANDLE on the server. NOTE-OLD is the text of any existing note." (let* ((note (read-string (format "Add private note to account %s: " handle) note-old)) (params `(("comment" . ,note))) (url (mastodon-http--api (format "accounts/%s/note" id))) (response (mastodon-http--post url params))) (mastodon-http--triage response (lambda (_) (message "Private note on %s added!" handle))))) (defun mastodon-profile--view-account-private-note () "Display the private note about a user." (interactive) (mastodon-profile--add-or-view-private-note 'mastodon-profile--display-private-note "view private note of" :view)) (defun mastodon-profile--display-private-note (note) "Display private NOTE in a temporary buffer." (with-output-to-temp-buffer "*mastodon-profile-private-note*" (let ((inhibit-read-only t)) (princ note)))) (defun mastodon-profile--profile-json () "Return the profile-json property if we are in a profile buffer." (when (mastodon-tl--profile-buffer-p) (save-excursion (goto-char (point-min)) (or (mastodon-tl--property 'profile-json :no-move) (error "No profile data found"))))) (defun mastodon-profile--add-or-view-private-note (action-fun &optional message view) "Add or view a private note for an account. ACTION-FUN does the adding or viewing, MESSAGE is a prompt for `mastodon-tl--user-handles-get', VIEW is a flag." (let* ((profile-json (mastodon-profile--profile-json)) (handle (if (mastodon-tl--profile-buffer-p) (alist-get 'acct profile-json) (mastodon-tl--user-handles-get message))) (account (if (mastodon-tl--profile-buffer-p) profile-json (mastodon-profile--search-account-by-handle handle))) (id (alist-get 'id account)) (relationships (mastodon-profile--relationships-get id)) (note (alist-get 'note relationships))) (if view (if (string-empty-p note) (message "No private note for %s" handle) (funcall action-fun note)) (funcall action-fun id handle note)))) (defun mastodon-profile--show-familiar-followers () "Show a list of familiar followers. Familiar followers are accounts that you follow, and that follow the given account." (interactive) (let* ((profile-json (mastodon-profile--profile-json)) (handle (if (mastodon-tl--profile-buffer-p) (alist-get 'acct profile-json) (mastodon-tl--user-handles-get "show familiar followers of"))) (account (if (mastodon-tl--profile-buffer-p) profile-json (mastodon-profile--search-account-by-handle handle))) (id (alist-get 'id account))) (mastodon-profile--get-familiar-followers id))) (defun mastodon-profile--get-familiar-followers (id) "Return JSON data of familiar followers for account ID." ;; the server handles multiple IDs, but we just handle one. (let* ((params `(("id" . ,id))) (url (mastodon-http--api "accounts/familiar_followers")) (json (mastodon-http--get-json url params)) (accounts (alist-get 'accounts (car json))) ; first id (handles (mastodon-tl--map-alist 'acct accounts))) (if (null handles) (message "Looks like there are no familiar followers for this account") (let ((choice (completing-read "Show profile of user: " handles))) (mastodon-profile--show-user choice))))) (provide 'mastodon-profile) ;;; mastodon-profile.el ends here mastodon.el/lisp/mastodon-search.el000066400000000000000000000346111452000115200176540ustar00rootroot00000000000000;;; mastodon-search.el --- Search functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Marty Hiatt ;; Author: Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; A basic search function for mastodon.el ;;; Code: (require 'json) (eval-when-compile (require 'mastodon-tl)) (autoload 'mastodon-auth--access-token "mastodon-auth") (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--get-json "mastodon-http") (autoload 'mastodon-http--get-search-json "mastodon-http") (autoload 'mastodon-mode "mastodon") (autoload 'mastodon-tl--as-string "mastodon-tl") (autoload 'mastodon-tl--as-string "mastodon-tl") (autoload 'mastodon-tl--render-text "mastodon-tl") (autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") (autoload 'mastodon-tl--set-face "mastodon-tl") (autoload 'mastodon-tl--timeline "mastodon-tl") (autoload 'mastodon-tl--toot "mastodon-tl") (autoload 'mastodon-tl--buffer-property "mastodon-tl") (autoload 'mastodon-http--api-search "mastodon-http") (defvar mastodon-toot--completion-style-for-mentions) (defvar mastodon-instance-url) (defvar mastodon-tl--link-keymap) (defvar mastodon-tl--horiz-bar) ;; functions for completion of mentions in mastodon-toot (defun mastodon-search--get-user-info-@ (account) "Get user handle, display name and account URL from ACCOUNT." (list (concat "@" (cdr (assoc 'acct account))) (cdr (assoc 'url account)) (cdr (assoc 'display_name account)))) (defun mastodon-search--search-accounts-query (query) "Prompt for a search QUERY and return accounts synchronously. Returns a nested list containing user handle, display name, and URL." (let* ((url (mastodon-http--api "accounts/search")) (response (if (equal mastodon-toot--completion-style-for-mentions "following") (mastodon-http--get-json url `(("q" . ,query) ("following" . "true")) :silent) (mastodon-http--get-json url `(("q" . ,query)) :silent)))) (mapcar #'mastodon-search--get-user-info-@ response))) ;; functions for tags completion: (defun mastodon-search--search-tags-query (query) "Return an alist containing tag strings plus their URLs. QUERY is the string to search." (let* ((url (mastodon-http--api-search)) (params `(("q" . ,query) ("type" . "hashtags"))) (response (mastodon-http--get-json url params :silent)) (tags (alist-get 'hashtags response))) (mapcar #'mastodon-search--get-hashtag-info tags))) ;; trending tags (defun mastodon-search--trending-tags () "Display a list of tags trending on your instance." (interactive) (mastodon-search--view-trending "tags" #'mastodon-search--print-tags)) (defun mastodon-search--trending-statuses () "Display a list of statuses trending on your instance." (interactive) (mastodon-search--view-trending "statuses" #'mastodon-tl--timeline)) (defun mastodon-search--view-trending (type print-fun) "Display a list of tags trending on your instance. TYPE is a string, either tags, statuses, or links. PRINT-FUN is the function used to print the data from the response." (let* ((url (mastodon-http--api (format "trends/%s" type))) ;; max for statuses = 40, for others = 20 (limit (if (equal type "statuses") '("limit" . "40") '("limit" . "20"))) (offset '(("offset" . "0"))) (params (push limit offset)) (data (mastodon-http--get-json url params)) (buffer (get-buffer-create (format "*mastodon-trending-%s*" type)))) (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-tl--set-buffer-spec (buffer-name buffer) (format "trends/%s" type) print-fun nil params) (mastodon-search--insert-heading "trending" type) (funcall print-fun data) (unless (equal type "statuses") (goto-char (point-min)))))) ;; functions for mastodon search (defun mastodon-search--insert-heading (heading &optional type) "Format HEADING as a heading. Optionally add string TYPE after HEADING." (insert (mastodon-tl--set-face (concat "\n " mastodon-tl--horiz-bar "\n " (upcase heading) " " (if type (upcase type) "") "\n" " " mastodon-tl--horiz-bar "\n") 'success))) (defvar mastodon-search-types '("statuses" "accounts" "hashtags")) (defun mastodon-search--query (query &optional type limit following account-id offset) "Prompt for a search QUERY and return accounts, statuses, and hashtags. TYPE is a member of `mastodon-search-types'. LIMIT is a number as string, up to 40, with 40 the default. FOLLOWING means limit to accounts followed, for \"accounts\" type only. A single prefix arg also sets FOLLOWING to true. ACCOUNT-ID means limit search to that account, for \"statuses\" type only. OFFSET is a number as string, means to skip that many results. It is used for pagination." ;; TODO: handle no results (interactive "sSearch mastodon for: ") (let* ((url (mastodon-http--api-search)) (following (when (or following (equal current-prefix-arg '(4))) "true")) (type (or type (if (equal current-prefix-arg '(4)) "accounts" ; if FOLLOWING, must be "accounts" (completing-read "Search type: " mastodon-search-types nil t)))) (limit (or limit "40")) (offset (or offset "0")) (buffer (format "*mastodon-search-%s-%s*" type query)) (params (cl-remove nil `(("q" . ,query) ,(when type `("type" . ,type)) ,(when limit `("limit" . ,limit)) ,(when offset `("offset" . ,offset)) ,(when following `("following" . ,following)) ,(when account-id `("account_id" . ,account-id))))) (response (mastodon-http--get-json url params)) (accts (when (equal type "accounts") (alist-get 'accounts response))) (tags (when (equal type "hashtags") (alist-get 'hashtags response))) (statuses (when (equal type "statuses") (alist-get 'statuses response)))) (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-search-mode) (mastodon-search--insert-heading type) ;; user results: (cond ((equal type "accounts") (mastodon-search--render-response accts type buffer params 'mastodon-views--insert-users-propertized-note 'mastodon-views--insert-users-propertized-note)) ((equal type "hashtags") (mastodon-search--render-response tags type buffer params 'mastodon-search--print-tags 'mastodon-search--print-tags)) ((equal type "statuses") (mastodon-search--render-response statuses type buffer params #'mastodon-tl--timeline #'mastodon-tl--timeline))) (goto-char (point-min)) (message (substitute-command-keys "\\[mastodon-search--query-cycle] to cycle result types."))))) (defun mastodon-search-insert-no-results (&optional thing) "Insert a no results message for object THING." (let ((thing (or thing "nothing"))) (insert (propertize (format "Looks like search returned no %s." thing) 'face 'font-lock-comment-face)))) (defun mastodon-search--render-response (data type buffer params insert-fun update-fun) "Call INSERT-FUN on DATA of result TYPE if non-nil. BUFFER, PARAMS, and UPDATE-FUN are for `mastodon-tl--buffer-spec'." (if (not data) (mastodon-search-insert-no-results type) (funcall insert-fun data)) ;; (mapc #'mastodon-tl--toot data)) (mastodon-tl--set-buffer-spec buffer "search" update-fun nil params)) (defun mastodon-search--buf-type () "Return search buffer type, a member of `mastodon-search-types'." ;; called in `mastodon-tl--get-buffer-type' (let* ((spec (mastodon-tl--buffer-property 'update-params))) (alist-get "type" spec nil nil #'equal))) (defun mastodon-search--query-cycle () "Cycle through search types: accounts, hashtags, and statuses." (interactive) (let* ((spec (mastodon-tl--buffer-property 'update-params)) (type (alist-get "type" spec nil nil #'equal)) (query (alist-get "q" spec nil nil #'equal))) (cond ((equal type "hashtags") (mastodon-search--query query "accounts")) ((equal type "accounts") (mastodon-search--query query "statuses")) ((equal type "statuses") (mastodon-search--query query "hashtags"))))) (defun mastodon-serach--query-accounts-followed (query) "Run an accounts search QUERY, limited to your followers." (interactive "sSearch mastodon for: ") (mastodon-search--query query "accounts" :following)) (defun mastodon-search--insert-users-propertized (json &optional note) "Insert users list into the buffer. JSON is the data from the server. If NOTE is non-nil, include user's profile note. This is also called by `mastodon-tl--get-follow-suggestions' and `mastodon-profile--insert-follow-requests'." (mapc (lambda (acct) (insert (concat (mastodon-search--propertize-user acct note) mastodon-tl--horiz-bar "\n\n"))) json)) (defun mastodon-search--propertize-user (acct &optional note) "Propertize display string for ACCT, optionally including profile NOTE." (let* ((user (mastodon-search--get-user-info acct)) (id (alist-get 'id acct))) (propertize (concat (propertize (car user) 'face 'mastodon-display-name-face 'byline t 'item-type 'user 'item-id id) ; for prev/next nav " : \n : " (propertize (concat "@" (cadr user)) 'face 'mastodon-handle-face 'mouse-face 'highlight 'mastodon-tab-stop 'user-handle 'keymap mastodon-tl--link-keymap 'mastodon-handle (concat "@" (cadr user)) 'help-echo (concat "Browse user profile of @" (cadr user))) " : \n" (if note (mastodon-tl--render-text (cadddr user) acct) "") "\n") 'item-json acct))) ; for compat w other processing functions (defun mastodon-search--print-tags (tags) "Print TAGS data as returned from a \"hashtags\" search query." (let ((tags-list (mapcar #'mastodon-search--get-hashtag-info tags))) (mastodon-search--print-tags-list tags-list))) (defun mastodon-search--print-tags-list (tags-list) "Insert a propertized list of TAGS-LIST." (mapc (lambda (el) (insert " : " (propertize (concat "#" (car el)) 'face '(:box t) 'mouse-face 'highlight 'mastodon-tag (car el) 'mastodon-tab-stop 'hashtag 'item-type 'tag ; for next/prev nav 'byline t ; for next/prev nav 'help-echo (concat "Browse tag #" (car el)) 'keymap mastodon-tl--link-keymap) " : \n\n")) tags-list)) (defun mastodon-search--get-user-info (account) "Get user handle, display name, account URL and profile note from ACCOUNT." (list (if (not (string-empty-p (alist-get 'display_name account))) (alist-get 'display_name account) (alist-get 'username account)) (alist-get 'acct account) (alist-get 'url account) (alist-get 'note account))) (defun mastodon-search--get-hashtag-info (tag) "Get hashtag name and URL from TAG." (list (alist-get 'name tag) (alist-get 'url tag))) (defun mastodon-search--get-status-info (status) "Get ID, timestamp, content, and spoiler from STATUS." (list (alist-get 'id status) (alist-get 'created_at status) (alist-get 'spoiler_text status) (alist-get 'content status))) (defun mastodon-search--id-from-status (status) "Fetch the id from a STATUS returned by a search call to the server. We use this to fetch the complete status from the server." (alist-get 'id status)) (defun mastodon-search--full-status-from-id (id) "Fetch the full status with id ID from the server. This allows us to access the full account etc. details and to render them properly." (let* ((url (concat mastodon-instance-url "/api/v1/statuses/" (mastodon-tl--as-string id))) (json (mastodon-http--get-json url))) json)) (defvar mastodon-search-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-c") #'mastodon-search--query-cycle) map) "Keymap for `mastodon-search-mode'.") (define-minor-mode mastodon-search-mode "Toggle mastodon search minor mode. This minor mode is used for mastodon search pages to adds a keybinding." :init-value nil :lighter " Search" :keymap mastodon-search-mode-map :group 'mastodon :global nil) (provide 'mastodon-search) ;;; mastodon-search.el ends here mastodon.el/lisp/mastodon-tl.el000066400000000000000000003642711452000115200170360ustar00rootroot00000000000000;;; mastodon-tl.el --- Timeline functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-tl.el provides timeline functions. ;;; Code: (require 'shr) (require 'thingatpt) ; for word-at-point (require 'time-date) (require 'cl-lib) (require 'mastodon-iso) (require 'mpv nil :no-error) (autoload 'mastodon-mode "mastodon") (autoload 'mastodon-notifications-get "mastodon") (autoload 'mastodon-url-lookup "mastodon") (autoload 'mastodon-auth--get-account-id "mastodon-auth") (autoload 'mastodon-auth--get-account-name "mastodon-auth") (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--build-array-params-alist "mastodon-http") (autoload 'mastodon-http--build-params-string "mastodon-http") (autoload 'mastodon-http--delete "mastodon-http") (autoload 'mastodon-http--get-json "mastodon-http") (autoload 'mastodon-http--get-json-async "mastodon-http") (autoload 'mastodon-http--get-response-async "mastodon-http") (autoload 'mastodon-http--post "mastodon-http") (autoload 'mastodon-http--process-json "mastodon-http") (autoload 'mastodon-http--put "mastodon-http") (autoload 'mastodon-http--triage "mastodon-http") (autoload 'mastodon-media--get-avatar-rendering "mastodon-media") (autoload 'mastodon-media--get-media-link-rendering "mastodon-media") (autoload 'mastodon-media--inline-images "mastodon-media") (autoload 'mastodon-notifications--filter-types-list "mastodon-notifications") (autoload 'mastodon-notifications--get-mentions "mastodon-notifications") (autoload 'mastodon-profile--account-from-id "mastodon-profile") (autoload 'mastodon-profile--extract-users-handles "mastodon-profile") (autoload 'mastodon-profile--get-preferences-pref "mastodon-profile") (autoload 'mastodon-profile--get-toot-author "mastodon-profile") (autoload 'mastodon-profile--lookup-account-in-status "mastodon-profile") (autoload 'mastodon-profile--make-author-buffer "mastodon-profile") (autoload 'mastodon-profile--my-profile "mastodon-profile") (autoload 'mastodon-profile--open-statuses-no-reblogs "mastodon-profile") (autoload 'mastodon-profile--profile-json "mastodon-profile") (autoload 'mastodon-profile--search-account-by-handle "mastodon-profile") (autoload 'mastodon-profile--item-json "mastodon-profile") (autoload 'mastodon-profile--view-author-profile "mastodon-profile") (autoload 'mastodon-profile-mode "mastodon-profile") (autoload 'mastodon-search--get-user-info "mastodon-search") (autoload 'mastodon-search--insert-users-propertized "mastodon-search") (autoload 'mastodon-search--propertize-user "mastodon-search") (autoload 'mastodon-toot--compose-buffer "mastodon-toot") (autoload 'mastodon-toot--delete-toot "mastodon-toot") (autoload 'mastodon-toot--get-toot-edits "mastodon-toot") (autoload 'mastodon-toot--iso-to-human "mastodon-toot") (autoload 'mastodon-toot--schedule-toot "mastodon-toot") (autoload 'mastodon-toot--set-toot-properties "mastodon-toot") (autoload 'mastodon-toot--update-status-fields "mastodon-toot") (autoload 'mastodon-search--buf-type "mastodon-search") (autoload 'mastodon-http--api-search "mastodon-http") (autoload 'mastodon-views--insert-users-propertized-note "mastodon-views") ; for search pagination (autoload 'mastodon-http--get-response "mastodon-http") (autoload 'mastodon-search--insert-heading "mastodon-search") (defvar mastodon-toot--visibility) (defvar mastodon-toot-mode) (defvar mastodon-active-user) (when (require 'mpv nil :no-error) (declare-function mpv-start "mpv")) (defvar mastodon-instance-url) (defvar mastodon-toot-timestamp-format) (defvar shr-use-fonts) ;; declare it since Emacs24 didn't have this (defvar mastodon-mode-map) ;;; CUSTOMIZES (defgroup mastodon-tl nil "Timelines in Mastodon." :prefix "mastodon-tl-" :group 'mastodon) (defcustom mastodon-tl--enable-relative-timestamps t "Whether to show relative (to the current time) timestamps. This will require periodic updates of a timeline buffer to keep the timestamps current as time progresses." :type '(boolean :tag "Enable relative timestamps and background updater task")) (defcustom mastodon-tl--enable-proportional-fonts nil "Nonnil to enable using proportional fonts when rendering HTML. By default fixed width fonts are used." :type '(boolean :tag "Enable using proportional rather than fixed \ width fonts when rendering HTML text")) (defcustom mastodon-tl--display-caption-not-url-when-no-media t "Display an image's caption rather than URL. Only has an effect when `mastodon-tl--display-media-p' is set to nil." :type 'boolean) (defcustom mastodon-tl--show-avatars nil "Whether to enable display of user avatars in timelines." :type '(boolean :tag "Whether to display user avatars in timelines")) (defcustom mastodon-tl--show-stats t "Whether to show toot stats (faves, boosts, replies counts)." :type 'boolean) (defcustom mastodon-tl--symbols '((reply . ("💬" . "R")) (boost . ("🔁" . "B")) (favourite . ("⭐" . "F")) (bookmark . ("🔖" . "K")) (media . ("📹" . "[media]")) (verified . ("" . "V")) (locked . ("🔒" . "[locked]")) (private . ("🔒" . "[followers]")) (direct . ("✉" . "[direct]")) (edited . ("✍" . "[edited]")) (replied . ("⬇" . "↓")) (reply-bar . ("┃" . "|"))) "A set of symbols (and fallback strings) to be used in timeline. If a symbol does not look right (tofu), it means your font settings do not support it." :type '(alist :key-type symbol :value-type string)) (defcustom mastodon-tl-position-after-update nil "Defines where `point' should be located after a timeline update. Valid values are: - nil Top/bottom depending on timeline type - keep-point Keep original position of point - last-old-toot The last toot before the new ones" :type '(choice (const :tag "Top/bottom depending on timeline type" nil) (const :tag "Keep original position of point" keep-point) (const :tag "The last toot before the new ones" last-old-toot))) (defcustom mastodon-tl--timeline-posts-count "20" "Number of posts to display when loading a timeline. Must be an integer between 20 and 40 inclusive." :type '(string)) (defcustom mastodon-tl--hide-replies nil "Whether to hide replies from the timelines. Note that you can hide replies on a one-off basis by loading a timeline with a simple prefix argument, `C-u'." :type '(boolean :tag "Whether to hide replies from the timelines.")) (defcustom mastodon-tl--highlight-current-toot nil "Whether to highlight the toot at point. Uses `cursor-face' special property." :type '(boolean)) (defcustom mastodon-tl--expand-content-warnings 'server "Whether to expand content warnings by default. The API returns data about this setting on the server, but no means to set it, so we roll our own option here to override the server setting if desired. If you change the server setting and want it to be respected by mastodon.el, you'll likely need to either unset `mastodon-profile-acccount-preferences-data' and re-load mastodon.el, or restart Emacs." :type '(choice (const :tag "true" t) (const :tag "false" nil) (const :tag "follow server setting" server))) ;;; VARIABLES (defvar-local mastodon-tl--buffer-spec nil "A unique identifier and functions for each Mastodon buffer.") (defvar-local mastodon-tl--update-point nil "When updating a mastodon buffer this is where new toots will be inserted. If nil `(point-min)' is used instead.") (defvar-local mastodon-tl--after-update-marker nil "Marker defining the position of point after the update is done.") (defvar mastodon-tl--display-media-p t "A boolean value stating whether to show media in timelines.") (defvar-local mastodon-tl--timestamp-next-update nil "The timestamp when the buffer should next be scanned to update the timestamps.") (defvar-local mastodon-tl--timestamp-update-timer nil "The timer that, when set will scan the buffer to update the timestamps.") (defvar mastodon-tl--horiz-bar (if (char-displayable-p ?―) (make-string 12 ?―) (make-string 12 ?-))) ;;; KEYMAPS (defvar mastodon-tl--link-keymap (let ((map (make-sparse-keymap))) (define-key map [return] #'mastodon-tl--do-link-action-at-point) (define-key map [mouse-2] #'mastodon-tl--do-link-action) (define-key map [follow-link] 'mouse-face) map) "The keymap for link-like things in buffer (except for shr.el generate links). This will make the region of text act like like a link with mouse highlighting, mouse click action tabbing to next/previous link etc.") (defvar mastodon-tl--shr-map-replacement (let ((map (make-sparse-keymap))) (set-keymap-parent map shr-map) ;; Replace the move to next/previous link bindings with our ;; version that knows about more types of links. (define-key map [remap shr-next-link] #'mastodon-tl--next-tab-item) (define-key map [remap shr-previous-link] #'mastodon-tl--previous-tab-item) ;; keep new my-profile binding; shr 'O' doesn't work here anyway (define-key map (kbd "O") #'mastodon-profile--my-profile) ;; remove shr's u binding, as it the maybe-probe-and-copy-url ;; is already bound to w also (define-key map (kbd "u") #'mastodon-tl--update) (define-key map [remap shr-browse-url] #'mastodon-url-lookup) map) "The keymap to be set for shr.el generated links that are not images. We need to override the keymap so tabbing will navigate to all types of mastodon links and not just shr.el-generated ones.") (defvar mastodon-tl--shr-image-map-replacement (let ((map (make-sparse-keymap))) (set-keymap-parent map (if (boundp 'shr-image-map) shr-image-map shr-map)) ;; Replace the move to next/previous link bindings with our ;; version that knows about more types of links. (define-key map [remap shr-next-link] #'mastodon-tl--next-tab-item) (define-key map [remap shr-previous-link] #'mastodon-tl--previous-tab-item) ;; browse-url loads the preview only, we want browse-image ;; on RET to browse full sized image URL (define-key map [remap shr-browse-url] #'shr-browse-image) ;; remove shr's u binding, as it the maybe-probe-and-copy-url ;; is already bound to w also (define-key map (kbd "u") #'mastodon-tl--update) ;; keep new my-profile binding; shr 'O' doesn't work here anyway (define-key map (kbd "O") #'mastodon-profile--my-profile) (define-key map (kbd "") #'mastodon-tl--mpv-play-video-at-point) (define-key map (kbd "") #'mastodon-tl--click-image-or-video) map) "The keymap to be set for shr.el generated image links. We need to override the keymap so tabbing will navigate to all types of mastodon links and not just shr.el-generated ones.") (defvar mastodon-tl--byline-link-keymap (when (require 'mpv nil :no-error) (let ((map (make-sparse-keymap))) (define-key map (kbd "") #'mastodon-tl--mpv-play-video-from-byline) (define-key map (kbd "RET") #'mastodon-profile--get-toot-author) map)) "The keymap to be set for the author byline. It is active where point is placed by `mastodon-tl--goto-next-item.'") ;;; MACROS (defmacro with-mastodon-buffer (buffer mode-fun other-window &rest body) "Evaluate BODY in a new or existing buffer called BUFFER. MODE-FUN is called to set the major mode. OTHER-WINDOW means call `switch-to-buffer-other-window' rather than `switch-to-buffer'." (declare (debug t) (indent 3)) `(with-current-buffer (get-buffer-create ,buffer) (let ((inhibit-read-only t)) (erase-buffer) (funcall ,mode-fun) (if ,other-window (switch-to-buffer-other-window ,buffer) (switch-to-buffer ,buffer)) ,@body))) (defmacro mastodon-tl--do-if-item (&rest body) "Execute BODY if we have an item at point." (declare (debug t)) `(if (and (not (mastodon-tl--profile-buffer-p)) (not (mastodon-tl--property 'item-json))) ; includes users but not tags (message "Looks like there's no item at point?") ,@body)) (defmacro mastodon-tl--do-if-item-strict (&rest body) "Execute BODY if we have a toot object at point. Includes boosts, and notifications that display toots." (declare (debug t)) `(if (not (equal 'toot (mastodon-tl--property 'item-type :no-move))) (message "Looks like there's no toot at point?") ,@body)) ;;; NAV (defun mastodon-tl--scroll-up-command () "Call `scroll-up-command', loading more toots if necessary. If we hit `point-max', call `mastodon-tl--more' then `scroll-up-command'." (interactive) (if (not (equal (point) (point-max))) (scroll-up-command) (mastodon-tl--more) (scroll-up-command))) (defun mastodon-tl--next-tab-item (&optional previous) "Move to the next interesting item. This could be the next toot, link, or image; whichever comes first. Don't move if nothing else to move to is found, i.e. near the end of the buffer. This also skips tab items in invisible text, i.e. hidden spoiler text. PREVIOUS means move to previous item." (interactive) (let (next-range (search-pos (point))) (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop search-pos previous)) (get-text-property (car next-range) 'invisible) (setq search-pos (if previous (1- (car next-range)) (1+ (cdr next-range))))) ;; do nothing, all the action is in the while condition ) (if (null next-range) (message "Nothing else here.") (goto-char (car next-range)) (message "%s" (mastodon-tl--property 'help-echo :no-move))))) (defun mastodon-tl--previous-tab-item () "Move to the previous interesting item. This could be the previous toot, link, or image; whichever comes first. Don't move if nothing else to move to is found, i.e. near the start of the buffer. This also skips tab items in invisible text, i.e. hidden spoiler text." (interactive) (mastodon-tl--next-tab-item :previous)) (defun mastodon-tl--goto-item-pos (find-pos refresh &optional pos) "Search for item with function FIND-POS. If search returns nil, execute REFRESH function. Optionally start from POS." (let* ((npos (or ; toot/user items have byline: (funcall find-pos (or pos (point)) ;; 'item-type ; breaks nav to last item in a view? 'byline (current-buffer))))) (if npos (if (not (or ;; (get-text-property npos 'item-id) ; toots, users, not tags (get-text-property npos 'item-type))) ; generic (mastodon-tl--goto-item-pos find-pos refresh npos) (goto-char npos) ;; force display of help-echo on moving to a toot byline: (mastodon-tl--message-help-echo)) ;; FIXME: this doesn't really work, as the funcall doesn't return if we ;; run into an endless refresh loop (condition-case nil (funcall refresh) (error "No more items"))))) (defun mastodon-tl--goto-next-item () "Jump to next item. Load more items it no next item." (interactive) (mastodon-tl--goto-item-pos 'next-single-property-change 'mastodon-tl--more)) (defun mastodon-tl--goto-prev-item () "Jump to previous item. Update if no previous items" (interactive) (mastodon-tl--goto-item-pos 'previous-single-property-change 'mastodon-tl--update)) (defun mastodon-tl--goto-first-item () "Jump to first toot or item in buffer. Used on initializing a timeline or thread." ;; goto-next-item assumes we already have items, and is therefore ;; incompatible with any view where it is possible to have no items. ;; when that is the case the call to goto-toot-pos loops infinitely (goto-char (point-min)) (mastodon-tl--goto-item-pos 'next-single-property-change 'next-line)) ;; (mastodon-tl--goto-next-item)) ;;; TIMELINES (defun mastodon-tl--get-federated-timeline (&optional prefix local) "Open federated timeline. If LOCAL, get only local timeline. With a single PREFIX arg, hide-replies. With a double PREFIX arg, only show posts with media." (interactive "p") (let ((params `(("limit" . ,mastodon-tl--timeline-posts-count)))) ;; avoid adding 'nil' to our params alist: (when (eq prefix 16) (push '("only_media" . "true") params)) (when local (push '("local" . "true") params)) (message "Loading federated timeline...") (mastodon-tl--init (if local "local" "federated") "timelines/public" 'mastodon-tl--timeline nil params (when (eq prefix 4) t)))) (defun mastodon-tl--get-home-timeline (&optional arg) "Open home timeline. With a single prefix ARG, hide replies." (interactive "p") (message "Loading home timeline...") (mastodon-tl--init "home" "timelines/home" 'mastodon-tl--timeline nil `(("limit" . ,mastodon-tl--timeline-posts-count)) (when (eq arg 4) t))) (defun mastodon-tl--get-local-timeline (&optional prefix) "Open local timeline. With a single PREFIX arg, hide-replies. With a double PREFIX arg, only show posts with media." (interactive "p") (message "Loading local timeline...") (mastodon-tl--get-federated-timeline prefix :local)) (defun mastodon-tl--get-tag-timeline (&optional prefix tag) "Prompt for tag and opens its timeline. Optionally load TAG timeline directly. With a single PREFIX arg, only show posts with media. With a double PREFIX arg, limit results to your own instance." (interactive "p") (let* ((word (or (word-at-point) "")) (input (or tag (read-string (format "Load timeline for tag (%s): " word)))) (tag (or tag (if (string-empty-p input) word input)))) (message "Loading timeline for #%s..." tag) (mastodon-tl--show-tag-timeline prefix tag))) (defun mastodon-tl--show-tag-timeline (&optional prefix tag) "Opens a new buffer showing the timeline of posts with hastag TAG. If TAG is a list, show a timeline for all tags. With a single PREFIX arg, only show posts with media. With a double PREFIX arg, limit results to your own instance." (let ((params `(("limit" . ,mastodon-tl--timeline-posts-count)))) ;; avoid adding 'nil' to our params alist: (when (eq prefix 4) (push '("only_media" . "true") params)) (when (eq prefix 16) (push '("local" . "true") params)) (when (listp tag) (let ((list (mastodon-http--build-array-params-alist "any[]" (cdr tag)))) (while list (push (pop list) params)))) (mastodon-tl--init (if (listp tag) "tags-multiple" (concat "tag-" tag)) (concat "timelines/tag/" (if (listp tag) (car tag) tag)) ; must be /tag/:sth 'mastodon-tl--timeline nil params))) ;;; BYLINES, etc. (defun mastodon-tl--message-help-echo () "Call message on `help-echo' property at point. Do so if type of status at poins is not follow_request/follow." (let ((type (alist-get 'type (mastodon-tl--property 'item-json :no-move))) (echo (mastodon-tl--property 'help-echo :no-move))) (when echo ; not for followers/following in profile (unless (or (string= type "follow_request") (string= type "follow")) ; no counts for these (message "%s" (mastodon-tl--property 'help-echo :no-move)))))) (defun mastodon-tl--byline-author (toot &optional avatar) "Propertize author of TOOT. With arg AVATAR, include the account's avatar image." (let-alist toot (concat ;; avatar insertion moved up to `mastodon-tl--byline' by default to be ;; outside 'byline propt. (when (and avatar ; used by `mastodon-profile--format-user' mastodon-tl--show-avatars mastodon-tl--display-media-p (if (version< emacs-version "27.1") (image-type-available-p 'imagemagick) (image-transforms-p))) (mastodon-media--get-avatar-rendering .account.avatar)) (propertize (if (not (string-empty-p .account.display_name)) .account.display_name .account.username) 'face 'mastodon-display-name-face ;; enable playing of videos when point is on byline: 'attachments (mastodon-tl--get-attachments-for-byline toot) 'keymap mastodon-tl--byline-link-keymap ;; echo faves count when point on post author name: ;; which is where --goto-next-toot puts point. 'help-echo ;; but don't add it to "following"/"follows" on profile views: ;; we don't have a tl--buffer-spec yet: (unless (or (string-suffix-p "-followers*" (buffer-name)) (string-suffix-p "-following*" (buffer-name))) (mastodon-tl--format-byline-help-echo toot))) " (" (propertize (concat "@" .account.acct) 'face 'mastodon-handle-face 'mouse-face 'highlight 'mastodon-tab-stop 'user-handle 'account .account 'shr-url .account.url 'keymap mastodon-tl--link-keymap 'mastodon-handle (concat "@" .account.acct) 'help-echo (concat "Browse user profile of @" .account.acct)) ")"))) (defun mastodon-tl--format-byline-help-echo (toot) "Format a help-echo for byline of TOOT. Displays a toot's media types and optionally the binding to play moving image media from the byline. Used when point is at the start of a byline, i.e. where `mastodon-tl--goto-next-item' leaves point." (let* ((toot-to-count (or ; simply praying this order works (alist-get 'status toot) ; notifications timeline ;; fol-req notif, has 'type placed before boosts coz fol-reqs have ;; a (useless) reblog entry: (when (and (or (mastodon-tl--buffer-type-eq 'notifications) (mastodon-tl--buffer-type-eq 'mentions)) (alist-get 'type toot)) toot) (alist-get 'reblog toot) ; boosts toot)) ; everything else (fol-req-p (or (string= (alist-get 'type toot-to-count) "follow") (string= (alist-get 'type toot-to-count) "follow_request")))) (unless fol-req-p (let* ((media-types (mastodon-tl--get-media-types toot)) (format-media (when media-types (format "media: %s" (mapconcat #'identity media-types " ")))) (format-media-binding (when (and (or (member "video" media-types) (member "gifv" media-types)) (require 'mpv nil :no-error)) (format " | C-RET to view with mpv")))) (format "%s" (concat format-media format-media-binding)))))) (defun mastodon-tl--get-media-types (toot) "Return a list of the media attachment types of the TOOT at point." (let* ((attachments (mastodon-tl--field 'media_attachments toot))) (mastodon-tl--map-alist 'type attachments))) (defun mastodon-tl--get-attachments-for-byline (toot) "Return a list of attachment URLs and types for TOOT. The result is added as an attachments property to author-byline." (let ((media-attachments (mastodon-tl--field 'media_attachments toot))) (mapcar (lambda (attachment) (let-alist attachment (list :url (or .remote_url .url) ; fallback for notifications :type .type))) media-attachments))) (defun mastodon-tl--byline-boosted (toot) "Add byline for boosted data from TOOT." (let ((reblog (alist-get 'reblog toot))) (when reblog (concat "\n " (propertize "Boosted" 'face 'mastodon-boosted-face) " " (mastodon-tl--byline-author reblog))))) (defun mastodon-tl--format-faved-or-boosted-byline (letter) "Format the byline marker for a boosted or favourited status. LETTER is a string, F for favourited, B for boosted, or K for bookmarked." (let ((help-string (cond ((equal letter "F") "favourited") ((equal letter "B") "boosted") ((equal letter (or "🔖" "K")) "bookmarked")))) (format "(%s) " (propertize letter 'face 'mastodon-boost-fave-face ;; emojify breaks this for 🔖: 'help-echo (format "You have %s this status." help-string))))) (defun mastodon-tl--byline (toot author-byline action-byline &optional detailed-p) "Generate byline for TOOT. AUTHOR-BYLINE is a function for adding the author portion of the byline that takes one variable. ACTION-BYLINE is a function for adding an action, such as boosting, favouriting and following to the byline. It also takes a single function. By default it is `mastodon-tl--byline-boosted'. DETAILED-P means display more detailed info. For now this just means displaying toot client." (let* ((created-time ;; bosts and faves in notifs view ;; (makes timestamps be for the original toot not the boost/fave): (or (mastodon-tl--field 'created_at (mastodon-tl--field 'status toot)) ;; all other toots, inc. boosts/faves in timelines: ;; (mastodon-tl--field auto fetches from reblogs if needed): (mastodon-tl--field 'created_at toot))) (parsed-time (date-to-time created-time)) (faved (equal 't (mastodon-tl--field 'favourited toot))) (boosted (equal 't (mastodon-tl--field 'reblogged toot))) (bookmarked (equal 't (mastodon-tl--field 'bookmarked toot))) (visibility (mastodon-tl--field 'visibility toot)) (account (alist-get 'account toot)) (avatar-url (alist-get 'avatar account)) (type (alist-get 'type toot)) (edited-time (alist-get 'edited_at toot)) (edited-parsed (when edited-time (date-to-time edited-time)))) (concat ;; Boosted/favourited markers are not technically part of the byline, so ;; we don't propertize them with 'byline t', as per the rest. This ;; ensures that `mastodon-tl--goto-next-item' puts point on ;; author-byline, not before the (F) or (B) marker. Not propertizing like ;; this makes the behaviour of these markers consistent whether they are ;; displayed for an already boosted/favourited toot or as the result of ;; the toot having just been favourited/boosted. (concat (when boosted (mastodon-tl--format-faved-or-boosted-byline (mastodon-tl--symbol 'boost))) (when faved (mastodon-tl--format-faved-or-boosted-byline (mastodon-tl--symbol 'favourite))) (when bookmarked (mastodon-tl--format-faved-or-boosted-byline (mastodon-tl--symbol 'bookmark)))) ;; we remove avatars from the byline also, so that they also do not mess ;; with `mastodon-tl--goto-next-item': (when (and mastodon-tl--show-avatars mastodon-tl--display-media-p (if (version< emacs-version "27.1") (image-type-available-p 'imagemagick) (image-transforms-p))) (mastodon-media--get-avatar-rendering avatar-url)) (propertize (concat ;; we propertize help-echo format faves for author name ;; in `mastodon-tl--byline-author' (funcall author-byline toot) ;; visibility: (cond ((equal visibility "direct") (propertize (concat " " (mastodon-tl--symbol 'direct)) 'help-echo visibility)) ((equal visibility "private") (propertize (concat " " (mastodon-tl--symbol 'private)) 'help-echo visibility))) (funcall action-byline toot) " " (propertize (format-time-string mastodon-toot-timestamp-format parsed-time) 'timestamp parsed-time 'display (if mastodon-tl--enable-relative-timestamps (mastodon-tl--relative-time-description parsed-time) parsed-time)) (when detailed-p (let* ((app (alist-get 'application toot)) (app-name (alist-get 'name app)) (app-url (alist-get 'website app))) (when app (concat (propertize " via " 'face 'default) (propertize app-name 'face 'mastodon-display-name-face 'follow-link t 'mouse-face 'highlight 'mastodon-tab-stop 'shr-url 'shr-url app-url 'help-echo app-url 'keymap mastodon-tl--shr-map-replacement))))) (if edited-time (concat " " (mastodon-tl--symbol 'edited) " " (propertize (format-time-string mastodon-toot-timestamp-format edited-parsed) 'face 'font-lock-comment-face 'timestamp edited-parsed 'display (if mastodon-tl--enable-relative-timestamps (mastodon-tl--relative-time-description edited-parsed) edited-parsed))) "") (propertize (concat "\n " mastodon-tl--horiz-bar) 'face 'default) (if (and mastodon-tl--show-stats (not (member type '("follow" "follow_request")))) (mastodon-tl--toot-stats toot) "") "\n") 'favourited-p faved 'boosted-p boosted 'bookmarked-p bookmarked 'edited edited-time 'edit-history (when edited-time (mastodon-toot--get-toot-edits (alist-get 'id toot))) 'byline t)))) ;;; TIMESTAMPS (defun mastodon-tl--relative-time-details (timestamp &optional current-time) "Return cons of (DESCRIPTIVE STRING . NEXT-CHANGE) for the TIMESTAMP. Use the optional CURRENT-TIME as the current time (only used for reliable testing). The descriptive string is a human readable version relative to the current time while the next change timestamp give the first time that this description will change in the future. TIMESTAMP is assumed to be in the past." (let* ((time-difference (time-subtract current-time timestamp)) (seconds-difference (float-time time-difference)) (tmp (mastodon-tl--human-duration (max 0 seconds-difference)))) (cons (concat (car tmp) " ago") (time-add current-time (cdr tmp))))) (defun mastodon-tl--relative-time-description (timestamp &optional current-time) "Return a string with a human readable TIMESTAMP relative to the current time. Use the optional CURRENT-TIME as the current time (only used for reliable testing). E.g. this could return something like \"1 min ago\", \"yesterday\", etc. TIME-STAMP is assumed to be in the past." (car (mastodon-tl--relative-time-details timestamp current-time))) ;;; RENDERING HTML, LINKS, HASHTAGS, HANDLES (defun mastodon-tl--render-text (string &optional toot) "Return a propertized text rendering the given HTML string STRING. The contents comes from the given TOOT which is used in parsing links in the text. If TOOT is nil no parsing occurs." (when string ; handle rare empty notif server bug (with-temp-buffer (insert string) (let ((shr-use-fonts mastodon-tl--enable-proportional-fonts) (shr-width (when mastodon-tl--enable-proportional-fonts (- (window-width) 3)))) (shr-render-region (point-min) (point-max))) ;; Make all links a tab stop recognized by our own logic, make things point ;; to our own logic (e.g. hashtags), and update keymaps where needed: (when toot (let (region) (while (setq region (mastodon-tl--find-property-range 'shr-url (or (cdr region) (point-min)))) (mastodon-tl--process-link toot (car region) (cdr region) (get-text-property (car region) 'shr-url))))) (buffer-string)))) (defun mastodon-tl--process-link (toot start end url) "Process link URL in TOOT as hashtag, userhandle, or normal link. START and END are the boundaries of the link in the toot." (let* (mastodon-tab-stop-type keymap (help-echo (get-text-property start 'help-echo)) extra-properties ;; handle calling this on non-toots, e.g. for profiles: (toot-url (when (proper-list-p toot) (mastodon-tl--field 'url toot))) (toot-url (when toot-url (url-generic-parse-url toot-url))) (toot-instance-url (if toot-url (concat (url-type toot-url) "://" (url-host toot-url)) mastodon-instance-url)) (link-str (buffer-substring-no-properties start end)) (maybe-hashtag (mastodon-tl--extract-hashtag-from-url url toot-instance-url)) (maybe-userhandle (if (proper-list-p toot) ; fails for profile buffers? (or (mastodon-tl--userhandle-from-mentions toot link-str) ;; FIXME: if prev always works, cut this: (mastodon-tl--extract-userhandle-from-url url link-str)) (mastodon-tl--extract-userhandle-from-url url link-str)))) (cond (;; Hashtags: maybe-hashtag (setq mastodon-tab-stop-type 'hashtag keymap mastodon-tl--link-keymap help-echo (concat "Browse tag #" maybe-hashtag) extra-properties (list 'mastodon-tag maybe-hashtag))) (;; User handles: maybe-userhandle ;; this fails on mentions in profile notes: (let ((maybe-userid (when (proper-list-p toot) (mastodon-tl--extract-userid-toot toot link-str)))) (setq mastodon-tab-stop-type 'user-handle keymap mastodon-tl--link-keymap help-echo (concat "Browse user profile of " maybe-userhandle) extra-properties (append (list 'mastodon-handle maybe-userhandle) (when maybe-userid (list 'account-id maybe-userid)))))) ;; Anything else: (t ; Leave it as a url handled by shr.el. (setq keymap (if (eq shr-map (get-text-property start 'keymap)) mastodon-tl--shr-map-replacement mastodon-tl--shr-image-map-replacement) mastodon-tab-stop-type 'shr-url))) (add-text-properties start end (append (list 'mastodon-tab-stop mastodon-tab-stop-type 'keymap keymap 'help-echo help-echo) extra-properties)))) (defun mastodon-tl--userhandle-from-mentions (toot link) "Extract a user handle from mentions in json TOOT. LINK is maybe the `@handle' to search for." (mastodon-tl--extract-el-from-mentions 'acct toot link)) (defun mastodon-tl--extract-userid-toot (toot link) "Extract a user id for an ACCT from mentions in a TOOT. LINK is maybe the `@handle' to search for." (mastodon-tl--extract-el-from-mentions 'id toot link)) (defun mastodon-tl--extract-el-from-mentions (el toot link) "Extract element EL from TOOT mentions that matches LINK. LINK should be a simple handle string with no domain, i.e. \"@user\". Return nil if no matching element." ;; Must return nil if nothing found! (let ((mentions (append (alist-get 'mentions toot) nil))) (when mentions (let* ((mention (pop mentions)) (name (substring-no-properties link 1 (length link))) ; cull @ return) (while mention (when (string= name (alist-get 'username mention)) (setq return (alist-get el mention))) (setq mention (pop mentions))) return)))) (defun mastodon-tl--extract-userhandle-from-url (url buffer-text) "Return the user hande the URL points to or nil if it is not a profile link. BUFFER-TEXT is the text covered by the link with URL, for a user profile this should be of the form , e.g. \"@Gargon\"." (let* ((parsed-url (url-generic-parse-url url)) (local-p (string= (url-host (url-generic-parse-url mastodon-instance-url)) (url-host parsed-url)))) (when (and (string= "@" (substring buffer-text 0 1)) ;; don't error on domain only url (rare): (not (string= "" (url-filename parsed-url))) (string= (downcase buffer-text) (downcase (substring (url-filename parsed-url) 1)))) (if local-p buffer-text ; no instance suffix for local mention (concat buffer-text "@" (url-host parsed-url)))))) (defun mastodon-tl--extract-hashtag-from-url (url instance-url) "Return the hashtag that URL points to or nil if URL is not a tag link. INSTANCE-URL is the url of the instance for the toot that the link came from (tag links always point to a page on the instance publishing the toot)." (cond ;; Mastodon type tag link: ((string-prefix-p (concat instance-url "/tags/") url) (substring url (length (concat instance-url "/tags/")))) ;; Link from some other ostatus site we've encountered: ((string-prefix-p (concat instance-url "/tag/") url) (substring url (length (concat instance-url "/tag/")))) ;; If nothing matches we assume it is not a hashtag link: (t nil))) ;;; HYPERLINKS (defun mastodon-tl--make-link (string link-type) "Return a propertized version of STRING that will act like link. LINK-TYPE is the type of link to produce." (let ((help-text (cond ((eq link-type 'content-warning) "Toggle hidden text") (t (error "Unknown link type %s" link-type))))) (propertize string 'mastodon-tab-stop link-type 'mouse-face 'highlight 'keymap mastodon-tl--link-keymap 'help-echo help-text))) (defun mastodon-tl--do-link-action-at-point (position) "Do the action of the link at POSITION. Used for hitting RET on a given link." (interactive "d") (let ((link-type (get-text-property position 'mastodon-tab-stop))) (cond ((eq link-type 'content-warning) (mastodon-tl--toggle-spoiler-text position)) ((eq link-type 'hashtag) (mastodon-tl--show-tag-timeline nil (get-text-property position 'mastodon-tag))) ;; 'account / 'account-id is not set for mentions, only bylines ((eq link-type 'user-handle) (let ((account-json (get-text-property position 'account)) (account-id (get-text-property position 'account-id))) (cond (account-json (mastodon-profile--make-author-buffer account-json)) (account-id (mastodon-profile--make-author-buffer (mastodon-profile--account-from-id account-id))) (t (let ((account (mastodon-profile--search-account-by-handle (get-text-property position 'mastodon-handle)))) ;; never call make-author-buffer on nil account: (if account (mastodon-profile--make-author-buffer account) ;; optional webfinger lookup: (if (y-or-n-p "Search for account returned nothing. Perform URL lookup?") (mastodon-url-lookup (get-text-property position 'shr-url)) (message "Unable to find account.")))))))) (t (error "Unknown link type %s" link-type))))) (defun mastodon-tl--do-link-action (event) "Do the action of the link at point. Used for a mouse-click EVENT on a link." (interactive "e") (mastodon-tl--do-link-action-at-point (posn-point (event-end event)))) ;;; CONTENT WARNINGS (defun mastodon-tl--has-spoiler (toot) "Check if the given TOOT has a spoiler text. Spoiler text should initially be shown only while the main content should be hidden." (let ((spoiler (mastodon-tl--field 'spoiler_text toot))) (and spoiler (> (length spoiler) 0)))) (defun mastodon-tl--toggle-spoiler-text (position) "Toggle the visibility of the spoiler text at/after POSITION." (let ((inhibit-read-only t) (spoiler-text-region (mastodon-tl--find-property-range 'mastodon-content-warning-body position nil))) (if (not spoiler-text-region) (message "No spoiler text here") (add-text-properties (car spoiler-text-region) (cdr spoiler-text-region) (list 'invisible (not (get-text-property (car spoiler-text-region) 'invisible))))))) (defun mastodon-tl--toggle-spoiler-text-in-toot () "Toggle the visibility of the spoiler text in the current toot." (interactive) (let* ((toot-range (or (mastodon-tl--find-property-range 'item-json (point)) (mastodon-tl--find-property-range 'item-json (point) t))) (spoiler-range (when toot-range (mastodon-tl--find-property-range 'mastodon-content-warning-body (car toot-range))))) (cond ((null toot-range) (message "No toot here")) ((or (null spoiler-range) (> (car spoiler-range) (cdr toot-range))) (message "No content warning text here")) (t (mastodon-tl--toggle-spoiler-text (car spoiler-range)))))) (defun mastodon-tl--clean-tabs-and-nl (string) "Remove tabs and newlines from STRING." (replace-regexp-in-string "[\t\n ]*\\'" "" string)) (defun mastodon-tl--spoiler (toot) "Render TOOT with spoiler message. This assumes TOOT is a toot with a spoiler message. The main body gets hidden and only the spoiler text and the content warning message are displayed. The content warning message is a link which unhides/hides the main body." (let* ((spoiler (mastodon-tl--field 'spoiler_text toot)) (string (mastodon-tl--set-face (mastodon-tl--clean-tabs-and-nl (mastodon-tl--render-text spoiler toot)) 'default)) (message (concat " " mastodon-tl--horiz-bar "\n " (mastodon-tl--make-link (concat "CW: " string) 'content-warning) "\n " mastodon-tl--horiz-bar "\n")) (cw (mastodon-tl--set-face message 'mastodon-cw-face))) (concat cw (propertize (mastodon-tl--content toot) 'invisible (let ((cust mastodon-tl--expand-content-warnings)) (cond ((eq t cust) nil) ((eq nil cust) t) ((eq 'server cust) (unless (eq t ;; If something goes wrong reading prefs, ;; just return nil so CWs show by default. (condition-case nil (mastodon-profile--get-preferences-pref 'reading:expand:spoilers) (error nil))) t)))) 'mastodon-content-warning-body t)))) ;;; MEDIA (defun mastodon-tl--media (toot) "Retrieve a media attachment link for TOOT if one exists." (let* ((media-attachments (mastodon-tl--field 'media_attachments toot)) (media-string (mapconcat #'mastodon-tl--media-attachment media-attachments ""))) (if (not (and mastodon-tl--display-media-p (string-empty-p media-string))) (concat "\n" media-string) ""))) (defun mastodon-tl--media-attachment (media-attachment) "Return a propertized string for MEDIA-ATTACHMENT." (let-alist media-attachment (let ((display-str (if (and mastodon-tl--display-caption-not-url-when-no-media .description) (concat "Media:: " .description) (concat "Media:: " .preview_url)))) (if mastodon-tl--display-media-p (mastodon-media--get-media-link-rendering ; placeholder: "[img]" .preview_url (or .remote_url .url) .type .description) ; 2nd arg for shr-browse-url ;; return URL/caption: (concat (mastodon-tl--propertize-img-str-or-url (concat "Media:: " .preview_url) ; string .preview_url .remote_url .type .description display-str ; display 'shr-link) "\n"))))) (defun mastodon-tl--propertize-img-str-or-url (str media-url full-remote-url type help-echo &optional display face) "Propertize an media placeholder string \"[img]\" or media URL. STR is the string to propertize, MEDIA-URL is the preview link, FULL-REMOTE-URL is the link to the full resolution image on the server, TYPE is the media type. HELP-ECHO, DISPLAY, and FACE are the text properties to add." (propertize str 'media-url media-url 'media-state (when (string= str "[img]") 'needs-loading) 'media-type 'media-link 'mastodon-media-type type 'display display 'face face 'mouse-face 'highlight 'mastodon-tab-stop 'image ; for do-link-action-at-point 'image-url full-remote-url ; for shr-browse-image 'keymap mastodon-tl--shr-image-map-replacement 'help-echo (if (or (string= type "image") (string= type nil) (string= type "unknown")) ; handle borked images help-echo (concat help-echo "\nC-RET: play " type " with mpv")))) ;; POLLS (defun mastodon-tl--format-poll-option (option option-counter longest-option) "Format poll OPTION. OPTION-COUNTER is just a counter. LONGEST-OPTION is the option whose length determines the formatting." (format "%s: %s%s%s\n" option-counter (propertize (alist-get 'title option) 'face 'success) (make-string (1+ (- (length longest-option) (length (alist-get 'title option)))) ?\ ) ;; TODO: disambiguate no votes from hidden votes (format "[%s votes]" (or (alist-get 'votes_count option) "0")))) (defun mastodon-tl--get-poll (toot) "If TOOT includes a poll, return it as a formatted string." (let-alist (mastodon-tl--field 'poll toot) ; toot or reblog (let* ((option-titles (mastodon-tl--map-alist 'title .options)) (longest-option (car (sort option-titles (lambda (x y) (> (length x) (length y)))))) (option-counter 0)) (concat "\nPoll: \n\n" (mapconcat (lambda (option) (setq option-counter (1+ option-counter)) (mastodon-tl--format-poll-option option option-counter longest-option)) .options "\n") "\n" (propertize (cond (.voters_count ; sometimes it is nil (if (= .voters_count 1) (format "%s person | " .voters_count) (format "%s people | " .voters_count))) (.vote_count (format "%s votes | " .vote_count)) (t "")) 'face 'font-lock-comment-face) (let ((str (if (eq .expired :json-false) (if (eq .expires_at nil) "" (mastodon-tl--format-poll-expiry .expires_at)) "Poll expired."))) (propertize str 'face 'font-lock-comment-face)) "\n")))) (defconst mastodon-tl--time-units '("sec" 60.0 ;Use a float to convert `n' to float. "min" 60 "hour" 24 "day" 7 "week" 4.345 "month" 12 "year")) (defun mastodon-tl--format-poll-expiry (timestamp) "Convert poll expiry TIMESTAMP into a descriptive string." ;; FIXME: Could we document the format of TIMESTAMP here? (let* ((ts (encode-time (parse-time-string timestamp))) (seconds (time-to-seconds (time-subtract ts nil)))) ;; FIXME: Use the `cdr' to update poll expiry times? (concat (car (mastodon-tl--human-duration (max 0 seconds))) " left"))) (defun mastodon-tl--human-duration (seconds &optional resolution) "Return a string describing SECONDS in a more human-friendly way. The return format is (STRING . RES) where RES is the resolution of this string, in seconds. RESOLUTION is the finest resolution, in seconds, to use for the second part of the output (defaults to 60, so that seconds are only displayed when the duration is smaller than a minute)." (cl-assert (>= seconds 0)) (unless resolution (setq resolution 60)) (let* ((units mastodon-tl--time-units) (n1 seconds) (unit1 (pop units)) (res1 1) n2 unit2 res2 next) (while (and units (> (truncate (setq next (/ n1 (car units)))) 0)) (setq unit2 unit1) (setq res2 res1) (setq n2 (- n1 (* (car units) (truncate n1 (car units))))) (setq n1 next) (setq res1 (truncate (* res1 (car units)))) (pop units) (setq unit1 (pop units))) (setq n1 (truncate n1)) (if n2 (setq n2 (truncate n2))) (cond ((null n2) (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) (max resolution res1))) ((< (* res2 n2) resolution) (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) (max resolution res2))) ((< res2 resolution) (let ((n2 (/ (* resolution (/ (* n2 res2) resolution)) res2))) (cons (format "%d %s%s, %d %s%s" n1 unit1 (if (> n1 1) "s" "") n2 unit2 (if (> n2 1) "s" "")) resolution))) (t (cons (format "%d %s%s, %d %s%s" n1 unit1 (if (> n1 1) "s" "") n2 unit2 (if (> n2 1) "s" "")) (max res2 resolution)))))) (defun mastodon-tl--read-poll-option () "Read a poll option to vote on a poll." (let* ((toot (mastodon-tl--property 'item-json)) (poll (mastodon-tl--field 'poll toot)) (options (mastodon-tl--field 'options poll)) (options-titles (mastodon-tl--map-alist 'title options)) (options-number-seq (number-sequence 1 (length options))) (options-numbers (mapcar #'number-to-string options-number-seq)) (options-alist (cl-mapcar #'cons options-numbers options-titles)) ;; we display both option number and the option title ;; but also store both as cons cell as cdr, as we need it below (candidates (mapcar (lambda (cell) (cons (format "%s | %s" (car cell) (cdr cell)) cell)) options-alist))) (if (null poll) (message "No poll here.") (list ;; var "option" = just the cdr, a cons of option number and desc (cdr (assoc (completing-read "Poll option to vote for: " candidates nil t) ; require match candidates)))))) (defun mastodon-tl--poll-vote (option) "If there is a poll at point, prompt user for OPTION to vote on it." (interactive (mastodon-tl--read-poll-option)) (if (null (mastodon-tl--field 'poll (mastodon-tl--property 'item-json))) (message "No poll here.") (let* ((toot (mastodon-tl--property 'item-json)) (poll (mastodon-tl--field 'poll toot)) (poll-id (alist-get 'id poll)) (url (mastodon-http--api (format "polls/%s/votes" poll-id))) ;; need to zero-index our option: (option-as-arg (number-to-string (1- (string-to-number (car option))))) (arg `(("choices[]" . ,option-as-arg))) (response (mastodon-http--post url arg))) (mastodon-http--triage response (lambda (_) (message "You voted for option %s: %s!" (car option) (cdr option))))))) ;; VIDEOS / MPV (defun mastodon-tl--find-first-video-in-attachments () "Return the first media attachment that is a moving image." (let ((attachments (mastodon-tl--property 'attachments)) vids) (mapc (lambda (x) (let ((att-type (plist-get x :type))) (when (or (string= "video" att-type) (string= "gifv" att-type)) (push x vids)))) attachments) (car vids))) (defun mastodon-tl--mpv-play-video-from-byline () "Run `mastodon-tl--mpv-play-video-at-point' on first moving image in post." (interactive) (let* ((video (mastodon-tl--find-first-video-in-attachments)) (url (plist-get video :url)) (type (plist-get video :type))) (mastodon-tl--mpv-play-video-at-point url type))) (defun mastodon-tl--click-image-or-video (_event) "Click to play video with `mpv.el'." (interactive "e") (if (mastodon-tl--media-video-p) (mastodon-tl--mpv-play-video-at-point) (shr-browse-image))) (defun mastodon-tl--media-video-p (&optional type) "T if mastodon-media-type prop is \"gifv\" or \"video\". TYPE is a mastodon media type." (let ((type (or type (mastodon-tl--property 'mastodon-media-type :no-move)))) (or (equal type "gifv") (equal type "video")))) (defun mastodon-tl--mpv-play-video-at-point (&optional url type) "Play the video or gif at point with an mpv process. URL and TYPE are provided when called while point is on byline, in which case play first video or gif from current toot." (interactive) (let ((url (or url ; point in byline: (mastodon-tl--property 'image-url :no-move)))) ; point in toot ;; (type (or type ; in byline ;; point in toot: ;; (mastodon-tl--property 'mastodon-media-type :no-move)))) (if url (if (mastodon-tl--media-video-p type) (progn (message "'q' to kill mpv.") (mpv-start "--loop" url)) (message "no moving image here?")) (message "no moving image here?")))) ;;; INSERT TOOTS (defun mastodon-tl--content (toot) "Retrieve text content from TOOT. Runs `mastodon-tl--render-text' and fetches poll or media." (let* ((content (mastodon-tl--field 'content toot)) (poll-p (mastodon-tl--field 'poll toot))) (concat (mastodon-tl--render-text content toot) (when poll-p (mastodon-tl--get-poll toot)) (mastodon-tl--media toot)))) (defun mastodon-tl--prev-item-id () "Return the id of the last toot inserted into the buffer." (let* ((prev-change (save-excursion (previous-single-property-change (point) 'base-toot-id))) (prev-pos (when prev-change (1- prev-change)))) (when prev-pos (get-text-property prev-pos 'base-toot-id)))) (defun mastodon-tl--after-reply-status (reply-to-id) "T if REPLY-TO-ID is equal to that of the last toot inserted in the bufer." (let ((prev-id (mastodon-tl--prev-item-id))) (string= reply-to-id prev-id))) (defun mastodon-tl--insert-status (toot body author-byline action-byline &optional id base-toot detailed-p thread) "Display the content and byline of timeline element TOOT. BODY will form the section of the toot above the byline. AUTHOR-BYLINE is an optional function for adding the author portion of the byline that takes one variable. By default it is `mastodon-tl--byline-author'. ACTION-BYLINE is also an optional function for adding an action, such as boosting favouriting and following to the byline. It also takes a single function. By default it is `mastodon-tl--byline-boosted'. ID is that of the status if it is a notification, which is attached as a `item-id' property if provided. If the status is a favourite or boost notification, BASE-TOOT is the JSON of the toot responded to. DETAILED-P means display more detailed info. For now this just means displaying toot client. THREAD means the status will be displayed in a thread view." (let* ((start-pos (point)) (reply-to-id (alist-get 'in_reply_to_id toot)) (after-reply-status-p (when (and thread reply-to-id) (mastodon-tl--after-reply-status reply-to-id)))) (insert (propertize (concat "\n" (if (and after-reply-status-p thread) (concat (mastodon-tl--symbol 'replied) "\n") "") (if (and after-reply-status-p thread) (let ((bar (mastodon-tl--symbol 'reply-bar))) (propertize body 'line-prefix bar 'wrap-prefix bar)) body) " \n" (mastodon-tl--byline toot author-byline action-byline detailed-p)) 'item-type 'toot 'item-id (or id ; notification's own id (alist-get 'id toot)) ; toot id 'base-item-id (mastodon-tl--item-id ;; if status is a notif, get id from base-toot ;; (-tl--item-id toot) will not work here: (or base-toot toot)) ; else normal toot with reblog check 'item-json toot 'base-toot base-toot 'cursor-face 'mastodon-cursor-highlight-face) "\n") (when mastodon-tl--display-media-p (mastodon-media--inline-images start-pos (point))))) ;; from mastodon-alt.el: (defun mastodon-tl--toot-for-stats (&optional toot) "Return the TOOT on which we want to extract stats. If no TOOT is given, the one at point is considered." (let* ((original-toot (or toot (get-text-property (point) 'item-json))) (toot (or (alist-get 'status original-toot) (when (alist-get 'type original-toot) original-toot) (alist-get 'reblog original-toot) original-toot)) (type (alist-get 'type (or toot)))) (unless (member type '("follow" "follow_request")) toot))) (defun mastodon-tl--toot-stats (toot) "Return a right aligned string (using display align-to). String is filled with TOOT statistics (boosts, favs, replies). When the TOOT is a reblog (boost), statistics from reblogged toots are returned. To disable showing the stats, customize `mastodon-tl--show-stats'." (let-alist (mastodon-tl--toot-for-stats toot) (let* ((faves-prop (propertize (format "%s" .favourites_count) 'favourites-count .favourites_count)) (boosts-prop (propertize (format "%s" .reblogs_count) 'boosts-count .reblogs_count)) (faves (format "%s %s" faves-prop (mastodon-tl--symbol 'favourite))) (boosts (format "%s %s" boosts-prop (mastodon-tl--symbol 'boost))) (replies (format "%s %s" .replies_count (mastodon-tl--symbol 'reply))) (status (concat (propertize faves 'favourited-p (eq 't .favourited) 'favourites-field t 'help-echo (format "%s favourites" .favourites_count) 'face 'font-lock-comment-face) (propertize " | " 'face 'font-lock-comment-face) (propertize boosts 'boosted-p (eq 't .reblogged) 'boosts-field t 'help-echo (format "%s boosts" .reblogs_count) 'face 'font-lock-comment-face) (propertize " | " 'face 'font-lock-comment-face) (propertize replies 'replies-field t 'replies-count .replies_count 'help-echo (format "%s replies" .replies_count) 'face 'font-lock-comment-face))) (status (concat (propertize " " 'display `(space :align-to (- right ,(+ (length status) 7)))) status))) status))) (defun mastodon-tl--is-reply (toot) "Check if the TOOT is a reply to another one (and not boosted)." (and (null (mastodon-tl--field 'in_reply_to_id toot)) (not (mastodon-tl--field 'rebloged toot)))) (defun mastodon-tl--toot (toot &optional detailed-p thread) "Format TOOT and insert it into the buffer. DETAILED-P means display more detailed info. For now this just means displaying toot client. THREAD means the status will be displayed in a thread view." (mastodon-tl--insert-status toot (mastodon-tl--clean-tabs-and-nl (if (mastodon-tl--has-spoiler toot) (mastodon-tl--spoiler toot) (mastodon-tl--content toot))) 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted nil nil detailed-p thread)) (defun mastodon-tl--timeline (toots &optional thread) "Display each toot in TOOTS. This function removes replies if user required. THREAD means the status will be displayed in a thread view." (mapc (lambda (toot) (mastodon-tl--toot toot nil thread)) ;; hack to *not* filter replies on profiles: (if (eq (mastodon-tl--get-buffer-type) 'profile-statuses) toots (if (or ; we were called via --more*: (mastodon-tl--buffer-property 'hide-replies nil :no-error) ;; loading a tl with a prefix arg: (mastodon-tl--hide-replies-p current-prefix-arg)) (cl-remove-if-not #'mastodon-tl--is-reply toots) toots))) (goto-char (point-min))) ;;; BUFFER SPEC (defun mastodon-tl--update-function (&optional buffer) "Get the UPDATE-FUNCTION stored in `mastodon-tl--buffer-spec'. Optionally get it for BUFFER." (mastodon-tl--buffer-property 'update-function buffer)) (defun mastodon-tl--endpoint (&optional buffer no-error) "Get the ENDPOINT stored in `mastodon-tl--buffer-spec'. Optionally set it for BUFFER. NO-ERROR means to fail silently." (mastodon-tl--buffer-property 'endpoint buffer no-error)) (defun mastodon-tl--buffer-name (&optional buffer no-error) "Get the BUFFER-NAME stored in `mastodon-tl--buffer-spec'. Optionally get it for BUFFER. NO-ERROR means to fail silently." (mastodon-tl--buffer-property 'buffer-name buffer no-error)) (defun mastodon-tl--link-header (&optional buffer) "Get the LINK HEADER stored in `mastodon-tl--buffer-spec'. Optionally get it for BUFFER." (mastodon-tl--buffer-property 'link-header buffer :no-error)) (defun mastodon-tl--update-params (&optional buffer) "Get the UPDATE PARAMS stored in `mastodon-tl--buffer-spec'. Optionally get it for BUFFER." (mastodon-tl--buffer-property 'update-params buffer :no-error)) (defun mastodon-tl--buffer-property (property &optional buffer no-error) "Get PROPERTY from `mastodon-tl--buffer-spec' in BUFFER or `current-buffer'. If NO-ERROR is non-nil, do not error when property is empty." (with-current-buffer (or buffer (current-buffer)) (if no-error (plist-get mastodon-tl--buffer-spec property) (or (plist-get mastodon-tl--buffer-spec property) (error "Mastodon-tl--buffer-spec not defined for buffer %s, prop %s" (or buffer (current-buffer)) property))))) (defun mastodon-tl--set-buffer-spec (buffer endpoint update-fun &optional link-header update-params hide-replies) "Set `mastodon-tl--buffer-spec' for the current buffer. BUFFER is buffer name, ENDPOINT is buffer's enpoint, UPDATE-FUN is its update function. LINK-HEADER is the http Link header if present. UPDATE-PARAMS is any http parameters needed for the update function. HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer." (setq mastodon-tl--buffer-spec `(account ,(cons mastodon-active-user mastodon-instance-url) buffer-name ,buffer endpoint ,endpoint update-function ,update-fun link-header ,link-header update-params ,update-params hide-replies ,hide-replies))) ;;; BUFFERS (defun mastodon-tl--endpoint-str-= (str &optional type) "Return T if STR is equal to the current buffer's endpoint. TYPE may be :prefix or :suffix, in which case, T if STR is a prefix or suffix." (let ((endpoint-fun (mastodon-tl--endpoint nil :no-error))) (cond ((eq type :prefix) (string-prefix-p str endpoint-fun)) ((eq type :suffix) (string-suffix-p str endpoint-fun)) (t (string= str endpoint-fun))))) (defun mastodon-tl--get-buffer-type () "Return a symbol descriptive of current mastodon buffer type. Should work in all mastodon buffers. Note that for many buffers, this requires `mastodon-tl--buffer-spec' to be set. It is set for almost all buffers, but you still have to call this function after it is set or use something else." (let ((buffer-name (mastodon-tl--buffer-name nil :no-error))) (cond (mastodon-toot-mode ;; composing/editing: (if (string= "*edit toot*" (buffer-name)) 'edit-toot 'new-toot)) ;; main timelines: ((mastodon-tl--endpoint-str-= "timelines/home") 'home) ((string= "*mastodon-local*" buffer-name) 'local) ((mastodon-tl--endpoint-str-= "timelines/public") 'federated) ((mastodon-tl--endpoint-str-= "timelines/tag/" :prefix) 'tag-timeline) ((mastodon-tl--endpoint-str-= "timelines/list/" :prefix) 'list-timeline) ;; notifs: ((string-suffix-p "mentions*" buffer-name) 'mentions) ((mastodon-tl--endpoint-str-= "notifications") 'notifications) ;; threads: ((mastodon-tl--endpoint-str-= "context" :suffix) 'thread) ((mastodon-tl--endpoint-str-= "statuses" :prefix) 'single-status) ;; profiles: ((mastodon-tl--profile-buffer-p) (cond ;; an own profile option is needlessly confusing e.g. for ;; `mastodon-profile--account-view-cycle' ;; profile note: ((string-suffix-p "update-profile*" buffer-name) 'update-profile-note) ;; posts inc. boosts: ((string-suffix-p "no-boosts*" buffer-name) 'profile-statuses-no-boosts) ((mastodon-tl--endpoint-str-= "statuses" :suffix) 'profile-statuses) ;; profile followers ((mastodon-tl--endpoint-str-= "followers" :suffix) 'profile-followers) ;; profile following ((mastodon-tl--endpoint-str-= "following" :suffix) 'profile-following))) ((mastodon-tl--endpoint-str-= "preferences") 'preferences) ;; search ((mastodon-tl--search-buffer-p) (cond ((equal (mastodon-search--buf-type) "accounts") 'search-accounts) ((equal (mastodon-search--buf-type) "hashtags") 'search-hashtags) ((equal (mastodon-search--buf-type) "statuses") 'search-statuses))) ;; trends ((mastodon-tl--endpoint-str-= "trends/statuses") 'trending-statuses) ((mastodon-tl--endpoint-str-= "trends/tags") 'trending-tags) ((mastodon-tl--endpoint-str-= "trends/links") 'trending-links) ;; User's views: ((mastodon-tl--endpoint-str-= "filters") 'filters) ((mastodon-tl--endpoint-str-= "lists") 'lists) ((mastodon-tl--endpoint-str-= "suggestions") 'follow-suggestions) ((mastodon-tl--endpoint-str-= "favourites") 'favourites) ((mastodon-tl--endpoint-str-= "bookmarks") 'bookmarks) ((mastodon-tl--endpoint-str-= "follow_requests") 'follow-requests) ((mastodon-tl--endpoint-str-= "scheduled_statuses") 'scheduled-statuses) ;; instance description ((mastodon-tl--endpoint-str-= "instance") 'instance-description) ((string= "*mastodon-toot-edits*" buffer-name) 'toot-edits)))) (defun mastodon-tl--buffer-type-eq (type) "Return t if current buffer type is equal to symbol TYPE." (eq (mastodon-tl--get-buffer-type) type)) (defun mastodon-tl--profile-buffer-p () "Return t if current buffer is a profile buffer of any kind. This includes the update profile note buffer, but not the preferences one." (string-prefix-p "accounts" (mastodon-tl--endpoint nil :no-error))) (defun mastodon-tl--search-buffer-p () "T if current buffer is a search buffer." (string-suffix-p "search" (mastodon-tl--endpoint nil :no-error))) (defun mastodon-tl--timeline-proper-p () "Return non-nil if the current buffer is a \"proper\" timeline. A proper timeline excludes notifications, threads, profiles, and other toot buffers that aren't strictly mastodon timelines." (let ((timeline-buffers '(home federated local tag-timeline list-timeline profile-statuses))) (member (mastodon-tl--get-buffer-type) timeline-buffers))) (defun mastodon-tl--hide-replies-p (&optional prefix) "Return non-nil if replies should be hidden in the timeline. We hide replies if user explictly set the `mastodon-tl--hide-replies' or used PREFIX combination to open a timeline." (and (mastodon-tl--timeline-proper-p) ; Only if we are in a proper timeline (or mastodon-tl--hide-replies ; User configured to hide replies (equal '(4) prefix)))) ; Timeline called with C-u prefix ;;; UTILITIES (defun mastodon-tl--map-alist (key alist) "Return a list of values extracted from ALIST with KEY. Key is a symbol, as with `alist-get'." (mapcar (lambda (x) (alist-get key x)) alist)) (defun mastodon-tl--map-alist-vals-to-alist (key1 key2 alist) "From ALIST, return an alist consisting of (val1 . val2) elements. Values are accessed by `alist-get', using KEY1 and KEY2." (mapcar (lambda (x) (cons (alist-get key1 x) (alist-get key2 x))) alist)) (defun mastodon-tl--symbol (name) "Return the unicode symbol (as a string) corresponding to NAME. If symbol is not displayable, an ASCII equivalent is returned. If NAME is not part of the symbol table, '?' is returned." (if-let* ((symbol (alist-get name mastodon-tl--symbols))) (if (char-displayable-p (string-to-char (car symbol))) (car symbol) (cdr symbol)) "?")) (defun mastodon-tl--set-face (string face) "Return the propertized STRING with the face property set to FACE." (propertize string 'face face)) (defun mastodon-tl--field (field toot) "Return FIELD from TOOT. Return value from boosted content if available." (or (alist-get field (alist-get 'reblog toot)) (alist-get field toot))) (defun mastodon-tl--remove-html (toot) "Remove unrendered tags from TOOT." (let* ((t1 (replace-regexp-in-string "<\/p>" "\n\n" toot)) (t2 (replace-regexp-in-string "<\/?span>" "" t1))) (replace-regexp-in-string "" "" t2))) (defun mastodon-tl--property (prop &optional no-move backward) "Get property PROP for toot at point. Move forward (down) the timeline unless NO-MOVE is non-nil. BACKWARD means move backward (up) the timeline." (if no-move (get-text-property (point) prop) (or (get-text-property (point) prop) (save-excursion (if backward (mastodon-tl--goto-prev-item) (mastodon-tl--goto-next-item)) (get-text-property (point) prop))))) (defun mastodon-tl--newest-id () "Return item-id from the top of the buffer." (save-excursion (goto-char (point-min)) (mastodon-tl--property 'item-id))) (defun mastodon-tl--oldest-id () "Return item-id from the bottom of the buffer." (save-excursion (goto-char (point-max)) (mastodon-tl--property 'item-id nil :backward))) (defun mastodon-tl--as-string (numeric) "Convert NUMERIC to string." (cond ((numberp numeric) (number-to-string numeric)) ((stringp numeric) numeric) (t (error "Numeric:%s must be either a string or a number" numeric)))) (defun mastodon-tl--item-id (json) "Find approproiate toot id in JSON. If the toot has been boosted use the id found in the reblog portion of the toot. Otherwise, use the body of the toot. This is the same behaviour as the mastodon.social webapp" (let-alist json (if .reblog .reblog.id .id))) (defun mastodon-tl--toot-or-base (json) "Return the base toot or just the toot from toot JSON." (or (alist-get 'reblog json) json)) ;;; THREADS (defun mastodon-tl--single-toot (id) "View toot at point in separate buffer. ID is that of the toot to view." (interactive) (let* ((buffer (format "*mastodon-toot-%s*" id)) (toot (mastodon-http--get-json (mastodon-http--api (concat "statuses/" id))))) (if (equal (caar toot) 'error) (user-error "Error: %s" (cdar toot)) (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-tl--set-buffer-spec buffer (format "statuses/%s" id) #'mastodon-tl--update-toot) (mastodon-tl--toot toot :detailed-p) (goto-char (point-min)) (mastodon-tl--goto-next-item))))) (defun mastodon-tl--update-toot (json) "Call `mastodon-tl--single-toot' on id found in JSON." (let ((id (alist-get 'id json))) (mastodon-tl--single-toot id))) (defun mastodon-tl--view-whole-thread () "From a thread view, view entire thread. If you load a thread from a toot, only the branches containing are displayed by default. Call this if you subsequently want to view all branches of a thread." (interactive) (if (not (eq (mastodon-tl--get-buffer-type) 'thread)) (user-error "You need to be viewing a thread to call this") (goto-char (point-min)) (let ((id (mastodon-tl--property 'base-item-id))) (mastodon-tl--thread id)))) (defun mastodon-tl--thread (&optional id) "Open thread buffer for toot at point or with ID." (interactive) (let* ((id (or id (mastodon-tl--property 'base-item-id :no-move))) (type (mastodon-tl--field 'type (mastodon-tl--property 'item-json :no-move)))) (if (or (string= type "follow_request") (string= type "follow")) ; no can thread these (user-error "No thread") (let* ((endpoint (format "statuses/%s/context" id)) (url (mastodon-http--api endpoint)) (buffer (format "*mastodon-thread-%s*" id)) (toot (mastodon-http--get-json ; refetch in case we just faved/boosted: (mastodon-http--api (concat "statuses/" id)) nil :silent)) (context (mastodon-http--get-json url nil :silent))) (if (equal (caar toot) 'error) (user-error "Error: %s" (cdar toot)) (when (member (alist-get 'type toot) '("reblog" "favourite")) (setq toot (alist-get 'status toot))) (if (> (+ (length (alist-get 'ancestors context)) (length (alist-get 'descendants context))) 0) ;; if we have a thread: (with-mastodon-buffer buffer #'mastodon-mode nil (let ((marker (make-marker))) (mastodon-tl--set-buffer-spec buffer endpoint #'mastodon-tl--thread) (mastodon-tl--timeline (alist-get 'ancestors context) :thread) (goto-char (point-max)) (move-marker marker (point)) ;; print re-fetched toot: (mastodon-tl--toot toot :detailed-p :thread) (mastodon-tl--timeline (alist-get 'descendants context) :thread) ;; put point at the toot: (goto-char (marker-position marker)) (mastodon-tl--goto-next-item))) ;; else just print the lone toot: (mastodon-tl--single-toot id))))))) (defun mastodon-tl--mute-thread () "Mute the thread displayed in the current buffer. Note that you can only (un)mute threads you have posted in." (interactive) (mastodon-tl--mute-or-unmute-thread)) (defun mastodon-tl--unmute-thread () "Mute the thread displayed in the current buffer. Note that you can only (un)mute threads you have posted in." (interactive) (mastodon-tl--mute-or-unmute-thread :unmute)) (defun mastodon-tl--mute-or-unmute-thread (&optional unmute) "Mute a thread. If UNMUTE, unmute it." (let ((endpoint (mastodon-tl--endpoint)) (mute-str (if unmute "unmute" "mute"))) (when (or (mastodon-tl--buffer-type-eq 'thread) (mastodon-tl--buffer-type-eq 'notifications)) (let* ((id (if (mastodon-tl--buffer-type-eq 'notifications) (get-text-property (point) 'base-item-id) (save-match-data (string-match "statuses/\\(?2:[[:digit:]]+\\)/context" endpoint) (match-string 2 endpoint)))) (we-posted-p (mastodon-tl--user-in-thread-p id)) (url (mastodon-http--api (format "statuses/%s/%s" id mute-str)))) (if (not we-posted-p) (message "You can only (un)mute a thread you have posted in.") (when (y-or-n-p (format "%s this thread? " (capitalize mute-str))) (let ((response (mastodon-http--post url))) (mastodon-http--triage response (lambda (_) (if unmute (message "Thread unmuted!") (message "Thread muted!"))))))))))) (defun mastodon-tl--map-account-id-from-toot (statuses) "Return a list of the account IDs of the author of each toot in STATUSES." (mapcar (lambda (status) (alist-get 'id (alist-get 'account status))) statuses)) (defun mastodon-tl--user-in-thread-p (id) "Return non-nil if the logged-in user has posted to the current thread. ID is that of the post the context is currently displayed for." (let* ((context-json (mastodon-http--get-json (mastodon-http--api (format "statuses/%s/context" id)) nil :silent)) (ancestors (alist-get 'ancestors context-json)) (descendants (alist-get 'descendants context-json)) (a-ids (mastodon-tl--map-account-id-from-toot ancestors)) (d-ids (mastodon-tl--map-account-id-from-toot descendants))) (or (member (mastodon-auth--get-account-id) a-ids) (member (mastodon-auth--get-account-id) d-ids)))) ;;; FOLLOW/BLOCK/MUTE, ETC (defun mastodon-tl--follow-user (user-handle &optional notify langs reblogs) "Query for USER-HANDLE from current status and follow that user. If NOTIFY is \"true\", enable notifications when that user posts. If NOTIFY is \"false\", disable notifications when that user posts. Can be called to toggle NOTIFY on users already being followed. LANGS is an array parameters alist of languages to filer user's posts by. REBLOGS is a boolean string like NOTIFY, enabling or disabling display of the user's boosts in your timeline." (interactive (list (mastodon-tl--user-handles-get "follow"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "follow" nil notify langs reblogs))) ;; TODO: make this action "enable/disable notifications" (defun mastodon-tl--enable-notify-user-posts (user-handle) "Query for USER-HANDLE and enable notifications when they post." (interactive (list (mastodon-tl--user-handles-get "enable"))) (mastodon-tl--do-if-item (mastodon-tl--follow-user user-handle "true"))) (defun mastodon-tl--disable-notify-user-posts (user-handle) "Query for USER-HANDLE and disable notifications when they post." (interactive (list (mastodon-tl--user-handles-get "disable"))) (mastodon-tl--follow-user user-handle "false")) (defun mastodon-tl--follow-user-disable-boosts (user-handle) "Prompt for a USER-HANDLE, and disable display of boosts in home timeline. If they are also not yet followed, follow them." (interactive (list (mastodon-tl--user-handles-get "disable boosts"))) (mastodon-tl--follow-user user-handle nil nil "false")) (defun mastodon-tl--follow-user-enable-boosts (user-handle) "Prompt for a USER-HANDLE, and enable display of boosts in home timeline. If they are also not yet followed, follow them. You only need to call this if you have previously disabled display of boosts." (interactive (list (mastodon-tl--user-handles-get "enable boosts"))) (mastodon-tl--follow-user user-handle nil nil "true")) (defun mastodon-tl--filter-user-user-posts-by-language (user-handle) "Query for USER-HANDLE and enable notifications when they post. This feature is experimental and for now not easily varified by the instance API." (interactive (list (mastodon-tl--user-handles-get "filter by language"))) (let ((langs (mastodon-tl--read-filter-langs))) (mastodon-tl--do-if-item (mastodon-tl--follow-user user-handle nil langs)))) (defun mastodon-tl--read-filter-langs (&optional langs) "Read language choices and return an alist array parameter. LANGS is the accumulated array param alist if we re-run recursively." (let* ((langs-alist langs) (choice (completing-read "Filter user's posts by language: " mastodon-iso-639-1))) (when choice (setq langs-alist (push `("languages[]" . ,(alist-get choice mastodon-iso-639-1 nil nil #'string=)) langs-alist)) (if (y-or-n-p "Filter by another language? ") (mastodon-tl--read-filter-langs langs-alist) langs-alist)))) (defun mastodon-tl--unfollow-user (user-handle) "Query for USER-HANDLE from current status and unfollow that user." (interactive (list (mastodon-tl--user-handles-get "unfollow"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "unfollow" t))) (defun mastodon-tl--block-user (user-handle) "Query for USER-HANDLE from current status and block that user." (interactive (list (mastodon-tl--user-handles-get "block"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "block"))) (defun mastodon-tl--unblock-user (user-handle) "Query for USER-HANDLE from list of blocked users and unblock that user." (interactive (list (mastodon-tl--get-blocks-or-mutes-list "unblock"))) (if (not user-handle) (message "Looks like you have no blocks to unblock!") (mastodon-tl--do-user-action-and-response user-handle "unblock" t))) (defun mastodon-tl--mute-user (user-handle) "Query for USER-HANDLE from current status and mute that user." (interactive (list (mastodon-tl--user-handles-get "mute"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "mute"))) (defun mastodon-tl--unmute-user (user-handle) "Query for USER-HANDLE from list of muted users and unmute that user." (interactive (list (mastodon-tl--get-blocks-or-mutes-list "unmute"))) (if (not user-handle) (message "Looks like you have no mutes to unmute!") (mastodon-tl--do-user-action-and-response user-handle "unmute" t))) (defun mastodon-tl--dm-user (user-handle) "Query for USER-HANDLE from current status and compose a message to that user." (interactive (list (mastodon-tl--user-handles-get "message"))) (mastodon-tl--do-if-item (mastodon-toot--compose-buffer (concat "@" user-handle)) (setq mastodon-toot--visibility "direct") (mastodon-toot--update-status-fields))) (defun mastodon-tl--user-handles-get (action) "Get the list of user-handles for ACTION from the current toot." (mastodon-tl--do-if-item (let ((user-handles (cond ((or ; follow suggests / search / foll requests compat: (mastodon-tl--buffer-type-eq 'follow-suggestions) (mastodon-tl--buffer-type-eq 'search) (mastodon-tl--buffer-type-eq 'follow-requests) ;; profile follows/followers but not statuses: (mastodon-tl--buffer-type-eq 'profile-followers) (mastodon-tl--buffer-type-eq 'profile-following)) ;; fetch 'item-json: (list (alist-get 'acct (mastodon-tl--property 'item-json :no-move)))) ;; profile view, point in profile details, poss no toots ;; needed for e.g. gup.pe groups which show no toots publically: ((and (mastodon-tl--profile-buffer-p) (get-text-property (point) 'profile-json)) (list (alist-get 'acct (mastodon-profile--profile-json)))) (t (mastodon-profile--extract-users-handles (mastodon-profile--item-json)))))) ;; return immediately if only 1 handle: (if (eq 1 (length user-handles)) (car user-handles) (completing-read (cond ((or ; TODO: make this "enable/disable notifications" (equal action "disable") (equal action "enable")) (format "%s notifications when user posts: " action)) ((string-suffix-p "boosts" action) (format "%s by user: " action)) (t (format "Handle of user to %s: " action))) user-handles nil ; predicate 'confirm))))) (defun mastodon-tl--get-blocks-or-mutes-list (action) "Fetch the list of accounts for ACTION from the server. Action must be either \"unblock\" or \"unmute\"." (let* ((endpoint (cond ((equal action "unblock") "blocks") ((equal action "unmute") "mutes"))) (url (mastodon-http--api endpoint)) (json (mastodon-http--get-json url)) (accts (mastodon-tl--map-alist 'acct json))) (when accts (completing-read (format "Handle of user to %s: " action) accts nil t)))) ; require match (defun mastodon-tl--do-user-action-and-response (user-handle action &optional negp notify langs reblogs) "Do ACTION on user USER-HANDLE. NEGP is whether the action involves un-doing something. If NOTIFY is \"true\", enable notifications when that user posts. If NOTIFY is \"false\", disable notifications when that user posts. NOTIFY is only non-nil when called by `mastodon-tl--follow-user'. LANGS is an array parameters alist of languages to filer user's posts by. REBLOGS is a boolean string like NOTIFY, enabling or disabling display of the user's boosts in your timeline." (let* ((account (if negp ;; unmuting/unblocking, handle from mute/block list (mastodon-profile--search-account-by-handle user-handle) ;; profile view, use 'profile-json as status: (if (mastodon-tl--profile-buffer-p) (mastodon-profile--lookup-account-in-status user-handle (mastodon-profile--profile-json)) ;; muting/blocking, select from handles in current status (mastodon-profile--lookup-account-in-status user-handle (mastodon-profile--item-json))))) (user-id (alist-get 'id account)) (name (if (string-empty-p (alist-get 'display_name account)) (alist-get 'username account) (alist-get 'display_name account))) (args (cond (notify `(("notify" . ,notify))) (langs langs) (reblogs `(("reblogs" . ,reblogs))) (t nil))) (url (mastodon-http--api (format "accounts/%s/%s" user-id action)))) (if account (if (equal action "follow") ; y-or-n for all but follow (mastodon-tl--do-user-action-function url name user-handle action notify args reblogs) (when (y-or-n-p (format "%s user %s? " action name)) (mastodon-tl--do-user-action-function url name user-handle action args))) (message "Cannot find a user with handle %S" user-handle)))) (defun mastodon-tl--do-user-action-function (url name user-handle action &optional notify args reblogs) "Post ACTION on user NAME/USER-HANDLE to URL. NOTIFY is either \"true\" or \"false\", and used when we have been called by `mastodon-tl--follow-user' to enable or disable notifications. ARGS is an alist of any parameters to send with the request." (let ((response (mastodon-http--post url args))) (mastodon-http--triage response (lambda (response) (let ((json (with-current-buffer response (mastodon-http--process-json)))) ;; TODO: when > if, with failure msg (cond ((string-equal notify "true") (when (equal 't (alist-get 'notifying json)) (message "Receiving notifications for user %s (@%s)!" name user-handle))) ((string-equal notify "false") (when (equal :json-false (alist-get 'notifying json)) (message "Not receiving notifications for user %s (@%s)!" name user-handle))) ((string-equal reblogs "true") (when (equal 't (alist-get 'showing_reblogs json)) (message "Receiving boosts by user %s (@%s)!" name user-handle))) ((string-equal reblogs "false") (when (equal :json-false (alist-get 'showing_reblogs json)) (message "Not receiving boosts by user %s (@%s)!" name user-handle))) ((or (string-equal action "mute") (string-equal action "unmute")) (message "User %s (@%s) %sd!" name user-handle action)) ((assoc "languages[]" args #'equal) (message "User %s filtered by language(s): %s" name (mapconcat #'cdr args " "))) ((and (eq notify nil) (eq reblogs nil)) (message "User %s (@%s) %sed!" name user-handle action)))))))) ;; FOLLOW TAGS (defun mastodon-tl--get-tags-list () "Return the list of tags of the toot at point." (let* ((toot (or (mastodon-tl--property 'base-toot :no-move) ; fave/boost notifs (mastodon-tl--property 'item-json :no-move))) (tags (mastodon-tl--field 'tags toot))) (mapcar (lambda (x) (alist-get 'name x)) tags))) (defun mastodon-tl--follow-tag (&optional tag) "Prompt for a tag and follow it. If TAG provided, follow it." (interactive) (let* ((tags (unless tag (mastodon-tl--get-tags-list))) (tag-at-point (unless tag (when (eq 'hashtag (get-text-property (point) 'mastodon-tab-stop)) (get-text-property (point) 'mastodon-tag)))) (tag (or tag (completing-read (format "Tag to follow [%s]: " tag-at-point) tags nil nil nil nil tag-at-point))) (url (mastodon-http--api (format "tags/%s/follow" tag))) (response (mastodon-http--post url))) (mastodon-http--triage response (lambda (_) (message "tag #%s followed!" tag))))) (defun mastodon-tl--followed-tags () "Return JSON of tags followed." (let ((url (mastodon-http--api (format "followed_tags")))) (mastodon-http--get-json url))) (defun mastodon-tl--unfollow-tag (&optional tag) "Prompt for a followed tag, and unfollow it. If TAG is provided, unfollow it." (interactive) (let* ((followed-tags-json (unless tag (mastodon-tl--followed-tags))) (tags (unless tag (mastodon-tl--map-alist 'name followed-tags-json))) (tag (or tag (completing-read "Unfollow tag: " tags))) (url (mastodon-http--api (format "tags/%s/unfollow" tag))) (response (mastodon-http--post url))) (mastodon-http--triage response (lambda (_) (message "tag #%s unfollowed!" tag))))) (defun mastodon-tl--list-followed-tags (&optional prefix) "List followed tags. View timeline of tag user choses. PREFIX is sent to `mastodon-tl--get-tag-timeline', which see." (interactive "p") (let* ((followed-tags-json (mastodon-tl--followed-tags)) (tags (mastodon-tl--map-alist 'name followed-tags-json)) (tag (completing-read "Tag: " tags nil))) (if (null tag) (message "You have to follow some tags first.") (mastodon-tl--get-tag-timeline prefix tag)))) (defun mastodon-tl--followed-tags-timeline (&optional prefix) "Open a timeline of all your followed tags. PREFIX is sent to `mastodon-tl--show-tag-timeline', which see. Note that the number of tags supported is undocumented, and from manual testing appears to be limited to a total of four tags." (interactive "p") (let* ((followed-tags-json (mastodon-tl--followed-tags)) (tags (mastodon-tl--map-alist 'name followed-tags-json))) (mastodon-tl--show-tag-timeline prefix tags))) (defun mastodon-tl--some-followed-tags-timeline (&optional prefix) "Prompt for some tags, and open a timeline for them. The suggestions are from followed tags, but any other tags are also allowed. PREFIX is for `mastodon-tl--show-tag-timeline', which see." (interactive "p") (let* ((followed-tags-json (mastodon-tl--followed-tags)) (tags (mastodon-tl--map-alist 'name followed-tags-json)) (selection (completing-read-multiple "Tags' timelines to view [TAB to view, comma to separate]: " tags))) (mastodon-tl--show-tag-timeline prefix selection))) ;;; REPORT TO MODERATORS (defun mastodon-tl--instance-rules () "Return the rules of the user's instance." (let ((url (mastodon-http--api "instance/rules"))) (mastodon-http--get-json url nil :silent))) (defun mastodon-tl--report-params (account toot) "Query user and return report params alist. ACCOUNT and TOOT are the data to use." (let* ((account-id (alist-get 'id account)) (comment (read-string "Add comment [optional]: ")) (item-id (when (y-or-n-p "Also report status at point? ") (mastodon-tl--item-id toot))) ; base toot if poss (forward-p (when (y-or-n-p "Forward to remote admin? ") "true")) (rules (when (y-or-n-p "Cite a rule broken? ") (mastodon-tl--read-rules-ids))) (cat (unless rules (if (y-or-n-p "Spam? ") "spam" "other")))) (mastodon-tl--report-build-params account-id comment item-id forward-p cat rules))) (defun mastodon-tl--report-build-params (account-id comment item-id forward-p cat &optional rules) "Build the parameters alist based on user responses. ACCOUNT-ID, COMMENT, ITEM-ID, FORWARD-P, CAT, and RULES are all from `mastodon-tl--report-params', which see." (let ((params `(("account_id" . ,account-id) ,(when comment `("comment" . ,comment)) ,(when item-id `("status_ids[]" . ,item-id)) ,(when forward-p `("forward" . ,forward-p)) ,(when cat `("category" . ,cat))))) (when rules (let ((alist (mastodon-http--build-array-params-alist "rule_ids[]" rules))) (mapc (lambda (x) (push x params)) alist))) ;; FIXME: the above approach adds nils to your params. (setq params (delete nil params)) params)) (defun mastodon-tl--report-to-mods () "Report the author of the toot at point to your instance moderators. Optionally report the toot at point, add a comment, cite rules that have been broken, forward the report to the remove admin, report the account for spam." (interactive) (mastodon-tl--do-if-item (when (y-or-n-p "Report author of toot at point?") (let* ((url (mastodon-http--api "reports")) (toot (mastodon-tl--toot-or-base (mastodon-tl--property 'item-json :no-move))) (account (alist-get 'account toot)) (handle (alist-get 'acct account)) (params (mastodon-tl--report-params account toot)) (response (mastodon-http--post url params))) (mastodon-http--triage response (lambda (_) (message "User %s reported!" handle))))))) (defvar crm-separator) (defun mastodon-tl--map-rules-alist (rules) "Convert RULES text and id fields into an alist." (mapcar (lambda (x) (let-alist x (cons .text .id))) rules)) (defun mastodon-tl--read-rules-ids () "Prompt for a list of instance rules and return a list of selected ids." (let* ((rules (mastodon-tl--instance-rules)) (alist (mastodon-tl--map-rules-alist rules)) (crm-separator (replace-regexp-in-string "," "|" crm-separator)) (choices (completing-read-multiple "rules [TAB for options, | to separate]: " alist nil t))) (mapcar (lambda (x) (alist-get x alist nil nil #'equal)) choices))) ;;; UPDATING, etc. (defun mastodon-tl--more-json (endpoint id) "Return JSON for timeline ENDPOINT before ID." (let* ((args `(("max_id" . ,(mastodon-tl--as-string id)))) (url (mastodon-http--api endpoint))) (mastodon-http--get-json url args))) (defun mastodon-tl--more-json-async (endpoint id &optional params callback &rest cbargs) "Return JSON for timeline ENDPOINT before ID. Then run CALLBACK with arguments CBARGS. PARAMS is used to send any parameters needed to correctly update the current view." (let* ((args `(("max_id" . ,(mastodon-tl--as-string id)))) (args (if params (push (car args) params) args)) (url (if (string-suffix-p "search" endpoint) (mastodon-http--api-search) (mastodon-http--api endpoint)))) (apply #'mastodon-http--get-json-async url args callback cbargs))) (defun mastodon-tl--more-json-async-offset (endpoint &optional params callback &rest cbargs) "Return JSON for ENDPOINT, using the \"offset\" query param. This is used for pagination with endpoints that implement the \"offset\" parameter, rather than using link-headers or \"max_id\". PARAMS are the update parameters, see `mastodon-tl--update-params'. These (\"limit\" and \"offset\") must be set in `mastodon-tl--buffer-spec' for pagination to work. Then run CALLBACK with arguments CBARGS." (let* ((params (or params (mastodon-tl--update-params))) (limit (string-to-number (alist-get "limit" params nil nil #'equal))) (offset (number-to-string (+ limit ; limit + old offset = new offset (string-to-number (alist-get "offset" params nil nil #'equal))))) (url (if (string-suffix-p "search" endpoint) (mastodon-http--api-search) (mastodon-http--api endpoint)))) ;; increment: (setf (alist-get "offset" params nil nil #'equal) offset) (apply #'mastodon-http--get-json-async url params callback cbargs))) (defun mastodon-tl--updated-json (endpoint id &optional params) "Return JSON for timeline ENDPOINT since ID. PARAMS is used to send any parameters needed to correctly update the current view." (let* ((args `(("since_id" . ,(mastodon-tl--as-string id)))) (args (if params (push (car args) params) args)) (url (mastodon-http--api endpoint))) (mastodon-http--get-json url args))) ;; TODO: add this to new posts in some cases, e.g. in thread view. (defun mastodon-tl--reload-timeline-or-profile (&optional pos) "Reload the current timeline or profile page. For use after e.g. deleting a toot. POS is a number, where point will be placed." (let ((type (mastodon-tl--get-buffer-type))) (cond ((eq type 'home) (mastodon-tl--get-home-timeline)) ((eq type 'federated) (mastodon-tl--get-federated-timeline)) ((eq type 'local) (mastodon-tl--get-local-timeline)) ((eq type 'mentions) (mastodon-notifications--get-mentions)) ((eq type 'notifications) (mastodon-notifications-get nil nil :force)) ((eq type 'profile-statuses-no-boosts) (mastodon-profile--open-statuses-no-reblogs)) ((eq type 'profile-statuses) (mastodon-profile--my-profile)) ((eq type 'thread) (save-match-data (let ((endpoint (mastodon-tl--endpoint))) (string-match "statuses/\\(?2:[[:digit:]]+\\)/context" endpoint) (mastodon-tl--thread (match-string 2 endpoint)))))) ;; TODO: sends point to where point was in buffer. This is very rough; we ;; may have removed an item , so the buffer will be smaller, point will ;; end up past where we were, etc. (when pos (goto-char pos) (mastodon-tl--goto-prev-item)))) (defun mastodon-tl--build-link-header-url (str) "Return a URL from STR, an http Link header." (let* ((split (split-string str "; ")) (url-base (string-trim (car split) "<" ">")) (param (cadr split))) (concat url-base "&" param))) (defun mastodon-tl--use-link-header-p () "Return t if we are in a view needing Link header pagination. Currently this includes favourites, bookmarks, follow requests, and profile pages when showing followers or accounts followed." (or (mastodon-tl--buffer-type-eq 'favourites) (mastodon-tl--buffer-type-eq 'bookmarks) (mastodon-tl--buffer-type-eq 'profile-followers) (mastodon-tl--buffer-type-eq 'profile-following) (mastodon-tl--buffer-type-eq 'follow-requests))) (defun mastodon-tl--get-link-header-from-response (headers) "Get http Link header from list of http HEADERS." ;; pleroma uses "link", so case-insensitive match required: (when-let ((link-headers (alist-get "Link" headers nil nil #'cl-equalp))) (split-string link-headers ", "))) (defun mastodon-tl--more () "Append older toots to timeline, asynchronously." (message "Loading...") (if (mastodon-tl--use-link-header-p) ;; link-header paginate: ;; can't build a URL with --more-json-async, endpoint/id: ;; ensure we have a "next" type here, otherwise the CAR will be the ;; "prev" type! (let ((link-header (mastodon-tl--link-header))) (if (> 2 (length link-header)) (message "No next page") (let* ((next (car link-header)) ;;(prev (cadr (mastodon-tl--link-header))) (url (mastodon-tl--build-link-header-url next))) (mastodon-http--get-response-async url nil 'mastodon-tl--more* (current-buffer) (point) :headers)))) (cond ( ; no paginate (or (mastodon-tl--buffer-type-eq 'follow-suggestions) (mastodon-tl--buffer-type-eq 'filters) (mastodon-tl--buffer-type-eq 'lists)) (message "No more results")) ;; offset paginate (search, trending, user lists, ...?): ((or (string-prefix-p "*mastodon-trending-" (buffer-name)) (mastodon-tl--search-buffer-p)) (mastodon-tl--more-json-async-offset (mastodon-tl--endpoint) (mastodon-tl--update-params) 'mastodon-tl--more* (current-buffer) (point))) (t;; max_id paginate (timelines, items with ids/timestamps): (mastodon-tl--more-json-async (mastodon-tl--endpoint) (mastodon-tl--oldest-id) (mastodon-tl--update-params) 'mastodon-tl--more* (current-buffer) (point)))))) (defun mastodon-tl--more* (response buffer point-before &optional headers) "Append older toots to timeline, asynchronously. Runs the timeline's update function on RESPONSE, in BUFFER. When done, places point at POINT-BEFORE. HEADERS is the http headers returned in the response, if any." (with-current-buffer buffer (if (not response) (message "No more results") (let* ((inhibit-read-only t) (json (if headers (car response) response)) ;; FIXME: max-id pagination works for statuses only, not other ;; search results pages: (json (if (mastodon-tl--search-buffer-p) (cond ((equal "statuses" (mastodon-search--buf-type)) (cdr ; avoid repeat of last status (alist-get 'statuses response))) ((equal "hashtags" (mastodon-search--buf-type)) (alist-get 'hashtags response)) ((equal "accounts" (mastodon-search--buf-type)) (alist-get 'accounts response))) json)) (headers (if headers (cdr response) nil)) (link-header (mastodon-tl--get-link-header-from-response headers))) (goto-char (point-max)) (if (eq (mastodon-tl--get-buffer-type) 'thread) ;; if thread view, call --thread with parent ID (progn (goto-char (point-min)) (mastodon-tl--goto-next-item) (funcall (mastodon-tl--update-function)) (goto-char point-before) (message "Loaded full thread.")) (if (not json) (message "No more results.") (funcall (mastodon-tl--update-function) json) (goto-char point-before) ;; update buffer spec to new link-header: ;; (other values should just remain as they were) (when headers (mastodon-tl--set-buffer-spec (mastodon-tl--buffer-name) (mastodon-tl--endpoint) (mastodon-tl--update-function) link-header)) (message "Loading... done."))))))) (defun mastodon-tl--find-property-range (property start-point &optional search-backwards) "Return nil if no such range is found. If PROPERTY is set at START-POINT returns a range around START-POINT otherwise before/after START-POINT. SEARCH-BACKWARDS determines whether we pick point before (non-nil) or after (nil)" (if (get-text-property start-point property) ;; We are within a range, so look backwards for the start: (cons (previous-single-property-change (if (equal start-point (point-max)) start-point (1+ start-point)) property nil (point-min)) (next-single-property-change start-point property nil (point-max))) (if search-backwards (let* ((end (or (previous-single-property-change (if (equal start-point (point-max)) start-point (1+ start-point)) property) ;; we may either be just before the range or there ;; is nothing at all (and (not (equal start-point (point-min))) (get-text-property (1- start-point) property) start-point))) (start (and end (previous-single-property-change end property nil (point-min))))) (when end (cons start end))) (let* ((start (next-single-property-change start-point property)) (end (and start (next-single-property-change start property nil (point-max))))) (when start (cons start end)))))) (defun mastodon-tl--find-next-or-previous-property-range (property start-point search-backwards) "Find (start . end) property range after/before START-POINT. Does so while PROPERTY is set to a consistent value (different from the value at START-POINT if that is set). Return nil if no such range exists. If SEARCH-BACKWARDS is non-nil it find a region before START-POINT otherwise after START-POINT." (if (get-text-property start-point property) ;; We are within a range, we need to start the search from ;; before/after this range: (let ((current-range (mastodon-tl--find-property-range property start-point))) (if search-backwards (unless (equal (car current-range) (point-min)) (mastodon-tl--find-property-range property (1- (car current-range)) search-backwards)) (unless (equal (cdr current-range) (point-max)) (mastodon-tl--find-property-range property (1+ (cdr current-range)) search-backwards)))) ;; If we are not within a range, we can just defer to ;; mastodon-tl--find-property-range directly. (mastodon-tl--find-property-range property start-point search-backwards))) (defun mastodon-tl--consider-timestamp-for-updates (timestamp) "Take note that TIMESTAMP is used in buffer and ajust timers as needed. This calculates the next time the text for TIMESTAMP will change and may adjust existing or future timer runs should that time before current plans to run the update function. The adjustment is only made if it is significantly (a few seconds) before the currently scheduled time. This helps reduce the number of occasions where we schedule an update only to schedule the next one on completion to be within a few seconds. If relative timestamps are disabled (i.e. if `mastodon-tl--enable-relative-timestamps' is nil), this is a no-op." (when mastodon-tl--enable-relative-timestamps (let ((this-update (cdr (mastodon-tl--relative-time-details timestamp)))) (when (time-less-p this-update (time-subtract mastodon-tl--timestamp-next-update (seconds-to-time 10))) (setq mastodon-tl--timestamp-next-update this-update) (when mastodon-tl--timestamp-update-timer ;; We need to re-schedule for an earlier time (cancel-timer mastodon-tl--timestamp-update-timer) (setq mastodon-tl--timestamp-update-timer (run-at-time (time-to-seconds (time-subtract this-update (current-time))) nil ;; don't repeat #'mastodon-tl--update-timestamps-callback (current-buffer) nil))))))) (defun mastodon-tl--update-timestamps-callback (buffer previous-marker) "Update the next few timestamp displays in BUFFER. Start searching for more timestamps from PREVIOUS-MARKER or from the start if it is nil." ;; only do things if the buffer hasn't been killed in the meantime (when (and mastodon-tl--enable-relative-timestamps ; just in case (buffer-live-p buffer)) (save-excursion (with-current-buffer buffer (let ((previous-timestamp (if previous-marker (marker-position previous-marker) (point-min))) (iteration 0) next-timestamp-range) (if previous-marker ;; a follow-up call to process the next batch of timestamps. ;; Release the marker to not slow things down. (set-marker previous-marker nil) ;; Otherwise this is a rew run, so let's initialize the next-run time. (setq mastodon-tl--timestamp-next-update (time-add (current-time) (seconds-to-time 300)) mastodon-tl--timestamp-update-timer nil)) (while (and (< iteration 5) (setq next-timestamp-range (mastodon-tl--find-property-range 'timestamp previous-timestamp))) (let* ((start (car next-timestamp-range)) (end (cdr next-timestamp-range)) (timestamp (get-text-property start 'timestamp)) (current-display (get-text-property start 'display)) (new-display (mastodon-tl--relative-time-description timestamp))) (unless (string= current-display new-display) (let ((inhibit-read-only t)) (add-text-properties start end (list 'display (mastodon-tl--relative-time-description timestamp))))) (mastodon-tl--consider-timestamp-for-updates timestamp) (setq iteration (1+ iteration) previous-timestamp (1+ (cdr next-timestamp-range))))) (if next-timestamp-range ;; schedule the next batch from the previous location to ;; start very soon in the future: (run-at-time 0.1 nil #'mastodon-tl--update-timestamps-callback buffer (copy-marker previous-timestamp)) ;; otherwise we are done for now; schedule a new run for when needed (setq mastodon-tl--timestamp-update-timer (run-at-time (time-to-seconds (time-subtract mastodon-tl--timestamp-next-update (current-time))) nil ;; don't repeat #'mastodon-tl--update-timestamps-callback buffer nil)))))))) (defun mastodon-tl--set-after-update-marker () "Set `mastodon-tl--after-update-marker' to the after-update location. This location is defined by a non-nil value of `mastodon-tl-position-after-update'." (if (not mastodon-tl-position-after-update) (setq mastodon-tl--after-update-marker nil) (let ((marker (make-marker))) (set-marker marker (cond ((eq 'keep-point mastodon-tl-position-after-update) (point)) ((eq 'last-old-toot mastodon-tl-position-after-update) (next-single-property-change (or mastodon-tl--update-point (point-min)) 'byline)) (t (error "Unknown mastodon-tl-position-after-update value %S" mastodon-tl-position-after-update)))) ;; Make the marker advance if text gets inserted there. (set-marker-insertion-type marker t) (setq mastodon-tl--after-update-marker marker)))) (defun mastodon-tl--update () "Update timeline with new toots." (interactive) ;; FIXME: actually these buffers should just reload by calling their own ;; load function: (if (or (mastodon-tl--buffer-type-eq 'trending-statuses) (mastodon-tl--buffer-type-eq 'trending-tags) (mastodon-tl--buffer-type-eq 'follow-suggestions) (mastodon-tl--buffer-type-eq 'lists) (mastodon-tl--buffer-type-eq 'filters) (mastodon-tl--search-buffer-p)) (message "update not available in this view.") ;; FIXME: handle update for search and trending buffers (let* ((endpoint (mastodon-tl--endpoint)) (update-function (mastodon-tl--update-function))) ;; update a thread, without calling `mastodon-tl--updated-json': (if (mastodon-tl--buffer-type-eq 'thread) (let ((thread-id (mastodon-tl--property 'item-id))) (funcall update-function thread-id)) ;; update other timelines: (let* ((id (mastodon-tl--newest-id)) (params (mastodon-tl--update-params)) (json (mastodon-tl--updated-json endpoint id params))) (if json (let ((inhibit-read-only t)) (mastodon-tl--set-after-update-marker) (goto-char (or mastodon-tl--update-point (point-min))) (funcall update-function json) (when mastodon-tl--after-update-marker (goto-char mastodon-tl--after-update-marker))) (message "nothing to update"))))))) ;;; LOADING TIMELINES (defun mastodon-tl--init (buffer-name endpoint update-function &optional headers params hide-replies) "Initialize BUFFER-NAME with timeline targeted by ENDPOINT asynchronously. UPDATE-FUNCTION is used to recieve more toots. HEADERS means to also collect the response headers. Used for paginating favourites and bookmarks. PARAMS is any parameters to send with the request. HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer." (let ((url (mastodon-http--api endpoint)) (buffer (concat "*mastodon-" buffer-name "*"))) (if headers (mastodon-http--get-response-async url params 'mastodon-tl--init* buffer endpoint update-function headers params hide-replies) (mastodon-http--get-json-async url params 'mastodon-tl--init* buffer endpoint update-function nil params hide-replies)))) (defun mastodon-tl--init* (response buffer endpoint update-function &optional headers update-params hide-replies) "Initialize BUFFER with timeline targeted by ENDPOINT. UPDATE-FUNCTION is used to recieve more toots. RESPONSE is the data returned from the server by `mastodon-http--process-json', with arg HEADERS a cons cell of JSON and http headers, without it just the JSON." (let ((json (if headers (car response) response))) (if (not json) ; praying this is right here, else try "\n[]" (message "Looks like nothing returned from endpoint: %s" endpoint) (let* ((headers (if headers (cdr response) nil)) (link-header (mastodon-tl--get-link-header-from-response headers))) (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-tl--set-buffer-spec buffer endpoint update-function link-header update-params hide-replies) (mastodon-tl--do-init json update-function)))))) (defun mastodon-tl--init-sync (buffer-name endpoint update-function &optional note-type params headers view-name binding-str) "Initialize BUFFER-NAME with timeline targeted by ENDPOINT. UPDATE-FUNCTION is used to receive more toots. Runs synchronously. Optional arg NOTE-TYPE means only get that type of note. PARAMS is an alist of any params to include in the request. HEADERS are any headers to send in the request. VIEW-NAME is a string, to be used as a heading for the view. BINDING-STR is a string explaining any bindins in the view." ;; Used by `mastodon-notifications-get' and in views.el (let* ((exclude-types (when note-type (mastodon-notifications--filter-types-list note-type))) (notes-params (when note-type (mastodon-http--build-array-params-alist "exclude_types[]" exclude-types))) (params (append notes-params params)) (url (mastodon-http--api endpoint)) (buffer (concat "*mastodon-" buffer-name "*")) (response (mastodon-http--get-response url params)) (json (car response)) (headers (when headers (cdr response))) (link-header (when headers (mastodon-tl--get-link-header-from-response headers)))) (with-mastodon-buffer buffer #'mastodon-mode nil ;; insert view-name/ heading-str (when view-name (mastodon-search--insert-heading view-name)) (when binding-str (insert (mastodon-tl--set-face (concat "[" binding-str "]\n\n") 'font-lock-comment-face))) (mastodon-tl--set-buffer-spec buffer endpoint update-function link-header params) (mastodon-tl--do-init json update-function) buffer))) (defun mastodon-tl--do-init (json update-fun) "Utility function for `mastodon-tl--init*' and `mastodon-tl--init-sync'. JSON is the data to call UPDATE-FUN on." (remove-overlays) ; video overlays (funcall update-fun json) (setq ;; Initialize with a minimal interval; we re-scan at least once ;; every 5 minutes to catch any timestamps we may have missed mastodon-tl--timestamp-next-update (time-add (current-time) (seconds-to-time 300))) (setq mastodon-tl--timestamp-update-timer (when mastodon-tl--enable-relative-timestamps (run-at-time (time-to-seconds (time-subtract mastodon-tl--timestamp-next-update (current-time))) nil ;; don't repeat #'mastodon-tl--update-timestamps-callback (current-buffer) nil))) (unless (mastodon-tl--profile-buffer-p) (mastodon-tl--goto-first-item))) (provide 'mastodon-tl) ;;; mastodon-tl.el ends here mastodon.el/lisp/mastodon-toot.el000066400000000000000000002361641452000115200174030ustar00rootroot00000000000000;;; mastodon-toot.el --- Minor mode for sending Mastodon toots -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-toot.el supports POSTing status data to Mastodon. ;;; Code: (eval-when-compile (require 'subr-x)) (require 'emojify nil :noerror) (declare-function emojify-insert-emoji "emojify") (declare-function emojify-set-emoji-data "emojify") (defvar emojify-emojis-dir) (defvar emojify-user-emojis) (require 'cl-lib) (require 'persist) (require 'mastodon-iso) (require 'facemenu) (require 'text-property-search) (eval-when-compile (require 'mastodon-tl)) (defvar mastodon-instance-url) (defvar mastodon-tl--buffer-spec) (defvar mastodon-tl--enable-proportional-fonts) (defvar mastodon-profile-account-settings) (autoload 'iso8601-parse "iso8601") (autoload 'mastodon-auth--user-acct "mastodon-auth") (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--build-array-params-alist "mastodon-http") (autoload 'mastodon-http--delete "mastodon-http") (autoload 'mastodon-http--get-json "mastodon-http") (autoload 'mastodon-http--get-json-async "mastodon-http") (autoload 'mastodon-http--post "mastodon-http") (autoload 'mastodon-http--post-media-attachment "mastodon-http") (autoload 'mastodon-http--process-json "mastodon-http") (autoload 'mastodon-http--put "mastodon-http") (autoload 'mastodon-http--read-file-as-string "mastodon-http") (autoload 'mastodon-http--triage "mastodon-http") (autoload 'mastodon-profile--fetch-server-account-settings "mastodon-profile") (autoload 'mastodon-profile--fetch-server-account-settings-maybe "mastodon-profile") (autoload 'mastodon-profile--get-source-pref "mastodon-profile") (autoload 'mastodon-profile--show-user "mastodon-profile") (autoload 'mastodon-profile--update-preference "mastodon-profile") (autoload 'mastodon-search--search-accounts-query "mastodon-search") (autoload 'mastodon-search--search-tags-query "mastodon-search") (autoload 'mastodon-tl--as-string "mastodon-tl") (autoload 'mastodon-tl--buffer-type-eq "mastodon-tl") (autoload 'mastodon-tl--clean-tabs-and-nl "mastodon-tl") (autoload 'mastodon-tl--do-if-item-strict "mastodon-tl") (autoload 'mastodon-tl--field "mastodon-tl") (autoload 'mastodon-tl--find-property-range "mastodon-tl") (autoload 'mastodon-tl--find-property-range "mastodon-tl") (autoload 'mastodon-tl--goto-next-item "mastodon-tl") (autoload 'mastodon-tl--map-alist "mastodon-tl") (autoload 'mastodon-tl--property "mastodon-tl") (autoload 'mastodon-tl--reload-timeline-or-profile "mastodon-tl") (autoload 'mastodon-tl--render-text "mastodon-tl") (autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") (autoload 'mastodon-tl--symbol "mastodon-tl") (autoload 'mastodon-tl--item-id "mastodon-tl") (autoload 'mastodon-toot "mastodon") (autoload 'mastodon-views--cancel-scheduled-toot "mastodon-views") (autoload 'mastodon-views--view-scheduled-toots "mastodon-views") (autoload 'org-read-date "org") (autoload 'mastodon-tl--toot-or-base "mastodon-tl") ;; for mastodon-toot--translate-toot-text (autoload 'mastodon-tl--content "mastodon-tl") (when (require 'lingva nil :no-error) (declare-function lingva-translate "lingva")) (defgroup mastodon-toot nil "Tooting in Mastodon." :prefix "mastodon-toot-" :group 'mastodon) (defcustom mastodon-toot--default-media-directory "~/" "The default directory when prompting for a media file to upload." :type 'string) (defcustom mastodon-toot--attachment-height 80 "Height of the attached images preview in the toot draft buffer." :type 'integer) (defcustom mastodon-toot--enable-completion t "Whether to enable completion of mentions and hashtags. Used for completion in toot compose buffer." :type 'boolean) (defcustom mastodon-toot--use-company-for-completion nil "Whether to enable company for completion. When non-nil, `company-mode' is enabled in the toot compose buffer, and mastodon completion backends are added to `company-capf'. You need to install company yourself to use this." :type 'boolean) (defcustom mastodon-toot--completion-style-for-mentions "all" "The company completion style to use for mentions." :type '(choice (const :tag "off" nil) (const :tag "following only" "following") (const :tag "all users" "all"))) (defcustom mastodon-toot-display-orig-in-reply-buffer nil "Display a copy of the toot replied to in the compose buffer." :type 'boolean) (defcustom mastodon-toot-orig-in-reply-length 191 ;; three lines of divider width: (- (* 3 67) (length " Reply to: ")) "Length to crop toot replied to in the compose buffer to." :type 'integer) (defcustom mastodon-toot--default-reply-visibility "public" "Default visibility settings when replying. If the original toot visibility is different we use the more restricted one." :type '(choice (const :tag "public" "public") (const :tag "unlisted" "unlisted") (const :tag "followers only" "private") (const :tag "direct" "direct"))) (defcustom mastodon-toot--enable-custom-instance-emoji nil "Whether to enable your instance's custom emoji by default." :type 'boolean) (defcustom mastodon-toot--proportional-fonts-compose nil "Nonnil to enable using proportional fonts in the compose buffer. By default fixed width fonts are used." :type '(boolean :tag "Enable using proportional rather than fixed \ width fonts")) (defvar-local mastodon-toot--content-warning nil "A flag whether the toot should be marked with a content warning.") (defvar-local mastodon-toot--content-warning-from-reply-or-redraft nil "The content warning of the toot being replied to.") (defvar-local mastodon-toot--content-nsfw nil "A flag indicating whether the toot should be marked as NSFW.") (defvar mastodon-toot-visibility-list '(direct private unlisted public) "A list of the available toot visibility settings.") (defvar-local mastodon-toot--visibility nil "A string indicating the visibility of the toot being composed. Valid values are \"direct\", \"private\" (followers-only), \"unlisted\", and \"public\". This is determined by the account setting on the server. To change the setting on the server, see `mastodon-toot--set-default-visibility'.") (defvar-local mastodon-toot--media-attachments nil "A list of the media attachments of the toot being composed.") (defvar-local mastodon-toot--media-attachment-ids nil "A list of any media attachment ids of the toot being composed.") (defvar-local mastodon-toot-poll nil "A list of poll options for the toot being composed.") (defvar-local mastodon-toot--language nil "The language of the toot being composed, in ISO 639 (two-letter).") (defvar-local mastodon-toot--scheduled-for nil "An ISO 8601 timestamp that specifying when the post should be published. Should be at least 5 minutes into the future.") (defvar-local mastodon-toot--scheduled-id nil "The id of the scheduled post that we are now editing.") (defvar-local mastodon-toot--reply-to-id nil "Buffer-local variable to hold the id of the toot being replied to.") (defvar-local mastodon-toot--edit-item-id nil "The id of the toot being edited.") (defvar-local mastodon-toot-previous-window-config nil "A list of window configuration prior to composing a toot. Takes its form from `window-configuration-to-register'.") (defvar mastodon-toot--max-toot-chars nil "The maximum allowed characters count for a single toot.") (defvar-local mastodon-toot-completions nil "The data of completion candidates for the current completion at point.") (defvar mastodon-toot-current-toot-text nil "The text of the toot being composed.") (persist-defvar mastodon-toot-draft-toots-list nil "A list of toots that have been saved as drafts. For the moment we just put all composed toots in here, as we want to also capture toots that are \"sent\" but that don't successfully send.") ;;; REGEXES (defvar mastodon-toot-handle-regex (rx (| (any ?\( "\n" "\t "" ") bol) ; preceding things (group-n 2 (+ ?@ (* (any ?- ?_ ?. "A-Z" "a-z" "0-9" ))) ; handle (? ?@ (* (not (any "\n" "\t" " "))))) ; optional domain (| "'" word-boundary))) ; boundary or possessive (defvar mastodon-toot-tag-regex (rx (| (any ?\( "\n" "\t" " ") bol) (group-n 2 ?# (+ (any "A-Z" "a-z" "0-9"))) (| "'" word-boundary))) ; boundary or possessive (defvar mastodon-toot-url-regex ;; adapted from ffap-url-regexp (concat "\\(?2:\\(news\\(post\\)?:\\|mailto:\\|file:\\|\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://\\)" ; uri prefix "[^ \n\t]*\\)" ; any old thing, that is, i.e. we allow invalid/unwise chars ;; "[ .,:;!?]\\b")) "\\>")) ; boundary end ;;; MODE MAP (defvar mastodon-toot-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-c") #'mastodon-toot--send) (define-key map (kbd "C-c C-k") #'mastodon-toot--cancel) (define-key map (kbd "C-c C-w") #'mastodon-toot--toggle-warning) (define-key map (kbd "C-c C-n") #'mastodon-toot--toggle-nsfw) (define-key map (kbd "C-c C-v") #'mastodon-toot--change-visibility) (when (require 'emojify nil :noerror) (define-key map (kbd "C-c C-e") #'mastodon-toot--insert-emoji)) (define-key map (kbd "C-c C-a") #'mastodon-toot--attach-media) (define-key map (kbd "C-c !") #'mastodon-toot--clear-all-attachments) (define-key map (kbd "C-c C-p") #'mastodon-toot--create-poll) (define-key map (kbd "C-c C-l") #'mastodon-toot--set-toot-language) (define-key map (kbd "C-c C-s") #'mastodon-toot--schedule-toot) map) "Keymap for `mastodon-toot'.") (defun mastodon-toot--set-default-visibility () "Set the default visibility for toots on the server." (interactive) (let ((vis (completing-read "Set default visibility to:" mastodon-toot-visibility-list nil t))) (mastodon-profile--update-preference "privacy" vis :source))) (defun mastodon-toot--get-max-toot-chars (&optional no-toot) "Fetch max_toot_chars from `mastodon-instance-url' asynchronously. NO-TOOT means we are not calling from a toot buffer." (mastodon-http--get-json-async (mastodon-http--api "instance") nil 'mastodon-toot--get-max-toot-chars-callback no-toot)) (defun mastodon-toot--get-max-toot-chars-callback (json-response &optional no-toot) "Set max_toot_chars returned in JSON-RESPONSE and display in new toot buffer. NO-TOOT means we are not calling from a toot buffer." (let ((max-chars (or (alist-get 'max_toot_chars json-response) (alist-get 'max_characters ; some servers have this instead (alist-get 'statuses (alist-get 'configuration json-response)))))) (setq mastodon-toot--max-toot-chars max-chars) (unless no-toot (with-current-buffer "*new toot*" (mastodon-toot--update-status-fields))))) (defun mastodon-toot--action-success (marker byline-region remove) "Insert/remove the text MARKER with `success' face in byline. BYLINE-REGION is a cons of start and end pos of the byline to be modified. Remove MARKER if REMOVE is non-nil, otherwise add it." (let ((inhibit-read-only t) (bol (car byline-region)) (eol (cdr byline-region)) (at-byline-p (eq (mastodon-tl--property 'byline :no-move) t))) (save-excursion (when remove (goto-char bol) (beginning-of-line) ;; The marker is not part of the byline (if (search-forward (format "(%s) " marker) eol t) (replace-match "") (message "Oops: could not find marker '(%s)'" marker))) (unless remove (goto-char bol) (insert (propertize (format "(%s) " (propertize marker 'face 'success)) 'cursor-face 'mastodon-cursor-highlight-face)))) (when at-byline-p ;; leave point after the marker: (unless remove ;; if point is inside the byline, back up first so ;; we don't move to the following toot: (beginning-of-line) (forward-line -1) (mastodon-tl--goto-next-item))))) (defun mastodon-toot--action (action callback) "Take ACTION on toot at point, then execute CALLBACK. Makes a POST request to the server. Used for favouriting, boosting, or bookmarking toots." (let* ((id (mastodon-tl--property 'base-item-id)) (url (mastodon-http--api (concat "statuses/" (mastodon-tl--as-string id) "/" action))) (response (mastodon-http--post url))) (mastodon-http--triage response callback))) (defun mastodon-toot--toggle-boost-or-favourite (type) "Toggle boost or favourite of toot at `point'. TYPE is a symbol, either `favourite' or `boost.'" (mastodon-tl--do-if-item-strict (let* ((boost-p (equal type 'boost)) ;; (has-id (mastodon-tl--property 'base-item-id)) (byline-region ;(when has-id (mastodon-tl--find-property-range 'byline (point))) (id (when byline-region (mastodon-tl--as-string (mastodon-tl--property 'base-item-id)))) (boosted (when byline-region (get-text-property (car byline-region) 'boosted-p))) (faved (when byline-region (get-text-property (car byline-region) 'favourited-p))) (action (if boost-p (if boosted "unreblog" "reblog") (if faved "unfavourite" "favourite"))) (msg (if boosted "unboosted" "boosted")) (action-string (if boost-p "boost" "favourite")) (remove (if boost-p (when boosted t) (when faved t))) (item-json (mastodon-tl--property 'item-json)) (toot-type (alist-get 'type item-json)) (visibility (mastodon-tl--field 'visibility item-json))) (if byline-region (if (and (or (equal visibility "direct") (equal visibility "private")) boost-p) (message "You cant boost posts with visibility: %s" visibility) (cond ;; actually there's nothing wrong with faving/boosting own toots! ;;((mastodon-toot--own-toot-p (mastodon-tl--property 'item-json)) ;;(error "You can't %s your own toots" action-string)) ;; & nothing wrong with faving/boosting own toots from notifs: ;; this boosts/faves the base toot, not the notif status ((and (equal "reblog" toot-type) (not (mastodon-tl--buffer-type-eq 'notifications))) (user-error "You can't %s boosts" action-string)) ((and (equal "favourite" toot-type) (not (mastodon-tl--buffer-type-eq 'notifications))) (user-error "You can't %s favourites" action-string)) ((and (equal "private" visibility) (equal type 'boost)) (user-error "You can't boost private toots")) (t (mastodon-toot--action action (lambda (_) (let ((inhibit-read-only t)) (add-text-properties (car byline-region) (cdr byline-region) (if boost-p (list 'boosted-p (not boosted)) (list 'favourited-p (not faved)))) (mastodon-toot--update-stats-on-action type remove) (mastodon-toot--action-success (if boost-p (mastodon-tl--symbol 'boost) (mastodon-tl--symbol 'favourite)) byline-region remove)) (message (format "%s #%s" (if boost-p msg action) id))))))) (message (format "Nothing to %s here?!?" action-string)))))) (defun mastodon-toot--inc-or-dec (count subtract) "If SUBTRACT, decrement COUNT, else increment." (if subtract (1- count) (1+ count))) (defun mastodon-toot--update-stats-on-action (action &optional subtract) "Increment the toot stats display upon ACTION. ACTION is a symbol, either `favourite' or `boost'. SUBTRACT means we are un-favouriting or unboosting, so we decrement." (let* ((count-prop (if (eq action 'favourite) 'favourites-count 'boosts-count)) (count-prop-range (mastodon-tl--find-property-range count-prop (point))) (count (get-text-property (car count-prop-range) count-prop)) (inhibit-read-only 1)) ;; TODO another way to implement this would be to async fetch counts again ;; and re-display from count-properties (add-text-properties (car count-prop-range) (cdr count-prop-range) (list 'display (number-to-string (mastodon-toot--inc-or-dec count subtract)) ;; update the count prop ;; we rely on this for any subsequent actions: count-prop (mastodon-toot--inc-or-dec count subtract))))) (defun mastodon-toot--toggle-boost () "Boost/unboost toot at `point'." (interactive) (mastodon-toot--toggle-boost-or-favourite 'boost)) (defun mastodon-toot--toggle-favourite () "Favourite/unfavourite toot at `point'." (interactive) (mastodon-toot--toggle-boost-or-favourite 'favourite)) ;; TODO maybe refactor into boost/fave fun (defun mastodon-toot--toggle-bookmark () "Bookmark or unbookmark toot at point." (interactive) (mastodon-tl--do-if-item-strict (let* ((id (mastodon-tl--property 'base-item-id)) (bookmarked-p (mastodon-tl--property 'bookmarked-p)) (byline-region (when id (mastodon-tl--find-property-range 'byline (point)))) (action (if bookmarked-p "unbookmark" "bookmark")) (bookmark-str (mastodon-tl--symbol 'bookmark)) (message (if bookmarked-p "Bookmark removed!" "Toot bookmarked!")) (remove (when bookmarked-p t))) (if byline-region (mastodon-toot--action action (lambda (_) (let ((inhibit-read-only t)) (add-text-properties (car byline-region) (cdr byline-region) (list 'bookmarked-p (not bookmarked-p)))) (mastodon-toot--action-success bookmark-str byline-region remove) (message (format "%s #%s" message id)))) (message (format "Nothing to %s here?!?" action)))))) (defun mastodon-toot--list-toot-boosters () "List the boosters of toot at point." (interactive) (mastodon-toot--list-toot-boosters-or-favers)) (defun mastodon-toot--list-toot-favouriters () "List the favouriters of toot at point." (interactive) (mastodon-toot--list-toot-boosters-or-favers :favourite)) (defun mastodon-toot--list-toot-boosters-or-favers (&optional favourite) "List the favouriters or boosters of toot at point. With FAVOURITE, list favouriters, else list boosters." (mastodon-tl--do-if-item-strict (let* ((base-toot (mastodon-tl--property 'base-item-id)) (endpoint (if favourite "favourited_by" "reblogged_by")) (url (mastodon-http--api (format "statuses/%s/%s" base-toot endpoint))) (params '(("limit" . "80"))) (json (mastodon-http--get-json url params))) (if (eq (caar json) 'error) (user-error "%s (Status does not exist or is private)" (alist-get 'error json)) (let ((handles (mastodon-tl--map-alist 'acct json)) (type-string (if favourite "Favouriters" "Boosters"))) (if (not handles) (user-error "Looks like this toot has no %s" type-string) (let ((choice (completing-read (format "%s (enter to view profile): " type-string) handles nil t))) (mastodon-profile--show-user choice)))))))) (defun mastodon-toot--copy-toot-url () "Copy URL of toot at point. If the toot is a fave/boost notification, copy the URL of the base toot." (interactive) (let* ((url (mastodon-toot--toot-url))) (kill-new url) (message "Toot URL copied to the clipboard."))) (defun mastodon-toot--toot-url () "Return the URL of the base toot at point." (let* ((toot (or (mastodon-tl--property 'base-toot) (mastodon-tl--property 'item-json)))) (if (mastodon-tl--field 'reblog toot) (alist-get 'url (alist-get 'reblog toot)) (alist-get 'url toot)))) (defun mastodon-toot--copy-toot-text () "Copy text of toot at point. If the toot is a fave/boost notification, copy the text of the base toot." (interactive) (let* ((toot (or (mastodon-tl--property 'base-toot) (mastodon-tl--property 'item-json)))) (kill-new (mastodon-tl--content toot)) (message "Toot content copied to the clipboard."))) (defun mastodon-toot--translate-toot-text () "Translate text of toot at point. Uses `lingva.el'." (interactive) (if (not (require 'lingva nil :no-error)) (message "Looks like you need to install lingva.el first.") (if mastodon-tl--buffer-spec (if-let ((toot (mastodon-tl--property 'item-json))) (lingva-translate nil (mastodon-tl--content toot) (when mastodon-tl--enable-proportional-fonts t)) (message "No toot to translate?")) (message "No mastodon buffer?")))) (defun mastodon-toot--own-toot-p (toot) "Check if TOOT is user's own, for deleting, editing, or pinning it." ;; this check needs to allow acting on own toots displayed as boosts, so we ;; call `mastodon-tl--toot-or-base'. (let ((json (mastodon-tl--toot-or-base toot))) (equal (alist-get 'acct (alist-get 'account json)) (mastodon-auth--user-acct)))) (defun mastodon-toot--pin-toot-toggle () "Pin or unpin user's toot at point." (interactive) (let* ((toot (or (mastodon-tl--property 'base-toot) ;fave/boost notifs (mastodon-tl--property 'item-json))) (pinnable-p (mastodon-toot--own-toot-p toot)) (pinned-p (equal (alist-get 'pinned toot) t)) (action (if pinned-p "unpin" "pin")) (msg (if pinned-p "unpinned" "pinned")) (msg-y-or-n (if pinned-p "Unpin" "Pin"))) (if (not pinnable-p) (message "You can only pin your own toots.") (when (y-or-n-p (format "%s this toot? " msg-y-or-n)) (mastodon-toot--action action (lambda (_) (when mastodon-tl--buffer-spec (mastodon-tl--reload-timeline-or-profile)) (message "Toot %s!" msg))))))) ;;; DELETE, DRAFT, REDRAFT (defun mastodon-toot--delete-toot () "Delete user's toot at point synchronously." (interactive) (mastodon-toot--delete-and-redraft-toot t)) ;; TODO: handle media/poll for redrafting toots (defun mastodon-toot--delete-and-redraft-toot (&optional no-redraft) "Delete and redraft user's toot at point synchronously. NO-REDRAFT means delete toot only." (interactive) (let* ((toot (or (mastodon-tl--property 'base-toot) ;fave/boost notifs (mastodon-tl--property 'item-json))) (id (mastodon-tl--as-string (mastodon-tl--item-id toot))) (url (mastodon-http--api (format "statuses/%s" id))) (toot-cw (alist-get 'spoiler_text toot)) (toot-visibility (alist-get 'visibility toot)) (reply-id (alist-get 'in_reply_to_id toot)) (pos (point))) (if (not (mastodon-toot--own-toot-p toot)) (message "You can only delete (and redraft) your own toots.") (when (y-or-n-p (if no-redraft (format "Delete this toot? ") (format "Delete and redraft this toot? "))) (let* ((response (mastodon-http--delete url))) (mastodon-http--triage response (lambda (_) (if no-redraft (progn (when mastodon-tl--buffer-spec (mastodon-tl--reload-timeline-or-profile pos)) (message "Toot deleted!")) (mastodon-toot--redraft response reply-id toot-visibility toot-cw))))))))) (defun mastodon-toot--set-cw (&optional cw) "Set content warning to CW if it is non-nil." (unless (or (null cw) ; cw is nil for `mastodon-tl--dm-user' (string-empty-p cw)) (setq mastodon-toot--content-warning t) (setq mastodon-toot--content-warning-from-reply-or-redraft cw))) ;;; REDRAFT (defun mastodon-toot--redraft (response &optional reply-id toot-visibility toot-cw) "Opens a new toot compose buffer using values from RESPONSE buffer. REPLY-ID, TOOT-VISIBILITY, and TOOT-CW of deleted toot are preseved." (with-current-buffer response (let* ((json-response (mastodon-http--process-json)) (content (alist-get 'text json-response))) (mastodon-toot--compose-buffer) (goto-char (point-max)) (insert content) ;; adopt reply-to-id, visibility and CW from deleted toot: (mastodon-toot--set-toot-properties reply-id toot-visibility toot-cw ;; TODO set new lang/scheduled props here nil)))) (defun mastodon-toot--set-toot-properties (reply-id visibility cw lang &optional scheduled scheduled-id) "Set the toot properties for the current redrafted or edited toot. REPLY-ID, VISIBILITY, CW, SCHEDULED, and LANG are the properties to set." (when reply-id (setq mastodon-toot--reply-to-id reply-id)) (setq mastodon-toot--visibility visibility) (setq mastodon-toot--scheduled-for scheduled) (setq mastodon-toot--scheduled-id scheduled-id) (when (not (string-empty-p lang)) (setq mastodon-toot--language lang)) (mastodon-toot--set-cw cw) (mastodon-toot--update-status-fields)) (defun mastodon-toot--kill (&optional cancel) "Kill `mastodon-toot-mode' buffer and window. CANCEL means the toot was not sent, so we save the toot text as a draft." (let ((prev-window-config mastodon-toot-previous-window-config)) (unless (eq mastodon-toot-current-toot-text nil) (when cancel (cl-pushnew mastodon-toot-current-toot-text mastodon-toot-draft-toots-list :test 'equal))) ;; prevent some weird bug when cancelling a non-empty toot: (delete #'mastodon-toot--save-toot-text after-change-functions) (kill-buffer-and-window) (mastodon-toot--restore-previous-window-config prev-window-config))) (defun mastodon-toot--cancel () "Kill new-toot buffer/window. Does not POST content to Mastodon. If toot is not empty, prompt to save text as a draft." (interactive) (if (mastodon-toot--empty-p) (mastodon-toot--kill) (when (y-or-n-p "Save draft toot?") (mastodon-toot--save-draft)) (mastodon-toot--kill))) (defun mastodon-toot--save-draft () "Save the current compose toot text as a draft. Pushes `mastodon-toot-current-toot-text' to `mastodon-toot-draft-toots-list'." (interactive) (unless (eq mastodon-toot-current-toot-text nil) (cl-pushnew mastodon-toot-current-toot-text mastodon-toot-draft-toots-list :test 'equal) (message "Draft saved!"))) (defun mastodon-toot--empty-p (&optional text-only) "Return t if toot has no text, attachments, or polls. TEXT-ONLY means don't check for attachments or polls." (and (if text-only t (and (not mastodon-toot--media-attachments) (not mastodon-toot-poll))) (string-empty-p (mastodon-tl--clean-tabs-and-nl (mastodon-toot--remove-docs))))) ;;; EMOJIS (defalias 'mastodon-toot--insert-emoji #'emojify-insert-emoji "Prompt to insert an emoji.") (defun mastodon-toot--emoji-dir () "Return the file path for the mastodon custom emojis directory." (concat (expand-file-name emojify-emojis-dir) "/mastodon-custom-emojis/")) (defun mastodon-toot--download-custom-emoji () "Download `mastodon-instance-url's custom emoji. Emoji images are stored in a subdir of `emojify-emojis-dir'. To use the downloaded emoji, run `mastodon-toot--enable-custom-emoji'." (interactive) (let* ((url (mastodon-http--api "custom_emojis")) (custom-emoji (mastodon-http--get-json url)) (mastodon-custom-emoji-dir (mastodon-toot--emoji-dir))) (if (not (file-directory-p emojify-emojis-dir)) (message "Looks like you need to set up emojify first.") (unless (file-directory-p mastodon-custom-emoji-dir) (make-directory mastodon-custom-emoji-dir nil)) ; no add parent (mapc (lambda (x) (let ((url (alist-get 'url x)) (shortcode (alist-get 'shortcode x))) ;; skip anything that contains unexpected characters (when (and url shortcode (string-match-p "^[a-zA-Z0-9-_]+$" shortcode) (string-match-p "^[a-zA-Z]+$" (file-name-extension url))) (url-copy-file url (concat mastodon-custom-emoji-dir shortcode "." (file-name-extension url)) t)))) custom-emoji) (message "Custom emoji for %s downloaded to %s" mastodon-instance-url mastodon-custom-emoji-dir)))) (defun mastodon-toot--collect-custom-emoji () "Return a list of `mastodon-instance-url's custom emoji. The list is formatted for `emojify-user-emojis', which see." (let* ((mastodon-custom-emojis-dir (mastodon-toot--emoji-dir)) (custom-emoji-files (directory-files mastodon-custom-emojis-dir nil ; not full path "^[^.]")) ; no dot files mastodon-emojify-user-emojis) (mapc (lambda (x) (push `(,(concat ":" (file-name-base x) ":") . (("name" . ,(file-name-base x)) ("image" . ,(concat mastodon-custom-emojis-dir x)) ("style" . "github"))) mastodon-emojify-user-emojis)) custom-emoji-files) (reverse mastodon-emojify-user-emojis))) (defun mastodon-toot--enable-custom-emoji () "Add `mastodon-instance-url's custom emoji to `emojify'. Custom emoji must first be downloaded with `mastodon-toot--download-custom-emoji'. Custom emoji are appended to `emojify-user-emojis', and the emoji data is updated." (interactive) (unless (file-exists-p (mastodon-toot--emoji-dir)) (when (y-or-n-p "Looks like you haven't downloaded your instance's custom emoji yet. Download now? ") (mastodon-toot--download-custom-emoji))) (let ((masto-emojis (mastodon-toot--collect-custom-emoji))) (unless (cl-find (car masto-emojis) emojify-user-emojis :test #'equal) (setq emojify-user-emojis (append masto-emojis emojify-user-emojis)) ;; if already loaded, reload (when (featurep 'emojify) ;; we now only do this within the unless test above, as it is extremely ;; slow and runs in `mastodon-mode-hook'. (emojify-set-emoji-data))))) (defun mastodon-toot--remove-docs () "Get the body of a toot from the current compose buffer." (let ((header-region (mastodon-tl--find-property-range 'toot-post-header (point-min)))) (buffer-substring (cdr header-region) (point-max)))) (defun mastodon-toot--build-poll-params () "Return an alist of parameters for POSTing a poll status." (append (mastodon-http--build-array-params-alist "poll[options][]" (plist-get mastodon-toot-poll :options)) `(("poll[expires_in]" . ,(plist-get mastodon-toot-poll :expiry))) `(("poll[multiple]" . ,(symbol-name (plist-get mastodon-toot-poll :multi)))) `(("poll[hide_totals]" . ,(symbol-name (plist-get mastodon-toot-poll :hide)))))) (defun mastodon-toot--read-cw-string () "Read a content warning from the minibuffer." (when (and (not (mastodon-toot--empty-p)) mastodon-toot--content-warning) (read-string "Warning: " mastodon-toot--content-warning-from-reply-or-redraft))) ;;; SEND TOOT FUNCTION (defun mastodon-toot--send () "POST contents of new-toot buffer to Mastodon instance and kill buffer. If media items have been attached and uploaded with `mastodon-toot--attach-media', they are attached to the toot. If `mastodon-toot--edit-item-id' is non-nil, PUT contents to instance to edit a toot." (interactive) (let* ((toot (mastodon-toot--remove-docs)) (scheduled mastodon-toot--scheduled-for) (scheduled-id mastodon-toot--scheduled-id) (edit-id mastodon-toot--edit-item-id) (endpoint (if edit-id ; we are sending an edit: (mastodon-http--api (format "statuses/%s" edit-id)) (mastodon-http--api "statuses"))) (cw (mastodon-toot--read-cw-string)) (args-no-media (append `(("status" . ,toot) ("in_reply_to_id" . ,mastodon-toot--reply-to-id) ("visibility" . ,mastodon-toot--visibility) ("sensitive" . ,(when mastodon-toot--content-nsfw (symbol-name t))) ("spoiler_text" . ,cw) ("language" . ,mastodon-toot--language)) ;; Pleroma instances can't handle null-valued ;; scheduled_at args, so only add if non-nil (when scheduled `(("scheduled_at" . ,scheduled))))) (args-media (when mastodon-toot--media-attachments (mastodon-http--build-array-params-alist "media_ids[]" mastodon-toot--media-attachment-ids))) (args-poll (when mastodon-toot-poll (mastodon-toot--build-poll-params))) ;; media || polls: (args (if mastodon-toot--media-attachments (append args-media args-no-media) (if mastodon-toot-poll (append args-no-media args-poll) args-no-media))) (prev-window-config mastodon-toot-previous-window-config)) (cond ((and mastodon-toot--media-attachments ;; make sure we have media args ;; and the same num of ids as attachments (or (not args-media) (not (= (length mastodon-toot--media-attachments) (length mastodon-toot--media-attachment-ids))))) (message "Something is wrong with your uploads. Wait for them to complete or try again.")) ((and mastodon-toot--max-toot-chars (> (mastodon-toot--count-toot-chars toot cw) mastodon-toot--max-toot-chars)) (message "Looks like your toot (inc. CW) is longer than that maximum allowed length.")) ((mastodon-toot--empty-p) (message "Empty toot. Cowardly refusing to post this.")) (t (let ((response (if edit-id ; we are sending an edit: (mastodon-http--put endpoint args) (mastodon-http--post endpoint args)))) (mastodon-http--triage response (lambda (_) (mastodon-toot--kill) (if scheduled (message "Toot scheduled!") (message "Toot toot!")) ;; cancel scheduled toot if we were editing it: (when scheduled-id (mastodon-views--cancel-scheduled-toot scheduled-id :no-confirm)) (mastodon-toot--restore-previous-window-config prev-window-config) (when edit-id (let ((pos (marker-position (cadr prev-window-config)))) (mastodon-tl--reload-timeline-or-profile pos)))))))))) ;;; EDITING TOOTS: (defun mastodon-toot--edit-toot-at-point () "Edit the user's toot at point." (interactive) (mastodon-tl--do-if-item-strict (let ((toot (or (mastodon-tl--property 'base-toot) ; fave/boost notifs (mastodon-tl--property 'item-json)))) (if (not (mastodon-toot--own-toot-p toot)) (message "You can only edit your own toots.") (let* ((id (mastodon-tl--as-string (mastodon-tl--item-id toot))) (source (mastodon-toot--get-toot-source id)) (content (alist-get 'text source)) (source-cw (alist-get 'spoiler_text source)) (toot-visibility (alist-get 'visibility toot)) (toot-language (alist-get 'language toot)) (reply-id (alist-get 'in_reply_to_id toot))) (when (y-or-n-p "Edit this toot? ") (mastodon-toot--compose-buffer nil reply-id nil content :edit) (goto-char (point-max)) ;; adopt reply-to-id, visibility, CW, and language: (mastodon-toot--set-toot-properties reply-id toot-visibility source-cw toot-language) (mastodon-toot--update-status-fields) (setq mastodon-toot--edit-item-id id))))))) (defun mastodon-toot--get-toot-source (id) "Fetch the source JSON of toot with ID." (let ((url (mastodon-http--api (format "/statuses/%s/source" id)))) (mastodon-http--get-json url nil :silent))) (defun mastodon-toot--get-toot-edits (id) "Return the edit history of toot with ID." (let* ((url (mastodon-http--api (format "statuses/%s/history" id)))) (mastodon-http--get-json url))) (defun mastodon-toot--view-toot-edits () "View editing history of the toot at point in a popup buffer." (interactive) (let ((id (mastodon-tl--property 'base-item-id)) (history (mastodon-tl--property 'edit-history)) (buf "*mastodon-toot-edits*")) (with-mastodon-buffer buf #'special-mode :other-window (let ((count 1)) (mapc (lambda (x) (insert (propertize (if (= count 1) (format "%s [original]:\n" count) (format "%s:\n" count)) 'face 'font-lock-comment-face) (mastodon-toot--insert-toot-iter x) "\n") (cl-incf count)) history)) (setq-local header-line-format (propertize (format "Edits to toot by %s:" (alist-get 'username (alist-get 'account (car history)))) 'face 'font-lock-comment-face)) (mastodon-tl--set-buffer-spec (buffer-name (current-buffer)) (format "statuses/%s/history" id) nil)))) (defun mastodon-toot--insert-toot-iter (it) "Insert iteration IT of toot." (let ((content (alist-get 'content it))) ;; (account (alist-get 'account it)) ;; TODO: handle polls, media (mastodon-tl--render-text content))) (defun mastodon-toot--restore-previous-window-config (config) "Restore the window CONFIG after killing the toot compose buffer. Buffer-local variable `mastodon-toot-previous-window-config' holds the config." (set-window-configuration (car config)) (goto-char (cadr config))) (defun mastodon-toot--mentions-to-string (mentions) "Apply `mastodon-toot--process-local' function to each mention in MENTIONS. Remove empty string (self) from result and joins the sequence with whitespace." (mapconcat (lambda (mention) mention) (remove "" (mapcar #'mastodon-toot--process-local mentions)) " ")) (defun mastodon-toot--process-local (acct) "Add domain to local ACCT and replace the curent user name with \"\". Mastodon requires the full @user@domain, even in the case of local accts. eg. \"user\" -> \"@user@local.social\" (when local.social is the domain of the mastodon-instance-url). eg. \"yourusername\" -> \"\" eg. \"feduser@fed.social\" -> \"@feduser@fed.social\"." (cond ((string-match-p "@" acct) (concat "@" acct)) ; federated acct ((string= (mastodon-auth--user-acct) acct) "") ; your acct (t (concat "@" acct "@" ; local acct (cadr (split-string mastodon-instance-url "/" t)))))) ;;; COMPLETION (TAGS, MENTIONS) (defun mastodon-toot--mentions (status) "Extract mentions (not the reply-to author or booster) from STATUS. The mentioned users look like this: Local user (including the logged in): `username`. Federated user: `username@host.co`." (let* ((boosted (mastodon-tl--field 'reblog status)) (mentions (if boosted (alist-get 'mentions (alist-get 'reblog status)) (alist-get 'mentions status)))) ;; reverse does not work on vectors in 24.5 (mastodon-tl--map-alist 'acct (reverse mentions)))) (defun mastodon-toot--get-bounds (regex) "Get bounds of tag or handle before point using REGEX." ;; # and @ are not part of any existing thing at point (save-match-data (save-excursion ;; match full handle inc. domain, or tag including # ;; (see the regexes for subexp 2) (when (re-search-backward regex (save-excursion (forward-whitespace -1) (point)) :no-error) (cons (match-beginning 2) (match-end 2)))))) (defun mastodon-toot--fetch-completion-candidates (start end &optional tags) "Search for a completion prefix from buffer positions START to END. Return a list of candidates. If TAGS, we search for tags, else we search for handles." ;; we can't save the first two-letter search then only filter the ;; resulting list, as max results returned is 40. (setq mastodon-toot-completions (if tags (let ((tags-list (mastodon-search--search-tags-query (buffer-substring-no-properties start end)))) (cl-loop for tag in tags-list collect (cons (concat "#" (car tag)) (cdr tag)))) (mastodon-search--search-accounts-query (buffer-substring-no-properties start end))))) (defun mastodon-toot--mentions-capf () "Build a mentions completion backend for `completion-at-point-functions'." (let* ((bounds (mastodon-toot--get-bounds mastodon-toot-handle-regex)) (start (car bounds)) (end (cdr bounds))) (when bounds (list start end (completion-table-dynamic ; only search when necessary (lambda (_) ;; Interruptible candidate computation, from minad/d mendler, thanks! (let ((result (while-no-input (mastodon-toot--fetch-completion-candidates start end)))) (and (consp result) result)))) :exclusive 'no :annotation-function (lambda (cand) (concat " " (mastodon-toot--mentions-annotation-fun cand))))))) (defun mastodon-toot--tags-capf () "Build a tags completion backend for `completion-at-point-functions'." (let* ((bounds (mastodon-toot--get-bounds mastodon-toot-tag-regex)) (start (car bounds)) (end (cdr bounds))) (when bounds (list start end (completion-table-dynamic ; only search when necessary: (lambda (_) ;; Interruptible candidate computation, from minad/d mendler, thanks! (let ((result (while-no-input (mastodon-toot--fetch-completion-candidates start end :tags)))) (and (consp result) result)))) :exclusive 'no :annotation-function (lambda (cand) (concat " " (mastodon-toot--tags-annotation-fun cand))))))) (defun mastodon-toot--mentions-annotation-fun (candidate) "Given a handle completion CANDIDATE, return its annotation string, a username." (caddr (assoc candidate mastodon-toot-completions))) (defun mastodon-toot--tags-annotation-fun (candidate) "Given a tag string CANDIDATE, return an annotation, the tag's URL." ;; TODO: check the list returned here? should be cadr ;; or make it an alist and use cdr (cadr (assoc candidate mastodon-toot-completions))) ;;; REPLY (defun mastodon-toot--reply () "Reply to toot at `point'. Customize `mastodon-toot-display-orig-in-reply-buffer' to display text of the toot being replied to in the compose buffer." (interactive) (mastodon-tl--do-if-item-strict (let* ((toot (mastodon-tl--property 'item-json)) ;; no-move arg for base toot: don't try next toot (base-toot (mastodon-tl--property 'base-toot :no-move)) ; for new notifs handling (id (mastodon-tl--as-string (mastodon-tl--field 'id (or base-toot toot)))) (account (mastodon-tl--field 'account toot)) (user (alist-get 'acct account)) (mentions (mastodon-toot--mentions (or base-toot toot))) (boosted (mastodon-tl--field 'reblog (or base-toot toot))) (booster (when boosted (alist-get 'acct (alist-get 'account toot))))) (mastodon-toot (when user (if booster (if (and (not (equal user booster)) (not (member booster mentions))) ;; different booster, user and mentions: (mastodon-toot--mentions-to-string (append (list user booster) mentions nil)) ;; booster is either user or in mentions: (if (not (member user mentions)) ;; user not already in mentions: (mastodon-toot--mentions-to-string (append (list user) mentions nil)) ;; user already in mentions: (mastodon-toot--mentions-to-string (copy-sequence mentions)))) ;; ELSE no booster: (if (not (member user mentions)) ;; user not in mentions: (mastodon-toot--mentions-to-string (append (list user) mentions nil)) ;; user in mentions already: (mastodon-toot--mentions-to-string (copy-sequence mentions))))) id (or base-toot toot))))) ;;; COMPOSE TOOT SETTINGS (defun mastodon-toot--toggle-warning () "Toggle `mastodon-toot--content-warning'." (interactive) (setq mastodon-toot--content-warning (not mastodon-toot--content-warning)) (mastodon-toot--update-status-fields)) (defun mastodon-toot--toggle-nsfw () "Toggle `mastodon-toot--content-nsfw'." (interactive) (setq mastodon-toot--content-nsfw (not mastodon-toot--content-nsfw)) (message "NSFW flag is now %s" (if mastodon-toot--content-nsfw "on" "off")) (mastodon-toot--update-status-fields)) (defun mastodon-toot--change-visibility () "Change the current visibility to the next valid value." (interactive) (if (mastodon-tl--buffer-type-eq 'edit-toot) (message "You can't change visibility when editing toots.") (setq mastodon-toot--visibility (cond ((string= mastodon-toot--visibility "public") "unlisted") ((string= mastodon-toot--visibility "unlisted") "private") ((string= mastodon-toot--visibility "private") "direct") (t "public"))) (mastodon-toot--update-status-fields))) (defun mastodon-toot--set-toot-language () "Prompt for a language and set `mastodon-toot--language'. Return its two letter ISO 639 1 code." (interactive) (let* ((choice (completing-read "Language for this toot: " mastodon-iso-639-1))) (setq mastodon-toot--language (alist-get choice mastodon-iso-639-1 nil nil 'equal)) (message "Language set to %s" choice) (mastodon-toot--update-status-fields))) ;;; ATTACHMENTS (defun mastodon-toot--clear-all-attachments () "Remove all attachments from a toot draft." (interactive) (setq mastodon-toot--media-attachments nil) (setq mastodon-toot--media-attachment-ids nil) (mastodon-toot--refresh-attachments-display) (mastodon-toot--update-status-fields)) (defun mastodon-toot--attach-media (file description) "Prompt for an attachment FILE with DESCRIPTION. A preview is displayed in the new toot buffer, and the file is uploaded asynchronously using `mastodon-toot--upload-attached-media'. File is actually attached to the toot upon posting." (interactive "fFilename: \nsDescription: ") (when (>= (length mastodon-toot--media-attachments) 4) ;; Only a max. of 4 attachments are allowed, so pop the oldest one. (pop mastodon-toot--media-attachments)) (if (file-directory-p file) (message "Looks like you chose a directory not a file.") (setq mastodon-toot--media-attachments (nconc mastodon-toot--media-attachments `(((:contents . ,(mastodon-http--read-file-as-string file)) (:description . ,description) (:filename . ,file))))) (mastodon-toot--refresh-attachments-display) ;; upload only most recent attachment: (mastodon-toot--upload-attached-media (car (last mastodon-toot--media-attachments))))) (defun mastodon-toot--upload-attached-media (attachment) "Upload a single ATTACHMENT using `mastodon-http--post-media-attachment'. The item's id is added to `mastodon-toot--media-attachment-ids', which is used to attach it to a toot when posting." (let* ((filename (expand-file-name (alist-get :filename attachment))) (caption (alist-get :description attachment)) (url (concat mastodon-instance-url "/api/v2/media"))) (message "Uploading %s... (please wait before starting further uploads)" (file-name-nondirectory filename)) (mastodon-http--post-media-attachment url filename caption))) (defun mastodon-toot--refresh-attachments-display () "Update the display attachment previews in toot draft buffer." (let ((inhibit-read-only t) (attachments-region (mastodon-tl--find-property-range 'toot-attachments (point-min))) (display-specs (mastodon-toot--format-attachments))) (dotimes (i (- (cdr attachments-region) (car attachments-region))) (add-text-properties (+ (car attachments-region) i) (+ (car attachments-region) i 1) (list 'display (or (nth i display-specs) "")))))) (defun mastodon-toot--format-attachments () "Format the attachment previews for display in toot draft buffer." (or (let ((counter 0) (image-options (when (or (image-type-available-p 'imagemagick) (image-transforms-p)) `(:height ,mastodon-toot--attachment-height)))) (mapcan (lambda (attachment) (let* ((data (alist-get :contents attachment)) (image (apply #'create-image data (if (version< emacs-version "27.1") (when image-options 'imagemagick) nil) ; inbuilt scaling in 27.1 t image-options)) (description (alist-get :description attachment))) (setq counter (1+ counter)) (list (format "\n %d: " counter) image (format " \"%s\"" description)))) mastodon-toot--media-attachments)) (list "None"))) ;;; POLL (defun mastodon-toot--fetch-max-poll-options (instance) "Return the maximum number of poll options from JSON data INSTANCE." (mastodon-toot--fetch-poll-field 'max_options instance)) (defun mastodon-toot--fetch-max-poll-option-chars (instance) "Return the maximum number of characters a poll option may have. INSTANCE is JSON." (if (alist-get 'pleroma instance) (mastodon-toot--fetch-poll-field 'max_option_chars instance) (or (mastodon-toot--fetch-poll-field 'max_characters_per_option instance) 50))) ; masto default (defun mastodon-toot--fetch-poll-field (field instance) "Return FIELD from the poll settings from JSON data INSTANCE." (let* ((polls (if (alist-get 'pleroma instance) (alist-get 'poll_limits instance) (alist-get 'polls (alist-get 'configuration instance))))) (alist-get field polls))) (defun mastodon-toot--read-poll-options-count (max) "Read the user's choice of the number of options the poll should have. MAX is the maximum number set by their instance." (let ((number (read-number (format "Number of options [2-%s]: " max) 2))) (if (> number max) (user-error "You need to choose a number between 2 and %s" max) number))) (defun mastodon-toot--create-poll () "Prompt for new poll options and return as a list." (interactive) (let* ((instance (mastodon-http--get-json (mastodon-http--api "instance"))) (max-options (mastodon-toot--fetch-max-poll-options instance)) (count (mastodon-toot--read-poll-options-count max-options)) (length (mastodon-toot--fetch-max-poll-option-chars instance)) (multiple-p (y-or-n-p "Multiple choice? ")) (options (mastodon-toot--read-poll-options count length)) (hide-totals (y-or-n-p "Hide votes until poll ends? ")) (expiry (mastodon-toot--read-poll-expiry))) (setq mastodon-toot-poll `(:options ,options :length ,length :multi ,multiple-p :hide ,hide-totals :expiry ,expiry)) (message "poll created!"))) (defun mastodon-toot--read-poll-options (count length) "Read a list of options for poll with COUNT options. LENGTH is the maximum character length allowed for a poll option." (let* ((choices (cl-loop for x from 1 to count collect (read-string (format "Poll option [%s/%s] [max %s chars]: " x count length)))) (longest (cl-reduce #'max (mapcar #'length choices)))) (if (> longest length) (progn (message "looks like you went over the max length. Try again.") (sleep-for 2) (mastodon-toot--read-poll-options count length)) choices))) (defun mastodon-toot--read-poll-expiry () "Prompt for a poll expiry time." ;; API requires this in seconds (let* ((options (mastodon-toot--poll-expiry-options-alist)) (response (completing-read "poll ends in [or enter seconds]: " options nil 'confirm))) (or (alist-get response options nil nil #'equal) (if (< (string-to-number response) 600) "600" ;; min 5 mins response)))) (defun mastodon-toot--poll-expiry-options-alist () "Return an alist of expiry options options in seconds." `(("5 minutes" . ,(number-to-string (* 60 5))) ("30 minutes" . ,(number-to-string (* 60 30))) ("1 hour" . ,(number-to-string (* 60 60))) ("6 hours" . ,(number-to-string (* 60 60 6))) ("1 day" . ,(number-to-string (* 60 60 24))) ("3 days" . ,(number-to-string (* 60 60 24 3))) ("7 days" . ,(number-to-string (* 60 60 24 7))) ("14 days" . ,(number-to-string (* 60 60 24 14))) ("30 days" . ,(number-to-string (* 60 60 24 30))))) ;;; SCHEDULE (defun mastodon-toot--schedule-toot (&optional reschedule) "Read a date (+ time) in the minibuffer and schedule the current toot. With RESCHEDULE, reschedule the scheduled toot at point without editing." ;; original idea by christian tietze, thanks! ;; https://codeberg.org/martianh/mastodon.el/issues/285 (interactive) (cond ((mastodon-tl--buffer-type-eq 'edit-toot) (message "You can't schedule toots you're editing.")) ((not (or (mastodon-tl--buffer-type-eq 'new-toot) (mastodon-tl--buffer-type-eq 'scheduled-statuses))) (message "You can only schedule toots from the compose buffer or scheduled toots view.")) (t (let* ((id (when reschedule (mastodon-tl--property 'id :no-move))) (ts (when reschedule (alist-get 'scheduled_at (mastodon-tl--property 'scheduled-json :no-move)))) (time-value (org-read-date t t nil "Schedule toot:" ;; default to scheduled timestamp if already set: (mastodon-toot--iso-to-org ;; we are rescheduling without editing: (or ts ;; we are maybe editing the scheduled toot: mastodon-toot--scheduled-for)))) (iso8601-str (format-time-string "%FT%T%z" time-value)) (msg-str (format-time-string "%d-%m-%y at %H:%M[%z]" time-value))) (if (not reschedule) (progn (setq-local mastodon-toot--scheduled-for iso8601-str) (message (format "Toot scheduled for %s." msg-str))) (let* ((args `(("scheduled_at" . ,iso8601-str))) (url (mastodon-http--api (format "scheduled_statuses/%s" id))) (response (mastodon-http--put url args))) (mastodon-http--triage response (lambda (_) ;; reschedule means we are in scheduled toots view: (mastodon-views--view-scheduled-toots) (message (format "Toot rescheduled for %s." msg-str)))))))))) (defun mastodon-toot--iso-to-human (ts) "Format an ISO8601 timestamp TS to be more human-readable." (let* ((decoded (iso8601-parse ts)) (encoded (encode-time decoded))) (format-time-string "%d-%m-%y, %H:%M[%z]" encoded))) (defun mastodon-toot--iso-to-org (ts) "Convert ISO8601 timestamp TS to something `org-read-date' can handle." (when ts (let* ((decoded (iso8601-parse ts))) (encode-time decoded)))) ;;; DISPLAY KEYBINDINGS (defun mastodon-toot--get-mode-kbinds () "Get a list of the keybindings in the mastodon-toot-mode." (let* ((binds (copy-tree mastodon-toot-mode-map)) (prefix (car (cadr binds))) (bindings (remove nil (mapcar (lambda (i) (when (listp i) i)) (cadr binds))))) (mapcar (lambda (b) (setf (car b) (vector prefix (car b))) b) bindings))) (defun mastodon-toot--format-kbind-command (cmd) "Format CMD to be more readable. e.g. mastodon-toot--send -> Send." (let* ((str (symbol-name cmd)) (re "--\\(.*\\)$") (str2 (save-match-data (string-match re str) (match-string 1 str)))) (capitalize (replace-regexp-in-string "-" " " str2)))) (defun mastodon-toot--format-kbind (kbind) "Format a single keybinding, KBIND, for display in documentation." (let ((key (concat "\\`" (help-key-description (car kbind) nil) "'")) (command (mastodon-toot--format-kbind-command (cdr kbind)))) (substitute-command-keys (format (concat (mastodon-toot--comment " ") "%s" (mastodon-toot--comment " - %s")) key command)))) (defun mastodon-toot--comment (str) "Propertize STR with `mastodon-toot-docs-face'." (propertize str 'face 'mastodon-toot-docs-face)) (defun mastodon-toot--format-kbinds (kbinds) "Format a list of keybindings, KBINDS, for display in documentation." (mapcar #'mastodon-toot--format-kbind kbinds)) (defvar-local mastodon-toot--kbinds-pairs nil "Contains a list of paired toot compose buffer keybindings for inserting.") (defun mastodon-toot--formatted-kbinds-pairs (kbinds-list longest) "Return a list of strings each containing two formatted kbinds. KBINDS-LIST is the list of formatted bindings to pair. LONGEST is the length of the longest binding." (when kbinds-list (push (concat "\n" (car kbinds-list) (make-string (- (1+ longest) (length (car kbinds-list))) ?\ ) (cadr kbinds-list)) mastodon-toot--kbinds-pairs) (mastodon-toot--formatted-kbinds-pairs (cddr kbinds-list) longest)) (reverse mastodon-toot--kbinds-pairs)) (defun mastodon-toot--formatted-kbinds-longest (kbinds-list) "Return the length of the longest item in KBINDS-LIST." (let ((lengths (mapcar #'length kbinds-list))) (car (sort lengths #'>)))) ;;; DISPLAY DOCS (defun mastodon-toot--make-mode-docs () "Create formatted documentation text for the mastodon-toot-mode." (let* ((kbinds (mastodon-toot--get-mode-kbinds)) (longest-kbind (mastodon-toot--formatted-kbinds-longest (mastodon-toot--format-kbinds kbinds)))) (concat (mastodon-toot--comment " Compose a new toot here. The following keybindings are available:") (mapconcat #'identity (mastodon-toot--formatted-kbinds-pairs (mastodon-toot--format-kbinds kbinds) longest-kbind) nil)))) (defun mastodon-toot--format-reply-in-compose-string (reply-text) "Format a REPLY-TEXT for display in compose buffer docs." (let* ((rendered (mastodon-tl--render-text reply-text)) (no-props (substring-no-properties rendered)) ;; FIXME: this replaces \n at end of every post, so we have to trim: (no-newlines (string-trim (replace-regexp-in-string "[\n]+" " " no-props))) (reply-to (concat " Reply to: \"" no-newlines "\"")) (crop (truncate-string-to-width reply-to mastodon-toot-orig-in-reply-length))) (if (> (length no-newlines) (length crop)) ; we cropped: (concat crop "\n") (concat reply-to "\n")))) (defun mastodon-toot--display-docs-and-status-fields (&optional reply-text) "Insert propertized text with documentation about `mastodon-toot-mode'. Also includes and the status fields which will get updated based on the status of NSFW, content warning flags, media attachments, etc. REPLY-TEXT is the text of the toot being replied to." (let ((divider "|=================================================================|")) (insert (concat (mastodon-toot--make-mode-docs) "\n" (mastodon-toot--comment divider) "\n" (propertize (concat " " (propertize "Count" 'toot-post-counter t) " ⋅ " (propertize "Visibility" 'toot-post-visibility t) " ⋅ " (propertize "Language" 'toot-post-language t) " " (propertize "Scheduled" 'toot-post-scheduled t) " " (propertize "CW" 'toot-post-cw-flag t) " " (propertize "NSFW" 'toot-post-nsfw-flag t) "\n" " Attachments: " (propertize "None " 'toot-attachments t) "\n" (if reply-text (propertize (mastodon-toot--format-reply-in-compose-string reply-text) 'toot-reply t) "") divider) 'face 'mastodon-toot-docs-face 'read-only "Edit your message below." 'toot-post-header t)) ;; allow us to enter text after read-only header: (propertize "\n" 'rear-nonsticky t)))) (defun mastodon-toot--most-restrictive-visibility (reply-visibility) "Return REPLY-VISIBILITY or default visibility, whichever is more restrictive. The default is given by `mastodon-toot--default-reply-visibility'." (unless (null reply-visibility) (let ((less-restrictive (member (intern mastodon-toot--default-reply-visibility) mastodon-toot-visibility-list))) (if (member (intern reply-visibility) less-restrictive) mastodon-toot--default-reply-visibility reply-visibility)))) (defun mastodon-toot--setup-as-reply (reply-to-user reply-to-id reply-json) "If REPLY-TO-USER is provided, inject their handle into the message. If REPLY-TO-ID is provided, set `mastodon-toot--reply-to-id'. REPLY-JSON is the full JSON of the toot being replied to." (let ((reply-visibility (mastodon-toot--most-restrictive-visibility (alist-get 'visibility reply-json))) (reply-cw (alist-get 'spoiler_text reply-json))) (when reply-to-user (when (> (length reply-to-user) 0) ; self is "" unforch (insert (format "%s " reply-to-user))) (setq mastodon-toot--reply-to-id reply-to-id) (unless (equal mastodon-toot--visibility reply-visibility) (setq mastodon-toot--visibility reply-visibility)) (mastodon-toot--set-cw reply-cw)))) (defun mastodon-toot--update-status-fields (&rest _args) "Update the status fields in the header based on the current state." (ignore-errors ;; called from after-change-functions so let's not leak errors (let* ((inhibit-read-only t) (header-region (mastodon-tl--find-property-range 'toot-post-header (point-min))) (count-region (mastodon-tl--find-property-range 'toot-post-counter (point-min))) (visibility-region (mastodon-tl--find-property-range 'toot-post-visibility (point-min))) (nsfw-region (mastodon-tl--find-property-range 'toot-post-nsfw-flag (point-min))) (cw-region (mastodon-tl--find-property-range 'toot-post-cw-flag (point-min))) (lang-region (mastodon-tl--find-property-range 'toot-post-language (point-min))) (scheduled-region (mastodon-tl--find-property-range 'toot-post-scheduled (point-min))) (toot-string (buffer-substring-no-properties (cdr header-region) (point-max)))) (add-text-properties (car count-region) (cdr count-region) (list 'display (format "%s/%s chars" (mastodon-toot--count-toot-chars toot-string) (number-to-string mastodon-toot--max-toot-chars)))) (add-text-properties (car visibility-region) (cdr visibility-region) (list 'display (format "%s" (if (equal mastodon-toot--visibility "private") "followers-only" mastodon-toot--visibility)))) (add-text-properties (car lang-region) (cdr lang-region) (list 'display (if mastodon-toot--language (format "Lang: %s ⋅" mastodon-toot--language) ""))) (add-text-properties (car scheduled-region) (cdr scheduled-region) (list 'display (if mastodon-toot--scheduled-for (format "Scheduled: %s ⋅" (mastodon-toot--iso-to-human mastodon-toot--scheduled-for)) ""))) (add-text-properties (car nsfw-region) (cdr nsfw-region) (list 'display (if mastodon-toot--content-nsfw (if mastodon-toot--media-attachments "NSFW" "NSFW (for attachments only)") "") 'face 'mastodon-cw-face)) (add-text-properties (car cw-region) (cdr cw-region) (list 'invisible (not mastodon-toot--content-warning) 'face 'mastodon-cw-face))))) (defun mastodon-toot--count-toot-chars (toot-string &optional cw) "Count the characters in TOOT-STRING. URLs always = 23, and domain names of handles are not counted. This is how mastodon does it. CW is the content warning, which contributes to the character count." (with-temp-buffer (switch-to-buffer (current-buffer)) (insert toot-string) (goto-char (point-min)) ;; handle URLs (while (search-forward-regexp mastodon-toot-url-regex nil t) ; "\\w+://[^ \n]*" old regex (replace-match "xxxxxxxxxxxxxxxxxxxxxxx")) ; 23 x's ;; handle @handles (goto-char (point-min)) (while (search-forward-regexp mastodon-toot-handle-regex nil t) (replace-match (match-string 2))) ; replace with handle only (+ (length cw) (length (buffer-substring (point-min) (point-max)))))) ;;; DRAFTS (defun mastodon-toot--save-toot-text (&rest _args) "Save the current toot text in `mastodon-toot-current-toot-text'. Added to `after-change-functions' in new toot buffers." (let ((text (mastodon-toot--remove-docs))) (unless (string-empty-p text) (setq mastodon-toot-current-toot-text text)))) (defun mastodon-toot--open-draft-toot () "Prompt for a draft and compose a toot with it." (interactive) (if mastodon-toot-draft-toots-list (let ((text (completing-read "Select draft toot: " mastodon-toot-draft-toots-list nil t))) (if (mastodon-toot--compose-buffer-p) (when (and (not (mastodon-toot--empty-p :text-only)) (y-or-n-p "Replace current text with draft?")) (cl-pushnew mastodon-toot-current-toot-text mastodon-toot-draft-toots-list) (goto-char (cdr (mastodon-tl--find-property-range 'toot-post-header (point-min)))) (kill-region (point) (point-max)) ;; to not save to kill-ring: ;; (delete-region (point) (point-max)) (insert text)) (mastodon-toot--compose-buffer nil nil nil text))) (unless (mastodon-toot--compose-buffer-p) (mastodon-toot--compose-buffer)) (message "No drafts available."))) (defun mastodon-toot--delete-draft-toot () "Prompt for a draft toot and delete it." (interactive) (if mastodon-toot-draft-toots-list (let ((draft (completing-read "Select draft to delete: " mastodon-toot-draft-toots-list nil t))) (setq mastodon-toot-draft-toots-list (cl-delete draft mastodon-toot-draft-toots-list :test #'equal)) (message "Draft deleted!")) (message "No drafts to delete."))) (defun mastodon-toot--delete-all-drafts () "Delete all drafts." (interactive) (setq mastodon-toot-draft-toots-list nil) (message "All drafts deleted!")) ;;; PROPERTIZE TAGS AND HANDLES (defun mastodon-toot--propertize-tags-and-handles (&rest _args) "Propertize tags and handles in toot compose buffer. Added to `after-change-functions'." (when (mastodon-toot--compose-buffer-p) (let ((header-region (mastodon-tl--find-property-range 'toot-post-header (point-min))) (face (when mastodon-toot--proportional-fonts-compose 'variable-pitch))) ;; cull any prev props: ;; stops all text after a handle or mention being propertized: (set-text-properties (cdr header-region) (point-max) `(face ,face)) (mastodon-toot--propertize-item mastodon-toot-tag-regex 'success (cdr header-region)) (mastodon-toot--propertize-item mastodon-toot-handle-regex 'mastodon-display-name-face (cdr header-region)) (mastodon-toot--propertize-item mastodon-toot-url-regex 'link (cdr header-region))))) (defun mastodon-toot--propertize-item (regex face start) "Propertize item matching REGEX with FACE starting from START." (save-excursion (goto-char start) (cl-loop while (search-forward-regexp regex nil :noerror) do (add-text-properties (match-beginning 2) (match-end 2) `(face ,face))))) (defun mastodon-toot--compose-buffer-p () "Return t if compose buffer is current." (or (mastodon-tl--buffer-type-eq 'edit-toot) (mastodon-tl--buffer-type-eq 'new-toot))) (defun mastodon-toot--fill-reply-in-compose () "Fill reply text in compose buffer to the width of the divider." (save-excursion (save-match-data (let* ((fill-column 67)) (goto-char (point-min)) (when-let ((prop (text-property-search-forward 'toot-reply))) (fill-region (prop-match-beginning prop) (point))))))) ;;; COMPOSE BUFFER FUNCTION (defun mastodon-toot--compose-buffer (&optional reply-to-user reply-to-id reply-json initial-text edit) "Create a new buffer to capture text for a new toot. If REPLY-TO-USER is provided, inject their handle into the message. If REPLY-TO-ID is provided, set the `mastodon-toot--reply-to-id' var. REPLY-JSON is the full JSON of the toot being replied to. INITIAL-TEXT is used by `mastodon-toot-insert-draft-toot' to add a draft into the buffer. EDIT means we are editing an existing toot, not composing a new one." (let* ((buffer-name (if edit "*edit toot*" "*new toot*")) (buffer-exists (get-buffer buffer-name)) (buffer (or buffer-exists (get-buffer-create buffer-name))) (inhibit-read-only t) (reply-text (alist-get 'content (or (alist-get 'reblog reply-json) reply-json))) (previous-window-config (list (current-window-configuration) (point-marker)))) (switch-to-buffer-other-window buffer) (text-mode) (mastodon-toot-mode t) (setq mastodon-toot--visibility (or (plist-get mastodon-profile-account-settings 'privacy) ;; use toot visibility setting from the server: (mastodon-profile--get-source-pref 'privacy) "public")) ; fallback (unless buffer-exists (if mastodon-toot-display-orig-in-reply-buffer (progn (mastodon-toot--display-docs-and-status-fields reply-text) (mastodon-toot--fill-reply-in-compose)) (mastodon-toot--display-docs-and-status-fields)) ;; `reply-to-user' (alone) is also used by `mastodon-tl--dm-user', so ;; perhaps we should not always call --setup-as-reply, or make its ;; workings conditional on reply-to-id. currently it only checks for ;; reply-to-user. (mastodon-toot--setup-as-reply reply-to-user reply-to-id reply-json)) (unless mastodon-toot--max-toot-chars ;; no need to fetch from `mastodon-profile-account-settings' as ;; `mastodon-toot--max-toot-chars' is set when we set it (mastodon-toot--get-max-toot-chars)) ;; set up completion: (when mastodon-toot--enable-completion (set (make-local-variable 'completion-at-point-functions) (add-to-list 'completion-at-point-functions #'mastodon-toot--mentions-capf)) (add-to-list 'completion-at-point-functions #'mastodon-toot--tags-capf) ;; company (when (and mastodon-toot--use-company-for-completion (require 'company nil :no-error)) (declare-function company-mode-on "company") (set (make-local-variable 'company-backends) (add-to-list 'company-backends 'company-capf)) (company-mode-on))) ;; after-change: (make-local-variable 'after-change-functions) (cl-pushnew #'mastodon-toot--save-toot-text after-change-functions) (cl-pushnew #'mastodon-toot--update-status-fields after-change-functions) (mastodon-toot--update-status-fields) (cl-pushnew #'mastodon-toot--propertize-tags-and-handles after-change-functions) (mastodon-toot--propertize-tags-and-handles) (mastodon-toot--refresh-attachments-display) ;; draft toot text saving: (setq mastodon-toot-current-toot-text nil) ;; if we set this before changing modes, it gets nuked: (setq mastodon-toot-previous-window-config previous-window-config) (when mastodon-toot--proportional-fonts-compose (facemenu-set-face 'variable-pitch)) (when initial-text (insert initial-text)))) ;; flyspell ignore masto toot regexes: (defvar flyspell-generic-check-word-predicate) (defun mastodon-toot-mode-flyspell-verify () "A predicate function for `flyspell'. Only text that is not one of these faces will be spell-checked." (let ((faces '(mastodon-display-name-face mastodon-toot-docs-face font-lock-comment-face success link))) (unless (eql (point) (point-min)) ;; (point) is next char after the word. Must check one char before. (let ((f (get-text-property (1- (point)) 'face))) (not (memq f faces)))))) (defun mastodon-toot-mode-hook-fun () "Function for code to run in `mastodon-toot-mode-hook'." ;; disable auto-fill-mode: (auto-fill-mode -1) ;; add flyspell predicate function: (setq flyspell-generic-check-word-predicate #'mastodon-toot-mode-flyspell-verify)) (add-hook 'mastodon-toot-mode-hook #'mastodon-toot-mode-hook-fun) ;;;###autoload (add-hook 'mastodon-toot-mode-hook #'mastodon-profile--fetch-server-account-settings-maybe) (define-minor-mode mastodon-toot-mode "Minor mode to capture Mastodon toots." :keymap mastodon-toot-mode-map :global nil) (provide 'mastodon-toot) ;;; mastodon-toot.el ends here mastodon.el/lisp/mastodon-views.el000066400000000000000000001144631452000115200175500ustar00rootroot00000000000000;;; mastodon-views.el --- Minor views functions for mastodon.el -*- lexical-binding: t -*- ;; Copyright (C) 2020-2022 Marty Hiatt ;; Author: Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon-views.el provides minor views functions. ;; These are currently lists, follow suggestions, filters, scheduled toots, ;; follow requests, and instance descriptions. ;; It doesn't include favourites, bookmarks, preferences, trending tags, followed tags, toot edits, ;;; Code: (require 'cl-lib) (require 'mastodon-http) (eval-when-compile (require 'mastodon-tl)) (defvar mastodon-mode-map) (defvar mastodon-tl--horiz-bar) (defvar mastodon-tl--timeline-posts-count) (autoload 'mastodon-mode "mastodon") (autoload 'mastodon-tl--init "mastodon-tl") (autoload 'mastodon-tl--init-sync "mastodon-tl") (autoload 'mastodon-tl--field "mastodon-tl") (autoload 'mastodon-tl--property "mastodon-tl") (autoload 'mastodon-tl--set-face "mastodon-tl") (autoload 'mastodon-tl--buffer-type-eq "mastodon-tl") (autoload 'mastodon-tl--profile-buffer-p "mastodon-tl") (autoload 'mastodon-tl--goto-first-item "mastodon-tl") (autoload 'mastodon-tl--do-if-item "mastodon-tl") (autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") (autoload 'mastodon-tl--render-text "mastodon-tl") (autoload 'mastodon-notifications--follow-request-accept "mastodon-notifications") (autoload 'mastodon-notifications--follow-request-reject "mastodon-notifications") (autoload 'mastodon-auth--get-account-id "mastodon-auth") (autoload 'mastodon-toot--iso-to-human "mastodon-toot") (autoload 'mastodon-toot--schedule-toot "mastodon-toot") (autoload 'mastodon-toot--compose-buffer "mastodon-toot") (autoload 'mastodon-toot--set-toot-properties "mastodon-toot") (autoload 'mastodon-search--propertize-user "mastodon-search") (autoload 'mastodon-search--insert-users-propertized "mastodon-search") (autoload 'mastodon-tl--map-alist "mastodon-tl") (autoload 'mastodon-tl--map-alist-vals-to-alist "mastodon-tl") ;;; KEYMAPS ;; we copy `mastodon-mode-map', as then all timeline functions are ;; available. this is helpful because if a minor view is the only buffer left ;; open, calling `mastodon' will switch to it, but then we will be unable to ;; switch to timlines without closing the minor view. ;; copying the mode map however means we need to avoid/unbind/override any ;; functions that might cause interfere with the minor view. ;; this is not redundant, as while the buffer -init function calls ;; `mastodon-mode', it gets overridden in some but not all cases. (defvar mastodon-views-map (let ((map (make-sparse-keymap))) (set-keymap-parent map mastodon-mode-map) map) "Base keymap for minor mastodon views.") (defvar mastodon-views--view-filters-keymap (let ((map (make-sparse-keymap))) (set-keymap-parent map mastodon-views-map) (define-key map (kbd "d") #'mastodon-views--delete-filter) (define-key map (kbd "c") #'mastodon-views--create-filter) (define-key map (kbd "g") #'mastodon-views--view-filters) map) "Keymap for viewing filters.") (defvar mastodon-views--follow-suggestions-map (let ((map (make-sparse-keymap))) (set-keymap-parent map mastodon-views-map) (define-key map (kbd "g") #'mastodon-views--view-follow-suggestions) map) "Keymap for viewing follow suggestions.") (defvar mastodon-views--view-lists-keymap (let ((map (make-sparse-keymap))) (set-keymap-parent map mastodon-views-map) (define-key map (kbd "D") #'mastodon-views--delete-list) (define-key map (kbd "C") #'mastodon-views--create-list) (define-key map (kbd "A") #'mastodon-views--add-account-to-list) (define-key map (kbd "R") #'mastodon-views--remove-account-from-list) (define-key map (kbd "E") #'mastodon-views--edit-list) (define-key map (kbd "g") #'mastodon-views--view-lists) map) "Keymap for viewing lists.") (defvar mastodon-views--list-name-keymap (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") #'mastodon-views--view-timeline-list-at-point) (define-key map (kbd "d") #'mastodon-views--delete-list-at-point) (define-key map (kbd "a") #'mastodon-views--add-account-to-list-at-point) (define-key map (kbd "r") #'mastodon-views--remove-account-from-list-at-point) (define-key map (kbd "e") #'mastodon-views--edit-list-at-point) map) "Keymap for when point is on list name.") (defvar mastodon-views--scheduled-map (let ((map (make-sparse-keymap))) (set-keymap-parent map mastodon-views-map) (define-key map (kbd "r") #'mastodon-views--reschedule-toot) (define-key map (kbd "c") #'mastodon-views--cancel-scheduled-toot) (define-key map (kbd "e") #'mastodon-views--edit-scheduled-as-new) (define-key map (kbd "RET") #'mastodon-views--edit-scheduled-as-new) map) "Keymap for when point is on a scheduled toot.") (defvar mastodon-views--view-follow-requests-keymap (let ((map (make-sparse-keymap))) (set-keymap-parent map mastodon-views-map) ;; make reject binding match the binding in notifs view ;; 'r' is then reserved for replying, even tho it is not avail ;; in foll-reqs view (define-key map (kbd "j") #'mastodon-notifications--follow-request-reject) (define-key map (kbd "a") #'mastodon-notifications--follow-request-accept) (define-key map (kbd "g") #'mastodon-views--view-follow-requests) map) "Keymap for viewing follow requests.") ;;; GENERAL FUNCTION (defun mastodon-views--minor-view (view-name insert-fun data) "Load a minor view named VIEW-NAME. BINDINGS-STRING is a string explaining the view's local bindings. INSERT-FUN is the function to call to insert the view's elements. DATA is the argument to insert-fun, usually JSON returned in a request. This function is used as the update-function to `mastodon-tl--init-sync', which initializes a buffer for us and provides the JSON data." ;; FIXME: this is not an update function as it inserts a heading and ;; possible bindings string ;; either it should go in init-sync, or possibly in each view function ;; but either way, this function does almost nothing for us. ;; could we call init-sync in here pehaps? ;; (mastodon-search--insert-heading view-name) ;; (when bindings-string ;; (insert (mastodon-tl--set-face (concat "[" bindings-string "]\n\n") ;; 'font-lock-comment-face))) (if (seq-empty-p data) (insert (propertize (format "Looks like you have no %s for now." view-name) 'face 'font-lock-comment-face 'byline t 'item-type 'no-item ; for nav 'item-id "0")) ; so point can move here when no item (funcall insert-fun data) (goto-char (point-min))) ;; (when data ;; FIXME: this seems to trigger a new request, but ideally would run. ;; (mastodon-tl--goto-next-item)) ) ;;; LISTS (defun mastodon-views--view-lists () "Show the user's lists in a new buffer." (interactive) (mastodon-tl--init-sync "lists" "lists" 'mastodon-views--insert-lists nil nil nil "your lists" "C - create a list\n D - delete a list\ \n A/R - add/remove account from a list\ \n E - edit a list\n n/p - go to next/prev item") (with-current-buffer "*mastodon-lists*" (use-local-map mastodon-views--view-lists-keymap))) (defun mastodon-views--insert-lists (json) "Insert the user's lists from JSON." (mastodon-views--minor-view "lists" #'mastodon-views--print-list-set json)) (defun mastodon-views--print-list-set (lists) "Print each account plus a separator for each list in LISTS." (mapc (lambda (x) (mastodon-views--print-list-accounts x) (insert (propertize (concat " " mastodon-tl--horiz-bar "\n\n") 'face 'success))) lists)) (defun mastodon-views--print-list-accounts (list) "Insert the accounts in list named LIST, an alist." (let-alist list (let* ((accounts (mastodon-views--accounts-in-list .id))) (insert (propertize .title 'byline t ; so we nav here 'item-id "0" ; so we nav here 'item-type 'list 'help-echo "RET: view list timeline, d: delete this list, \ a: add account to this list, r: remove account from this list" 'list t 'face 'link 'keymap mastodon-views--list-name-keymap 'list-name .title 'list-id .id) (propertize (format " [replies: %s, exclusive %s]" .replies_policy (when (eq t .exclusive) "true")) 'face 'font-lock-comment-face) (propertize "\n\n" 'list t 'keymap mastodon-views--list-name-keymap 'list-name .title 'list-id .id) (propertize (mapconcat #'mastodon-search--propertize-user accounts " ") 'list t 'keymap mastodon-views--list-name-keymap 'list-name .title 'list-id .id))))) (defun mastodon-views--get-users-lists () "Get the list of the user's lists from the server." (let ((url (mastodon-http--api "lists"))) (mastodon-http--get-json url))) (defun mastodon-views--get-lists-names () "Return a list of the user's lists' names." (let ((lists (mastodon-views--get-users-lists))) (mastodon-tl--map-alist 'title lists))) (defun mastodon-views--get-list-by-name (name) "Return the list data for list with NAME." (let* ((lists (mastodon-views--get-users-lists))) (cl-loop for list in lists if (string= (alist-get 'title list) name) return list))) (defun mastodon-views--get-list-id (name) "Return id for list with NAME." (let ((list (mastodon-views--get-list-by-name name))) (alist-get 'id list))) (defun mastodon-views--get-list-name (id) "Return name of list with ID." (let* ((url (mastodon-http--api (format "lists/%s" id))) (response (mastodon-http--get-json url))) (alist-get 'title response))) (defun mastodon-views--edit-list-at-point () "Edit list at point." (interactive) (let ((id (mastodon-tl--property 'list-id :no-move))) (mastodon-views--edit-list id))) (defun mastodon-views--edit-list (&optional id) "Prompt for a list and edit the name and replies policy. If ID is provided, use that list." (interactive) (let* ((list-names (unless id (mastodon-views--get-lists-names))) (name-old (if id (mastodon-tl--property 'list-name :no-move) (completing-read "Edit list: " list-names))) (id (or id (mastodon-views--get-list-id name-old))) (name-choice (read-string "List name: " name-old)) (replies-policy (completing-read "Replies policy: " ; give this a proper name '("followed" "list" "none") nil t nil nil "list")) (exclusive (if (y-or-n-p "Exclude items from home timeline? ") "true" "false")) (url (mastodon-http--api (format "lists/%s" id))) (response (mastodon-http--put url `(("title" . ,name-choice) ("replies_policy" . ,replies-policy) ("exclusive" . ,exclusive))))) (mastodon-http--triage response (lambda (_) (with-current-buffer response (let* ((json (mastodon-http--process-json)) (name-new (alist-get 'title json))) (message "list %s edited to %s!" name-old name-new))) (when (mastodon-tl--buffer-type-eq 'lists) (mastodon-views--view-lists)))))) (defun mastodon-views--view-timeline-list-at-point () "View timeline of list at point." (interactive) (let ((list-id (mastodon-tl--property 'list-id :no-move))) (mastodon-views--view-list-timeline list-id))) (defun mastodon-views--view-list-timeline (&optional id) "Prompt for a list and view its timeline. If ID is provided, use that list." (interactive) (let* ((list-names (unless id (mastodon-views--get-lists-names))) (list-name (unless id (completing-read "View list: " list-names))) (id (or id (mastodon-views--get-list-id list-name))) (endpoint (format "timelines/list/%s" id)) (name (mastodon-views--get-list-name id)) (buffer-name (format "list-%s" name))) (mastodon-tl--init buffer-name endpoint 'mastodon-tl--timeline nil `(("limit" . ,mastodon-tl--timeline-posts-count))))) (defun mastodon-views--create-list () "Create a new list. Prompt for name and replies policy." (interactive) (let* ((title (read-string "New list name: ")) (replies-policy (completing-read "Replies policy: " ; give this a proper name '("followed" "list" "none") nil t nil nil "list")) ; default (exclusive (when (y-or-n-p "Exclude items from home timeline? ") "true")) (response (mastodon-http--post (mastodon-http--api "lists") `(("title" . ,title) ("replies_policy" . ,replies-policy) ("exclusive" . ,exclusive))))) (mastodon-views--list-action-triage response "list %s created!" title))) (defun mastodon-views--delete-list-at-point () "Delete list at point." (interactive) (let ((id (mastodon-tl--property 'list-id :no-move))) (mastodon-views--delete-list id))) (defun mastodon-views--delete-list (&optional id) "Prompt for a list and delete it. If ID is provided, delete that list." (interactive) (let* ((list-names (unless id (mastodon-views--get-lists-names))) (name (if id (mastodon-views--get-list-name id) (completing-read "Delete list: " list-names))) (id (or id (mastodon-views--get-list-id name))) (url (mastodon-http--api (format "lists/%s" id)))) (when (y-or-n-p (format "Delete list %s?" name)) (let ((response (mastodon-http--delete url))) (mastodon-views--list-action-triage response "list %s deleted!" name))))) (defun mastodon-views--get-users-followings () "Return the list of followers of the logged in account." (let* ((id (mastodon-auth--get-account-id)) (url (mastodon-http--api (format "accounts/%s/following" id)))) (mastodon-http--get-json url '(("limit" . "80"))))) ; max 80 accounts (defun mastodon-views--add-account-to-list-at-point () "Prompt for account and add to list at point." (interactive) (let ((id (mastodon-tl--property 'list-id :no-move))) (mastodon-views--add-account-to-list id))) (defun mastodon-views--add-account-to-list (&optional id account-id handle) "Prompt for a list and for an account, add account to list. If ID is provided, use that list. If ACCOUNT-ID and HANDLE are provided use them rather than prompting." (interactive) (let* ((list-prompt (if handle (format "Add %s to list: " handle) "Add account to list: ")) (list-name (if id (mastodon-tl--property 'list-name :no-move) (completing-read list-prompt (mastodon-views--get-lists-names) nil t))) (list-id (or id (mastodon-views--get-list-id list-name))) (followings (mastodon-views--get-users-followings)) (handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id followings)) (account (or handle (completing-read "Account to add: " handles nil t))) (account-id (or account-id (alist-get account handles))) (url (mastodon-http--api (format "lists/%s/accounts" list-id))) (response (mastodon-http--post url `(("account_ids[]" . ,account-id))))) (mastodon-views--list-action-triage response "%s added to list %s!" account list-name))) (defun mastodon-views--add-toot-account-at-point-to-list () "Prompt for a list, and add the account of the toot at point to it." (interactive) (let* ((toot (mastodon-tl--property 'item-json)) (account (mastodon-tl--field 'account toot)) (account-id (mastodon-tl--field 'id account)) (handle (mastodon-tl--field 'acct account))) (mastodon-views--add-account-to-list nil account-id handle))) (defun mastodon-views--remove-account-from-list-at-point () "Prompt for account and remove from list at point." (interactive) (let ((id (mastodon-tl--property 'list-id :no-move))) (mastodon-views--remove-account-from-list id))) (defun mastodon-views--remove-account-from-list (&optional id) "Prompt for a list, select an account and remove from list. If ID is provided, use that list." (interactive) (let* ((list-name (if id (mastodon-tl--property 'list-name :no-move) (completing-read "Remove account from list: " (mastodon-views--get-lists-names) nil t))) (list-id (or id (mastodon-views--get-list-id list-name))) (accounts (mastodon-views--accounts-in-list list-id)) (handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id accounts)) (account (completing-read "Account to remove: " handles nil t)) (account-id (alist-get account handles)) (url (mastodon-http--api (format "lists/%s/accounts" list-id))) (args (mastodon-http--build-array-params-alist "account_ids[]" `(,account-id))) (response (mastodon-http--delete url args))) (mastodon-views--list-action-triage response "%s removed from list %s!" account list-name))) (defun mastodon-views--list-action-triage (response &rest args) "Call `mastodon-http--triage' on RESPONSE and call message on ARGS." (mastodon-http--triage response (lambda (_) (when (mastodon-tl--buffer-type-eq 'lists) (mastodon-views--view-lists)) (apply #'message args)))) (defun mastodon-views--accounts-in-list (list-id) "Return the JSON of the accounts in list with LIST-ID." (let* ((url (mastodon-http--api (format "lists/%s/accounts" list-id)))) (mastodon-http--get-json url))) ;;; FOLLOW REQUESTS (defun mastodon-views--insert-follow-requests (json) "Insert the user's current follow requests. JSON is the data returned by the server." (mastodon-views--minor-view "follow requests" #'mastodon-views--insert-users-propertized-note json)) (defun mastodon-views--view-follow-requests () "Open a new buffer displaying the user's follow requests." (interactive) (mastodon-tl--init-sync "follow-requests" "follow_requests" 'mastodon-views--insert-follow-requests nil '(("limit" . "40")) ; server max is 80 :headers "follow requests" "a/j - accept/reject request at point\n\ n/p - go to next/prev request") (mastodon-tl--goto-first-item) (with-current-buffer "*mastodon-follow-requests*" (use-local-map mastodon-views--view-follow-requests-keymap))) ;;; SCHEDULED TOOTS (defun mastodon-views--view-scheduled-toots () "Show the user's scheduled toots in a new buffer." (interactive) (mastodon-tl--init-sync "scheduled-toots" "scheduled_statuses" 'mastodon-views--insert-scheduled-toots nil nil nil "your scheduled toots" "n/p - prev/next\n r - reschedule\n\ e/RET - edit toot\n c - cancel") (with-current-buffer "*mastodon-scheduled-toots*" (use-local-map mastodon-views--scheduled-map))) (defun mastodon-views--insert-scheduled-toots (json) "Insert the user's scheduled toots, from JSON." (mastodon-views--minor-view "scheduled toots" #'mastodon-views--insert-scheduled-toots-list json)) (defun mastodon-views--insert-scheduled-toots-list (scheduleds) "Insert scheduled toots in SCHEDULEDS." (mapc #'mastodon-views--insert-scheduled-toot scheduleds)) (defun mastodon-views--insert-scheduled-toot (toot) "Insert scheduled TOOT into the buffer." (let-alist toot (insert (propertize (concat .params.text " | " (mastodon-toot--iso-to-human .scheduled_at)) 'byline t ; so we nav here 'item-id "0" ; so we nav here 'face 'font-lock-comment-face 'keymap mastodon-views--scheduled-map 'scheduled-json toot 'id .id) "\n"))) (defun mastodon-views--get-scheduled-toots (&optional id) "Get the user's currently scheduled toots. If ID, just return that toot." (let* ((endpoint (if id (format "scheduled_statuses/%s" id) "scheduled_statuses")) (url (mastodon-http--api endpoint))) (mastodon-http--get-json url))) (defun mastodon-views--reschedule-toot () "Reschedule the scheduled toot at point." (interactive) (let ((id (mastodon-tl--property 'id :no-move))) (if (null id) (message "no scheduled toot at point?") (mastodon-toot--schedule-toot :reschedule)))) (defun mastodon-views--copy-scheduled-toot-text () "Copy the text of the scheduled toot at point." (interactive) (let* ((toot (mastodon-tl--property 'toot :no-move)) (params (alist-get 'params toot)) (text (alist-get 'text params))) (kill-new text))) (defun mastodon-views--cancel-scheduled-toot (&optional id no-confirm) "Cancel the scheduled toot at point. ID is that of the scheduled toot to cancel. NO-CONFIRM means there is no ask or message, there is only do." (interactive) (let ((id (or id (mastodon-tl--property 'id :no-move)))) (if (null id) (message "no scheduled toot at point?") (when (or no-confirm (y-or-n-p "Cancel scheduled toot?")) (let* ((url (mastodon-http--api (format "scheduled_statuses/%s" id))) (response (mastodon-http--delete url))) (mastodon-http--triage response (lambda (_) (mastodon-views--view-scheduled-toots) (unless no-confirm (message "Toot cancelled!"))))))))) (defun mastodon-views--edit-scheduled-as-new () "Edit scheduled status as new toot." (interactive) (let ((id (mastodon-tl--property 'id :no-move))) (if (null id) (message "no scheduled toot at point?") (let* ((toot (mastodon-tl--property 'scheduled-json :no-move)) (scheduled (alist-get 'scheduled_at toot))) (let-alist (alist-get 'params toot) ;; (poll (alist-get 'poll params)) ;; (media (alist-get 'media_attachments toot))) (mastodon-toot--compose-buffer) (goto-char (point-max)) (insert .text) ;; adopt properties from scheduled toot: (mastodon-toot--set-toot-properties .in_reply_to_id .visibility .spoiler_text .language scheduled id)))))) ;;; FILTERS (defun mastodon-views--view-filters () "View the user's filters in a new buffer." (interactive) (mastodon-tl--init-sync "filters" "filters" 'mastodon-views--insert-filters nil nil nil "current filters" "c - create filter\n d - delete filter at point\n\ n/p - go to next/prev filter") (with-current-buffer "*mastodon-filters*" (use-local-map mastodon-views--view-filters-keymap))) (defun mastodon-views--insert-filters (json) "Insert the user's current filters. JSON is what is returned by by the server." (mastodon-views--minor-view "filters" #'mastodon-views--insert-filter-string-set json)) (defun mastodon-views--insert-filter-string-set (json) "Insert a filter string plus a blank line. JSON is the filters data." (mapc #'mastodon-views--insert-filter-string json)) (defun mastodon-views--insert-filter-string (filter) "Insert a single FILTER." (let* ((phrase (alist-get 'phrase filter)) (contexts (alist-get 'context filter)) (id (alist-get 'id filter)) (filter-string (concat "- \"" phrase "\" filtered in: " (mapconcat #'identity contexts ", ")))) (insert (propertize filter-string 'item-id id ;for goto-next-filter compat 'phrase phrase 'byline t) ;for goto-next-filter compat "\n\n"))) (defun mastodon-views--create-filter () "Create a filter for a word. Prompt for a context, must be a list containting at least one of \"home\", \"notifications\", \"public\", \"thread\"." (interactive) (let* ((url (mastodon-http--api "filters")) (word (read-string (format "Word(s) to filter (%s): " (or (current-word) "")) nil nil (or (current-word) ""))) (contexts (if (string-empty-p word) (user-error "You must select at least one word for a filter") (completing-read-multiple "Contexts to filter [TAB for options]: " '("home" "notifications" "public" "thread") nil t))) (contexts-processed (if (equal nil contexts) (user-error "You must select at least one context for a filter") (mapcar (lambda (x) (cons "context[]" x)) contexts))) (response (mastodon-http--post url (push `("phrase" . ,word) contexts-processed)))) (mastodon-http--triage response (lambda (_) (message "Filter created for %s!" word) (when (mastodon-tl--buffer-type-eq 'filters) (mastodon-views--view-filters)))))) (defun mastodon-views--delete-filter () "Delete filter at point." (interactive) (let* ((filter-id (mastodon-tl--property 'item-id :no-move)) (phrase (mastodon-tl--property 'phrase :no-move)) (url (mastodon-http--api (format "filters/%s" filter-id)))) (if (null phrase) (user-error "No filter at point?") (when (y-or-n-p (format "Delete filter %s? " phrase)) (let ((response (mastodon-http--delete url))) (mastodon-http--triage response (lambda (_) (mastodon-views--view-filters) (message "Filter for \"%s\" deleted!" phrase)))))))) ;;; FOLLOW SUGGESTIONS ;; No pagination: max 80 results (defun mastodon-views--view-follow-suggestions () "Display a buffer of suggested accounts to follow." (interactive) (mastodon-tl--init-sync "follow-suggestions" "suggestions" 'mastodon-views--insert-follow-suggestions nil '(("limit" . "80")) ; server max nil "suggested accounts") (with-current-buffer "*mastodon-follow-suggestions*" (use-local-map mastodon-views--follow-suggestions-map))) (defun mastodon-views--insert-follow-suggestions (json) "Insert follow suggestions into buffer. JSON is the data returned by the server." (mastodon-views--minor-view "suggested accounts" #'mastodon-views--insert-users-propertized-note json)) (defun mastodon-views--insert-users-propertized-note (json) "Insert users list into the buffer, including profile note. JSON is the users list data." (mastodon-search--insert-users-propertized json :note)) ;;; INSTANCES (defun mastodon-views--view-own-instance (&optional brief) "View details of your own instance. BRIEF means show fewer details." (interactive) (mastodon-views--view-instance-description :user brief)) (defun mastodon-views--view-own-instance-brief () "View brief details of your own instance." (interactive) (mastodon-views--view-instance-description :user :brief)) (defun mastodon-views--view-instance-description-brief () "View brief details of the instance the current post's author is on." (interactive) (mastodon-views--view-instance-description nil :brief)) (defun mastodon-views--get-instance-url (url username &optional instance) "Return an instance base url from a user account URL. USERNAME is the name to cull. If INSTANCE is given, use that." (cond (instance (concat "https://" instance)) ;; pleroma URL is https://instance.com/users/username ((string-suffix-p "users/" (url-basepath url)) (string-remove-suffix "/users/" (url-basepath url))) ;; friendica is https://instance.com/profile/user ((string-suffix-p "profile/" (url-basepath url)) (string-remove-suffix "/profile/" (url-basepath url))) ;; mastodon is https://instance.com/@user (t (string-remove-suffix (concat "/@" username) url)))) (defun mastodon-views--view-instance-description (&optional user brief instance misskey) "View the details of the instance the current post's author is on. USER means to show the instance details for the logged in user. BRIEF means to show fewer details. INSTANCE is an instance domain name. MISSKEY means the instance is a Misskey or derived server." (interactive) (if user (let ((response (mastodon-http--get-json (mastodon-http--api "instance") nil nil :vector))) (mastodon-views--instance-response-fun response brief instance)) (mastodon-tl--do-if-item (let* ((toot (if (mastodon-tl--profile-buffer-p) ;; we may be on profile description itself: (or (mastodon-tl--property 'profile-json) ;; or on profile account listings, or just toots: (mastodon-tl--property 'item-json)) ;; normal timeline/account listing: (mastodon-tl--property 'item-json))) (reblog (alist-get 'reblog toot)) (account (or (alist-get 'account reblog) (alist-get 'account toot) toot)) ; else `toot' is already an account listing. ;; we may be at toots/boosts/users in a profile buffer. ;; profile-json is a defacto test for if point is on the profile ;; details at the top of a profile buffer. (profile-note-p (and (mastodon-tl--profile-buffer-p) ;; only call this in profile buffers: (mastodon-tl--property 'profile-json))) (url (if profile-note-p (alist-get 'url toot) ; profile description (alist-get 'url account))) (username (if profile-note-p (alist-get 'username toot) ;; profile (alist-get 'username account))) (instance (mastodon-views--get-instance-url url username instance))) (if misskey (let* ((params `(("detail" . ,(or brief t)))) (headers '(("Content-Type" . "application/json"))) (url (concat instance "/api/meta")) (response (with-current-buffer (mastodon-http--post url params headers t :json) (mastodon-http--process-response)))) (mastodon-views--instance-response-fun response brief instance :misskey)) (let ((response (mastodon-http--get-json (concat instance "/api/v1/instance") nil nil :vector))) ;; if non-misskey attempt errors, try misskey instance: ;; akkoma i guess should not error here. (if (eq 'error (caar response)) (mastodon-views--instance-desc-misskey) (mastodon-views--instance-response-fun response brief instance)))))))) (defun mastodon-views--instance-desc-misskey (&optional user brief instance) "Show instance description for a misskey/firefish server. USER, BRIEF, and INSTANCE are all for `mastodon-views--view-instance-description', which see." (interactive) (mastodon-views--view-instance-description user brief instance :miskey)) (defun mastodon-views--instance-response-fun (response brief instance &optional misskey) "Display instance description RESPONSE in a new buffer. BRIEF means to show fewer details. INSTANCE is the instance were are working with. MISSKEY means the instance is a Misskey or derived server." (when response (let* ((domain (url-file-nondirectory instance)) (buf (get-buffer-create (format "*mastodon-instance-%s*" domain)))) (with-mastodon-buffer buf #'special-mode :other-window (if misskey (mastodon-views--insert-json response) (condition-case nil (progn (when brief (setq response (list (assoc 'uri response) (assoc 'title response) (assoc 'short_description response) (assoc 'email response) (cons 'contact_account (list (assoc 'username (assoc 'contact_account response)))) (assoc 'rules response) (assoc 'stats response)))) (mastodon-views--print-json-keys response) (mastodon-tl--set-buffer-spec (buffer-name buf) "instance" nil) (goto-char (point-min))) (error ; just insert the raw response: (mastodon-views--insert-json response)))))))) (defun mastodon-views--insert-json (response) "Insert raw JSON RESPONSE in current buffer." (let ((inhibit-read-only t)) (erase-buffer) (insert (prin1-to-string response)) (pp-buffer) (goto-char (point-min)))) (defun mastodon-views--format-key (el pad) "Format a key of element EL, a cons, with PAD padding." (format (concat "%-" (number-to-string pad) "s: ") (propertize (prin1-to-string (car el)) 'face '(:underline t)))) (defun mastodon-views--print-json-keys (response &optional ind) "Print the JSON keys and values in RESPONSE. IND is the optional indentation level to print at." (let* ((cars (mapcar (lambda (x) (symbol-name (car x))) response)) (pad (1+ (cl-reduce #'max (mapcar #'length cars))))) (while response (let ((el (pop response))) (cond ((and (vectorp (cdr el)) ; vector of alists (fields, instance rules): (not (seq-empty-p (cdr el))) (consp (seq-elt (cdr el) 0))) (insert (mastodon-views--format-key el pad) "\n\n") (seq-do #'mastodon-views--print-instance-rules-or-fields (cdr el)) (insert "\n")) ((and (vectorp (cdr el)) ; vector of strings (media types): (not (seq-empty-p (cdr el))) (< 1 (seq-length (cdr el))) (stringp (seq-elt (cdr el) 0))) (when ind (indent-to ind)) (insert (mastodon-views--format-key el pad) "\n" (seq-mapcat (lambda (x) (concat x ", ")) (cdr el) 'string) "\n\n")) ((consp (cdr el)) ; basic nesting: (when ind (indent-to ind)) (insert (mastodon-views--format-key el pad) "\n\n") (mastodon-views--print-json-keys (cdr el) (if ind (+ ind 4) 4))) (t ; basic handling of raw booleans: (let ((val (cond ((equal (cdr el) :json-false) "no") ((equal (cdr el) 't) "yes") (t (cdr el))))) (when ind (indent-to ind)) (insert (mastodon-views--format-key el pad) " " (mastodon-views--newline-if-long (cdr el)) ;; only send strings to --render-text (for hyperlinks): (mastodon-tl--render-text (if (stringp val) val (prin1-to-string val))) "\n")))))))) (defun mastodon-views--print-instance-rules-or-fields (alist) "Print ALIST of instance rules or contact account or emoji fields." (let-alist alist (let ((key (or .id .name .shortcode)) (value (or .text .value .url))) (indent-to 4) (insert (format "%-5s: " (propertize key 'face '(:underline t))) (mastodon-views--newline-if-long value) (format "%s" (mastodon-tl--render-text value)) "\n")))) (defun mastodon-views--newline-if-long (el) "Return a newline string if the cdr of EL is over 50 characters long." (let ((rend (if (stringp el) (mastodon-tl--render-text el) el))) (if (and (sequencep rend) (< 50 (length rend))) "\n" ""))) (provide 'mastodon-views) ;;; mastodon-views.el ends here mastodon.el/lisp/mastodon.el000066400000000000000000000464021452000115200164120ustar00rootroot00000000000000;;; mastodon.el --- Client for fediverse services using the Mastodon API -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen ;; Copyright (C) 2020-2022 Marty Hiatt ;; Copyright (C) 2021 Abhiseck Paira ;; Author: Johnson Denen ;; Marty Hiatt ;; Maintainer: Marty Hiatt ;; Version: 1.0.12 ;; Package-Requires: ((emacs "27.1") (request "0.3.0") (persist "0.4")) ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. ;; This file is part of mastodon.el. ;; mastodon.el 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 3 of the License, or ;; (at your option) any later version. ;; mastodon.el 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 mastodon.el. If not, see . ;;; Commentary: ;; mastodon.el is a client for fediverse services that implement the Mastodon ;; API. See . ;; See the readme file at https://codeberg.org/martianh/mastodon.el for set up ;; and usage details. ;;; Code: (require 'cl-lib) ; for `cl-some' call in mastodon (eval-when-compile (require 'subr-x)) (require 'mastodon-http) (require 'mastodon-toot) (require 'mastodon-search) (require 'url) (require 'thingatpt) (require 'shr) (declare-function discover-add-context-menu "discover") (declare-function emojify-mode "emojify") (declare-function request "request") (autoload 'mastodon-auth--get-account-name "mastodon-auth") (autoload 'mastodon-auth--user-acct "mastodon-auth") (autoload 'mastodon-discover "mastodon-discover") (autoload 'mastodon-notifications--follow-request-accept "mastodon-notifications") (autoload 'mastodon-notifications--follow-request-reject "mastodon-notifications") (autoload 'mastodon-notifications--get-mentions "mastodon-notifications") (autoload 'mastodon-notifications--timeline "mastodon-notifications") (autoload 'mastodon-profile--fetch-server-account-settings "mastodon-profile") (autoload 'mastodon-profile--get-toot-author "mastodon-profile") (autoload 'mastodon-profile--make-author-buffer "mastodon-profile") (autoload 'mastodon-profile--my-profile "mastodon-profile") (autoload 'mastodon-profile--show-user "mastodon-profile") (autoload 'mastodon-profile--update-user-profile-note "mastodon-profile") (autoload 'mastodon-profile--view-bookmarks "mastodon-profile") (autoload 'mastodon-profile--view-favourites "mastodon-profile") (autoload 'mastodon-tl--block-user "mastodon-tl") (autoload 'mastodon-tl--follow-user "mastodon-tl") (autoload 'mastodon-tl--followed-tags-timeline "mastodon-tl") (autoload 'mastodon-tl--get-buffer-type "mastodon-tl") (autoload 'mastodon-tl--get-federated-timeline "mastodon-tl") (autoload 'mastodon-tl--get-home-timeline "mastodon-tl") (autoload 'mastodon-tl--get-local-timeline "mastodon-tl") (autoload 'mastodon-tl--get-tag-timeline "mastodon-tl") (autoload 'mastodon-tl--goto-next-item "mastodon-tl") (autoload 'mastodon-tl--goto-prev-item "mastodon-tl") (autoload 'mastodon-tl--init-sync "mastodon-tl") (autoload 'mastodon-tl--list-followed-tags "mastodon-tl") (autoload 'mastodon-tl--mute-user "mastodon-tl") (autoload 'mastodon-tl--next-tab-item "mastodon-tl") (autoload 'mastodon-tl--poll-vote "mastodon-http") (autoload 'mastodon-tl--previous-tab-item "mastodon-tl") (autoload 'mastodon-tl--thread "mastodon-tl") (autoload 'mastodon-tl--toggle-spoiler-text-in-toot "mastodon-tl") (autoload 'mastodon-tl--unblock-user "mastodon-tl") (autoload 'mastodon-tl--unfollow-user "mastodon-tl") (autoload 'mastodon-tl--unmute-user "mastodon-tl") (autoload 'mastodon-tl--report-to-mods "mastodon-tl") (autoload 'mastodon-tl--update "mastodon-tl") (autoload 'mastodon-toot--edit-toot-at-point "mastodon-toot") (when (require 'lingva nil :no-error) (autoload 'mastodon-toot--translate-toot-text "mastodon-toot")) (autoload 'mastodon-toot--view-toot-history "mastodon-tl") (autoload 'mastodon-views--view-follow-suggestions "mastodon-views") (autoload 'mastodon-views--view-filters "mastodon-views") (autoload 'mastodon-views--view-follow-requests "mastodon-views") (autoload 'mastodon-views--view-instance-description "mastodon-views") (autoload 'mastodon-views--view-lists "mastodon-views") (autoload 'mastodon-views--view-scheduled-toots "mastodon-views") (autoload 'special-mode "simple") (defvar mastodon-tl--highlight-current-toot) (defvar mastodon-notifications--map) (defgroup mastodon nil "Interface with Mastodon." :prefix "mastodon-" :group 'external) (defcustom mastodon-instance-url "https://mastodon.social" "Base URL for the Mastodon instance you want to be active. For example, if your mastodon username is \"example_user@social.instance.org\", and you want this account to be active, the value of this variable should be \"https://social.instance.org\". Also for completeness, the value of `mastodon-active-user' should be \"example_user\". After setting these variables you should restart Emacs for these changes to take effect." :type 'string) (defcustom mastodon-active-user nil "Username of the active user. For example, if your mastodon username is \"example_user@social.instance.org\", and you want this account to be active, the value of this variable should be \"example_user\". Also for completeness, the value of `mastodon-instance-url' should be \"https://social.instance.org\". After setting these variables you should restart Emacs for these changes to take effect." :type 'string) (defcustom mastodon-toot-timestamp-format "%F %T" "Format to use for timestamps. For valid formatting options see `format-time-string`. The default value \"%F %T\" prints ISO8601-style YYYY-mm-dd HH:MM:SS. Use. e.g. \"%c\" for your locale's date and time format." :type 'string) (defvar mastodon-mode-map (let ((map (make-sparse-keymap))) ;; navigation inside a timeline (define-key map (kbd "n") #'mastodon-tl--goto-next-item) (define-key map (kbd "p") #'mastodon-tl--goto-prev-item) (define-key map (kbd "M-n") #'mastodon-tl--next-tab-item) (define-key map (kbd "M-p") #'mastodon-tl--previous-tab-item) (define-key map [?\t] #'mastodon-tl--next-tab-item) (define-key map [backtab] #'mastodon-tl--previous-tab-item) (define-key map [?\S-\t] #'mastodon-tl--previous-tab-item) (define-key map [?\M-\t] #'mastodon-tl--previous-tab-item) (define-key map (kbd "l") #'recenter-top-bottom) ;; navigation between timelines (define-key map (kbd "#") #'mastodon-tl--get-tag-timeline) (define-key map (kbd "\"") #'mastodon-tl--list-followed-tags) (define-key map (kbd "'") #'mastodon-tl--followed-tags-timeline) (define-key map (kbd "A") #'mastodon-profile--get-toot-author) (define-key map (kbd "F") #'mastodon-tl--get-federated-timeline) (define-key map (kbd "H") #'mastodon-tl--get-home-timeline) (define-key map (kbd "L") #'mastodon-tl--get-local-timeline) (define-key map (kbd "N") #'mastodon-notifications-get) (define-key map (kbd "@") #'mastodon-notifications--get-mentions) (define-key map (kbd "P") #'mastodon-profile--show-user) (define-key map (kbd "s") #'mastodon-search--query) (define-key map (kbd "/") #'mastodon-switch-to-buffer) ;; quitting mastodon (define-key map (kbd "q") #'kill-current-buffer) (define-key map (kbd "Q") #'kill-buffer-and-window) (define-key map (kbd "M-C-q") #'mastodon-kill-all-buffers) ;; toot actions (define-key map (kbd "c") #'mastodon-tl--toggle-spoiler-text-in-toot) (define-key map (kbd "b") #'mastodon-toot--toggle-boost) (define-key map (kbd "f") #'mastodon-toot--toggle-favourite) (define-key map (kbd "k") #'mastodon-toot--toggle-bookmark) (define-key map (kbd "r") #'mastodon-toot--reply) (define-key map (kbd "C") #'mastodon-toot--copy-toot-url) (define-key map (kbd "v") #'mastodon-tl--poll-vote) (define-key map (kbd "E") #'mastodon-toot--view-toot-edits) (define-key map (kbd "T") #'mastodon-tl--thread) (define-key map (kbd "m") #'mastodon-tl--dm-user) (when (require 'lingva nil :no-error) (define-key map (kbd "a") #'mastodon-toot--translate-toot-text)) (define-key map (kbd ",") #'mastodon-toot--list-toot-favouriters) (define-key map (kbd ".") #'mastodon-toot--list-toot-boosters) (define-key map (kbd ";") #'mastodon-views--view-instance-description) ;; override special mode binding (define-key map (kbd "g") #'undefined) (define-key map (kbd "g") #'mastodon-tl--update) ;; this is now duplicated by 'g', cd remove/use for else: (define-key map (kbd "u") #'mastodon-tl--update) ;; own toot actions: (define-key map (kbd "t") #'mastodon-toot) (define-key map (kbd "d") #'mastodon-toot--delete-toot) (define-key map (kbd "D") #'mastodon-toot--delete-and-redraft-toot) (define-key map (kbd "i") #'mastodon-toot--pin-toot-toggle) (define-key map (kbd "e") #'mastodon-toot--edit-toot-at-point) ;; user actions (define-key map (kbd "W") #'mastodon-tl--follow-user) (define-key map (kbd "C-S-W") #'mastodon-tl--unfollow-user) (define-key map (kbd "B") #'mastodon-tl--block-user) (define-key map (kbd "C-S-B") #'mastodon-tl--unblock-user) (define-key map (kbd "M") #'mastodon-tl--mute-user) (define-key map (kbd "C-S-M") #'mastodon-tl--unmute-user) (define-key map (kbd "Z") #'mastodon-tl--report-to-mods) ;; own profile (define-key map (kbd "O") #'mastodon-profile--my-profile) (define-key map (kbd "U") #'mastodon-profile--update-user-profile-note) (define-key map (kbd "V") #'mastodon-profile--view-favourites) (define-key map (kbd "K") #'mastodon-profile--view-bookmarks) ;; minor views (define-key map (kbd "R") #'mastodon-views--view-follow-requests) (define-key map (kbd "S") #'mastodon-views--view-scheduled-toots) (define-key map (kbd "I") #'mastodon-views--view-filters) (define-key map (kbd "G") #'mastodon-views--view-follow-suggestions) (define-key map (kbd "X") #'mastodon-views--view-lists) (define-key map (kbd "SPC") #'mastodon-tl--scroll-up-command) map) "Keymap for `mastodon-mode'.") (defcustom mastodon-mode-hook nil "Hook run when entering Mastodon mode." :type 'hook :options '(provide-discover-context-menu)) (defface mastodon-handle-face '((t :inherit default)) "Face used for user handles in bylines.") (defface mastodon-display-name-face '((t :inherit warning)) "Face used for user display names.") (defface mastodon-boosted-face '((t :inherit success :weight bold)) "Face to indicate that a toot is boosted.") (defface mastodon-boost-fave-face '((t :inherit success)) "Face to indicate that you have boosted or favourited a toot.") (defface mastodon-cw-face '((t :inherit success)) "Face used for content warning.") (defface mastodon-toot-docs-face `((t :inherit font-lock-comment-face)) "Face used for documentation in toot compose buffer. If `mastodon-tl--enable-proportional-fonts' is changed, mastodon.el needs to be re-loaded for this to be correctly set.") (defface mastodon-toot-docs-reply-text-face `((t :inherit font-lock-comment-face :family ,(face-attribute 'variable-pitch :family))) "Face used for reply text in toot compose buffer. See `mastodon-toot-display-orig-in-reply-buffer'.") (defface mastodon-cursor-highlight-face `((t :inherit highlight :extend t)) "Face for `mastodon-tl--highlight-current-toot'.") ;;;###autoload (defun mastodon () "Connect Mastodon client to `mastodon-instance-url' instance." (interactive) (let* ((tls (list "home" "local" "federated" (concat (mastodon-auth--user-acct) "-statuses") ; own profile "favourites" "search")) (buffer (or (cl-some (lambda (el) (get-buffer (concat "*mastodon-" el "*"))) tls) ; return first buff that exists (cl-some (lambda (x) (when (string-prefix-p "*mastodon-" (buffer-name x)) (get-buffer x))) (buffer-list))))) ; catch any other masto buffer (mastodon-return-credential-account :force) (if buffer (switch-to-buffer buffer) (mastodon-tl--get-home-timeline) (message "Loading Mastodon account %s on %s..." (mastodon-auth--user-acct) mastodon-instance-url)))) (defvar mastodon-profile-credential-account nil) (defun mastodon-return-credential-account (&optional force) "Return the CredentialAccount entity. Either from `mastodon-profile-credential-account' or from the server. FORCE means to fetch from the server and update `mastodon-profile-credential-account'." (let ((req '(mastodon-http--get-json (mastodon-http--api "accounts/verify_credentials") nil :silent))) (if force (setq mastodon-profile-credential-account (eval req)) (or mastodon-profile-credential-account (setq mastodon-profile-credential-account (eval req)))))) ;;;###autoload (defun mastodon-toot (&optional user reply-to-id reply-json) "Update instance with new toot. Content is captured in a new buffer. If USER is non-nil, insert after @ symbol to begin new toot. If REPLY-TO-ID is non-nil, attach new toot to a conversation. If REPLY-JSON is the json of the toot being replied to." (interactive) (mastodon-toot--compose-buffer user reply-to-id reply-json)) ;;;###autoload (defun mastodon-notifications-get (&optional type buffer-name force) "Display NOTIFICATIONS in buffer. Optionally only print notifications of type TYPE, a string. BUFFER-NAME is added to \"*mastodon-\" to create the buffer name. FORCE means do not try to update an existing buffer, but fetch from the server and load anew." (interactive) (let ((buffer (if buffer-name (concat "*mastodon-" buffer-name "*") "*mastodon-notifications*"))) (if (and (not force) (get-buffer buffer)) (progn (switch-to-buffer buffer) (mastodon-tl--update)) (message "Loading your notifications...") (mastodon-tl--init-sync (or buffer-name "notifications") "notifications" 'mastodon-notifications--timeline type) (with-current-buffer buffer (use-local-map mastodon-notifications--map))))) ;; URL lookup: should be available even if `mastodon.el' not loaded: ;;;###autoload (defun mastodon-url-lookup (&optional query-url) "If a URL resembles a mastodon link, try to load in `mastodon.el'. Does a WebFinger lookup. URL can be arg QUERY-URL, or URL at point, or provided by the user. If a status or account is found, load it in `mastodon.el', if not, just browse the URL in the normal fashion." (interactive) (let* ((query (or query-url (thing-at-point-url-at-point) (mastodon-tl--property 'shr-url :no-move) (read-string "Lookup URL: ")))) (if (not (mastodon--fedi-url-p query)) ;; (shr-browse-url query) ; doesn't work (keep our shr keymap) (browse-url query) (message "Performing lookup...") (let* ((url (format "%s/api/v2/search" mastodon-instance-url)) (params `(("q" . ,query) ("resolve" . "t"))) ; webfinger (response (mastodon-http--get-json url params :silent))) (cond ((not (seq-empty-p (alist-get 'statuses response))) (let* ((statuses (assoc 'statuses response)) (status (seq-first (cdr statuses))) (status-id (alist-get 'id status))) (mastodon-tl--thread status-id))) ((not (seq-empty-p (alist-get 'accounts response))) (let* ((accounts (assoc 'accounts response)) (account (seq-first (cdr accounts)))) (mastodon-profile--make-author-buffer account))) (t (browse-url query))))))) (defun mastodon--fedi-url-p (query) "Check if QUERY resembles a fediverse URL." ;; calqued off https://github.com/tuskyapp/Tusky/blob/c8fc2418b8f5458a817bba221d025b822225e130/app/src/main/java/com/keylesspalace/tusky/BottomSheetActivity.kt ;; thx to Conny Duck! (let* ((uri-parsed (url-generic-parse-url query)) (query (url-filename uri-parsed))) (save-match-data (or (string-match "^/@[^/]+$" query) (string-match "^/@[^/]+/[[:digit:]]+$" query) (string-match "^/user[s]?/@?[[:alnum:]]+$" query) ; @: pleroma or soapbox (string-match "^/notice/[[:alnum:]]+$" query) (string-match "^/objects/[-a-f0-9]+$" query) (string-match "^/notes/[a-z0-9]+$" query) (string-match "^/display/[-a-f0-9]+$" query) (string-match "^/profile/[[:alpha:]]+$" query) (string-match "^/p/[[:alpha:]]+/[[:digit:]]+$" query) (string-match "^/[[:alpha:]]+$" query) (string-match "^/u/[[:alpha:]]+$" query) (string-match "^/c/[[:alnum:]]+$" query) (string-match "^/post/[[:digit:]]+$" query) (string-match "^/comment/[[:digit:]]+$" query) ; lemmy (string-match "^/user[s]?/[[:alnum:]]+/statuses/[[:digit:]]+$" query) ; hometown (string-match "^/notes/[[:alnum:]]+$" query))))) ; misskey post (defun mastodon-live-buffers () "Return a list of open mastodon buffers. Calls `mastodon-tl--get-buffer-type', which see." (cl-loop for x in (buffer-list) when (with-current-buffer x (mastodon-tl--get-buffer-type)) collect (get-buffer x))) (defun mastodon-buffer-p (&optional buffer) "Non-nil if BUFFER or `current-buffer' is a mastodon one." (let ((buf (or buffer (current-buffer)))) (member buf (mastodon-live-buffers)))) (defun mastodon-kill-all-buffers () "Kill any and all open mastodon buffers, hopefully." (interactive) (let ((mastodon-buffers (mastodon-live-buffers))) (cl-loop for x in mastodon-buffers do (kill-buffer x)))) (defun mastodon-switch-to-buffer () "Switch to a live mastodon buffer." (interactive) (let* ((bufs (mastodon-live-buffers)) (buf-names (mapcar #'buffer-name bufs)) (choice (completing-read "Switch to mastodon buffer: " buf-names))) (switch-to-buffer choice))) (defun mastodon-mode-hook-fun () "Function to add to `mastodon-mode-hook'." (when (require 'emojify nil :noerror) (emojify-mode t) (when mastodon-toot--enable-custom-instance-emoji (mastodon-toot--enable-custom-emoji))) (mastodon-profile--fetch-server-account-settings) (when mastodon-tl--highlight-current-toot (cursor-face-highlight-mode))) ; 29.1 ;;;###autoload (add-hook 'mastodon-mode-hook #'mastodon-mode-hook-fun) (define-derived-mode mastodon-mode special-mode "Mastodon" "Major mode for Mastodon, the federated microblogging network." (read-only-mode 1)) (provide 'mastodon) ;;; mastodon.el ends here mastodon.el/mastodon-index.org000066400000000000000000000762511452000115200167440ustar00rootroot00000000000000 * mastodon commands index #+BEGIN_SRC emacs-lisp :results table :colnames '("Binding" "Command" "Description") :exports results (let ((rows)) (mapatoms (lambda (symbol) (when (and (string-match "^mastodon" (symbol-name symbol)) (commandp symbol)) (let* ((doc (car (split-string (or (documentation symbol t) "") "\n"))) ;; add more keymaps here ;; some keys are in sub 'keymap keys inside a map (maps (list mastodon-mode-map mastodon-toot-mode-map mastodon-profile-mode-map mastodon-notifications--map mastodon-tl--shr-image-map-replacement mastodon-profile-update-mode-map mastodon-views-map mastodon-views--follow-suggestions-map mastodon-views--scheduled-map mastodon-views--view-lists-keymap mastodon-views--view-follow-requests-keymap mastodon-views--view-filters-keymap)) (binding-code (let ((keys (where-is-internal symbol maps nil nil (command-remapping symbol)))) ;; just take first 2 bindings: (if (> (length keys) 2) (list (car keys) (cadr keys)) keys))) ;; (or (car (rassoc symbol mastodon-mode-map)) ;; (car (rassoc symbol (cadr mastodon-toot-mode-map))) ;; (car (rassoc symbol (cadr mastodon-profile-mode-map))) ;; (car (rassoc symbol mastodon-notifications--map)))) (binding-str (if binding-code (mapconcat #'help--key-description-fontified binding-code ", ") ""))) (push `(,binding-str ,symbol ,doc) rows) rows)))) (sort rows (lambda (x y) (string-lessp (cadr x) (cadr y))))) #+END_SRC #+RESULTS: | Binding | Command | Description | |------------------+---------------------------------------------------+--------------------------------------------------------------------------------| | | mastodon | Connect Mastodon client to `mastodon-instance-url' instance. | | | mastodon-async-mode | Async Mastodon. | | | mastodon-discover | Plug Mastodon functionality into `discover'. | | C-M-q | mastodon-kill-all-buffers | Kill any and all open mastodon buffers, hopefully. | | | mastodon-mode | Major mode for Mastodon, the federated microblogging network. | | | mastodon-notifications--clear-all | Clear all notifications. | | C-k | mastodon-notifications--clear-current | Dismiss the notification at point. | | | mastodon-notifications--follow-request-accept | Accept a follow request. | | j | mastodon-notifications--follow-request-reject | Reject a follow request. | | | mastodon-notifications--get-boosts | Display boost notifications in buffer. | | | mastodon-notifications--get-favourites | Display favourite notifications in buffer. | | @ | mastodon-notifications--get-mentions | Display mention notifications in buffer. | | | mastodon-notifications--get-polls | Display poll notifications in buffer. | | | mastodon-notifications--get-statuses | Display status notifications in buffer. | | N | mastodon-notifications-get | Display NOTIFICATIONS in buffer. | | | mastodon-profile--account-bot-toggle | Toggle the bot status of your account. | | | mastodon-profile--account-discoverable-toggle | Toggle the discoverable status of your account. | | | mastodon-profile--account-locked-toggle | Toggle the locked status of your account. | | | mastodon-profile--account-search | Run a statuses search QUERY for the currently viewed account. | | | mastodon-profile--account-sensitive-toggle | Toggle the sensitive status of your account. | | | mastodon-profile--account-view-cycle | Cycle through profile view: toots, toot sans boosts, followers, and following. | | | mastodon-profile--add-account-to-list | Add account of current profile buffer to a list. | | | mastodon-profile--add-private-note-to-account | Add a private note to an account. | | A | mastodon-profile--get-toot-author | Open profile of author of toot under point. | | O | mastodon-profile--my-profile | Show the profile of the currently signed in user. | | | mastodon-profile--open-followers | Open a profile buffer showing the accounts following the current profile. | | | mastodon-profile--open-following | Open a profile buffer showing the accounts that current profile follows. | | | mastodon-profile--open-statuses-no-reblogs | Open a profile buffer showing statuses without reblogs. | | | mastodon-profile--remove-from-followers-at-point | Prompt for a user in the item at point and remove from followers. | | | mastodon-profile--remove-from-followers-list | Select a user from your followers and remove from followers. | | | mastodon-profile--remove-user-from-followers | Remove a user from your followers. | | | mastodon-profile--show-familiar-followers | Show a list of familiar followers. | | P | mastodon-profile--show-user | Query for USER-HANDLE from current status and show that user's profile. | | | mastodon-profile--update-display-name | Update display name for your account. | | | mastodon-profile--update-meta-fields | Prompt for new metadata fields information and PATCH the server. | | | mastodon-profile--update-profile-note-cancel | Cancel updating user profile and kill buffer and window. | | U | mastodon-profile--update-user-profile-note | Fetch user's profile note and display for editing. | | | mastodon-profile--user-profile-send-updated | Send PATCH request with the updated profile note. | | | mastodon-profile--view-account-private-note | Display the private note about a user. | | K | mastodon-profile--view-bookmarks | Open a new buffer displaying the user's bookmarks. | | V | mastodon-profile--view-favourites | Open a new buffer displaying the user's favourites. | | | mastodon-profile--view-preferences | View user preferences in another window. | | | mastodon-profile-mode | Toggle mastodon profile minor mode. | | | mastodon-profile-update-mode | Minor mode to update Mastodon user profile. | | s | mastodon-search--query | Prompt for a search QUERY and return accounts, statuses, and hashtags. | | | mastodon-search--query-cycle | Cycle through search types: accounts, hashtags, and statuses. | | | mastodon-search--trending-statuses | Display a list of statuses trending on your instance. | | | mastodon-search--trending-tags | Display a list of tags trending on your instance. | | | mastodon-search-mode | Toggle mastodon search minor mode. | | | mastodon-serach--query-accounts-followed | Run an accounts search QUERY, limited to your followers. | | B | mastodon-tl--block-user | Query for USER-HANDLE from current status and block that user. | | | mastodon-tl--click-image-or-video | Click to play video with `mpv.el'. | | | mastodon-tl--disable-notify-user-posts | Query for USER-HANDLE and disable notifications when they post. | | m | mastodon-tl--dm-user | Query for USER-HANDLE from current status and compose a message to that user. | | | mastodon-tl--do-link-action | Do the action of the link at point. | | | mastodon-tl--do-link-action-at-point | Do the action of the link at POSITION. | | | mastodon-tl--enable-notify-user-posts | Query for USER-HANDLE and enable notifications when they post. | | | mastodon-tl--filter-user-user-posts-by-language | Query for USER-HANDLE and enable notifications when they post. | | | mastodon-tl--follow-tag | Prompt for a tag and follow it. | | W | mastodon-tl--follow-user | Query for USER-HANDLE from current status and follow that user. | | | mastodon-tl--follow-user-disable-boosts | Prompt for a USER-HANDLE, and disable display of boosts in home timeline. | | | mastodon-tl--follow-user-enable-boosts | Prompt for a USER-HANDLE, and enable display of boosts in home timeline. | | ' | mastodon-tl--followed-tags-timeline | Open a timeline of all your followed tags. | | F | mastodon-tl--get-federated-timeline | Open federated timeline. | | H | mastodon-tl--get-home-timeline | Open home timeline. | | L | mastodon-tl--get-local-timeline | Open local timeline. | | # | mastodon-tl--get-tag-timeline | Prompt for tag and opens its timeline. | | n | mastodon-tl--goto-next-item | Jump to next item. | | C- | mastodon-tl--goto-next-toot | | | p | mastodon-tl--goto-prev-item | Jump to previous item. | | C- | mastodon-tl--goto-prev-toot | | | " | mastodon-tl--list-followed-tags | List followed tags. View timeline of tag user choses. | | C- | mastodon-tl--mpv-play-video-at-point | Play the video or gif at point with an mpv process. | | | mastodon-tl--mpv-play-video-from-byline | Run `mastodon-tl--mpv-play-video-at-point' on first moving image in post. | | | mastodon-tl--mute-thread | Mute the thread displayed in the current buffer. | | M | mastodon-tl--mute-user | Query for USER-HANDLE from current status and mute that user. | | TAB, M-n | mastodon-tl--next-tab-item | Move to the next interesting item. | | v | mastodon-tl--poll-vote | If there is a poll at point, prompt user for OPTION to vote on it. | | S-TAB, | mastodon-tl--previous-tab-item | Move to the previous interesting item. | | Z | mastodon-tl--report-to-mods | Report the author of the toot at point to your instance moderators. | | SPC | mastodon-tl--scroll-up-command | Call `scroll-up-command', loading more toots if necessary. | | | mastodon-tl--single-toot | View toot at point in separate buffer. | | | mastodon-tl--some-followed-tags-timeline | Prompt for some tags, and open a timeline for them. | | T | mastodon-tl--thread | Open thread buffer for toot at point or with ID. | | c | mastodon-tl--toggle-spoiler-text-in-toot | Toggle the visibility of the spoiler text in the current toot. | | C-S-b | mastodon-tl--unblock-user | Query for USER-HANDLE from list of blocked users and unblock that user. | | | mastodon-tl--unfollow-tag | Prompt for a followed tag, and unfollow it. | | C-S-w | mastodon-tl--unfollow-user | Query for USER-HANDLE from current status and unfollow that user. | | | mastodon-tl--unmute-thread | Mute the thread displayed in the current buffer. | | S-RET | mastodon-tl--unmute-user | Query for USER-HANDLE from list of muted users and unmute that user. | | u, g | mastodon-tl--update | Update timeline with new toots. | | | mastodon-tl--view-whole-thread | From a thread view, view entire thread. | | t | mastodon-toot | Update instance with new toot. Content is captured in a new buffer. | | C-c C-a | mastodon-toot--attach-media | Prompt for an attachment FILE with DESCRIPTION. | | C-c C-k | mastodon-toot--cancel | Kill new-toot buffer/window. Does not POST content to Mastodon. | | C-c C-v | mastodon-toot--change-visibility | Change the current visibility to the next valid value. | | C-c ! | mastodon-toot--clear-all-attachments | Remove all attachments from a toot draft. | | | mastodon-toot--copy-toot-text | Copy text of toot at point. | | C | mastodon-toot--copy-toot-url | Copy URL of toot at point. | | C-c C-p | mastodon-toot--create-poll | Prompt for new poll options and return as a list. | | | mastodon-toot--delete-all-drafts | Delete all drafts. | | D | mastodon-toot--delete-and-redraft-toot | Delete and redraft user's toot at point synchronously. | | | mastodon-toot--delete-draft-toot | Prompt for a draft toot and delete it. | | d | mastodon-toot--delete-toot | Delete user's toot at point synchronously. | | | mastodon-toot--download-custom-emoji | Download `mastodon-instance-url's custom emoji. | | e | mastodon-toot--edit-toot-at-point | Edit the user's toot at point. | | | mastodon-toot--enable-custom-emoji | Add `mastodon-instance-url's custom emoji to `emojify'. | | C-c C-e | mastodon-toot--insert-emoji | Prompt to insert an emoji. | | . | mastodon-toot--list-toot-boosters | List the boosters of toot at point. | | , | mastodon-toot--list-toot-favouriters | List the favouriters of toot at point. | | | mastodon-toot--open-draft-toot | Prompt for a draft and compose a toot with it. | | i | mastodon-toot--pin-toot-toggle | Pin or unpin user's toot at point. | | r | mastodon-toot--reply | Reply to toot at `point'. | | | mastodon-toot--save-draft | Save the current compose toot text as a draft. | | C-c C-s | mastodon-toot--schedule-toot | Read a date (+ time) in the minibuffer and schedule the current toot. | | C-c C-c | mastodon-toot--send | POST contents of new-toot buffer to Mastodon instance and kill buffer. | | | mastodon-toot--set-default-visibility | Set the default visibility for toots on the server. | | C-c C-l | mastodon-toot--set-toot-language | Prompt for a language and set `mastodon-toot--language'. | | k | mastodon-toot--toggle-bookmark | Bookmark or unbookmark toot at point. | | b | mastodon-toot--toggle-boost | Boost/unboost toot at `point'. | | f | mastodon-toot--toggle-favourite | Favourite/unfavourite toot at `point'. | | C-c C-n | mastodon-toot--toggle-nsfw | Toggle `mastodon-toot--content-nsfw'. | | C-c C-w | mastodon-toot--toggle-warning | Toggle `mastodon-toot--content-warning'. | | a | mastodon-toot--translate-toot-text | Translate text of toot at point. | | E | mastodon-toot--view-toot-edits | View editing history of the toot at point in a popup buffer. | | | mastodon-toot-mode | Minor mode to capture Mastodon toots. | | | mastodon-turn-on-discover | Turns on discover support | | | mastodon-url-lookup | If a URL resembles a mastodon link, try to load in `mastodon.el'. | | | mastodon-views--add-account-to-list | Prompt for a list and for an account, add account to list. | | | mastodon-views--add-account-to-list-at-point | Prompt for account and add to list at point. | | | mastodon-views--add-toot-account-at-point-to-list | Prompt for a list, and add the account of the toot at point to it. | | | mastodon-views--cancel-scheduled-toot | Cancel the scheduled toot at point. | | | mastodon-views--copy-scheduled-toot-text | Copy the text of the scheduled toot at point. | | | mastodon-views--create-filter | Create a filter for a word. | | | mastodon-views--create-list | Create a new list. | | | mastodon-views--delete-filter | Delete filter at point. | | | mastodon-views--delete-list | Prompt for a list and delete it. | | | mastodon-views--delete-list-at-point | Delete list at point. | | | mastodon-views--edit-list | Prompt for a list and edit the name and replies policy. | | | mastodon-views--edit-list-at-point | Edit list at point. | | | mastodon-views--edit-scheduled-as-new | Edit scheduled status as new toot. | | | mastodon-views--instance-desc-misskey | Show instance description for a misskey/firefish server. | | | mastodon-views--remove-account-from-list | Prompt for a list, select an account and remove from list. | | | mastodon-views--remove-account-from-list-at-point | Prompt for account and remove from list at point. | | | mastodon-views--reschedule-toot | Reschedule the scheduled toot at point. | | I | mastodon-views--view-filters | View the user's filters in a new buffer. | | R | mastodon-views--view-follow-requests | Open a new buffer displaying the user's follow requests. | | G | mastodon-views--view-follow-suggestions | Display a buffer of suggested accounts to follow. | | ; | mastodon-views--view-instance-description | View the details of the instance the current post's author is on. | | | mastodon-views--view-instance-description-brief | View brief details of the instance the current post's author is on. | | | mastodon-views--view-list-timeline | Prompt for a list and view its timeline. | | X | mastodon-views--view-lists | Show the user's lists in a new buffer. | | | mastodon-views--view-own-instance | View details of your own instance. | | | mastodon-views--view-own-instance-brief | View brief details of your own instance. | | S | mastodon-views--view-scheduled-toots | Show the user's scheduled toots in a new buffer. | | | mastodon-views--view-timeline-list-at-point | View timeline of list at point. | * mastodon custom variables index #+BEGIN_SRC emacs-lisp :results table :colnames '("Custom variable" "Description") :exports results (let ((rows)) (mapatoms (lambda (symbol) (when (and (string-match "^mastodon" (symbol-name symbol)) (custom-variable-p symbol)) (let* ((doc (car (split-string (or (get (indirect-variable symbol) 'variable-documentation) (get symbol 'variable-documentation) "") "\n")))) (push `(,symbol ,doc) rows) rows)))) (sort rows (lambda (x y) (string-lessp (car x) (car y))))) #+end_src #+RESULTS: | Custom variable | Description | |----------------------------------------------------+------------------------------------------------------------------------------| | mastodon-active-user | Username of the active user. | | mastodon-client--token-file | File path where Mastodon access tokens are stored. | | mastodon-instance-url | Base URL for the Mastodon instance you want to be active. | | mastodon-media--avatar-height | Height of the user avatar images (if shown). | | mastodon-media--enable-image-caching | Whether images should be cached. | | mastodon-media--preview-max-height | Max height of any media attachment preview to be shown in timelines. | | mastodon-mode-hook | Hook run when entering Mastodon mode. | | mastodon-profile-mode-hook | Hook run after entering or leaving `mastodon-profile-mode'. | | mastodon-profile-update-mode-hook | Hook run after entering or leaving `mastodon-profile-update-mode'. | | mastodon-tl--display-caption-not-url-when-no-media | Display an image's caption rather than URL. | | mastodon-tl--enable-proportional-fonts | Nonnil to enable using proportional fonts when rendering HTML. | | mastodon-tl--enable-relative-timestamps | Whether to show relative (to the current time) timestamps. | | mastodon-tl--expand-content-warnings | Whether to expand content warnings by default. | | mastodon-tl--hide-replies | Whether to hide replies from the timelines. | | mastodon-tl--highlight-current-toot | Whether to highlight the toot at point. Uses `cursor-face' special property. | | mastodon-tl--show-avatars | Whether to enable display of user avatars in timelines. | | mastodon-tl--show-stats | Whether to show toot stats (faves, boosts, replies counts). | | mastodon-tl--symbols | A set of symbols (and fallback strings) to be used in timeline. | | mastodon-tl--timeline-posts-count | Number of posts to display when loading a timeline. | | mastodon-tl-position-after-update | Defines where `point' should be located after a timeline update. | | mastodon-toot--attachment-height | Height of the attached images preview in the toot draft buffer. | | mastodon-toot--completion-style-for-mentions | The company completion style to use for mentions. | | mastodon-toot--default-media-directory | The default directory when prompting for a media file to upload. | | mastodon-toot--default-reply-visibility | Default visibility settings when replying. | | mastodon-toot--enable-completion | Whether to enable completion of mentions and hashtags. | | mastodon-toot--enable-custom-instance-emoji | Whether to enable your instance's custom emoji by default. | | mastodon-toot--proportional-fonts-compose | Nonnil to enable using proportional fonts in the compose buffer. | | mastodon-toot--use-company-for-completion | Whether to enable company for completion. | | mastodon-toot-display-orig-in-reply-buffer | Display a copy of the toot replied to in the compose buffer. | | mastodon-toot-mode-hook | Hook run after entering or leaving `mastodon-toot-mode'. | | mastodon-toot-orig-in-reply-length | Length to crop toot replied to in the compose buffer to. | | mastodon-toot-timestamp-format | Format to use for timestamps. | mastodon.el/mastodon.info000066400000000000000000000633021452000115200157740ustar00rootroot00000000000000This is mastodon.info, produced by makeinfo version 6.8 from mastodon.texi. INFO-DIR-SECTION Emacs START-INFO-DIR-ENTRY * Mastodon: (mastodon). Client for Mastodon on ActivityPub networks. END-INFO-DIR-ENTRY  File: mastodon.info, Node: Top, Next: README, Up: (dir) * Menu: * README:: — The Detailed Node Listing — README * Installation:: * Usage:: * Dependencies:: * Network compatibility:: * Contributing:: * Supporting ‘mastodon.el’: Supporting mastodonel. * Contributors:: Installation * ELPA:: * MELPA:: * Repo:: * Emoji:: * Discover:: Usage * Logging in to your instance:: * Timelines:: * Composing toots:: * Other commands and account settings:: * Customization:: * Commands and variables index:: * Alternative timeline layout:: * Live-updating timelines mastodon-async-mode:: * Translating toots:: * Bookmarks and ‘mastodon.el’: Bookmarks and mastodonel. Contributing * Bug reports:: * Fixes and features:: * Coding style::  File: mastodon.info, Node: README, Prev: Top, Up: Top 1 README ******** ‘mastodon.el’ is an Emacs client for the AcitivityPub social networks that implement the Mastodon API. For info see joinmastodon.org (https://joinmastodon.org/). * Menu: * Installation:: * Usage:: * Dependencies:: * Network compatibility:: * Contributing:: * Supporting ‘mastodon.el’: Supporting mastodonel. * Contributors::  File: mastodon.info, Node: Installation, Next: Usage, Up: README 1.1 Installation ================ You can install ‘mastodon.el’ from ELPA, MELPA, or directly from this repo. It is also available as a GUIX package. * Menu: * ELPA:: * MELPA:: * Repo:: * Emoji:: * Discover::  File: mastodon.info, Node: ELPA, Next: MELPA, Up: Installation 1.1.1 ELPA ---------- You should be able to directly install with: ‘M-x package-refresh-contents RET’ ‘M-x package-install RET mastodon RET’  File: mastodon.info, Node: MELPA, Next: Repo, Prev: ELPA, Up: Installation 1.1.2 MELPA ----------- Add ‘MELPA’ to your archives: (require 'package) (add-to-list 'package-archives '("melpa" . "http://melpa.org/packages/") t) Update and install: ‘M-x package-refresh-contents RET’ ‘M-x package-install RET mastodon RET’  File: mastodon.info, Node: Repo, Next: Emoji, Prev: MELPA, Up: Installation 1.1.3 Repo ---------- Clone this repository and add the lisp directory to your load path. Then, require it and go. (add-to-list 'load-path "/path/to/mastodon.el/lisp") (require 'mastodon) Or, with ‘use-package’: (use-package mastodon :ensure t) The minimum Emacs version is now 27.1. But if you are running an older version it shouldn’t be very hard to get it working.  File: mastodon.info, Node: Emoji, Next: Discover, Prev: Repo, Up: Installation 1.1.4 Emoji ----------- ‘mastodon-mode’ will enable Emojify (https://github.com/iqbalansari/emacs-emojify) if it is loaded in your Emacs environment, so there’s no need to write your own hook anymore. ‘emojify-mode’ is not required.  File: mastodon.info, Node: Discover, Prev: Emoji, Up: Installation 1.1.5 Discover -------------- ‘mastodon-mode’ can provide a context menu for its keybindings if Discover (https://github.com/mickeynp/discover.el) is installed. It is not required. if you have Discover, add the following to your Emacs init configuration: (require 'mastodon-discover) (with-eval-after-load 'mastodon (mastodon-discover)) Or, with ‘use-package’: (use-package mastodon :ensure t :config (mastodon-discover))  File: mastodon.info, Node: Usage, Next: Dependencies, Prev: Installation, Up: README 1.2 Usage ========= * Menu: * Logging in to your instance:: * Timelines:: * Composing toots:: * Other commands and account settings:: * Customization:: * Commands and variables index:: * Alternative timeline layout:: * Live-updating timelines mastodon-async-mode:: * Translating toots:: * Bookmarks and ‘mastodon.el’: Bookmarks and mastodonel.  File: mastodon.info, Node: Logging in to your instance, Next: Timelines, Up: Usage 1.2.1 Logging in to your instance --------------------------------- You need to set 2 variables in your init file to get started: 1. ‘mastodon-instance-url’ 2. ‘mastodon-active-user’ (see their doc strings for details). For example If you want to post toots as "example_user@social.instance.org", then put this in your init file: (setq mastodon-instance-url "https://social.instance.org" mastodon-active-user "example_user") Then *restart* Emacs and run ‘M-x mastodon’. Make sure you are connected to internet before you do this. If you have multiple mastodon accounts you can activate one at a time by changing those two variables and restarting Emacs. If you were using mastodon.el before 2FA was implemented and the above steps do not work, delete the old file specified by ‘mastodon-client--token-file’ and restart Emacs and follow the steps again.  File: mastodon.info, Node: Timelines, Next: Composing toots, Prev: Logging in to your instance, Up: Usage 1.2.2 Timelines --------------- ‘M-x mastodon’ Opens a ‘*mastodon-home*’ buffer in the major mode and displays toots. If your credentials are not yet saved, you will be prompted for email and password. The app registration process will take place if your ‘mastodon-token-file’ does not contain ‘:client_id’ and ‘:client_secret’. 1. Keybindings Key Action ----------------------------------------------------------------------------------------------------------- *Help* ‘?’ Show discover menu of all bindings, if ‘discover’ is available *Timeline actions* ‘n’ Go to next item (toot, notification, user) ‘p’ Go to previous item (toot, notification, user) ‘M-n=/=’ Go to the next interesting thing that has an action ‘M-p=/=’ Go to the previous interesting thing that has an action ‘F’ Open federated timeline (1 prefix arg: hide-replies, 2 prefix args: media only) ‘H’ Open home timeline (1 prefix arg: hide-replies) ‘L’ Open local timeline (1 prefix arg: hide-replies, 2 prefix args: media only) ‘N’ Open notifications timeline ‘@’ Open mentions-only notifications timeline ‘u’ Update current timeline ‘T’ Open thread for toot at point ‘#’ Prompt for tag and open its timeline ‘A’ Open author profile of toot at point ‘P’ Open profile of user attached to toot at point ‘O’ View own profile ‘U’ update your profile bio note ‘;’ view instance description for toot at point ‘:’ view followed tags and load a tag timeline ‘C-:’ view timeline of all followed tags ‘,’ view favouriters of toot at point ‘.’ view boosters of toot at point ‘/’ switch between mastodon buffers ‘Z’ report user/toot at point to instances moderators *Other views* ‘s’ search (posts, users, tags) (NB: only posts you have interacted with) ‘I’, ‘c’, ‘d’ view, create, and delete filters ‘R’, ‘a’, ‘j’ view/accept/reject follow requests ‘G’ view follow suggestions ‘V’ view your favourited toots ‘K’ view bookmarked toots ‘X’ view/edit/create/delete lists ‘S’ view your scheduled toots *Toot actions* ‘t’ Compose a new toot ‘c’ Toggle content warning content ‘b’ Boost toot under ‘point’ ‘f’ Favourite toot under ‘point’ ‘k’ toggle bookmark of toot at point ‘r’ Reply to toot under ‘point’ ‘v’ Vote on poll at point ‘C’ copy url of toot at point ‘C-RET’ play video/gif at point (requires ‘mpv’) ‘e’ edit your toot at point ‘E’ view edits of toot at point ‘i’ (un)pin your toot at point ‘d’ delete your toot at point, and reload current timeline ‘D’ delete and redraft toot at point, preserving reply/CW/visibility (‘S-C-’) ‘W’, ‘M’, ‘B’ (un)follow, (un)mute, (un)block author of toot at point *Profile view* ‘C-c C-c’ cycle between statuses, statuses without boosts, followers, and following ‘mastodon-profile--account-account-to-list’ (see lists view) *Notifications view* ‘a’, ‘j’ accept/reject follow request ‘C-k’ clear notification at point see ‘mastodon-notifications--get-*’ functions for filtered views *Quitting* ‘q’ Quit mastodon buffer, leave window open ‘Q’ Quit mastodon buffer and kill window ‘C-M-q’ Quit and kill all mastodon buffers 2. Toot byline legend Marker Meaning -------------------------------------------- ‘(🔁)’ (or I boosted this toot ‘(B)’) ‘(⭐)’ (or I favourited this toot ‘(F)’) ‘(🔖)’ (or I bookmarked this toot (‘K’))  File: mastodon.info, Node: Composing toots, Next: Other commands and account settings, Prev: Timelines, Up: Usage 1.2.3 Composing toots --------------------- ‘M-x mastodon-toot’ (or ‘t’ from a mastodon.el buffer) opens a new buffer/window in ‘text-mode’ and ‘mastodon-toot’ minor mode. Enter the contents of your toot here. ‘C-c C-c’ sends the toot. ‘C-c C-k’ cancels. Both actions kill the buffer and window. Further keybindings are displayed in the buffer, and in the following subsection. Replies preserve visibility status/content warnings, and include boosters by default. Server’s max toot length, and attachment previews, are shown. You can download and use your instance’s custom emoji (‘mastodon-toot--download-custom-emoji’, ‘mastodon-toot--enable-custom-emoji’). The compose buffer uses ‘text-mode’ so any configuration you have for that mode will be enabled. If any of your existing config conflicts with ‘mastodon-toot’, you can disable it in the ‘mastodon-toot-mode-hook’. For example, the default value of that hook is as follows: (add-hook 'mastodon-toot-mode-hook (lambda () (auto-fill-mode -1))) 1. Keybindings Key Action ------------------------------------------------- ‘C-c C-c’ Send toot ‘C-c C-k’ Cancel toot ‘C-c C-w’ Add content warning ‘C-c C-v’ Change toot visibility ‘C-c C-n’ Add sensitive media/nsfw flag ‘C-c C-a’ Upload attachment(s) ‘C-c !’ Remove all attachments ‘C-c C-e’ Add emoji (if ‘emojify’ installed) ‘C-c C-p’ Create a poll ‘C-c C-l’ Set toot language 2. Autocompletion of mentions and tags Autocompletion of mentions and tags is provided by ‘completion-at-point-functions’ (capf) backends. ‘mastodon-toot--enable-completion’ is enabled by default. If you want to enable ‘company-mode’ in the toot compose buffer, set ‘mastodon-toot--use-company-for-completion’ to ‘t’. (‘mastodon.el’ used to run its own native company backends, but these have been removed in favour of capfs.) If you don’t run ‘company’ and want immediate, keyless completion, you’ll need to have another completion engine running that handles capfs. A common combination is ‘consult’ and ‘corfu’. 3. Draft toots • Compose buffer text is saved as you type, kept in ‘mastodon-toot-current-toot-text’. • ‘mastodon-toot--save-draft’: save the current toot as a draft. • ‘mastodon-toot--open-draft-toot’: Open a compose buffer and insert one of your draft toots. • ‘mastodon-toot--delete-draft-toot’: Delete a draft toot. • ‘mastodon-toot--delete-all-drafts’: Delete all your drafts.  File: mastodon.info, Node: Other commands and account settings, Next: Customization, Prev: Composing toots, Up: Usage 1.2.4 Other commands and account settings: ------------------------------------------ In addition to ‘mastodon’, the following three functions are autoloaded and should work without first loading ‘mastodon.el’: • ‘mastodon-toot’: Compose new toot • ‘mastodon-notifications-get’: View all notifications • ‘mastodon-url-lookup’: Attempt to load a URL in ‘mastodon.el’. URL may be at point or provided in the minibuffer. • ‘mastodon-tl--view-instance-description’: View information about the instance that the author of the toot at point is on. • ‘mastodon-tl--view-own-instance’: View information about your own instance. • ‘mastodon-search--trending-tags’: View a list of trending hashtags on your instance. • ‘mastodon-search--trending-statuses’: View a list of trending statuses on your instance. • ‘mastodon-tl--add-toot-account-at-point-to-list’: Add the account of the toot at point to a list. • ‘mastodon-tl--dm-user’: Send a direct message to one of the users at point. • ‘mastodon-profile--add-private-note-to-account’: Add a private note to another user’s account. • ‘mastodon-profile--view-account-private-note’: View a private note on a user’s account. • ‘mastodon-profile--show-familiar-followers’: Show a list of “familiar followers” for a given account. Familiar followers are accounts that you follow, and that follow the account. • ‘mastodon-tl--follow-tag’: Follow a tag (works like following a user) • ‘mastodon-tl--unfollow-tag’: Unfollow a tag • ‘mastodon-tl--list-followed-tags’: View a list of tags you’re following. • ‘mastodon-tl--followed-tags-timeline’: View a timeline of all your followed tags. • ‘mastodon-tl--some-followed-tags-timleine’: View a timeline of multiple tags, from your followed tags or any other. • ‘mastodon-switch-to-buffer’: switch between mastodon buffers. • ‘mastodon-profile--update-display-name’: Update the display name for your account. • ‘mastodon-profile--update-user-profile-note’: Update your bio note. • ‘mastodon-profile--update-meta-fields’: Update your metadata fields. • ‘mastodon-profile--set-default-toot-visibility’: Set the default visibility for your toots. • ‘mastodon-profile--account-locked-toggle’: Toggle the locked status of your account. Locked accounts have to manually approve follow requests. • ‘mastodon-profile--account-discoverable-toggle’: Toggle the discoverable status of your account. Non-discoverable accounts are not listed in the profile directory. • ‘mastodon-profile--account-bot-toggle’: Toggle whether your account is flagged as a bot. • ‘mastodon-profile--account-sensitive-toggle’: Toggle whether your posts are marked as sensitive (nsfw) by default.  File: mastodon.info, Node: Customization, Next: Commands and variables index, Prev: Other commands and account settings, Up: Usage 1.2.5 Customization ------------------- See ‘M-x customize-group RET mastodon’ to view all customize options. • Timeline options: • Use proportional fonts • Default number of posts displayed • Timestamp format • Relative timestamps • Display user avatars • Avatar image height • Enable image caching • Hide replies in timelines • Show toot stats in byline • Compose options: • Completion style for mentions and tags • Enable custom emoji • Display toot being replied to • Set default reply visibility  File: mastodon.info, Node: Commands and variables index, Next: Alternative timeline layout, Prev: Customization, Up: Usage 1.2.6 Commands and variables index ---------------------------------- An index of all user-facing commands and custom variables is available here: mastodon-index.org (mastodon-index.org).  File: mastodon.info, Node: Alternative timeline layout, Next: Live-updating timelines mastodon-async-mode, Prev: Commands and variables index, Up: Usage 1.2.7 Alternative timeline layout --------------------------------- The incomparable Nicholas Rougier has written an alternative timeline layout for ‘mastodon.el’. The repo is at mastodon-alt (https://github.com/rougier/mastodon-alt).  File: mastodon.info, Node: Live-updating timelines mastodon-async-mode, Next: Translating toots, Prev: Alternative timeline layout, Up: Usage 1.2.8 Live-updating timelines: ‘mastodon-async-mode’ ---------------------------------------------------- (code taken from mastodon-future (https://github.com/alexjgriffith/mastodon-future.el).) Works for federated, local, and home timelines and for notifications. It’s a little touchy, one thing to avoid is trying to load a timeline more than once at a time. It can go off the rails a bit, but it’s still pretty cool. The current maintainer of ‘mastodon.el’ is unable to debug or improve this feature. To enable, it, add ‘(require 'mastodon-async)’ to your ‘init.el’. Then you can view a timeline with one of the commands that begin with ‘mastodon-async--stream-’.  File: mastodon.info, Node: Translating toots, Next: Bookmarks and mastodonel, Prev: Live-updating timelines mastodon-async-mode, Up: Usage 1.2.9 Translating toots ----------------------- You can translate toots with ‘mastodon-toot--translate-toot-text’ (‘a’ in a timeline). At the moment this requires lingva.el (https://codeberg.org/martianh/lingva.el), a little interface I wrote to lingva.ml (https://lingva.ml), to be installed to work. You could easily modify the simple function to use your Emacs translator of choice (‘libretrans.el’ , ‘google-translate’, ‘babel’, ‘go-translate’, etc.), you just need to fetch the toot’s content with ‘(mastodon-tl--content toot)’ and pass it to your translator function as its text argument. Here’s what ‘mastodon-toot--translate-toot-text’ looks like: (defun mastodon-toot--translate-toot-text () "Translate text of toot at point. Uses `lingva.el'." (interactive) (let* ((toot (mastodon-tl--property 'item-json))) (if toot (lingva-translate nil (mastodon-tl--content toot)) (message "No toot to translate?"))))  File: mastodon.info, Node: Bookmarks and mastodonel, Prev: Translating toots, Up: Usage 1.2.10 Bookmarks and ‘mastodon.el’ ---------------------------------- ‘mastodon.el’ doesn’t currently implement its own bookmark record and handler, which means that emacs bookmarks will not work as is. Until we implement them, you can get bookmarks going immediately by using bookmark+.el (https://github.com/emacsmirror/emacswiki.org/blob/master/bookmark%2b.el).  File: mastodon.info, Node: Dependencies, Next: Network compatibility, Prev: Usage, Up: README 1.3 Dependencies ================ Hard dependencies (should all install with ‘mastodon.el’): • ‘request’ (for uploading attachments), emacs-request (https://github.com/tkf/emacs-request) • ‘persist’ for storing some settings across sessions Optional dependencies (install yourself, ‘mastodon.el’ can use them): • ‘emojify’ for inserting and viewing emojis • ‘mpv’ and ‘mpv.el’ for viewing videos and gifs • ‘lingva.el’ for translating toots  File: mastodon.info, Node: Network compatibility, Next: Contributing, Prev: Dependencies, Up: README 1.4 Network compatibility ========================= ‘mastodon.el’ should work with ActivityPub servers that implement the Mastodon API. Apart from Mastodon itself, it is currently known to work with: • Pleroma (pleroma.social (https://pleroma.social/)) • Akkoma (akkoma.social (https://akkoma.social/)) • Gotosocial (gotosocial.org (https://gotosocial.org/)) It does not support the non-Mastodon API servers Misskey (misskey.io (https://misskey.io/)), Firefish (joinfirefish.org (https://joinfirefish.org/), formerly Calkey) and Friendica, but it should fully support displaying and interacting with posts and users on those platforms. If you attempt to use ‘mastodon.el’ with a server and run into problems, feel free to open an issue.  File: mastodon.info, Node: Contributing, Next: Supporting mastodonel, Prev: Network compatibility, Up: README 1.5 Contributing ================ PRs, issues, feature requests, and general feedback are very welcome! * Menu: * Bug reports:: * Fixes and features:: * Coding style::  File: mastodon.info, Node: Bug reports, Next: Fixes and features, Up: Contributing 1.5.1 Bug reports ----------------- 1. ‘mastodon.el’ has bugs, as well as lots of room for improvement. 2. I receive very little feedback, so if I don’t run into the bug it often doesn’t get fixed. 3. If you run into something that seems broken, first try running ‘mastodon.el’ in emacs with no init file (i.e. ‘emacs -q’ (instructions and code for doing this are here (https://codeberg.org/martianh/mastodon.el/issues/300)) to see if it also happens independently of your own config (it probably does). 4. Enable debug on error (‘toggle-debug-on-error’), make the bug happen again, and copy the backtrace that appears. 5. Open an issue here and explain what is going on. Provide your emacs version and what kind of server your account is on.  File: mastodon.info, Node: Fixes and features, Next: Coding style, Prev: Bug reports, Up: Contributing 1.5.2 Fixes and features ------------------------ 1. Create an issue (https://codeberg.org/martianh/mastodon.el/issues) detailing what you’d like to do. 2. Fork the repository and create a branch off of ‘develop’. 3. Run the tests and ensure that your code doesn’t break any of them. 4. Create a pull request referencing the issue created in step 1.  File: mastodon.info, Node: Coding style, Prev: Fixes and features, Up: Contributing 1.5.3 Coding style ------------------ • This library uses an unconvential double dash (‘--’) between file namespaces and function names, which contradicts normal Elisp style. This needs to be respected until the whole library is changed. • Use ‘aggressive-indent-mode’ or similar to keep your code indented. • Single spaces end sentences in docstrings. • There’s no need for a blank line after the first docstring line (one is added automatically when documentation is displayed).  File: mastodon.info, Node: Supporting mastodonel, Next: Contributors, Prev: Contributing, Up: README 1.6 Supporting ‘mastodon.el’ ============================ If you’d like to support continued development of ‘mastodon.el’, I accept donations via paypal: paypal.me/martianh (https://paypal.me/martianh). If you would prefer a different payment method, please write to me at and I can provide IBAN or other bank account details. I don’t have a tech worker’s income, so even a small tip would help out.  File: mastodon.info, Node: Contributors, Prev: Supporting mastodonel, Up: README 1.7 Contributors ================ ‘mastodon.el’ is the work of a number of people. Some significant contributors are: • [original author] • • • •  Tag Table: Node: Top210 Node: README962 Node: Installation1378 Node: ELPA1667 Node: MELPA1895 Node: Repo2275 Node: Emoji2768 Node: Discover3099 Node: Usage3651 Node: Logging in to your instance4094 Node: Timelines5091 Ref: Keybindings5566 Ref: Toot byline legend10139 Node: Composing toots10448 Ref: Keybindings (1)11687 Ref: Autocompletion of mentions and tags12205 Ref: Draft toots12918 Node: Other commands and account settings13389 Node: Customization16547 Node: Commands and variables index17334 Node: Alternative timeline layout17654 Node: Live-updating timelines mastodon-async-mode18059 Node: Translating toots18911 Node: Bookmarks and mastodonel20093 Node: Dependencies20565 Node: Network compatibility21175 Node: Contributing22057 Node: Bug reports22346 Node: Fixes and features23252 Node: Coding style23735 Node: Supporting mastodonel24359 Node: Contributors24926  End Tag Table  Local Variables: coding: utf-8 End: mastodon.el/mastodon.texi000066400000000000000000000543571452000115200160240ustar00rootroot00000000000000\input texinfo @c -*- texinfo -*- @c %**start of header @setfilename mastodon.info @settitle @documentencoding UTF-8 @documentlanguage en @c %**end of header @dircategory Emacs @direntry * Mastodon: (mastodon). Client for Mastodon on ActivityPub networks. @end direntry @finalout @titlepage @title @end titlepage @contents @ifnottex @node Top @top @end ifnottex @menu * README:: @detailmenu --- The Detailed Node Listing --- README * Installation:: * Usage:: * Dependencies:: * Network compatibility:: * Contributing:: * Supporting @samp{mastodon.el}: Supporting @samp{mastodonel}. * Contributors:: Installation * ELPA:: * MELPA:: * Repo:: * Emoji:: * Discover:: Usage * Logging in to your instance:: * Timelines:: * Composing toots:: * Other commands and account settings:: * Customization:: * Commands and variables index:: * Alternative timeline layout:: * Live-updating timelines @samp{mastodon-async-mode}:: * Translating toots:: * Bookmarks and @samp{mastodon.el}: Bookmarks and @samp{mastodonel}. Contributing * Bug reports:: * Fixes and features:: * Coding style:: @end detailmenu @end menu @node README @chapter README @samp{mastodon.el} is an Emacs client for the AcitivityPub social networks that implement the Mastodon API@. For info see @uref{https://joinmastodon.org/, joinmastodon.org}. @menu * Installation:: * Usage:: * Dependencies:: * Network compatibility:: * Contributing:: * Supporting @samp{mastodon.el}: Supporting @samp{mastodonel}. * Contributors:: @end menu @node Installation @section Installation You can install @samp{mastodon.el} from ELPA, MELPA, or directly from this repo. It is also available as a GUIX package. @menu * ELPA:: * MELPA:: * Repo:: * Emoji:: * Discover:: @end menu @node ELPA @subsection ELPA You should be able to directly install with: @samp{M-x package-refresh-contents RET} @samp{M-x package-install RET mastodon RET} @node MELPA @subsection MELPA Add @samp{MELPA} to your archives: @lisp (require 'package) (add-to-list 'package-archives '("melpa" . "http://melpa.org/packages/") t) @end lisp Update and install: @samp{M-x package-refresh-contents RET} @samp{M-x package-install RET mastodon RET} @node Repo @subsection Repo Clone this repository and add the lisp directory to your load path. Then, require it and go. @lisp (add-to-list 'load-path "/path/to/mastodon.el/lisp") (require 'mastodon) @end lisp Or, with @samp{use-package}: @lisp (use-package mastodon :ensure t) @end lisp The minimum Emacs version is now 27.1. But if you are running an older version it shouldn't be very hard to get it working. @node Emoji @subsection Emoji @samp{mastodon-mode} will enable @uref{https://github.com/iqbalansari/emacs-emojify, Emojify} if it is loaded in your Emacs environment, so there's no need to write your own hook anymore. @samp{emojify-mode} is not required. @node Discover @subsection Discover @samp{mastodon-mode} can provide a context menu for its keybindings if @uref{https://github.com/mickeynp/discover.el, Discover} is installed. It is not required. if you have Discover, add the following to your Emacs init configuration: @lisp (require 'mastodon-discover) (with-eval-after-load 'mastodon (mastodon-discover)) @end lisp Or, with @samp{use-package}: @lisp (use-package mastodon :ensure t :config (mastodon-discover)) @end lisp @node Usage @section Usage @menu * Logging in to your instance:: * Timelines:: * Composing toots:: * Other commands and account settings:: * Customization:: * Commands and variables index:: * Alternative timeline layout:: * Live-updating timelines @samp{mastodon-async-mode}:: * Translating toots:: * Bookmarks and @samp{mastodon.el}: Bookmarks and @samp{mastodonel}. @end menu @node Logging in to your instance @subsection Logging in to your instance You need to set 2 variables in your init file to get started: @enumerate @item @samp{mastodon-instance-url} @item @samp{mastodon-active-user} @end enumerate (see their doc strings for details). For example If you want to post toots as "example@math{_user}@@social.instance.org", then put this in your init file: @lisp (setq mastodon-instance-url "https://social.instance.org" mastodon-active-user "example_user") @end lisp Then @strong{restart} Emacs and run @samp{M-x mastodon}. Make sure you are connected to internet before you do this. If you have multiple mastodon accounts you can activate one at a time by changing those two variables and restarting Emacs. If you were using mastodon.el before 2FA was implemented and the above steps do not work, delete the old file specified by @samp{mastodon-client--token-file} and restart Emacs and follow the steps again. @node Timelines @subsection Timelines @samp{M-x mastodon} Opens a @samp{*mastodon-home*} buffer in the major mode and displays toots. If your credentials are not yet saved, you will be prompted for email and password. The app registration process will take place if your @samp{mastodon-token-file} does not contain @samp{:client_id} and @samp{:client_secret}. @enumerate @item @anchor{Keybindings}Keybindings @multitable {aaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} @headitem Key @tab Action @item @tab @strong{Help} @item @samp{?} @tab Show discover menu of all bindings, if @samp{discover} is available @item @tab @strong{Timeline actions} @item @samp{n} @tab Go to next item (toot, notification, user) @item @samp{p} @tab Go to previous item (toot, notification, user) @item @samp{M-n=/=} @tab Go to the next interesting thing that has an action @item @samp{M-p=/=} @tab Go to the previous interesting thing that has an action @item @samp{F} @tab Open federated timeline (1 prefix arg: hide-replies, 2 prefix args: media only) @item @samp{H} @tab Open home timeline (1 prefix arg: hide-replies) @item @samp{L} @tab Open local timeline (1 prefix arg: hide-replies, 2 prefix args: media only) @item @samp{N} @tab Open notifications timeline @item @samp{@@} @tab Open mentions-only notifications timeline @item @samp{u} @tab Update current timeline @item @samp{T} @tab Open thread for toot at point @item @samp{#} @tab Prompt for tag and open its timeline @item @samp{A} @tab Open author profile of toot at point @item @samp{P} @tab Open profile of user attached to toot at point @item @samp{O} @tab View own profile @item @samp{U} @tab update your profile bio note @item @samp{;} @tab view instance description for toot at point @item @samp{:} @tab view followed tags and load a tag timeline @item @samp{C-:} @tab view timeline of all followed tags @item @samp{,} @tab view favouriters of toot at point @item @samp{.} @tab view boosters of toot at point @item @samp{/} @tab switch between mastodon buffers @item @samp{Z} @tab report user/toot at point to instances moderators @item @tab @strong{Other views} @item @samp{s} @tab search (posts, users, tags) (NB: only posts you have interacted with) @item @samp{I}, @samp{c}, @samp{d} @tab view, create, and delete filters @item @samp{R}, @samp{a}, @samp{j} @tab view/accept/reject follow requests @item @samp{G} @tab view follow suggestions @item @samp{V} @tab view your favourited toots @item @samp{K} @tab view bookmarked toots @item @samp{X} @tab view/edit/create/delete lists @item @samp{S} @tab view your scheduled toots @item @tab @strong{Toot actions} @item @samp{t} @tab Compose a new toot @item @samp{c} @tab Toggle content warning content @item @samp{b} @tab Boost toot under @samp{point} @item @samp{f} @tab Favourite toot under @samp{point} @item @samp{k} @tab toggle bookmark of toot at point @item @samp{r} @tab Reply to toot under @samp{point} @item @samp{v} @tab Vote on poll at point @item @samp{C} @tab copy url of toot at point @item @samp{C-RET} @tab play video/gif at point (requires @samp{mpv}) @item @samp{e} @tab edit your toot at point @item @samp{E} @tab view edits of toot at point @item @samp{i} @tab (un)pin your toot at point @item @samp{d} @tab delete your toot at point, and reload current timeline @item @samp{D} @tab delete and redraft toot at point, preserving reply/CW/visibility @item (@samp{S-C-}) @samp{W}, @samp{M}, @samp{B} @tab (un)follow, (un)mute, (un)block author of toot at point @item @tab @strong{Profile view} @item @samp{C-c C-c} @tab cycle between statuses, statuses without boosts, followers, and following @item @tab @samp{mastodon-profile--account-account-to-list} (see lists view) @item @tab @strong{Notifications view} @item @samp{a}, @samp{j} @tab accept/reject follow request @item @samp{C-k} @tab clear notification at point @item @tab see @samp{mastodon-notifications--get-*} functions for filtered views @item @tab @strong{Quitting} @item @samp{q} @tab Quit mastodon buffer, leave window open @item @samp{Q} @tab Quit mastodon buffer and kill window @item @samp{C-M-q} @tab Quit and kill all mastodon buffers @end multitable @item @anchor{Toot byline legend}Toot byline legend @multitable {aaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaa} @headitem Marker @tab Meaning @item @samp{(🔁)} (or @samp{(B)}) @tab I boosted this toot @item @samp{(⭐)} (or @samp{(F)}) @tab I favourited this toot @item @samp{(🔖)} (or (@samp{K})) @tab I bookmarked this toot @end multitable @end enumerate @node Composing toots @subsection Composing toots @samp{M-x mastodon-toot} (or @samp{t} from a mastodon.el buffer) opens a new buffer/window in @samp{text-mode} and @samp{mastodon-toot} minor mode. Enter the contents of your toot here. @samp{C-c C-c} sends the toot. @samp{C-c C-k} cancels. Both actions kill the buffer and window. Further keybindings are displayed in the buffer, and in the following subsection. Replies preserve visibility status/content warnings, and include boosters by default. Server's max toot length, and attachment previews, are shown. You can download and use your instance's custom emoji (@samp{mastodon-toot--download-custom-emoji}, @samp{mastodon-toot--enable-custom-emoji}). The compose buffer uses @samp{text-mode} so any configuration you have for that mode will be enabled. If any of your existing config conflicts with @samp{mastodon-toot}, you can disable it in the @samp{mastodon-toot-mode-hook}. For example, the default value of that hook is as follows: @lisp (add-hook 'mastodon-toot-mode-hook (lambda () (auto-fill-mode -1))) @end lisp @enumerate @item @anchor{Keybindings (1)}Keybindings @multitable {aaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} @headitem Key @tab Action @item @samp{C-c C-c} @tab Send toot @item @samp{C-c C-k} @tab Cancel toot @item @samp{C-c C-w} @tab Add content warning @item @samp{C-c C-v} @tab Change toot visibility @item @samp{C-c C-n} @tab Add sensitive media/nsfw flag @item @samp{C-c C-a} @tab Upload attachment(s) @item @samp{C-c !} @tab Remove all attachments @item @samp{C-c C-e} @tab Add emoji (if @samp{emojify} installed) @item @samp{C-c C-p} @tab Create a poll @item @samp{C-c C-l} @tab Set toot language @end multitable @item @anchor{Autocompletion of mentions and tags}Autocompletion of mentions and tags Autocompletion of mentions and tags is provided by @samp{completion-at-point-functions} (capf) backends. @samp{mastodon-toot--enable-completion} is enabled by default. If you want to enable @samp{company-mode} in the toot compose buffer, set @samp{mastodon-toot--use-company-for-completion} to @samp{t}. (@samp{mastodon.el} used to run its own native company backends, but these have been removed in favour of capfs.) If you don’t run @samp{company} and want immediate, keyless completion, you’ll need to have another completion engine running that handles capfs. A common combination is @samp{consult} and @samp{corfu}. @item @anchor{Draft toots}Draft toots @itemize @item Compose buffer text is saved as you type, kept in @samp{mastodon-toot-current-toot-text}. @item @samp{mastodon-toot--save-draft}: save the current toot as a draft. @item @samp{mastodon-toot--open-draft-toot}: Open a compose buffer and insert one of your draft toots. @item @samp{mastodon-toot--delete-draft-toot}: Delete a draft toot. @item @samp{mastodon-toot--delete-all-drafts}: Delete all your drafts. @end itemize @end enumerate @node Other commands and account settings @subsection Other commands and account settings: In addition to @samp{mastodon}, the following three functions are autoloaded and should work without first loading @samp{mastodon.el}: @itemize @item @samp{mastodon-toot}: Compose new toot @item @samp{mastodon-notifications-get}: View all notifications @item @samp{mastodon-url-lookup}: Attempt to load a URL in @samp{mastodon.el}. URL may be at point or provided in the minibuffer. @end itemize @itemize @item @samp{mastodon-tl--view-instance-description}: View information about the instance that the author of the toot at point is on. @item @samp{mastodon-tl--view-own-instance}: View information about your own instance. @item @samp{mastodon-search--trending-tags}: View a list of trending hashtags on your instance. @item @samp{mastodon-search--trending-statuses}: View a list of trending statuses on your instance. @end itemize @itemize @item @samp{mastodon-tl--add-toot-account-at-point-to-list}: Add the account of the toot at point to a list. @end itemize @itemize @item @samp{mastodon-tl--dm-user}: Send a direct message to one of the users at point. @end itemize @itemize @item @samp{mastodon-profile--add-private-note-to-account}: Add a private note to another user’s account. @item @samp{mastodon-profile--view-account-private-note}: View a private note on a user’s account. @end itemize @itemize @item @samp{mastodon-profile--show-familiar-followers}: Show a list of “familiar followers” for a given account. Familiar followers are accounts that you follow, and that follow the account. @end itemize @itemize @item @samp{mastodon-tl--follow-tag}: Follow a tag (works like following a user) @item @samp{mastodon-tl--unfollow-tag}: Unfollow a tag @item @samp{mastodon-tl--list-followed-tags}: View a list of tags you're following. @item @samp{mastodon-tl--followed-tags-timeline}: View a timeline of all your followed tags. @item @samp{mastodon-tl--some-followed-tags-timleine}: View a timeline of multiple tags, from your followed tags or any other. @end itemize @itemize @item @samp{mastodon-switch-to-buffer}: switch between mastodon buffers. @end itemize @itemize @item @samp{mastodon-profile--update-display-name}: Update the display name for your account. @item @samp{mastodon-profile--update-user-profile-note}: Update your bio note. @item @samp{mastodon-profile--update-meta-fields}: Update your metadata fields. @item @samp{mastodon-profile--set-default-toot-visibility}: Set the default visibility for your toots. @item @samp{mastodon-profile--account-locked-toggle}: Toggle the locked status of your account. Locked accounts have to manually approve follow requests. @item @samp{mastodon-profile--account-discoverable-toggle}: Toggle the discoverable status of your account. Non-discoverable accounts are not listed in the profile directory. @item @samp{mastodon-profile--account-bot-toggle}: Toggle whether your account is flagged as a bot. @item @samp{mastodon-profile--account-sensitive-toggle}: Toggle whether your posts are marked as sensitive (nsfw) by default. @end itemize @node Customization @subsection Customization See @samp{M-x customize-group RET mastodon} to view all customize options. @itemize @item Timeline options: @itemize @item Use proportional fonts @item Default number of posts displayed @item Timestamp format @item Relative timestamps @item Display user avatars @item Avatar image height @item Enable image caching @item Hide replies in timelines @item Show toot stats in byline @end itemize @item Compose options: @itemize @item Completion style for mentions and tags @item Enable custom emoji @item Display toot being replied to @item Set default reply visibility @end itemize @end itemize @node Commands and variables index @subsection Commands and variables index An index of all user-facing commands and custom variables is available here: @uref{mastodon-index.org, mastodon-index.org}. @node Alternative timeline layout @subsection Alternative timeline layout The incomparable Nicholas Rougier has written an alternative timeline layout for @samp{mastodon.el}. The repo is at @uref{https://github.com/rougier/mastodon-alt, mastodon-alt}. @node Live-updating timelines @samp{mastodon-async-mode} @subsection Live-updating timelines: @samp{mastodon-async-mode} (code taken from @uref{https://github.com/alexjgriffith/mastodon-future.el, mastodon-future}.) Works for federated, local, and home timelines and for notifications. It's a little touchy, one thing to avoid is trying to load a timeline more than once at a time. It can go off the rails a bit, but it's still pretty cool. The current maintainer of @samp{mastodon.el} is unable to debug or improve this feature. To enable, it, add @samp{(require 'mastodon-async)} to your @samp{init.el}. Then you can view a timeline with one of the commands that begin with @samp{mastodon-async--stream-}. @node Translating toots @subsection Translating toots You can translate toots with @samp{mastodon-toot--translate-toot-text} (@samp{a} in a timeline). At the moment this requires @uref{https://codeberg.org/martianh/lingva.el, lingva.el}, a little interface I wrote to @uref{https://lingva.ml, lingva.ml}, to be installed to work. You could easily modify the simple function to use your Emacs translator of choice (@samp{libretrans.el} , @samp{google-translate}, @samp{babel}, @samp{go-translate}, etc.), you just need to fetch the toot's content with @samp{(mastodon-tl--content toot)} and pass it to your translator function as its text argument. Here's what @samp{mastodon-toot--translate-toot-text} looks like: @lisp (defun mastodon-toot--translate-toot-text () "Translate text of toot at point. Uses `lingva.el'." (interactive) (let* ((toot (mastodon-tl--property 'item-json))) (if toot (lingva-translate nil (mastodon-tl--content toot)) (message "No toot to translate?")))) @end lisp @node Bookmarks and @samp{mastodonel} @subsection Bookmarks and @samp{mastodon.el} @samp{mastodon.el} doesn’t currently implement its own bookmark record and handler, which means that emacs bookmarks will not work as is. Until we implement them, you can get bookmarks going immediately by using @uref{https://github.com/emacsmirror/emacswiki.org/blob/master/bookmark%2b.el, bookmark+.el}. @node Dependencies @section Dependencies Hard dependencies (should all install with @samp{mastodon.el}): @itemize @item @samp{request} (for uploading attachments), @uref{https://github.com/tkf/emacs-request, emacs-request} @item @samp{persist} for storing some settings across sessions @end itemize Optional dependencies (install yourself, @samp{mastodon.el} can use them): @itemize @item @samp{emojify} for inserting and viewing emojis @item @samp{mpv} and @samp{mpv.el} for viewing videos and gifs @item @samp{lingva.el} for translating toots @end itemize @node Network compatibility @section Network compatibility @samp{mastodon.el} should work with ActivityPub servers that implement the Mastodon API@. Apart from Mastodon itself, it is currently known to work with: @itemize @item Pleroma (@uref{https://pleroma.social/, pleroma.social}) @item Akkoma (@uref{https://akkoma.social/, akkoma.social}) @item Gotosocial (@uref{https://gotosocial.org/, gotosocial.org}) @end itemize It does not support the non-Mastodon API servers Misskey (@uref{https://misskey.io/, misskey.io}), Firefish (@uref{https://joinfirefish.org/, joinfirefish.org}, formerly Calkey) and Friendica, but it should fully support displaying and interacting with posts and users on those platforms. If you attempt to use @samp{mastodon.el} with a server and run into problems, feel free to open an issue. @node Contributing @section Contributing PRs, issues, feature requests, and general feedback are very welcome! @menu * Bug reports:: * Fixes and features:: * Coding style:: @end menu @node Bug reports @subsection Bug reports @enumerate @item @samp{mastodon.el} has bugs, as well as lots of room for improvement. @item I receive very little feedback, so if I don't run into the bug it often doesn't get fixed. @item If you run into something that seems broken, first try running @samp{mastodon.el} in emacs with no init file (i.e. @samp{emacs -q} (instructions and code for doing this are @uref{https://codeberg.org/martianh/mastodon.el/issues/300, here}) to see if it also happens independently of your own config (it probably does). @item Enable debug on error (@samp{toggle-debug-on-error}), make the bug happen again, and copy the backtrace that appears. @item Open an issue here and explain what is going on. Provide your emacs version and what kind of server your account is on. @end enumerate @node Fixes and features @subsection Fixes and features @enumerate @item Create an @uref{https://codeberg.org/martianh/mastodon.el/issues, issue} detailing what you'd like to do. @item Fork the repository and create a branch off of @samp{develop}. @item Run the tests and ensure that your code doesn't break any of them. @item Create a pull request referencing the issue created in step 1. @end enumerate @node Coding style @subsection Coding style @itemize @item This library uses an unconvential double dash (@samp{--}) between file namespaces and function names, which contradicts normal Elisp style. This needs to be respected until the whole library is changed. @item Use @samp{aggressive-indent-mode} or similar to keep your code indented. @item Single spaces end sentences in docstrings. @item There's no need for a blank line after the first docstring line (one is added automatically when documentation is displayed). @end itemize @node Supporting @samp{mastodonel} @section Supporting @samp{mastodon.el} If you'd like to support continued development of @samp{mastodon.el}, I accept donations via paypal: @uref{https://paypal.me/martianh, paypal.me/martianh}. If you would prefer a different payment method, please write to me at and I can provide IBAN or other bank account details. I don't have a tech worker's income, so even a small tip would help out. @node Contributors @section Contributors @samp{mastodon.el} is the work of a number of people. Some significant contributors are: @itemize @item @uref{https://github.com/jdenen} [original author] @item @uref{http://atomized.org} @item @uref{https://alexjgriffith.itch.io} @item @uref{https://github.com/hdurer} @item @uref{https://codeberg.org/Red_Starfish} @end itemize @byemastodon.el/test/000077500000000000000000000000001452000115200142465ustar00rootroot00000000000000mastodon.el/test/ert-helper.el000066400000000000000000000015321452000115200166400ustar00rootroot00000000000000(load-file "lisp/mastodon-http.el") (load-file "lisp/mastodon-iso.el") (load-file "lisp/mastodon-tl.el") (load-file "lisp/mastodon-toot.el") (load-file "lisp/mastodon-search.el") (load-file "lisp/mastodon.el") (load-file "lisp/mastodon-search.el") (load-file "lisp/mastodon-client.el") (load-file "lisp/mastodon-auth.el") (load-file "lisp/mastodon-discover.el") (load-file "lisp/mastodon-inspect.el") (load-file "lisp/mastodon-media.el") (load-file "lisp/mastodon-notifications.el") (load-file "lisp/mastodon-profile.el") (load-file "lisp/mastodon-async.el") ;; load tests in bulk to avoid using deprecated `cask exec' (let ((tests (cl-remove-if-not (lambda (x) (string-suffix-p "-tests.el" x)) (directory-files "test/." t directory-files-no-dot-files-regexp)))) (mapc #'load-file tests)) mastodon.el/test/fixture000077700000000000000000000000001452000115200174762../fixtureustar00rootroot00000000000000mastodon.el/test/mastodon-auth-tests.el000066400000000000000000000060111452000115200205110ustar00rootroot00000000000000;;; mastodon-auth-test.el --- Tests for mastodon-auth.el -*- lexical-binding: nil -*- (require 'el-mock) (require 'mastodon) (require 'mastodon-auth) (ert-deftest mastodon-auth--handle-token-response--good () "Should extract the access token from a good response." (should (string= "foo" (mastodon-auth--handle-token-response '(:access_token "foo" :token_type "Bearer" :scope "read write follow" :created_at 0))))) (ert-deftest mastodon-auth--handle-token-response--unknown () "Should throw an error when the response is unparsable." (should (equal '(error "Unknown response from mastodon-auth--get-token!") (condition-case error (progn (mastodon-auth--handle-token-response '(:herp "derp")) nil) (t error))))) (ert-deftest mastodon-auth--handle-token-response--failure () "Should throw an error when the response indicates an error." (let ((error-message "The provided authorization grant is invalid, expired, revoked, does not match the redirection URI used in the authorization request, or was issued to another client.")) (should (equal `(error ,(format "Mastodon-auth--access-token: invalid_grant: %s" error-message)) (condition-case error (mastodon-auth--handle-token-response `(:error "invalid_grant" :error_description ,error-message)) (t error)))))) (ert-deftest mastodon-auth--get-token () "Should generate token and return JSON response." (with-temp-buffer (with-mock (mock (mastodon-auth--generate-token) => (progn (insert "\n\n{\"access_token\":\"abcdefg\"}") (current-buffer))) (should (equal (mastodon-auth--get-token) '(:access_token "abcdefg")))))) (ert-deftest mastodon-auth--access-token-found () "Should return value in `mastodon-auth--token-alist' if found." (let ((mastodon-instance-url "https://instance.url") (mastodon-auth--token-alist '(("https://instance.url" . "foobar")) )) (should (string= (mastodon-auth--access-token) "foobar")))) (ert-deftest mastodon-auth--access-token-not-found () "Should set and return `mastodon-auth--token' if nil." (let ((mastodon-instance-url "https://instance.url") (mastodon-active-user "user") (mastodon-auth--token-alist nil)) (with-mock (mock (mastodon-auth--get-token) => '(:access_token "foobaz")) (mock (mastodon-client--store-access-token "foobaz")) (stub mastodon-client--make-user-active) (should (string= (mastodon-auth--access-token) "foobaz")) (should (equal mastodon-auth--token-alist '(("https://instance.url" . "foobaz"))))))) (ert-deftest mastodon-auth--user-unaware () (let ((mastodon-instance-url "https://instance.url") (mastodon-active-user nil) (mastodon-auth--token-alist nil)) (with-mock (mock (mastodon-client--active-user)) (should-error (mastodon-auth--access-token))))) mastodon.el/test/mastodon-client-tests.el000066400000000000000000000204601452000115200210320ustar00rootroot00000000000000;;; mastodon-client-test.el --- Tests for mastodon-client.el -*- lexical-binding: nil -*- (require 'el-mock) (ert-deftest mastodon-client--register () "Should POST to /apps." (with-mock (mock (mastodon-http--api "apps") => "https://instance.url/api/v1/apps") (mock (mastodon-http--post "https://instance.url/api/v1/apps" '(("client_name" . "mastodon.el") ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob") ("scopes" . "read write follow") ("website" . "https://codeberg.org/martianh/mastodon.el")) nil :unauthenticated)) (mastodon-client--register))) (ert-deftest mastodon-client--fetch () "Should return client registration JSON." (with-temp-buffer (with-mock (mock (mastodon-client--register) => (progn (insert "\n\n{\"foo\":\"bar\"}") (current-buffer))) (should (equal (mastodon-client--fetch) '(:foo "bar")))))) (ert-deftest mastodon-client--store () "Test the value `mastodon-client--store' returns/stores." (let ((mastodon-instance-url "http://mastodon.example") (plist '(:client_id "id" :client_secret "secret"))) (with-mock (mock (mastodon-client--token-file) => "stubfile.plstore") (mock (mastodon-client--fetch) => plist) (should (equal (mastodon-client--store) plist))) (let* ((plstore (plstore-open "stubfile.plstore")) (client (mastodon-client--remove-key-from-plstore (plstore-get plstore "mastodon-http://mastodon.example")))) (plstore-close plstore) (should (equal client plist)) ;; clean up - delete the stubfile (delete-file "stubfile.plstore")))) (ert-deftest mastodon-client--read-finds-match () "Should return mastodon client from `mastodon-token-file' if it exists." (let ((mastodon-instance-url "http://mastodon.example")) (with-mock (mock (mastodon-client--token-file) => "fixture/client.plstore") (should (equal (mastodon-client--read) '(:client_id "id2" :client_secret "secret2")))))) (ert-deftest mastodon-client--general-read-finds-match () (with-mock (mock (mastodon-client--token-file) => "fixture/client.plstore") (should (equal (mastodon-client--general-read "user-test8000@mastodon.example") '(:username "test8000@mastodon.example" :instance "http://mastodon.example" :client_id "id2" :client_secret "secret2" :access_token "token2"))))) (ert-deftest mastodon-client--general-read-finds-no-match () (with-mock (mock (mastodon-client--token-file) => "fixture/client.plstore") (should (equal (mastodon-client--general-read "nonexistant-key") nil)))) (ert-deftest mastodon-client--general-read-empty-store () (with-mock (mock (mastodon-client--token-file) => "fixture/empty.plstore") (should (equal (mastodon-client--general-read "something") nil)))) (ert-deftest mastodon-client--read-finds-no-match () "Should return mastodon client from `mastodon-token-file' if it exists." (let ((mastodon-instance-url "http://mastodon.social")) (with-mock (mock (mastodon-client--token-file) => "fixture/client.plstore") (should (equal (mastodon-client--read) nil))))) (ert-deftest mastodon-client--read-empty-store () "Should return nil if mastodon client is not present in the plstore." (with-mock (mock (mastodon-client--token-file) => "fixture/empty.plstore") (should (equal (mastodon-client--read) nil)))) (ert-deftest mastodon-client--client-set-and-matching () "Should return `mastondon-client' if `mastodon-client--client-details-alist' is non-nil and instance url is included." (let ((mastodon-instance-url "http://mastodon.example") (mastodon-client--client-details-alist '(("https://other.example" . :no-match) ("http://mastodon.example" . :matches)))) (should (eq (mastodon-client) :matches)))) (ert-deftest mastodon-client--client-set-but-not-matching () "Should read from `mastodon-token-file' if wrong data is cached." (let ((mastodon-instance-url "http://mastodon.example") (mastodon-client--client-details-alist '(("http://other.example" :wrong)))) (with-mock (mock (mastodon-client--read) => '(:client_id "foo" :client_secret "bar")) (should (equal (mastodon-client) '(:client_id "foo" :client_secret "bar"))) (should (equal mastodon-client--client-details-alist '(("http://mastodon.example" :client_id "foo" :client_secret "bar") ("http://other.example" :wrong))))))) (ert-deftest mastodon-client--client-unset () "Should read from `mastodon-token-file' if available." (let ((mastodon-instance-url "http://mastodon.example") (mastodon-client--client-details-alist nil)) (with-mock (mock (mastodon-client--read) => '(:client_id "foo" :client_secret "bar")) (should (equal (mastodon-client) '(:client_id "foo" :client_secret "bar"))) (should (equal mastodon-client--client-details-alist '(("http://mastodon.example" :client_id "foo" :client_secret "bar"))))))) (ert-deftest mastodon-client--client-unset-and-not-in-storage () "Should store client data in plstore if it can't be read." (let ((mastodon-instance-url "http://mastodon.example") (mastodon-client--client-details-alist nil)) (with-mock (mock (mastodon-client--read)) (mock (mastodon-client--store) => '(:client_id "foo" :client_secret "baz")) (should (equal (mastodon-client) '(:client_id "foo" :client_secret "baz"))) (should (equal mastodon-client--client-details-alist '(("http://mastodon.example" :client_id "foo" :client_secret "baz"))))))) (ert-deftest mastodon-client--form-user-from-vars () (let ((mastodon-active-user "test9000") (mastodon-instance-url "https://mastodon.example")) (should (equal (mastodon-client--form-user-from-vars) "test9000@mastodon.example")))) (ert-deftest mastodon-client--current-user-active-p () (let ((mastodon-active-user "test9000") (mastodon-instance-url "https://mastodon.example")) ;; when the current user /is/ the active user (with-mock (mock (mastodon-client--general-read "active-user") => '(:username "test9000@mastodon.example" :client_id "id1")) (should (equal (mastodon-client--current-user-active-p) '(:username "test9000@mastodon.example" :client_id "id1")))) ;; when the current user is /not/ the active user (with-mock (mock (mastodon-client--general-read "active-user") => '(:username "user@other.example" :client_id "id1")) (should (null (mastodon-client--current-user-active-p)))))) (ert-deftest mastodon-client--store-access-token () (let ((mastodon-instance-url "https://mastodon.example") (mastodon-active-user "test8000") (user-details '(:username "test8000@mastodon.example" :instance "https://mastodon.example" :client_id "id" :client_secret "secret" :access_token "token"))) ;; test if mastodon-client--store-access-token /returns/ right ;; value (with-mock (mock (mastodon-client) => '(:client_id "id" :client_secret "secret")) (mock (mastodon-client--token-file) => "stubfile.plstore") (should (equal (mastodon-client--store-access-token "token") user-details))) ;; test if mastodon-client--store-access-token /stores/ right value (with-mock (mock (mastodon-client--token-file) => "stubfile.plstore") (should (equal (mastodon-client--general-read "user-test8000@mastodon.example") user-details))) (delete-file "stubfile.plstore"))) (ert-deftest mastodon-client--make-user-active () (let ((user-details '(:username "test@mastodon.example"))) (with-mock (mock (mastodon-client--token-file) => "stubfile.plstore") (mastodon-client--make-user-active user-details) (should (equal (mastodon-client--general-read "active-user") user-details))))) mastodon.el/test/mastodon-http-tests.el000066400000000000000000000073741452000115200205440ustar00rootroot00000000000000;;; mastodon-http-test.el --- Tests for mastodon-http.el -*- lexical-binding: nil -*- (require 'el-mock) (defconst mastodon-http--example-200 "HTTP/1.1 200 OK Date: Mon, 20 Dec 2021 13:42:29 GMT Content-Type: application/json; charset=utf-8 Transfer-Encoding: chunked Connection: keep-alive Server: Mastodon X-Frame-Options: DENY X-Content-Type-Options: nosniff X-XSS-Protection: 1; mode=block Permissions-Policy: interest-cohort=() X-RateLimit-Limit: 300 X-RateLimit-Remaining: 298 X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z Cache-Control: no-store Vary: Accept, Accept-Encoding, Origin ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\" X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675 X-Runtime: 0.371914 Strict-Transport-Security: max-age=63072000; includeSubDomains Strict-Transport-Security: max-age=31536000 {\"id\":\"18173\",\"following\":true,\"showing_reblogs\":true,\"notifying\":true,\"followed_by\":true,\"blocking\":false,\"blocked_by\":false,\"muting\":false,\"muting_notifications\":false,\"requested\":false,\"domain_blocking\":false,\"endorsed\":false,\"note\":\"\"}") (defconst mastodon-http--example-400 "HTTP/1.1 444 OK Date: Mon, 20 Dec 2021 13:42:29 GMT Content-Type: application/json; charset=utf-8 Transfer-Encoding: chunked Connection: keep-alive Server: Mastodon X-Frame-Options: DENY X-Content-Type-Options: nosniff X-XSS-Protection: 1; mode=block Permissions-Policy: interest-cohort=() X-RateLimit-Limit: 300 X-RateLimit-Remaining: 298 X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z Cache-Control: no-store Vary: Accept, Accept-Encoding, Origin ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\" X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675 X-Runtime: 0.371914 Strict-Transport-Security: max-age=63072000; includeSubDomains Strict-Transport-Security: max-age=31536000 {\"error\":\"some unhappy complaint\"}") (ert-deftest mastodon-http--get-retrieves-endpoint () "Should make a `url-retrieve' of the given URL." (with-mock (mock (mastodon-http--url-retrieve-synchronously "https://foo.bar/baz" nil)) (mock (mastodon-auth--access-token) => "test-token") (mastodon-http--get "https://foo.bar/baz" nil))) (ert-deftest mastodon-http--triage-success () "Should run success function for 200 HTML response." (let ((response-buffer (get-buffer-create "mastodon-http--triage-buffer"))) (with-current-buffer response-buffer (erase-buffer) (insert mastodon-http--example-200)) (should (equal (mastodon-http--triage response-buffer (lambda (_) (message "success call"))) "success call")))) (ert-deftest mastodon-http--triage-failure () "Should return formatted JSON error from bad HTML response buffer. Should not run success function." (let ((response-buffer (get-buffer-create "mastodon-http--triage-buffer"))) (with-current-buffer response-buffer (erase-buffer) (insert mastodon-http--example-400)) (should (equal (mastodon-http--triage response-buffer (lambda (_) (message "success call"))) "Error 444: some unhappy complaint")))) (ert-deftest mastodon-http-params-build () "Should correctly format parameters from an alist." (let ((params '(("q" . "test") ("foo" . "bar")))) (should (string= (mastodon-http--build-params-string params) "q=test&foo=bar")))) (ert-deftest mastodon-http-params-array-build () "Should correctly format parameters from an alist." (let ((array '("option" "option2")) (param-str "poll[x][]")) (should (equal (mastodon-http--build-array-params-alist param-str array) '(("poll[x][]" . "option") ("poll[x][]" . "option2")))))) mastodon.el/test/mastodon-media-tests.el000066400000000000000000000270611452000115200206370ustar00rootroot00000000000000;;; mastodon-media-test.el --- Tests for mastodon-media.el -*- lexical-binding: nil -*- (require 'el-mock) (ert-deftest mastodon-media--get-avatar-rendering () "Should return text with all expected properties." (with-mock (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) t :height 123) => :mock-image) (let* ((mastodon-media--avatar-height 123) (result (mastodon-media--get-avatar-rendering "http://example.org/img.png")) (result-no-properties (substring-no-properties result)) (properties (text-properties-at 0 result))) (should (string= " " result-no-properties)) (should (string= "http://example.org/img.png" (plist-get properties 'media-url))) (should (eq 'needs-loading (plist-get properties 'media-state))) (should (eq 'avatar (plist-get properties 'media-type))) (should (eq :mock-image (plist-get properties 'display)))))) (ert-deftest mastodon-media--get-media-link-rendering () "Should return text with all expected properties." (with-mock (mock (create-image * nil t) => :mock-image) (let* ((mastodon-media--preview-max-height 123) (result (mastodon-media--get-media-link-rendering "http://example.org/img.png" "http://example.org/remote/img.png" "image")) (result-no-properties (substring-no-properties result)) (properties (text-properties-at 0 result))) (should (string= "[img] " result-no-properties)) (should (string= "http://example.org/img.png" (plist-get properties 'media-url))) (should (eq 'needs-loading (plist-get properties 'media-state))) (should (eq 'media-link (plist-get properties 'media-type))) (should (eq :mock-image (plist-get properties 'display))) (should (eq 'highlight (plist-get properties 'mouse-face))) (should (eq 'image (plist-get properties 'mastodon-tab-stop))) (should (string= "http://example.org/remote/img.png" (plist-get properties 'image-url))) (should (eq mastodon-tl--shr-image-map-replacement (plist-get properties 'keymap))) (should (string= "image" (plist-get properties 'mastodon-media-type))) (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview" (plist-get properties 'help-echo)))))) (ert-deftest mastodon-media:get-media-link-rendering-gif () "Should return text with all expected properties." (with-mock (mock (create-image * nil t) => :mock-image) (let* ((mastodon-media--preview-max-height 123) (result (mastodon-media--get-media-link-rendering "http://example.org/img.png" "http://example.org/remote/img.png" "gifv")) (result-no-properties (substring-no-properties result)) (properties (text-properties-at 0 result))) (should (string= "[img] " result-no-properties)) (should (string= "http://example.org/img.png" (plist-get properties 'media-url))) (should (eq 'needs-loading (plist-get properties 'media-state))) (should (eq 'media-link (plist-get properties 'media-type))) (should (eq :mock-image (plist-get properties 'display))) (should (eq 'highlight (plist-get properties 'mouse-face))) (should (eq 'image (plist-get properties 'mastodon-tab-stop))) (should (string= "http://example.org/remote/img.png" (plist-get properties 'image-url))) (should (eq mastodon-tl--shr-image-map-replacement (plist-get properties 'keymap))) (should (string= "gifv" (plist-get properties 'mastodon-media-type))) (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview\nC-RET: play gifv with mpv" (plist-get properties 'help-echo)))))) (ert-deftest mastodon-media--load-image-from-url-avatar-with-imagemagic () "Should make the right call to url-retrieve." (let ((url "http://example.org/image.png") (mastodon-media--avatar-height 123)) (with-mock (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) t :height 123) => '(image foo)) (mock (copy-marker 7) => :my-marker ) (mock (url-retrieve url #'mastodon-media--process-image-response `(:my-marker (:height 123) 1 ,url)) => :called-as-expected) (with-temp-buffer (insert (concat "Start:" (mastodon-media--get-avatar-rendering "http://example.org/img.png") ":rest")) (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'avatar 7 1))))))) (ert-deftest mastodon-media--load-image-from-url-avatar-without-imagemagic () "Should make the right call to url-retrieve." (let ((url "http://example.org/image.png")) (with-mock (mock (image-type-available-p 'imagemagick) => nil) (mock (image-transforms-p) => nil) (mock (create-image * nil t) => '(image foo)) (mock (copy-marker 7) => :my-marker ) (mock (url-retrieve url #'mastodon-media--process-image-response `(:my-marker () 1 ,url)) => :called-as-expected) (with-temp-buffer (insert (concat "Start:" (mastodon-media--get-avatar-rendering "http://example.org/img.png") ":rest")) (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'avatar 7 1))))))) (ert-deftest mastodon-media--load-image-from-url-media-link-with-imagemagic () "Should make the right call to url-retrieve." (let ((url "http://example.org/image.png")) (with-mock (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * nil t) => '(image foo)) (mock (copy-marker 7) => :my-marker ) (mock (url-retrieve "http://example.org/image.png" #'mastodon-media--process-image-response '(:my-marker (:max-height 321) 5 "http://example.org/image.png")) => :called-as-expected) (with-temp-buffer (insert (concat "Start:" (mastodon-media--get-media-link-rendering url) ":rest")) (let ((mastodon-media--preview-max-height 321)) (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5)))))))) (ert-deftest mastodon-media--load-image-from-url-media-link-without-imagemagic () "Should make the right call to url-retrieve." (let ((url "http://example.org/image.png")) (with-mock (mock (image-type-available-p 'imagemagick) => nil) (mock (image-transforms-p) => nil) (mock (create-image * nil t) => '(image foo)) (mock (copy-marker 7) => :my-marker ) (mock (url-retrieve "http://example.org/image.png" #'mastodon-media--process-image-response '(:my-marker () 5 "http://example.org/image.png")) => :called-as-expected) (with-temp-buffer (insert (concat "Start:" (mastodon-media--get-avatar-rendering url) ":rest")) (let ((mastodon-media--preview-max-height 321)) (should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5)))))))) (ert-deftest mastodon-media--load-image-from-url-url-fetching-fails () "Should cope with failures in url-retrieve." (let ((url "http://example.org/image.png") (mastodon-media--avatar-height 123)) (with-mock (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) t :height 123) => '(image foo)) (stub url-retrieve => (error "url-retrieve failed")) (with-temp-buffer (insert (concat "Start:" (mastodon-media--get-avatar-rendering "http://example.org/img.png") ":rest")) (should (eq :loading-failed (mastodon-media--load-image-from-url url 'avatar 7 1))) ;; the media state was updated so we won't load this again: (should (eq 'loading-failed (get-text-property 7 'media-state))))))) (ert-deftest mastodon-media--process-image-response () "Should process the HTTP response and adjust the source buffer." (with-temp-buffer (with-mock (let ((source-buffer (current-buffer)) used-marker saved-marker) (insert "start:") (setq used-marker (copy-marker (point)) saved-marker (copy-marker (point))) ;; Mock needed for the preliminary image created in ;; mastodon-media--get-avatar-rendering (stub create-image => :fake-image) (insert (mastodon-media--get-avatar-rendering "http://example.org/image.png.") ":end") (with-temp-buffer (insert "some irrelevant\n" "http headers\n" "which will be ignored\n\n" "fake\nimage\ndata") (goto-char (point-min)) (mock (create-image "fake\nimage\ndata" (when (version< emacs-version "27.1") 'imagemagick) t ':image :option) => :fake-image) (mastodon-media--process-image-response () used-marker '(:image :option) 1 "http://example.org/image.png") ;; the used marker has been unset: (should (null (marker-position used-marker))) ;; the media-state has been set to loaded and the image is being displayed (should (eq 'loaded (get-text-property saved-marker 'media-state source-buffer))) (should (eq ':fake-image (get-text-property saved-marker 'display source-buffer)))))))) (ert-deftest mastodon-media--inline-images () "Should process all media in buffer." (with-mock ;; Stub needed for the test setup: (stub create-image => '(image ignored)) (let (marker-media-link marker-media-link-bad-url marker-false-media marker-avatar) (with-temp-buffer (insert "Some text before\n") (setq marker-media-link (copy-marker (point))) (insert (mastodon-media--get-media-link-rendering "http://example.org/i.jpg") " some more text ") (setq marker-media-link-bad-url (copy-marker (point))) (insert (mastodon-media--get-media-link-rendering "/files/small/missing.png") " some more text ") (setq marker-false-media (copy-marker (point))) (insert ;; text that looks almost like an avatar but lacks the media-url property (propertize "this won't be processed" 'media-state 'needs-loading 'media-type 'avatar) "even more text ") (setq marker-avatar (copy-marker (point))) (insert (mastodon-media--get-avatar-rendering "http://example.org/avatar.png") " end of text") (goto-char (point-min)) ;; stub for the actual test: (stub mastodon-media--load-image-from-url) (mastodon-media--inline-images (point-min) (point-max)) (should (eq 'loading (get-text-property marker-media-link 'media-state))) (should (eq 'invalid-url (get-text-property marker-media-link-bad-url 'media-state))) (should (eq 'loading (get-text-property marker-avatar 'media-state))) (should (eq 'needs-loading (get-text-property marker-false-media 'media-state))))))) mastodon.el/test/mastodon-notifications-tests.el000066400000000000000000000210731452000115200224260ustar00rootroot00000000000000;;; mastodon-notifications-tests.el --- Tests for mastodon-notifications.el -*- lexical-binding: nil -*- (require 'cl-lib) (require 'cl-macs) (require 'el-mock) (defconst mastodon-notifications--test-base-mentioned '((id . "1234") (type . "mention") (created_at . "2018-03-06T04:27:21.288Z" ) (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (status (id . 61208) (created_at . "2017-04-24T19:01:02.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (media_attachments . []) (mentions . []) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (content . "

Just some text

") (reblogs_count . 0) (favourites_count . 0) (reblog)))) (defconst mastodon-notifications--test-base-favourite '((id . "1234") (type . "favourite") (created_at . "2018-03-06T04:27:21.288Z" ) (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (status (id . 61208) (created_at . "2017-04-24T19:01:02.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (media_attachments . []) (mentions . []) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (content . "

Just some text

") (reblogs_count . 0) (favourites_count . 0) (reblog)))) (defconst mastodon-notifications--test-base-boosted '((id . "1234") (type . "reblog") (created_at . "2018-03-06T04:27:21.288Z" ) (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (status (id . 61208) (created_at . "2017-04-24T19:01:02.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (media_attachments . []) (mentions . []) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (content . "

Just some text

") (reblogs_count . 0) (favourites_count . 0) (reblog)))) (defconst mastodon-notifications--test-base-followed '((id . "1234") (type . "follow") (created_at . "2018-03-06T04:27:21.288Z" ) (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (status (id . 61208) (created_at . "2017-04-24T19:01:02.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (media_attachments . []) (mentions . []) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (content . "

Just some text

") (reblogs_count . 0) (favourites_count . 0) (reblog)))) (defconst mastodon-notifications--test-base-favourite '((id . "1234") (type . "mention") (created_at . "2018-03-06T04:27:21.288Z" ) (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")))) ;; (ert-deftest mastodon-notifications--notification-get () ;; "Ensure get request format for notifictions is accurate." ;; (let ((mastodon-instance-url "https://instance.url")) ;; (with-mock ;; (mock (mastodon-http--get-json "https://instance.url/api/v1/notifications" nil)) ;; (mock (mastodon-profile--fetch-server-account-settings) ;; => '(max_toot_chars 1312 privacy "public" display_name "Eugen" discoverable t locked :json-false bot :json-false sensitive :json-false language "")) ;; (mastodon-notifications-get)))) (defun mastodon-notifications--test-type (fun sample) "Test notification draw functions. FUN is the notificiation function to be called and SAMPLE is the notification to be tested." (let ((mastodon-tl--show-avatars-p nil) (timestamp (cdr (assoc 'created_at sample)))) (with-temp-buffer (funcall fun sample) (buffer-substring-no-properties (point-min) (point-max))))) (ert-deftest mastodon-notifications--test-byline-concat () "Ensure proper suffix is appended to action." (should (and (string= " Mentioned you" (mastodon-notifications--byline-concat "Mentioned")) (string= " Followed you" (mastodon-notifications--byline-concat "Followed")) (string= " Favourited your status from" (mastodon-notifications--byline-concat "Favourited")) (string= " Boosted your status from" (mastodon-notifications--byline-concat "Boosted")) (string= " Posted a post" (mastodon-notifications--byline-concat "Posted"))))) mastodon.el/test/mastodon-profile-tests.el000066400000000000000000000316331452000115200212200ustar00rootroot00000000000000;;; mastodon-profile-test.el --- Tests for mastodon-profile.el -*- lexical-binding: nil -*- (require 'el-mock) (defconst gargron-profile-json '((id . "1") (username . "Gargron") (acct . "Gargron") (display_name . "Eugen") (locked . :json-false) (bot . :json-false) (discoverable . t) (group . :json-false) (created_at . "2016-03-16T00:00:00.000Z") (note . "

Developer of Mastodon and administrator of mastodon.social. I post service announcements, development updates, and personal stuff.

") (url . "https://mastodon.social/@Gargron") (avatar . "https://files.mastodon.social/accounts/avatars/000/000/001/original/d96d39a0abb45b92.jpg") (avatar_static . "https://files.mastodon.social/accounts/avatars/000/000/001/original/d96d39a0abb45b92.jpg") (header . "https://files.mastodon.social/accounts/headers/000/000/001/original/c91b871f294ea63e.png") (header_static . "https://files.mastodon.social/accounts/headers/000/000/001/original/c91b871f294ea63e.png") (followers_count . 470905) (following_count . 451) (statuses_count . 70741) (last_status_at . "2021-11-14") (emojis . []) (fields . [((name . "Patreon") (value . "https://www.patreon.com/mastodon") (verified_at)) ((name . "Homepage") (value . "https://zeonfederated.com") (verified_at . "2019-07-15T18:29:57.191+00:00"))]))) (defconst ccc-profile-json '((id . "369027") (username . "CCC") (acct . "CCC@social.bau-ha.us") (display_name . "") (locked . :json-false) (bot . :json-false) (discoverable . :json-false) (group . :json-false) (created_at . "2018-06-03T00:00:00.000Z") (note . "

https://www.ccc.de/

") (url . "https://social.bau-ha.us/@CCC") (avatar . "https://files.mastodon.social/cache/accounts/avatars/000/369/027/original/6cfeb310f40e041a.jpg") (avatar_static . "https://files.mastodon.social/cache/accounts/avatars/000/369/027/original/6cfeb310f40e041a.jpg") (header . "https://files.mastodon.social/cache/accounts/headers/000/369/027/original/0d20bef6131b8139.jpg") (header_static . "https://files.mastodon.social/cache/accounts/headers/000/369/027/original/0d20bef6131b8139.jpg") (followers_count . 2733) (following_count . 120) (statuses_count . 1357) (last_status_at . "2021-11-02") (emojis . []) (fields . []))) (defconst gargon-statuses-json `(((id . "123456789012345678") (created_at . "2021-11-11T11:11:11.111Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (language) (uri . "https://mastodon.social/users/Gargron/statuses/123456789012345678/activity") (url . "https://mastodon.social/users/Gargron/statuses/123456789012345678/activity") (replies_count . 0) (reblogs_count . 0) (favourites_count . 0) (favourited . :json-false) (reblogged . :json-false) (muted . :json-false) (bookmarked . :json-false) (content . "

Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua.

") (reblog) (application) (account ,@gargron-profile-json) (media_attachments . []) (mentions . []) (tags . []) (emojis . []) (card) (poll)) ((id . "107279356043066700") (created_at . "2021-11-11T00:00:00.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (language . "en") (uri . "https://mastodon.social/users/Gargron/statuses/107279356043066700") (url . "https://mastodon.social/@Gargron/107279356043066700") (replies_count . 0) (reblogs_count . 2) (favourites_count . 0) (favourited . :json-false) (reblogged . :json-false) (muted . :json-false) (bookmarked . :json-false) (content . "

@CCC At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.

") (reblog) (application (name . "Web") (website)) (account ,@gargron-profile-json) (media_attachments . []) (mentions . [((id . "369027") (username . "CCC") (url . "https://social.bau-ha.us/@CCC") (acct . "CCC@social.bau-ha.us"))]) (tags . []) (emojis . []) (card) (poll)))) (ert-deftest mastodon-profile--add-author-bylines () "Should correctly format short infos about one account. When formatting Gargon's state we want to see - the short description of that profile, - the url of the avatar (yet to be loaded) - the info attached to the name" (with-mock ;; Don't start any image loading: (mock (mastodon-media--inline-images * *) => nil) ;; Let's not do formatting as that makes it hard to not rely on ;; window width and reflowing the text. (mock (shr-render-region * *) => nil) (if (version< emacs-version "27.1") (mock (image-type-available-p 'imagemagick) => t) (mock (image-transforms-p) => t)) (with-temp-buffer (let ((mastodon-tl--show-avatars t) (mastodon-tl--display-media-p t)) (mastodon-profile--format-user (list gargron-profile-json))) (should (equal (buffer-substring-no-properties (point-min) (point-max)) "\n Eugen (@Gargron)\n

Developer of Mastodon and administrator of mastodon.social. I post service announcements, development updates, and personal stuff.

\n")) ;; Check the avatar at pos 2 (should (equal (get-text-property 2 'media-url) "https://files.mastodon.social/accounts/avatars/000/000/001/original/d96d39a0abb45b92.jpg")) (should (equal (get-text-property 2 'media-state) 'needs-loading)) ;; Check the byline state (should (equal (get-text-property 4 'byline) t)) (should (equal (get-text-property 4 'item-id) (alist-get 'id gargron-profile-json))) (should (equal (get-text-property 4 'item-json) gargron-profile-json))))) (ert-deftest mastodon-profile--search-account-by-handle--removes-at () "Should ignore a leading at-sign in user handle. The search will happen as if called without the \"@\"." (with-mock (mock (mastodon-http--get-json "https://instance.url/api/v1/accounts/search" '(("q" . "gargron")))) (let ((mastodon-instance-url "https://instance.url")) ;; We don't check anything from the return value. We only care ;; that the mocked fetch was called with the expected URL. (mastodon-profile--search-account-by-handle "@gargron")))) (ert-deftest mastodon-profile--search-account-by-handle--filters-out-false-results () "Should ignore results that don't match the searched handle." (with-mock (mock (mastodon-http--get-json "https://instance.url/api/v1/accounts/search" '(("q" . "Gargron"))) => (vector ccc-profile-json gargron-profile-json)) (let ((mastodon-instance-url "https://instance.url")) (should (equal (mastodon-profile--search-account-by-handle "Gargron") gargron-profile-json))))) (ert-deftest mastodon-profile--search-account-by-handle--filtering-is-case-sensitive () "Should ignore results that don't match the searched handle with exact case. TODO: We need to decide if this is actually desired or not." (with-mock (mock (mastodon-http--get-json * '(("q" . "gargron"))) => (vector gargron-profile-json)) (let ((mastodon-instance-url "https://instance.url")) (should (null (mastodon-profile--search-account-by-handle "gargron")))))) (ert-deftest mastodon-profile--account-from-id--correct-url () "Should use the expected url for looking up by account id." (with-mock (mock (mastodon-http--get-json "https://instance.url/api/v1/accounts/1234567")) (let ((mastodon-instance-url "https://instance.url")) ;; We don't check anything from the return value. We only care ;; that the mocked fetch was called with the expected URL. (mastodon-profile--account-from-id "1234567")))) (ert-deftest mastodon-profile--make-author-buffer () "Should set up the buffer as expected for the given author. This is a far more complicated test as the mastodon-profile--make-author-buffer function does so much. There is a bit too much mocking and this may be brittle but it should help identify when things change unexpectedly. TODO: Consider separating the data retrieval and the actual content generation in the function under test." (with-mock ;; Don't start any image loading: (mock (mastodon-media--inline-images * *) => nil) (if (version< emacs-version "27.1") (mock (image-type-available-p 'imagemagick) => t) (mock (image-transforms-p) => t)) (mock (mastodon-http--get-json "https://instance.url/api/v1/accounts/1/statuses" nil) => gargon-statuses-json) (mock (mastodon-profile--get-statuses-pinned *) => []) (mock (mastodon-profile--relationships-get "1") => '(((id . "1") (following . :json-false) (showing_reblogs . :json-false) (notifying . :json-false) (followed_by . :json-false) (blocking . :json-false) (blocked_by . :json-false) (muting . :json-false) (muting_notifications . :json-false) (requested . :json-false) (domain_blocking . :json-false) (endorsed . :json-false) (note . "")))) ;; Let's not do formatting as that makes it hard to not rely on ;; window width and reflowing the text. (mock (shr-render-region * *) => nil) ;; Don't perform the actual update call at the end. ;;(mock (mastodon-tl--timeline *)) (mock (mastodon-profile--fetch-server-account-settings) => '(max_toot_chars 1312 privacy "public" display_name "Eugen" discoverable t locked :json-false bot :json-false sensitive :json-false language "")) (mock (mastodon-profile--format-joined-date-string *) => "Joined March 2016") (let ((mastodon-tl--show-avatars t) (mastodon-tl--display-media-p t) (mastodon-instance-url "https://instance.url")) (mastodon-profile--make-author-buffer gargron-profile-json) (should (equal (buffer-substring-no-properties (point-min) (point-max)) (concat "\n" "[img] [img] \n" "Eugen\n" "@Gargron\n" " ------------\n" "

Developer of Mastodon and administrator of mastodon.social. I post service announcements, development updates, and personal stuff.

\n" "_ Patreon __ :: https://www.patreon.com/mastodon_ Homepage _ :: https://zeonfederated.com" "\n" "Joined March 2016" "\n\n" " ------------\n" " TOOTS: 70741 | FOLLOWERS: 470905 | FOLLOWING: 451\n" " ------------\n" "\n" " ------------\n" " TOOTS \n" " ------------\n" "\n" "

Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua.

\n" " Eugen (@Gargron) 2021-11-11 11:11:11\n" " ------------\n" "\n" "\n" "

@CCC At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.

\n" " Eugen (@Gargron) 2021-11-11 00:00:00\n" " ------------\n" "\n" ))) ;; Until the function gets refactored this creates a non-temp ;; buffer with Gargron's statuses which we want to delete (if ;; the tests succeed). (kill-buffer)))) mastodon.el/test/mastodon-search-tests.el000066400000000000000000000227321452000115200210250ustar00rootroot00000000000000;;; mastodon-search-test.el --- Tests for mastodon-search.el -*- lexical-binding: nil -*- (defconst mastodon-search--single-account-query '((id . "242971") (username . "mousebot") (acct . "mousebot") (display_name . ": ( ) { : | : & } ; :") (locked . t) (bot . :json-false) (discoverable . t) (group . :json-false) (created_at . "2020-04-14T00:00:00.000Z") (note . "

poetry, writing, dmt, desertion, trash, black metal, translation, hegel, language, autonomia....

https://anarchive.mooo.com
https://pleasantlybabykid.tumblr.com/
IG: https://bibliogram.snopyta.org/u/martianhiatus
photos alt: @goosebot
git: https://git.blast.noho.st/mouse

want to trade chapbooks or zines? hmu!

he/him or they/them

") (url . "https://todon.nl/@mousebot") (avatar . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg") (avatar_static . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg") (header . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg") (header_static . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg") (followers_count . 226) (following_count . 634) (statuses_count . 3807) (last_status_at . "2021-11-05") (emojis . []) (fields . [((name . "dark to") (value . "themselves") (verified_at)) ((name . "its raining") (value . "plastic") (verified_at)) ((name . "dis") (value . "integration") (verified_at)) ((name . "ungleichzeitigkeit und") (value . "gleichzeitigkeit, philosophisch") (verified_at))])) "A sample mastodon account search result (parsed json)") (defconst mastodon-search--test-single-tag '((name . "TeamBringBackVisibleScrollbars") (url . "https://todon.nl/tags/TeamBringBackVisibleScrollbars") (history . [((day . "1636156800") (uses . "0") (accounts . "0")) ((day . "1636070400") (uses . "0") (accounts . "0")) ((day . "1635984000") (uses . "0") (accounts . "0")) ((day . "1635897600") (uses . "0") (accounts . "0")) ((day . "1635811200") (uses . "0") (accounts . "0")) ((day . "1635724800") (uses . "0") (accounts . "0")) ((day . "1635638400") (uses . "0") (accounts . "0"))]))) (defconst mastodon-search--test-single-status '((id . "107230316503209282") (created_at . "2021-11-06T13:19:40.628Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "direct") (language . "en") (uri . "https://todon.nl/users/mousebot/statuses/107230316503209282") (url . "https://todon.nl/@mousebot/107230316503209282") (replies_count . 0) (reblogs_count . 0) (favourites_count . 0) (favourited . :json-false) (reblogged . :json-false) (muted . :json-false) (bookmarked . :json-false) (content . "

This is a nice test toot, for testing purposes. Thank you.

") (reblog) (application (name . "mastodon.el") (website . "https://github.com/jdenen/mastodon.el")) (account (id . "242971") (username . "mousebot") (acct . "mousebot") (display_name . ": ( ) { : | : & } ; :") (locked . t) (bot . :json-false) (discoverable . t) (group . :json-false) (created_at . "2020-04-14T00:00:00.000Z") (note . "

poetry, writing, dmt, desertion, trash, black metal, translation, hegel, language, autonomia....

https://anarchive.mooo.com
https://pleasantlybabykid.tumblr.com/
IG: https://bibliogram.snopyta.org/u/martianhiatus
photos alt: @goosebot
git: https://git.blast.noho.st/mouse

want to trade chapbooks or zines? hmu!

he/him or they/them

") (url . "https://todon.nl/@mousebot") (avatar . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg") (avatar_static . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg") (header . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg") (header_static . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg") (followers_count . 226) (following_count . 634) (statuses_count . 3807) (last_status_at . "2021-11-05") (emojis . []) (fields . [((name . "dark to") (value . "themselves") (verified_at)) ((name . "its raining") (value . "plastic") (verified_at)) ((name . "dis") (value . "integration") (verified_at)) ((name . "ungleichzeitigkeit und") (value . "gleichzeitigkeit, philosophisch") (verified_at))])) (media_attachments . []) (mentions . [((id . "242971") (username . "mousebot") (url . "https://todon.nl/@mousebot") (acct . "mousebot"))]) (tags . []) (emojis . []) (card) (poll))) (ert-deftest mastodon-search--get-user-info-@ () "Should build a list from a single account for company completion." (should (equal (mastodon-search--get-user-info-@ mastodon-search--single-account-query) '("@mousebot" "https://todon.nl/@mousebot" ": ( ) { : | : & } ; :")))) (ert-deftest mastodon-search--get-user-info () "Should build a list from a single account for company completion." (should (equal (mastodon-search--get-user-info mastodon-search--single-account-query) '(": ( ) { : | : & } ; :" "mousebot" "https://todon.nl/@mousebot" "

poetry, writing, dmt, desertion, trash, black metal, translation, hegel, language, autonomia....

https://anarchive.mooo.com
https://pleasantlybabykid.tumblr.com/
IG: https://bibliogram.snopyta.org/u/martianhiatus
photos alt: @goosebot
git: https://git.blast.noho.st/mouse

want to trade chapbooks or zines? hmu!

he/him or they/them

")))) (ert-deftest mastodon-search--get-hashtag-info () "Should build a list of hashtag name and URL." (should (equal (mastodon-search--get-hashtag-info mastodon-search--test-single-tag) '("TeamBringBackVisibleScrollbars" "https://todon.nl/tags/TeamBringBackVisibleScrollbars")))) (ert-deftest mastodon-search--get-status-info () "Should return a list of ID, timestamp, content, and spoiler." (should (equal (mastodon-search--get-status-info mastodon-search--test-single-status) '("107230316503209282" "2021-11-06T13:19:40.628Z" "" "

This is a nice test toot, for testing purposes. Thank you.

")))) mastodon.el/test/mastodon-tl-tests.el000066400000000000000000001571471452000115200202100ustar00rootroot00000000000000;;; mastodon-tl-test.el --- Tests for mastodon-tl.el -*- lexical-binding: nil -*- (require 'cl-lib) (require 'cl-macs) (require 'el-mock) (defconst mastodon-tl--test-instance-rules ;; brief ones calqued off todon.nl '(((id . "1") (text . "We do not accept racism.")) ((id . "2") (text . "We do not accept homophobia.")) ((id . "3") (text . "We do not accept sexism.")) ((id . "4") (text . "We do not accept ableism.")) ((id . "5") (text . "We do not accept harassment.")) ((id . "6") (text . "We also do not accept hate speech.")) ((id . "7") (text . "We do not accept abuse of minors.")) ((id . "8") (text . "We do not accept glorification of violence.")))) (defconst mastodon-tl-test-base-toot '((id . 61208) (created_at . "2017-04-24T19:01:02.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (media_attachments . []) (mentions . []) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (content . "

Just some text

") (reblogs_count . 0) (favourites_count . 0) (reblog)) "A sample toot (parsed json)") (defconst mastodon-tl-test-base-boosted-toot '((id . 61208) (created_at . "2017-04-24T20:59:59.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (media_attachments . []) (mentions . []) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (reblogs_count . 0) (favourites_count . 0) (reblog (id . 4543919) (created_at . "2017-04-24T19:01:02.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (application) (account (id . 43) (username . "acct43") (acct . "acct43@example.space") (display_name . "Account 43") (locked . :json-false) (created_at . "2017-04-02T00:00:00.000Z") (followers_count . 1) (following_count . 1) (statuses_count . 1) (note . "Other account")) (media_attachments . []) (mentions . [((url . "https://mastodon.social/@johnson") (acct . "acct42") (id . 42) (username . "acct42"))]) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (content . "

@acct42 boost

") (url . "https://example.space/users/acct42/updates/123456789") (reblogs_count . 1) (favourites_count . 1) (favourited) (reblogged))) "A sample reblogged/boosted toot (parsed json)") (defconst mastodon-tl--follow-notify-true-response "HTTP/1.1 200 OK Date: Mon, 20 Dec 2021 13:42:29 GMT Content-Type: application/json; charset=utf-8 Transfer-Encoding: chunked Connection: keep-alive Server: Mastodon X-Frame-Options: DENY X-Content-Type-Options: nosniff X-XSS-Protection: 1; mode=block Permissions-Policy: interest-cohort=() X-RateLimit-Limit: 300 X-RateLimit-Remaining: 298 X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z Cache-Control: no-store Vary: Accept, Accept-Encoding, Origin ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\" X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675 X-Runtime: 0.371914 Strict-Transport-Security: max-age=63072000; includeSubDomains Strict-Transport-Security: max-age=31536000 {\"id\":\"123456789\",\"following\":true,\"showing_reblogs\":true,\"notifying\":true,\"followed_by\":true,\"blocking\":false,\"blocked_by\":false,\"muting\":false,\"muting_notifications\":false,\"requested\":false,\"domain_blocking\":false,\"endorsed\":false,\"note\":\"\"}") (defconst mastodon-tl--follow-notify-false-response "HTTP/1.1 200 OK Date: Mon, 20 Dec 2021 13:42:29 GMT Content-Type: application/json; charset=utf-8 Transfer-Encoding: chunked Connection: keep-alive Server: Mastodon X-Frame-Options: DENY X-Content-Type-Options: nosniff X-XSS-Protection: 1; mode=block Permissions-Policy: interest-cohort=() X-RateLimit-Limit: 300 X-RateLimit-Remaining: 298 X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z Cache-Control: no-store Vary: Accept, Accept-Encoding, Origin ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\" X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675 X-Runtime: 0.371914 Strict-Transport-Security: max-age=63072000; includeSubDomains Strict-Transport-Security: max-age=31536000 {\"id\":\"123456789\",\"following\":true,\"showing_reblogs\":true,\"notifying\":false,\"followed_by\":true,\"blocking\":false,\"blocked_by\":false,\"muting\":false,\"muting_notifications\":false,\"requested\":false,\"domain_blocking\":false,\"endorsed\":false,\"note\":\"\"}") (ert-deftest mastodon-tl--remove-html-1 () "Should remove all tags." (let ((input "foobar foobaz")) (should (string= (mastodon-tl--remove-html input) "foobar foobaz")))) (ert-deftest mastodon-tl--remove-html-2 () "Should replace <\p> tags with two new lines." (let ((input "foobar

")) (should (string= (mastodon-tl--remove-html input) "foobar\n\n")))) (ert-deftest mastodon-tl--item-id-boosted () "If a toot is boostedm, return the reblog id." (should (string= (mastodon-tl--as-string (mastodon-tl--item-id mastodon-tl-test-base-boosted-toot)) "4543919"))) (ert-deftest mastodon-tl--item-id () "If a toot is boostedm, return the reblog id." (should (string= (mastodon-tl--as-string (mastodon-tl--item-id mastodon-tl-test-base-toot)) "61208"))) (ert-deftest mastodon-tl--as-string-1 () "Should accept a string or number and return a string." (let ((id "1000")) (should (string= (mastodon-tl--as-string id) id)))) (ert-deftest mastodon-tl--as-string-2 () "Should accept a string or number and return a string." (let ((id 1000)) (should (string= (mastodon-tl--as-string id) (number-to-string id))))) (ert-deftest mastodon-tl--more-json () "Should request toots older than max_id." (let ((mastodon-instance-url "https://instance.url")) (with-mock (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo" '(("max_id" . "12345")))) (mastodon-tl--more-json "timelines/foo" "12345")))) (ert-deftest mastodon-tl--more-json-id-string () "Should request toots older than max_id. `mastodon-tl--more-json' should accept and id that is either a string or a numeric." (let ((mastodon-instance-url "https://instance.url")) (with-mock (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo" '(("max_id" . "12345")))) (mastodon-tl--more-json "timelines/foo" "12345")))) (ert-deftest mastodon-tl--update-json-id-string () "Should request toots more recent than since_id. `mastodon-tl--updated-json' should accept and id that is either a string or a numeric." (let ((mastodon-instance-url "https://instance.url")) (with-mock (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo" '(("since_id" . "12345")))) (mastodon-tl--updated-json "timelines/foo" "12345")))) (ert-deftest mastodon-tl--relative-time-description () "Should format relative time as expected" (cl-labels ((minutes (n) (* n 60)) (hours (n) (* n (minutes 60))) (days (n) (* n (hours 24))) (weeks (n) (* n (days 7))) (years (n) (* n (days 365))) (format-seconds-since (seconds) (let ((timestamp (time-subtract (current-time) (seconds-to-time seconds)))) (mastodon-tl--relative-time-description timestamp))) (check (seconds expected) (should (string= (format-seconds-since seconds) expected)))) (check 1 "just now") (check 59 "just now") (check 60 "1 minute ago") (check 89 "1 minute ago") ;; rounding down (check 91 "2 minutes ago") ;; rounding up (check (minutes 3.49) "3 minutes ago") ;; rounding down (check (minutes 3.52) "4 minutes ago") (check (minutes 59) "59 minutes ago") (check (minutes 60) "1 hour ago") (check (minutes 89) "1 hour ago") (check (minutes 91) "2 hours ago") (check (hours 3.49) "3 hours ago") ;; rounding down (check (hours 3.51) "4 hours ago") ;; rounding down (check (hours 23.4) "23 hours ago") (check (hours 23.6) "1 day ago") ;; rounding up (check (days 1.48) "1 day ago") ;; rounding down (check (days 1.52) "2 days ago") ;; rounding up (check (days 6.6) "1 week ago") ;; rounding up (check (weeks 2.49) "2 weeks ago") ;; rounding down (check (weeks 2.51) "3 weeks ago") ;; rounding down (check (1- (weeks 52)) "52 weeks ago") (check (weeks 52) "1 year ago") (check (years 2.49) "2 years ago") ;; rounding down (check (years 2.51) "3 years ago") ;; rounding down )) (ert-deftest mastodon-tl--relative-time-details--next-update () "Should calculate the next update time information as expected" (let ((current-time (current-time))) (cl-labels ((minutes (n) (* n 60)) (hours (n) (* n (minutes 60))) (days (n) (* n (hours 24))) (weeks (n) (* n (days 7))) (years (n) (* n (days 365.25))) (next-update (seconds-ago) (let* ((timestamp (time-subtract current-time (seconds-to-time seconds-ago)))) (cdr (mastodon-tl--relative-time-details timestamp current-time)))) (check (seconds-ago) (let* ((timestamp (time-subtract current-time (seconds-to-time seconds-ago))) (at-now (mastodon-tl--relative-time-description timestamp current-time)) (at-one-second-before (mastodon-tl--relative-time-description timestamp (time-subtract (next-update seconds-ago) (seconds-to-time 1)))) (at-result (mastodon-tl--relative-time-description timestamp (next-update seconds-ago)))) (when nil ;; change to t to debug test failures (prin1 (format "\nFor %s: %s / %s" seconds-ago (time-to-seconds (time-subtract (next-update seconds-ago) timestamp)) (round (time-to-seconds (time-subtract (next-update seconds-ago) current-time)))))) ;; a second earlier the description is the same as at current time (should (string= at-now at-one-second-before)) ;; but at the result time it is different (should-not (string= at-one-second-before at-result))))) (check 0) (check 1) (check 59) (check 60) (check 89) (check 90) (check 149) (check 150) (check (1- (hours 1.5))) ;; just before we switch from "one hour" to "2 hours" (check (hours 1.5)) (check (hours 2.1)) (check (1- (hours 23.5))) ;; just before "23 hours" -> "one day" (check (hours 23.5)) (check (1- (days 1.5))) ;; just before "one day" -> "2 days" (check (days 1.5)) ;; just before "one day" -> "2 days" (check (days 2.1)) (check (1- (days 6.5))) ;; just before "6 days" -> "one week" (check (days 6.5)) ;; "one week" -> "2 weeks" (check (weeks 2.1)) (check (1- (weeks 52))) ;; just before "52 weeks" -> "one year" (check (weeks 52)) (check (days 365)) (check (days 366)) (check (years 2.1)) ))) (ert-deftest mastodon-tl--byline-regular () "Should format the regular toot correctly." (let ((mastodon-tl--show-avatars-p nil) (timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) (mock (mastodon-tl--toot-stats mastodon-tl-test-base-toot) => "") (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") (let ((byline (mastodon-tl--byline mastodon-tl-test-base-toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (handle-location 20)) (should (string= (substring-no-properties byline) (concat "Account 42 (@acct42@example.space) 2999-99-99 00:11:22 " mastodon-tl--horiz-bar " "))) (should (eq (get-text-property handle-location 'mastodon-tab-stop byline) 'user-handle)) (should (string= (get-text-property handle-location 'mastodon-handle byline) "@acct42@example.space")) (should (equal (get-text-property handle-location 'help-echo byline) "Browse user profile of @acct42@example.space")))))) (ert-deftest mastodon-tl--byline-regular-with-avatar () "Should format the regular toot correctly." (let ((mastodon-tl--show-avatars-p t) (timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) (with-mock (stub create-image => '(image "fake data")) (mock (date-to-time timestamp) => '(22782 21551)) (mock (mastodon-tl--toot-stats mastodon-tl-test-base-toot) => "") (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") (should (string= (substring-no-properties (mastodon-tl--byline mastodon-tl-test-base-toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (concat "Account 42 (@acct42@example.space) 2999-99-99 00:11:22 " mastodon-tl--horiz-bar " ")))))) (ert-deftest mastodon-tl--byline-boosted () "Should format the boosted toot correctly." (let* ((mastodon-tl--show-avatars-p nil) (toot (cons '(reblogged . t) mastodon-tl-test-base-toot)) (timestamp (cdr (assoc 'created_at toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) (mock (mastodon-tl--symbol 'boost) => "B") (mock (mastodon-tl--toot-stats toot) => "") (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") (should (string= (substring-no-properties (mastodon-tl--byline toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (concat "(B) Account 42 (@acct42@example.space) 2999-99-99 00:11:22 " mastodon-tl--horiz-bar " ")))))) (ert-deftest mastodon-tl--byline-favorited () "Should format the favourited toot correctly." (let* ((mastodon-tl--show-avatars-p nil) (toot (cons '(favourited . t) mastodon-tl-test-base-toot)) (timestamp (cdr (assoc 'created_at toot)))) (with-mock (mock (mastodon-tl--symbol 'favourite) => "F") (mock (date-to-time timestamp) => '(22782 21551)) (mock (mastodon-tl--toot-stats toot) => "") (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") (should (string= (substring-no-properties (mastodon-tl--byline toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (concat "(F) Account 42 (@acct42@example.space) 2999-99-99 00:11:22 " mastodon-tl--horiz-bar " ")))))) (ert-deftest mastodon-tl--byline-boosted/favorited () "Should format the boosted & favourited toot correctly." (let* ((mastodon-tl--show-avatars-p nil) (toot `((favourited . t) (reblogged . t) ,@mastodon-tl-test-base-toot)) (timestamp (cdr (assoc 'created_at toot)))) (with-mock (mock (mastodon-tl--toot-stats toot) => "") (mock (date-to-time timestamp) => '(22782 21551)) ;; FIXME this mock refuses to recognise our different args ;; (mock (mastodon-tl--symbol 'favourite) => "F") ;; (mock (mastodon-tl--symbol 'boost) => "B") (mock (mastodon-tl--symbol *) => "?") (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") (should (string= (substring-no-properties (mastodon-tl--byline toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (concat "(?) (?) Account 42 (@acct42@example.space) 2999-99-99 00:11:22 " mastodon-tl--horiz-bar " ")))))) (ert-deftest mastodon-tl--byline-reblogged () "Should format the reblogged toot correctly." (let* ((mastodon-tl--show-avatars-p nil) (toot mastodon-tl-test-base-boosted-toot) (original-toot (cdr (assoc 'reblog mastodon-tl-test-base-boosted-toot))) (timestamp (cdr (assoc 'created_at toot))) (original-timestamp (cdr (assoc 'created_at original-toot)))) (with-mock ;; We don't expect to use the toot's timestamp but the timestamp of the ;; reblogged toot: (mock (date-to-time timestamp) => '(1 2)) (mock (format-time-string mastodon-toot-timestamp-format '(1 2)) => "reblogging time") (mock (date-to-time original-timestamp) => '(3 4)) (mock (mastodon-tl--toot-stats toot) => "") (mock (format-time-string mastodon-toot-timestamp-format '(3 4)) => "original time") (let ((byline (mastodon-tl--byline toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (handle1-location 20) (handle2-location 65)) (should (string= (substring-no-properties byline) (concat "Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time " mastodon-tl--horiz-bar " "))) (should (eq (get-text-property handle1-location 'mastodon-tab-stop byline) 'user-handle)) (should (equal (get-text-property handle1-location 'help-echo byline) "Browse user profile of @acct42@example.space")) (should (eq (get-text-property handle2-location 'mastodon-tab-stop byline) 'user-handle)) (should (equal (get-text-property handle2-location 'help-echo byline) "Browse user profile of @acct43@example.space")))))) (ert-deftest mastodon-tl--byline-reblogged-with-avatars () "Should format the reblogged toot correctly." (let* ((mastodon-tl--show-avatars-p t) (toot mastodon-tl-test-base-boosted-toot) (original-toot (cdr (assoc 'reblog mastodon-tl-test-base-boosted-toot))) (timestamp (cdr (assoc 'created_at toot))) (original-timestamp (cdr (assoc 'created_at original-toot)))) (with-mock ;; We don't expect to use the toot's timestamp but the timestamp of the ;; reblogged toot: (stub create-image => '(image "fake data")) (mock (date-to-time timestamp) => '(1 2)) (mock (format-time-string mastodon-toot-timestamp-format '(1 2)) => "reblogging time") (mock (date-to-time original-timestamp) => '(3 4)) (mock (format-time-string mastodon-toot-timestamp-format '(3 4)) => "original time") (mock (mastodon-tl--toot-stats toot) => "") (should (string= (substring-no-properties (mastodon-tl--byline toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (concat "Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time " mastodon-tl--horiz-bar " ")))))) (ert-deftest mastodon-tl--byline-reblogged-boosted/favorited () "Should format the reblogged toot that was also boosted & favoritedcorrectly." (let* ((mastodon-tl--show-avatars-p nil) (toot `((favourited . t) (reblogged . t) ,@mastodon-tl-test-base-boosted-toot)) (original-toot (cdr (assoc 'reblog mastodon-tl-test-base-boosted-toot))) (timestamp (cdr (assoc 'created_at toot))) (original-timestamp (cdr (assoc 'created_at original-toot)))) (with-mock ;; We don't expect to use the toot's timestamp but the timestamp of the ;; reblogged toot: (mock (date-to-time timestamp) => '(1 2)) ;; FIXME this mock refuses to recognise our different args ;; (mock (mastodon-tl--symbol 'favourite) => "F") ;; (mock (mastodon-tl--symbol 'boost) => "B") (mock (mastodon-tl--symbol *) => "?") (mock (mastodon-tl--toot-stats toot) => "") (mock (format-time-string mastodon-toot-timestamp-format '(1 2)) => "reblogging time") (mock (date-to-time original-timestamp) => '(3 4)) (mock (format-time-string mastodon-toot-timestamp-format '(3 4)) => "original time") (should (string= (substring-no-properties (mastodon-tl--byline toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (concat "(?) (?) Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time " mastodon-tl--horiz-bar " ")))))) (ert-deftest mastodon-tl--byline-timestamp-has-relative-display () "Should display the timestamp with a relative time." (let ((mastodon-tl--show-avatars-p nil) (timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) (mock (current-time) => '(22782 22000)) (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") (let* ((formatted-string (mastodon-tl--byline mastodon-tl-test-base-toot 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted)) (timestamp-start (string-match "2999-99-99" formatted-string)) (properties (text-properties-at timestamp-start formatted-string))) (should (equal '(22782 21551) (plist-get properties 'timestamp))) (should (string-equal "7 minutes ago" (plist-get properties 'display))))))) (ert-deftest mastodon-tl--consider-timestamp-for-updates-no-active-callback () "Should update the timestamp update variables as expected." (let* ((now (current-time)) (soon-in-the-future (time-add now (seconds-to-time 10000))) (long-in-the-future (time-add now (seconds-to-time 10000000)))) (with-temp-buffer ;; start with timer way into the future and no active callback (setq mastodon-tl--timestamp-next-update long-in-the-future mastodon-tl--timestamp-update-timer nil) ;; something a later update doesn't update: (with-mock (mock (mastodon-tl--relative-time-details 'fake-timestamp) => (cons "xxx ago" (time-add long-in-the-future (seconds-to-time 100)))) (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) (should (null mastodon-tl--timestamp-update-timer)) (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) ;; something only shortly sooner doesn't update: (with-mock (mock (mastodon-tl--relative-time-details 'fake-timestamp) => (cons "xxx ago" (time-subtract long-in-the-future (seconds-to-time 9)))) (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) (should (null mastodon-tl--timestamp-update-timer)) (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) ;; something much sooner, does update (with-mock (mock (mastodon-tl--relative-time-details 'fake-timestamp) => (cons "xxx ago" soon-in-the-future)) (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) (should (null mastodon-tl--timestamp-update-timer)) (should (eq mastodon-tl--timestamp-next-update soon-in-the-future))) ))) (ert-deftest mastodon-tl--consider-timestamp-for-updates-with-active-callback () "Should update the timestamp update variables as expected." (let* ((now (current-time)) (soon-in-the-future (time-add now (seconds-to-time 10000))) (long-in-the-future (time-add now (seconds-to-time 10000000)))) (with-temp-buffer ;; start with timer way into the future and no active callback (setq mastodon-tl--timestamp-next-update long-in-the-future mastodon-tl--timestamp-update-timer 'initial-timer) ;; something a later update doesn't update: (with-mock (mock (mastodon-tl--relative-time-details 'fake-timestamp) => (cons "xxx ago" (time-add long-in-the-future (seconds-to-time 100)))) (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) (should (eq 'initial-timer mastodon-tl--timestamp-update-timer)) (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) ;; something much sooner, does update (with-mock (mock (mastodon-tl--relative-time-details 'fake-timestamp) => (cons "xxx ago" soon-in-the-future)) (mock (cancel-timer 'initial-timer)) (mock (run-at-time * nil #'mastodon-tl--update-timestamps-callback (current-buffer) nil) => 'new-timer) (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) (should (eq 'new-timer mastodon-tl--timestamp-update-timer)) (should (eq mastodon-tl--timestamp-next-update soon-in-the-future))) ))) (ert-deftest mastodon-tl--find-property-range--no-tag () "Should cope with a buffer completely lacking the tag." (with-temp-buffer (insert "Just some random text") (insert (propertize "More text with a different property" 'other-property 'set)) (should (null (mastodon-tl--find-property-range 'test-property 2 nil))) (should (null (mastodon-tl--find-property-range 'test-property 2 t))))) (ert-deftest mastodon-tl--find-property-range--earlier-tag () "Should cope with a buffer completely lacking the tag." (with-temp-buffer (insert (propertize "Just some text with a the sought property" 'test-property 'set)) (let ((end-of-region (point))) (insert "More random text") (should (null (mastodon-tl--find-property-range 'test-property end-of-region nil))) (should (equal (cons (point-min) end-of-region) (mastodon-tl--find-property-range 'test-property end-of-region t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding () "Should find the sought tag in all expected circumstances." (with-temp-buffer (insert "Previous text") (let ((start-of-region (point)) end-of-region) (insert (propertize "Just some text with a the sought property" 'test-property 'set)) (setq end-of-region (point)) (insert "More random text") ;; before the region (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property 1 nil))) (should (null (mastodon-tl--find-property-range 'test-property 1 t))) ;; in the region (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region) nil))) (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region) t))) ;; at end of region (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (1- end-of-region) nil))) (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding-consecutive-ranges () "Should find the sought tag even from in between consecutive ranges." (with-temp-buffer (insert "Previous text") (let ((start-of-region-1 (point)) between-regions end-of-region-2) (insert (propertize "region1" 'test-property 'region1)) (setq between-regions (point)) (insert (propertize "region2" 'test-property 'region2)) (setq end-of-region-2 (point)) (insert "More random text") ;; before (should (equal (cons start-of-region-1 between-regions) (mastodon-tl--find-property-range 'test-property 1 nil))) (should (null (mastodon-tl--find-property-range 'test-property 1 t))) ;; between the regions (should (equal (cons between-regions end-of-region-2) (mastodon-tl--find-property-range 'test-property between-regions nil))) (should (equal (cons between-regions end-of-region-2) (mastodon-tl--find-property-range 'test-property between-regions t))) ;; after (should (null (mastodon-tl--find-property-range 'test-property end-of-region-2 nil))) (should (equal (cons between-regions end-of-region-2) (mastodon-tl--find-property-range 'test-property end-of-region-2 t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding-at-start () "Should cope with a tag at start." (with-temp-buffer (insert (propertize "Just some text with a the sought property" 'test-property 'set)) (let ((end-of-region (point))) (insert "More random text") ;; at start of the region (should (equal (cons 1 end-of-region) (mastodon-tl--find-property-range 'test-property 1 nil))) (should (equal (cons 1 end-of-region) (mastodon-tl--find-property-range 'test-property 1 t))) ;; in the region (should (equal (cons 1 end-of-region) (mastodon-tl--find-property-range 'test-property 3 nil))) (should (equal (cons 1 end-of-region) (mastodon-tl--find-property-range 'test-property 3 t))) ;; at end of region (should (equal (cons 1 end-of-region) (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding-at-end () "Should cope with a tag at end." (with-temp-buffer (insert "More random text") (let ((start-of-region (point)) end-of-region) (insert (propertize "Just some text with a the sought property" 'test-property 'set)) (setq end-of-region (point-max)) ;; before the region (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property 1 nil))) (should (null (mastodon-tl--find-property-range 'test-property 1 t))) ;; in the region (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (1+ start-of-region) nil))) (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (1+ start-of-region) t))) ;; at end of region (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (1- end-of-region) nil))) (should (equal (cons start-of-region end-of-region) (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) (ert-deftest mastodon-tl--find-property-range--successful-finding-whole-buffer () "Should cope with a tag being set for the whole buffer." (with-temp-buffer (insert (propertize "Just some text with a the sought property" 'test-property 'set)) (should (equal (cons (point-min) (point-max)) (mastodon-tl--find-property-range 'test-property 2 nil))) (should (equal (cons (point-min) (point-max)) (mastodon-tl--find-property-range 'test-property 2 t))))) (defun tl-tests--all-regions-with-property (property) "Returns a list with (start . end) regions where PROPERTY is set." (let (result region) (goto-char (point-min)) (while (and (< (point) (point-max)) (setq region (mastodon-tl--find-property-range property (point)))) (push region result) (goto-char (min (point-max) (cdr region)))) (nreverse result))) (ert-deftest mastodon-tl--next-tab-item--with-spaces-at-ends () "Should do the correct tab actions." (with-temp-buffer ;; We build a buffer with 3 tab stops: "...R1...R2R3..." (a dot ;; represents text that is not part of a link, so R1 and R2 have a ;; gap in between each other, R2 and R3 don't. (insert "Random text at start") (let ((start 2) (r1 (point)) r2 gap r3 end) (insert (propertize "R1 R1 R1" 'mastodon-tab-stop 'region1)) (setq gap (+ (point) 2)) (insert " a gap ") (setq r2 (point)) (insert (propertize "R2 R2 R2" 'mastodon-tab-stop 'region2)) (setq r3 (point)) (insert (propertize "R3 R3 R3" 'mastodon-tab-stop 'region3)) (setq end (+ (point) 2)) (insert " more text at end") (let ((test-cases ;; a list 4-elemet lists of (test-name start-point ;; expected-prev-stop expected-next-stop): (list (list 'start start start r1) (list 'r1 r1 r1 r2) (list 'gap gap r1 r2) (list 'r2 r2 r1 r3) (list 'r3 r3 r2 r3) (list 'end end r3 end)))) (with-mock (stub message => nil) ;; don't mess up our test output with the function's messages (cl-dolist (test test-cases) (let ((test-name (cl-first test)) (test-start (cl-second test)) (expected-prev (cl-third test)) (expected-next (cl-fourth test))) (goto-char test-start) (mastodon-tl--previous-tab-item) (should (equal (list 'prev test-name expected-prev) (list 'prev test-name (point)))) (goto-char test-start) (mastodon-tl--next-tab-item) (should (equal (list 'next test-name expected-next) (list 'next test-name (point))))))))))) (ert-deftest mastodon-tl--next-tab-item--no-spaces-at-ends () "Should do the correct tab actions even with regions right at buffer ends." (with-temp-buffer ;; We build a buffer with 3 tab stops: "R1...R2R3...R4" (a dot ;; represents text that is not part of a link, so R1 and R2, and ;; R3 and R4 have a gap in between each other, R2 and R3 don't. (let ((r1 (point)) gap1 r2 r3 gap2 r4) (insert (propertize "R1 R1 R1" 'mastodon-tab-stop 'region1)) (setq gap1 (+ (point) 2)) (insert " a gap ") (setq r2 (point)) (insert (propertize "R2 R2 R2" 'mastodon-tab-stop 'region2)) (setq r3 (point)) (insert (propertize "R3 R3 R3" 'mastodon-tab-stop 'region3)) (setq gap2 (+ (point) 2)) (insert " another gap ") (setq r4 (point)) (insert (propertize "R4 R4 R4" 'mastodon-tab-stop 'region4)) (let ((test-cases ;; a list 4-elemet lists of (test-name start-point ;; expected-prev-stop expected-next-stop): (list (list 'r1 r1 r1 r2) (list 'gap1 gap1 r1 r2) (list 'r2 r2 r1 r3) (list 'r3 r3 r2 r4) (list 'gap2 gap2 r3 r4) (list 'r4 r4 r3 r4)))) (with-mock (stub message => nil) ;; don't mess up our test output with the function's messages (cl-dolist (test test-cases) (let ((test-name (cl-first test)) (test-start (cl-second test)) (expected-prev (cl-third test)) (expected-next (cl-fourth test))) (goto-char test-start) (mastodon-tl--previous-tab-item) (should (equal (list 'prev test-name expected-prev) (list 'prev test-name (point)))) (goto-char test-start) (mastodon-tl--next-tab-item) (should (equal (list 'next test-name expected-next) (list 'next test-name (point))))))))))) (defun tl-tests--property-values-at (property ranges) "Returns a list with property values at the given ranges. The property value for PROPERTY within a region is assumed to be constant." (let (result) (dolist (range ranges (nreverse result)) (push (get-text-property (car range) property) result)))) (ert-deftest mastodon-tl--update-timestamps-callback () "Should update the 5 timestamps at a time as expected." (let ((now (current-time)) markers) (cl-labels ((insert-timestamp (n) (insert (format "\nSome text before timestamp %s:" n)) (insert (propertize (format "timestamp #%s" n) 'timestamp (time-subtract now (seconds-to-time (* 60 n))) 'display (format "unset %s" n))) (push (copy-marker (point)) markers) (insert " some more text."))) (with-temp-buffer (cl-dotimes (n 12) (insert-timestamp (+ n 2))) (setq markers (nreverse markers)) (with-mock (mock (current-time) => now) (stub run-at-time => 'fake-timer) ;; make the initial call (mastodon-tl--update-timestamps-callback (current-buffer) nil) (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" "unset 7" "unset 8" "unset 9" "unset 10" "unset 11" "unset 12" "unset 13") (tl-tests--property-values-at 'display (tl-tests--all-regions-with-property 'timestamp)))) ;; fake the follow-up call (mastodon-tl--update-timestamps-callback (current-buffer) (nth 4 markers)) (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" "7 minutes ago" "8 minutes ago" "9 minutes ago" "10 minutes ago" "11 minutes ago" "unset 12" "unset 13") (tl-tests--property-values-at 'display (tl-tests--all-regions-with-property 'timestamp)))) (should (null (marker-position (nth 4 markers)))) ;; fake the follow-up call (mastodon-tl--update-timestamps-callback (current-buffer) (nth 9 markers)) (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" "7 minutes ago" "8 minutes ago" "9 minutes ago" "10 minutes ago" "11 minutes ago" "12 minutes ago" "13 minutes ago") (tl-tests--property-values-at 'display (tl-tests--all-regions-with-property 'timestamp)))) (should (null (marker-position (nth 9 markers))))))))) (ert-deftest mastodon-tl--has-spoiler () "Should be able to detect toots with spoiler text as expected" (let* ((normal-toot mastodon-tl-test-base-toot) (normal-toot-with-spoiler (cons '(spoiler_text . "spoiler") normal-toot)) (boosted-toot mastodon-tl-test-base-boosted-toot) (boosted-toot-with-spoiler (cons (cons 'reblog normal-toot-with-spoiler) boosted-toot))) (should (null (mastodon-tl--has-spoiler normal-toot))) (should-not (null (mastodon-tl--has-spoiler normal-toot-with-spoiler))) (should (null (mastodon-tl--has-spoiler boosted-toot))) (should-not (null (mastodon-tl--has-spoiler boosted-toot-with-spoiler))))) (ert-deftest mastodon-tl--spoiler () "Should render a toot with spoiler properly, with link that toggles the body." (let ((normal-toot-with-spoiler (cons '(spoiler_text . "This is the spoiler warning text") mastodon-tl-test-base-toot)) toot-start toot-end link-region body-position) (with-temp-buffer (insert "some text before\n") (setq toot-start (point)) (with-mock (mock (mastodon-profile--get-preferences-pref 'reading:expand:spoilers) => :json-false) (stub create-image => '(image "fake data")) (stub shr-render-region => nil) ;; Travis's Emacs doesn't have libxml (insert (mastodon-tl--spoiler normal-toot-with-spoiler))) (setq toot-end (point)) (insert "\nsome more text.") (add-text-properties toot-start toot-end (list 'item-json normal-toot-with-spoiler 'item-id (cdr (assoc 'id normal-toot-with-spoiler)))) (goto-char toot-start) ;; (should (eq t (looking-at "This is the spoiler warning text"))) (setq link-region (mastodon-tl--find-next-or-previous-property-range 'mastodon-tab-stop toot-start nil)) ;; There should be a link following the text: (should-not (null link-region)) (goto-char (car link-region)) (should (eq t (looking-at "CW: This is the spoiler warning text"))) ;Content Warning"))) (setq body-position (+ 25 (cdr link-region))) ;; 25 is enough to skip the "\n--------------...." ;; The text a bit after the link should be invisible: (should (eq t (get-text-property body-position 'invisible))) ;; Click the link: (mastodon-tl--do-link-action-at-point (car link-region)) ;; The body is now visible: (should (eq nil (get-text-property body-position 'invisible))) ;; Click the link once more: (mastodon-tl--do-link-action-at-point (car link-region)) ;; The body is invisible again: (should (eq t (get-text-property body-position 'invisible))) ;; Go back to the toot's beginning (goto-char toot-start) ;; Press 'c' and the body is visible again and point hasn't changed: (mastodon-tl--toggle-spoiler-text-in-toot) (should (eq nil (get-text-property body-position 'invisible))) (should (eq toot-start (point))) ;; Go to the toot's end (goto-char toot-end) ;; Press 'c' and the body is invisible again and point hasn't changed: (mastodon-tl--toggle-spoiler-text-in-toot) (should (eq t (get-text-property body-position 'invisible))) (should (eq toot-end (point))) ))) (ert-deftest mastodon-tl--hashtag () "Should recognise hashtags in a toot and add the required properties to it." ;; Travis's Emacs doesn't have libxml so we fake things by inputting ;; propertized text and stubbing shr-render-region (let* ((fake-input-text (concat "Tag:" (propertize "sampletag" 'shr-url "https://example.space/tags/sampletag" 'keymap shr-map 'help-echo "https://example.space/tags/sampletag") " some text after")) (rendered (with-mock (stub shr-render-region => nil) (mastodon-tl--render-text fake-input-text mastodon-tl-test-base-toot))) (tag-location 7)) (should (eq (get-text-property tag-location 'mastodon-tab-stop rendered) 'hashtag)) (should (equal (get-text-property tag-location 'mastodon-tag rendered) "sampletag")) (should (equal (get-text-property tag-location 'help-echo rendered) "Browse tag #sampletag")))) (ert-deftest mastodon-tl--extract-hashtag-from-url-mastodon-link () "Should extract the hashtag from a tags url." (should (equal (mastodon-tl--extract-hashtag-from-url "https://example.org/tags/foo" "https://example.org") "foo"))) (ert-deftest mastodon-tl--extract-hashtag-from-url-other-link () "Should extract the hashtag from a tag url." (should (equal (mastodon-tl--extract-hashtag-from-url "https://example.org/tag/foo" "https://example.org") "foo"))) (ert-deftest mastodon-tl--extract-hashtag-from-url-wrong-instance () "Should not find a tag when the instance doesn't match." (should (null (mastodon-tl--extract-hashtag-from-url "https://example.org/tags/foo" "https://other.example.org")))) (ert-deftest mastodon-tl--extract-hashtag-from-url-not-tag () "Should not find a hashtag when not a tag url" (should (null (mastodon-tl--extract-hashtag-from-url "https://example.org/@userid" "https://example.org")))) (ert-deftest mastodon-tl--userhandles () "Should recognise userhandles in a toot and add the required properties to it." ;; Travis's Emacs doesn't have libxml so we fake things by inputting ;; propertized text and stubbing shr-render-region (let* ((fake-input-text (concat "mention: " (propertize "@foo" 'shr-url "https://bar.example/@foo" 'keymap shr-map 'help-echo "https://bar.example/@foo") " some text after")) (rendered (with-mock (stub shr-render-region => nil) (mastodon-tl--render-text fake-input-text mastodon-tl-test-base-toot))) (mention-location 11)) (should (eq (get-text-property mention-location 'mastodon-tab-stop rendered) 'user-handle)) (should (equal (get-text-property mention-location 'help-echo rendered) "Browse user profile of @foo@bar.example")))) (ert-deftest mastodon-tl--extract-userhandle-from-url-correct-case () "Should extract the user handle from url." (should (equal (mastodon-tl--extract-userhandle-from-url "https://example.org/@someuser" "@SomeUser") "@SomeUser@example.org"))) (ert-deftest mastodon-tl--extract-userhandle-from-url-missing-at-in-text () "Should not extract a user handle from url if the text is wrong." (should (null (mastodon-tl--extract-userhandle-from-url "https://example.org/@someuser" "SomeUser")))) (ert-deftest mastodon-tl--extract-userhandle-from-url-query-in-url () "Should not extract a user handle from url if there is a query param." (should (null (mastodon-tl--extract-userhandle-from-url "https://example.org/@someuser?shouldnot=behere" "SomeUser")))) (ert-deftest mastodon-tl--do-user-action-function-follow-notify-block-mute () "Should triage a follow request response buffer and return correct value for following, as well as notifications enabled or disabled." (let* ((user-handle "some-user@instance.url") (user-name "some-user") (user-id "123456789") (url-follow-only "https://instance.url/accounts/123456789/follow") (url-mute "https://instance.url/accounts/123456789/mute") (url-block "https://instance.url/accounts/123456789/block") (url-true "https://instance.url/accounts/123456789/follow?notify=true") (url-false "https://instance.url/accounts/123456789/follow?notify=false")) (with-temp-buffer (let ((response-buffer-true (current-buffer))) (insert mastodon-tl--follow-notify-true-response) (with-mock (mock (mastodon-http--post url-follow-only nil) => response-buffer-true) (should (equal (mastodon-tl--do-user-action-function url-follow-only user-name user-handle "follow") "User some-user (@some-user@instance.url) followed!"))))) (with-temp-buffer (let ((response-buffer-true (current-buffer))) (insert mastodon-tl--follow-notify-true-response) (with-mock (mock (mastodon-http--post url-mute nil) => response-buffer-true) (should (equal (mastodon-tl--do-user-action-function url-mute user-name user-handle "mute") "User some-user (@some-user@instance.url) muted!"))))) (with-temp-buffer (let ((response-buffer-true (current-buffer))) (insert mastodon-tl--follow-notify-true-response) (with-mock (mock (mastodon-http--post url-block nil) => response-buffer-true) (should (equal (mastodon-tl--do-user-action-function url-block user-name user-handle "block") "User some-user (@some-user@instance.url) blocked!"))))) (with-temp-buffer (let ((response-buffer-true (current-buffer))) (insert mastodon-tl--follow-notify-true-response) (with-mock (with-mock (mock (mastodon-http--post url-true nil) => response-buffer-true) (should (equal (mastodon-tl--do-user-action-function url-true user-name user-handle "follow" "true") "Receiving notifications for user some-user (@some-user@instance.url)!")))))) (with-temp-buffer (let ((response-buffer-false (current-buffer))) (insert mastodon-tl--follow-notify-false-response) (with-mock (mock (mastodon-http--post url-false nil) => response-buffer-false) (should (equal (mastodon-tl--do-user-action-function url-false user-name user-handle "follow" "false") "Not receiving notifications for user some-user (@some-user@instance.url)!"))))))) (ert-deftest mastodon-tl--report-to-mods-params-alist () "" (with-temp-buffer (let* ((toot mastodon-tl-test-base-toot) (account (alist-get 'account toot))) (with-mock ;; no longer needed after our refactor ;; (mock (mastodon-http--api "reports") => "https://instance.url/api/v1/reports") ;; (mock (mastodon-tl--toot-or-base ;; (mastodon-tl--property 'item-json :no-move)) ;; => mastodon-tl-test-base-toot) (mock (read-string "Add comment [optional]: ") => "Dummy complaint") (stub y-or-n-p => nil) ; no to all (should (equal (mastodon-tl--report-params account toot) '(("account_id" . 42) ("comment" . "Dummy complaint") ("category" . "other")))) (with-mock (stub y-or-n-p => t) ; yes to all (mock (mastodon-tl--read-rules-ids) => '(1 2 3)) (should (equal (mastodon-tl--report-params account toot) '(("rule_ids[]" . 3) ("rule_ids[]" . 2) ("rule_ids[]" . 1) ("account_id" . 42) ("comment" . "Dummy complaint") ("status_ids[]" . 61208) ("forward" . "true"))))))))) (ert-deftest mastodon-tl--report-build-params () "" (should (equal (mastodon-tl--report-build-params 42 "Dummy complaint" 61208 "true" nil '(1 2 3)) '(("rule_ids[]" . 3) ("rule_ids[]" . 2) ("rule_ids[]" . 1) ("account_id" . 42) ("comment" . "Dummy complaint") ("status_ids[]" . 61208) ("forward" . "true")))) (should (equal (mastodon-tl--report-build-params 42 "Dummy complaint" nil "true" nil nil) '(("account_id" . 42) ("comment" . "Dummy complaint") ("forward" . "true")))) (should (equal (mastodon-tl--report-build-params 42 "Dummy complaint" 61208 "true" "spam" nil) '(("account_id" . 42) ("comment" . "Dummy complaint") ("status_ids[]" . 61208) ("forward" . "true") ("category" . "spam")))) (should (equal (mastodon-tl--report-build-params 42 "Dummy complaint" 61208 "true" "other" nil) '(("account_id" . 42) ("comment" . "Dummy complaint") ("status_ids[]" . 61208) ("forward" . "true") ("category" . "other")))) (should (equal (mastodon-tl--report-build-params 42 "Dummy complaint" 61208 nil "spam" nil) '(("account_id" . 42) ("comment" . "Dummy complaint") ("status_ids[]" . 61208) ("category" . "spam"))))) (ert-deftest mastodon-tl--read-rules () "Should return a list of string numbers based on `mastodon-tl--test-instance-rules'" (let ((crm-separator "[ ]*,[ ]*")) (with-mock (stub mastodon-tl--instance-rules => mastodon-tl--test-instance-rules) (stub completing-read-multiple => '("We do not accept homophobia." "We do not accept harassment." "We also do not accept hate speech.")) (should (equal '("2" "5" "6") (mastodon-tl--read-rules-ids)))))) mastodon.el/test/mastodon-toot-tests.el000066400000000000000000000173221452000115200205440ustar00rootroot00000000000000;;; mastodon-toot-test.el --- Tests for mastodon-toot.el -*- lexical-binding: nil -*- (require 'el-mock) (require 'mastodon-http) (defconst mastodon-toot--200-html "HTTP/1.1 200 OK Date: Mon, 20 Dec 2021 13:42:29 GMT Content-Type: application/json; charset=utf-8 Transfer-Encoding: chunked") (defconst mastodon-toot-test-base-toot '((id . 61208) (created_at . "2017-04-24T19:01:02.000Z") (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") (acct . "acct42@example.space") (display_name . "Account 42") (locked . :json-false) (created_at . "2017-04-01T00:00:00.000Z") (followers_count . 99) (following_count . 13) (statuses_count . 101) (note . "E")) (media_attachments . []) (mentions . []) (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (content . "

Just some text

") (reblogs_count . 0) (favourites_count . 0) (reblog)) "A sample toot (parsed json)") (defconst mastodon-toot--mock-toot (propertize "here is a mock toot text." 'item-json mastodon-toot-test-base-toot)) (defconst mastodon-toot--multi-mention '((mentions . [((id . "1") (username . "federated") (url . "https://site.cafe/@federated") (acct . "federated@federated.cafe")) ((id . "1") (username . "federated") (url . "https://site.cafe/@federated") (acct . "federated@federated.social")) ((id . "1") (username . "local") (url . "") (acct . "local"))]))) (defconst mastodon-toot-no-mention '((mentions . []))) (defconst mastodon-toot--multi-mention-extracted '("local" "federated@federated.social" "federated@federated.cafe")) (ert-deftest mastodon-toot--multi-mentions () "Should build a correct mention string from the test toot data. Even the local name \"local\" gets a domain name added." (let ((mastodon-auth--acct-alist '(("https://local.social". "null"))) (mastodon-instance-url "https://local.social")) (should (equal (mastodon-toot--mentions mastodon-toot--multi-mention) '("local" "federated@federated.social" "federated@federated.cafe"))))) (ert-deftest mastodon-toot--multi-mentions-to-string () "Should build a correct mention string from the test toot data. Even the local name \"local\" gets a domain name added." (let ((mastodon-auth--acct-alist '(("https://local.social". "null"))) (mastodon-instance-url "https://local.social")) (should (string= (mastodon-toot--mentions-to-string mastodon-toot--multi-mention-extracted) "@local@local.social @federated@federated.social @federated@federated.cafe")))) (ert-deftest mastodon-toot--multi-mentions-with-name-to-string () "Should build a correct mention string omitting self. Here \"local\" is the user themselves and gets omitted from the mention string." (let ((mastodon-auth--acct-alist '(("https://local.social". "local"))) (mastodon-instance-url "https://local.social")) (should (string= (mastodon-toot--mentions-to-string mastodon-toot--multi-mention-extracted) "@federated@federated.social @federated@federated.cafe")))) (ert-deftest mastodon-toot--no-mention-to-string () "Should return and empty string." (let ((mastodon-auth--acct-alist '(("https://local.social". "local"))) (mastodon-instance-url "https://local.social")) (should (string= (mastodon-toot--mentions-to-string nil) "")))) (ert-deftest mastodon-toot--no-mention () "Should construct an empty mention list without mentions." (let ((mastodon-auth--acct-alist '(("https://local.social". "null"))) (mastodon-instance-url "https://local.social")) (should (equal (mastodon-toot--mentions mastodon-toot-no-mention) nil)))) ;; TODO: test y-or-no-p with mastodon-toot--cancel (ert-deftest mastodon-toot--kill () "Should kill the buffer when cancelling the toot." (let ((mastodon-toot-previous-window-config (list (current-window-configuration) (point-marker)))) (with-mock (mock (kill-buffer-and-window)) (mastodon-toot--kill) (mock-verify)))) (ert-deftest mastodon-toot--own-toot-p-fail () "Should not return t if not own toot." (let ((toot mastodon-toot-test-base-toot)) (with-mock (mock (mastodon-auth--user-acct) => "joebogus@bogus.space") (should (not (equal (mastodon-toot--own-toot-p toot) t)))))) (ert-deftest mastodon-toot--own-toot-p () "Should return 't' if own toot." (let ((toot mastodon-toot-test-base-toot)) (with-mock (mock (mastodon-auth--user-acct) => "acct42@example.space") (should (equal (mastodon-toot--own-toot-p toot) t))))) (ert-deftest mastodon-toot--delete-toot-fail () "Should refuse to delete toot." (let ((toot mastodon-toot-test-base-toot)) (with-mock (mock (mastodon-auth--user-acct) => "joebogus") ;; (mock (mastodon-toot--own-toot-p toot) => nil) (mock (mastodon-tl--property 'item-json) => mastodon-toot-test-base-toot) (mock (mastodon-tl--property 'base-toot) => toot) (should (equal (mastodon-toot--delete-toot) "You can only delete (and redraft) your own toots."))))) (ert-deftest mastodon-toot--delete-toot () "Should return correct triaged response to a legitimate DELETE request." (with-temp-buffer (insert mastodon-toot--200-html) (let ((delete-response (current-buffer)) (toot mastodon-toot-test-base-toot)) (with-mock (mock (mastodon-tl--property 'item-json) => toot) (mock (mastodon-tl--property 'base-toot) => toot) ;; (mock (mastodon-toot--own-toot-p toot) => t) (mock (mastodon-auth--user-acct) => "acct42@example.space") (mock (mastodon-http--api (format "statuses/61208")) => "https://example.space/statuses/61208") (mock (y-or-n-p "Delete this toot? ") => t) (mock (mastodon-http--delete "https://example.space/statuses/61208") => delete-response) (should (equal (mastodon-toot--delete-toot) "Toot deleted!")))))) (ert-deftest mastodon-toot-action-pin () "Should return callback provided by `mastodon-toot--pin-toot-toggle'." (with-temp-buffer (insert mastodon-toot--200-html) (let ((pin-response (current-buffer)) (toot mastodon-toot-test-base-toot) (id 61208)) (with-mock (mock (mastodon-tl--property 'base-item-id) => id) (mock (mastodon-http--api "statuses/61208/pin") => "https://example.space/statuses/61208/pin") (mock (mastodon-http--post "https://example.space/statuses/61208/pin") => pin-response) (should (equal (mastodon-toot--action "pin" (lambda (_) (message "Toot pinned!"))) "Toot pinned!")))))) (ert-deftest mastodon-toot--pin-toot-fail () (with-temp-buffer (insert mastodon-toot--200-html) (let ((pin-response (current-buffer)) (toot mastodon-toot-test-base-toot)) (with-mock (mock (mastodon-tl--property 'item-json) => toot) (mock (mastodon-tl--property 'base-toot) => toot) (mock (mastodon-auth--user-acct) => "joebogus@example.space") (should (equal (mastodon-toot--pin-toot-toggle) "You can only pin your own toots."))))))