diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 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 Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are 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. + + 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. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + 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 Affero 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. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + 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 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 work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero 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 Affero 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 Affero 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 Affero 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 Affero 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + 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 AGPL, see +. diff --git a/README.rst b/README.rst new file mode 100644 --- /dev/null +++ b/README.rst @@ -0,0 +1,1 @@ +Email handling library. Groks RFC 5322 and MIME. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/purebred-email.cabal b/purebred-email.cabal new file mode 100644 --- /dev/null +++ b/purebred-email.cabal @@ -0,0 +1,126 @@ +-- Initial purebred-email.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: purebred-email +version: 0.1.0.0 +synopsis: types and parser for email messages (including MIME) +description: + The purebred email library. RFC 5322, MIME, etc. + . + Things that are currently implemented: + . + - RFC 5322 message parsing and serialisation + - MIME multipart parsing (RFC 2046) + - MIME message header extensions for non-ASCII text (RFC 2047) + - MIME parameter value and encoded word extensions (RFC 2231) + - Content-Disposition header field (RFC 2183) + . + Things that are not yet implemented / need improvement: + . + - Support for more charsets + - Improve handling of dates + - Sensible heuristics for choosing a content transfer encoding + - Probably lots of other things + +license: AGPL-3 +license-file: LICENSE +author: Fraser Tweedale +maintainer: frase@frase.id.au +copyright: Copyright 2017-2018 Fraser Tweedale +category: Data, Email +build-type: Simple +extra-source-files: + README.rst + test-vectors/*.eml + tests/golden/*.golden +cabal-version: >=1.10 +tested-with: + GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3 + +homepage: https://github.com/purebred-mua/purebred-email +bug-reports: https://github.com/purebred-mua/purebred-email/issues +source-repository head + type: git + location: https://github.com/purebred-mua/purebred-email.git + +flag demos + description: Build demonstration programs + default: False + +library + exposed-modules: + Data.RFC5322 + , Data.RFC5322.Address.Text + , Data.RFC5322.Address.Types + , Data.MIME + , Data.MIME.Error + , Data.MIME.Charset + , Data.MIME.EncodedWord + , Data.MIME.Types + , Data.MIME.Parameter + , Data.MIME.TransferEncoding + , Data.MIME.Base64 + , Data.MIME.QuotedPrintable + other-modules: + Data.RFC5322.Internal + , Data.MIME.Internal + -- other-extensions: + build-depends: + base >= 4.8 && < 5 + , attoparsec >= 0.13 && < 0.14 + , base64-bytestring >= 1 && < 2 + , bytestring >= 0.10 && < 0.11 + , case-insensitive >= 1.2 && < 1.3 + , concise >= 0.1.0.1 && < 1 + , deepseq >= 1.4.2 + , lens >= 4 && < 5 + , semigroupoids >= 5 && < 6 + , semigroups >= 0.16 && < 0.19 + , stringsearch >= 0.3 + , text >= 1.2 + , time + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -Wredundant-constraints + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: Test.hs + other-modules: + ContentTransferEncodings + , Headers + , MIME + , Generator + build-depends: + base + , bytestring + , lens + , text + , purebred-email + + , tasty + , tasty-quickcheck + , tasty-hunit + , tasty-golden + , attoparsec + , QuickCheck + , quickcheck-instances + , case-insensitive >= 1.2 && < 1.3 + , semigroups >= 0.16 + , time + +executable purebred-email-parse + if !flag(demos) + buildable: False + default-language: Haskell2010 + hs-source-dirs: tools + ghc-options: -Wall + main-is: Parse.hs + build-depends: + base + , attoparsec + , bytestring + , semigroups >= 0.16 + , purebred-email diff --git a/src/Data/MIME.hs b/src/Data/MIME.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME.hs @@ -0,0 +1,758 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- | + +MIME messages (RFC 2045, RFC 2046 and friends). + +-} +module Data.MIME + ( + -- * Overview + -- $overview + + -- * Examples / HOWTO + -- $examples + + -- * API + + -- ** MIME data type + MIME(..) + , mime + , MIMEMessage + + , WireEntity + , ByteEntity + , TextEntity + , EncStateWire + , EncStateByte + + -- *** Accessing and processing entities + , entities + , attachments + , isAttachment + , transferDecoded + , charsetDecoded + + -- ** Header processing + , decodeEncodedWords + + -- ** Content-Type header + , contentType + , ContentType(..) + , ctType + , ctSubtype + , matchContentType + , ctEq + , parseContentType + , showContentType + , mimeBoundary + + -- *** Content-Type values + , contentTypeTextPlain + , contentTypeApplicationOctetStream + , contentTypeMultipartMixed + , defaultContentType + + -- ** Content-Disposition header + , contentDisposition + , ContentDisposition(..) + , DispositionType(..) + , dispositionType + , filename + , filenameParameter + + -- ** Serialisation + , renderMessage + , buildMessage + + -- ** Mail creation + , headerFrom + , headerTo + , headerCC + , headerBCC + , headerDate + , replyHeaderReferences + , createAttachmentFromFile + , createAttachment + , createTextPlainMessage + , createMultipartMixedMessage + + -- * Re-exports + , module Data.RFC5322 + , module Data.MIME.Parameter + , module Data.MIME.Error + ) where + +import Control.Applicative +import Control.Monad (void) +import Data.Maybe (fromMaybe, catMaybes) +import Data.Semigroup ((<>)) +import GHC.Generics (Generic) + +import Control.DeepSeq (NFData) +import Control.Lens +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 (char8) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Builder as Builder +import Data.ByteString.Lazy (toStrict) +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, parseTimeOrError) + +import Data.RFC5322 +import Data.RFC5322.Internal +import Data.MIME.Error +import Data.MIME.Charset +import Data.MIME.EncodedWord +import Data.MIME.Parameter +import Data.MIME.TransferEncoding +import Data.MIME.Types (Encoding(..)) + +{- $overview + +This module extends 'Data.RFC5322' with types for handling MIME +messages. It provides the 'mime' parsing helper function for +use with 'message'. + +@ +'mime' :: Headers -> Parser MIME +message mime :: Parser (Message ctx MIME) +@ + +The 'Message' data type has a phantom type parameter for context. +In this module we use it to track whether the body has +/content transfer encoding/ or /charset encoding/ applied. Type +aliases are provided for convenince. + +@ +data 'Message' ctx a = Message Headers a +data 'EncStateWire' +data 'EncStateByte' + +type 'MIMEMessage' = Message EncStateWire MIME +type 'WireEntity' = Message EncStateWire B.ByteString +type 'ByteEntity' = Message EncStateByte B.ByteString +type 'TextEntity' = Message () T.Text +@ + +Folds are provided over all leaf /entities/, and entities that are +identified as attachments: + +@ +'entities' :: Fold MIMEMessage WireEntity +'attachments' :: Fold MIMEMessage WireEntity +@ + +Content transfer decoding is performed using the 'transferDecoded' +optic. This will convert /Quoted-Printable/ or /Base64/ encoded +entities into their decoded form. + +@ +'transferDecoded' :: Getter WireEntity (Either 'TransferEncodingError' ByteEntity) +transferDecoded :: Getter WireEntity (Either 'EncodingError' ByteEntity) +transferDecoded :: (HasTransferEncoding a, AsTransferEncodingError e) => Getter a (Either e (TransferDecoded a)) +@ + +Charset decoding is performed using the 'charsetDecoded' optic: + +@ +'charsetDecoded' :: Getter ByteEntity (Either 'CharsetError' TextEntity) +charsetDecoded :: Getter ByteEntity (Either 'EncodingError' TextEntity) +charsetDecoded :: (HasCharset a, AsCharsetError e) => Getter a (Either e (Decoded a)) +@ + +-} + +{- $examples + +__Parse__ a MIME message: + +@ +'parse' (message mime) :: ByteString -> Either String MIMEMessage +@ + +Find the first entity with the @text/plain@ __content type__: + +@ +getTextPlain :: 'MIMEMessage' -> Maybe 'WireEntity' +getTextPlain = firstOf ('entities' . filtered f) + where + f = 'matchContentType' "text" (Just "plain") . view ('headers' . 'contentType') +@ + +Perform __content transfer decoding__ /and/ __charset__ decoding +while preserving decode errors: + +@ +view 'transferDecoded' >=> view 'charsetDecoded' :: WireEntity -> Either EncodingError TextEntity +@ + +Get all __attachments__ (transfer decoded) and their __filenames__ (if specified): + +@ +getAttachments :: 'MIMEMessage' -> [(Either 'TransferEncodingError' B.ByteString, Maybe T.Text)] +getAttachments = toListOf ('attachments' . to (liftA2 (,) content name) + where + content = view 'transferDecodedBytes' + name = preview ('headers' . 'contentDisposition' . 'filename') +@ + +Create an inline, plain text message and render it: + +@ +renderMessage $ createTextPlainMessage "This is a test body" +@ +-} + + +-- | Entity is formatted for transfer. Processing requires +-- transfer decoding. +-- +data EncStateWire + +-- | Entity requires content-transfer-encoding to send, +-- and may require charset decoding to read. +-- +data EncStateByte + +type MIMEMessage = Message EncStateWire MIME +type WireEntity = Message EncStateWire B.ByteString +type ByteEntity = Message EncStateByte B.ByteString +type TextEntity = Message () T.Text + +-- | MIME message body. Either a single @Part@, or @Multipart@. +-- Only the body is represented; preamble and epilogue are not. +-- +data MIME + = Part B.ByteString + | Multipart [MIMEMessage] + deriving (Eq, Show) + +-- | Get all leaf entities from the MIME message +-- +entities :: Traversal' MIMEMessage WireEntity +entities f (Message h a) = case a of + Part b -> + (\(Message h' b') -> Message h' (Part b')) <$> f (Message h b) + Multipart bs -> + Message h . Multipart <$> sequenceA (entities f <$> bs) + +-- | Leaf entities with @Content-Disposition: attachment@ +attachments :: Traversal' MIMEMessage WireEntity +attachments = entities . filtered (notNullOf l) where + l = headers . contentDisposition . dispositionType . filtered (== Attachment) + +-- | MIMEMessage content disposition is an 'Attachment' +isAttachment :: MIMEMessage -> Bool +isAttachment = has (headers . contentDisposition . dispositionType . filtered (== Attachment)) + +contentTransferEncoding :: Getter Headers TransferEncodingName +contentTransferEncoding = to $ + fromMaybe "7bit" + . preview (header "content-transfer-encoding" . caseInsensitive) + +instance HasTransferEncoding WireEntity where + type TransferDecoded WireEntity = ByteEntity + transferEncodingName = headers . contentTransferEncoding + transferEncodedData = body + transferDecoded = to $ \a -> (\t -> set body t a) <$> view transferDecodedBytes a + +printContentTransferEncoding :: Encoding -> B.ByteString +printContentTransferEncoding Base64 = "base64" +printContentTransferEncoding None = "7bit" + +caseInsensitive :: CI.FoldCase s => Iso' s (CI s) +caseInsensitive = iso CI.mk CI.original +{-# INLINE caseInsensitive #-} + + +-- | Content-Type header (RFC 2183). +-- Use 'parameters' to access the parameters. +-- Example: +-- +-- @ +-- ContentType "text" "plain" [("charset", "utf-8")] +-- @ +-- +data ContentType = ContentType (CI B.ByteString) (CI B.ByteString) Parameters + deriving (Show, Generic, NFData) + +-- | Equality of Content-Type. Type and subtype are compared +-- case-insensitively and parameters are also compared. Use +-- 'matchContentType' if you just want to match on the media type +-- while ignoring parameters. +-- +instance Eq ContentType where + ContentType a b c == ContentType a' b' c' = a == a' && b == b' && c == c' + +-- | Match content type. If @Nothing@ is given for subtype, any +-- subtype is accepted. +-- +matchContentType + :: CI B.ByteString -- ^ type + -> Maybe (CI B.ByteString) -- ^ optional subtype + -> ContentType + -> Bool +matchContentType wantType wantSubtype (ContentType gotType gotSubtype _) = + wantType == gotType && maybe True (== gotSubtype) wantSubtype + +printContentType :: ContentType -> B.ByteString +printContentType (ContentType typ sub params) = + CI.original typ <> "/" <> CI.original sub <> printParameters params + +printParameters :: Parameters -> B.ByteString +printParameters (Parameters xs) = + foldMap (\(k,v) -> "; " <> CI.original k <> "=" <> v) xs + +-- | Are the type and subtype the same? (parameters are ignored) +-- +ctEq :: ContentType -> ContentType -> Bool +ctEq (ContentType typ1 sub1 _) = matchContentType typ1 (Just sub1) +{-# DEPRECATED ctEq "Use 'matchContentType' instead" #-} + +ctType :: Lens' ContentType (CI B.ByteString) +ctType f (ContentType a b c) = fmap (\a' -> ContentType a' b c) (f a) + +ctSubtype :: Lens' ContentType (CI B.ByteString) +ctSubtype f (ContentType a b c) = fmap (\b' -> ContentType a b' c) (f b) + +ctParameters :: Lens' ContentType Parameters +ctParameters f (ContentType a b c) = fmap (\c' -> ContentType a b c') (f c) +{-# ANN ctParameters ("HLint: ignore Avoid lambda" :: String) #-} + +-- | Rendered content type field value for displaying +showContentType :: ContentType -> T.Text +showContentType = decodeLenient . printContentType + +instance HasParameters ContentType where + parameters = ctParameters + +-- | Parser for Content-Type header +parseContentType :: Parser ContentType +parseContentType = do + typ <- ci token + _ <- char8 '/' + subtype <- ci token + params <- parseParameters + if typ == "multipart" && "boundary" `notElem` fmap fst params + then + -- https://tools.ietf.org/html/rfc2046#section-5.1.1 + fail "\"boundary\" parameter is required for multipart content type" + else pure $ ContentType typ subtype (Parameters params) + +parseParameters :: Parser [(CI B.ByteString, B.ByteString)] +parseParameters = many (char8 ';' *> skipWhile (== 32 {-SP-}) *> param) + where + param = (,) <$> ci token <* char8 '=' <*> val + val = token <|> quotedString + +-- | header token parser +token :: Parser B.ByteString +token = + takeWhile1 (\c -> c >= 33 && c <= 126 && notInClass "()<>@,;:\\\"/[]?=" c) + +-- | RFC 2046 §4.1.2. defines the default character set to be US-ASCII. +-- +instance HasCharset ByteEntity where + type Decoded ByteEntity = TextEntity + charsetName = to $ \ent -> + let + (ContentType typ sub params) = view (headers . contentType) ent + source = fromMaybe (InParameter (Just "us-ascii")) . (`lookup` textCharsetSources) + l = rawParameter "charset" . caseInsensitive + in + if typ == "text" + then case source sub of + InBand f -> f (view body ent) + InParameter def -> preview l params <|> def + InBandOrParameter f def -> f (view body ent) <|> preview l params <|> def + else + preview l params <|> Just "us-ascii" + charsetData = body -- XXX: do we need to drop the BOM / encoding decl? + charsetDecoded = to $ \a -> (\t -> set body t a) <$> view charsetText a + + -- | Encode (@utf-8@) and add/set charset parameter. If consisting + -- entirely of ASCII characters, the @charset@ parameter gets set to + -- @us-ascii@ instead of @utf-8@. + -- + -- Ignores Content-Type (which is not correct for all content types). + -- + charsetEncode (Message h a) = + let + b = T.encodeUtf8 a + charset = if B.all (< 0x80) b then "us-ascii" else "utf-8" + in Message (set (contentType . rawParameter "charset") charset h) b + +-- | RFC 6657 provides for different media types having different +-- ways to determine the charset. This data type defines how a +-- charset should be determined for some media type. +-- +data EntityCharsetSource + = InBand (B.ByteString -> Maybe CharsetName) + -- ^ Charset should be declared within payload (e.g. xml, rtf). + -- The given function reads it from the payload. + | InParameter (Maybe CharsetName) + -- ^ Charset should be declared in the 'charset' parameter, + -- with optional fallback to the given default. + | InBandOrParameter (B.ByteString -> Maybe CharsetName) (Maybe CharsetName) + -- ^ Check in-band first, fall back to 'charset' parameter, + -- and further optionally fall back to a default. + +-- | Charset sources for text/* media types. IANA registry: +-- https://www.iana.org/assignments/media-types/media-types.xhtml#text +-- +textCharsetSources :: [(CI B.ByteString, EntityCharsetSource)] +textCharsetSources = + [ ("plain", InParameter (Just "us-ascii")) + , ("csv", InParameter (Just "utf-8")) + , ("rtf", InBand (const (Just "us-ascii" {- TODO -}))) + + -- https://tools.ietf.org/html/rfc2854 + -- The default is ambiguous; using us-ascii for now + , ("html", InBandOrParameter (const Nothing {-TODO-}) (Just "us-ascii")) + + -- https://tools.ietf.org/html/rfc7763 + , ("markdown", InParameter Nothing) + + -- https://tools.ietf.org/html/rfc7303#section-3.2 and + -- https://www.w3.org/TR/2008/REC-xml-20081126/#charencoding + , ("xml", InBand (const (Just "utf-8") {-TODO-})) + ] + +-- | @text/plain; charset=us-ascii@ +defaultContentType :: ContentType +defaultContentType = + over parameterList (("charset", "us-ascii"):) contentTypeTextPlain + +-- | @text/plain@ +contentTypeTextPlain :: ContentType +contentTypeTextPlain = ContentType "text" "plain" (Parameters []) + +-- | @application/octet-stream@ +contentTypeApplicationOctetStream :: ContentType +contentTypeApplicationOctetStream = + ContentType "application" "octet-stream" (Parameters []) + +-- | @multipart/mixed; boundary=asdf@ +contentTypeMultipartMixed :: B.ByteString -> ContentType +contentTypeMultipartMixed boundary = + over parameterList (("boundary", boundary):) + $ ContentType "multipart" "mixed" (Parameters []) + +-- | Lens to the content-type header. Probably not a lawful lens. +-- +-- If the header is not specified or is syntactically invalid, +-- 'defaultContentType' is used. For more info see +-- . +-- +-- If the Content-Transfer-Encoding is unrecognised, the +-- actual Content-Type value is ignored and +-- @application/octet-stream@ is returned, as required by +-- . +-- +-- When setting, if the header already exists it is replaced, +-- otherwise it is added. Unrecognised Content-Transfer-Encoding +-- is ignored when setting. +-- +contentType :: Lens' Headers ContentType +contentType = lens sa sbt where + sa s = case view cte s of + Nothing -> contentTypeApplicationOctetStream + Just _ -> + fromMaybe defaultContentType $ preview (ct . parsed parseContentType) s + + sbt s b = set (at "Content-Type") (Just (printContentType b)) s + + ct = header "content-type" + cte = contentTransferEncoding . to (`lookup` transferEncodings) + +-- | Content-Disposition header (RFC 2183). +-- +-- Use 'parameters' to access the parameters. +-- +data ContentDisposition = ContentDisposition + DispositionType -- disposition + Parameters -- parameters + deriving (Show, Generic, NFData) + +data DispositionType = Inline | Attachment + deriving (Eq, Show, Generic, NFData) + +dispositionType :: Lens' ContentDisposition DispositionType +dispositionType f (ContentDisposition a b) = + fmap (\a' -> ContentDisposition a' b) (f a) +{-# ANN dispositionType ("HLint: ignore Avoid lambda" :: String) #-} + +dispositionParameters :: Lens' ContentDisposition Parameters +dispositionParameters f (ContentDisposition a b) = + fmap (\b' -> ContentDisposition a b') (f b) +{-# ANN dispositionParameters ("HLint: ignore Avoid lambda" :: String) #-} + +instance HasParameters ContentDisposition where + parameters = dispositionParameters + +-- | Parser for Content-Disposition header +-- +-- Unrecognised disposition types are coerced to @Attachment@ +-- in accordance with RFC 2183 §2.8 which states: /Unrecognized disposition +-- types should be treated as /attachment//. +parseContentDisposition :: Parser ContentDisposition +parseContentDisposition = ContentDisposition + <$> (mapDispType <$> ci token) + <*> (Parameters <$> parseParameters) + where + mapDispType s + | s == "inline" = Inline + | otherwise = Attachment + +printContentDisposition :: ContentDisposition -> B.ByteString +printContentDisposition (ContentDisposition typ params) = + typStr <> printParameters params + where + typStr = case typ of Inline -> "inline" ; Attachment -> "attachment" + +-- | Get Content-Disposition header. +-- Unrecognised disposition types are coerced to @Attachment@ +-- in accordance with RFC 2183 §2.8 which states: +-- /Unrecognized disposition types should be treated as/ attachment. +-- +-- The fold may be empty, e.g. if the header is absent or unparseable. +-- +contentDisposition :: Traversal' Headers ContentDisposition +contentDisposition = + header "content-disposition" + . parsePrint parseContentDisposition printContentDisposition + +-- | Traverse the value of the filename parameter (if present). +-- +filename :: HasParameters a => Traversal' a T.Text +filename = filenameParameter . traversed . charsetPrism . value + +-- | Access the filename parameter as a @Maybe ('ParameterValue' B.ByteString)@. +-- +-- This can be used to read or set the filename parameter (see also +-- the 'newParameter' convenience function): +-- +-- @ +-- λ> let hdrs = Headers [("Content-Disposition", "attachment")] +-- λ> set ('contentDisposition' . 'filenameParameter') (Just ('newParameter' "foo.txt")) hdrs +-- Headers [("Content-Disposition","attachment; filename=foo.txt")] +-- @ +filenameParameter :: HasParameters a => Lens' a (Maybe EncodedParameterValue) +filenameParameter = parameter "filename" + + +-- | Get the boundary, if specified +mimeBoundary :: Traversal' ContentType B.ByteString +mimeBoundary = parameters . rawParameter "boundary" + +-- | Top-level MIME body parser that uses headers to decide how to +-- parse the body. +-- +-- __Do not use this parser for parsing a nested message.__ +-- This parser should only be used when the message you want to +-- parse is the /whole input/. If you use it to parse a nested +-- message it will treat the remainder of the outer message(s) +-- as part of the epilogue. +-- +-- Preambles and epilogues are discarded. +-- +-- This parser accepts non-MIME messages, and unconditionally +-- treats them as a single part. +-- +mime :: Headers -> Parser MIME +mime h + | nullOf (header "MIME-Version") h = Part <$> takeByteString + | otherwise = mime' takeByteString h + +mime' + :: Parser B.ByteString + -- ^ Parser FOR A TAKE to the part delimiter. If this part is + -- multipart, we pass it on to the 'multipart' parser. If this + -- part is not multipart, we just do the take. + -> Headers + -> Parser MIME +mime' takeTillEnd h = case view contentType h of + ct | view ctType ct == "multipart" -> + case preview (rawParameter "boundary") ct of + Nothing -> part + Just boundary -> Multipart <$> multipart takeTillEnd boundary + _ -> part + where + part = Part <$> takeTillEnd + +-- | Parse a multipart MIME message. Preambles and epilogues are +-- discarded. +-- +multipart + :: Parser B.ByteString -- ^ parser to the end of the part + -> B.ByteString -- ^ boundary, sans leading "--" + -> Parser [MIMEMessage] +multipart takeTillEnd boundary = + multipartBody + where + delimiter = "\n--" <> boundary + dashBoundary = B.tail delimiter + part = message (mime' (trim <$> takeTillString delimiter)) + trim s -- trim trailing CR, because we only searched for LF + | B.null s = s + | C8.last s == '\r' = B.init s + | otherwise = s + + multipartBody = + skipTillString dashBoundary *> crlf -- FIXME transport-padding + *> part `sepBy` crlf + <* string "--" <* crlf <* void takeTillEnd + +-- | Serialise a given `MIMEMessage` into a ByteString. The message is +-- serialised as is. No additional headers are set. +renderMessage :: MIMEMessage -> B.ByteString +renderMessage = toStrict . Builder.toLazyByteString . buildMessage + +-- | Serialise a given `MIMEMessage` using a `Builder` +buildMessage :: MIMEMessage -> Builder.Builder +buildMessage (Message h (Part partbody)) = + buildFields h <> "\r\n" <> Builder.byteString partbody +buildMessage (Message h (Multipart xs)) = + let b = firstOf (contentType . mimeBoundary) h + boundary = maybe mempty (\b' -> "\r\n--" <> Builder.byteString b') b + ents = foldMap (\part -> boundary <> "\r\n" <> buildMessage part) xs + in buildFields h <> ents <> boundary <> "--\r\n" + + +mimeHeader :: (CI B.ByteString, B.ByteString) +mimeHeader = (CI.mk "MIME-Version", "1.0") + +-- | creates a new `MIMEMessage` and transfer encodes the given content with the +-- given Encoding +createMessage + :: ContentType + -> ContentDisposition + -> Encoding + -> B.ByteString -- ^ content + -> MIMEMessage +createMessage ct cd encoding content = + let m = Message (Headers [mimeHeader]) (Part $ transferEncodeData encoding content) + in m + & set (headers . at "Content-Type") (Just (printContentType ct)) + . set (headers . at "Content-Disposition") (Just (printContentDisposition cd)) + . set (headers . at "Content-Transfer-Encoding") (Just (printContentTransferEncoding encoding)) + +headerFrom :: Lens' Headers [Mailbox] +headerFrom = lens getter setter + where + getter = either (pure []) id . parseOnly mailboxList . view (header "from") + setter = flip $ set (header "from") . renderMailboxes + +headerTo :: Lens' Headers [Address] +headerTo = lens (headerGetter "to") (headerSetter "to") + +headerCC :: Lens' Headers [Address] +headerCC = lens (headerGetter "cc") (headerSetter "cc") + +headerBCC :: Lens' Headers [Address] +headerBCC = lens (headerGetter "bcc") (headerSetter "bcc") + +headerSetter :: CI B.ByteString -> Headers -> [Address] -> Headers +headerSetter fieldname = flip $ set (header fieldname) . renderAddresses + +headerGetter :: CI C8.ByteString -> Headers -> [Address] +headerGetter fieldname = + either (pure []) id . parseOnly addressList . view (header fieldname) + +headerDate :: Lens' Headers UTCTime +headerDate = lens getter setter + where + -- TODO for parseTimeOrError. See #16 + getter = + parseTimeOrError True defaultTimeLocale rfc5422DateTimeFormat + . C8.unpack . view (header "date") + setter hdrs x = set (header "date") (renderRFC5422Date x) hdrs + +-- | Returns a space delimited `B.ByteString` with values from identification +-- fields from the parents message `Headers`. Rules to gather the values are in +-- accordance to RFC5322 - 3.6.4 as follows sorted by priority (first has +-- precedence): +-- * Values from 'References' and `Message-ID` (if any) +-- * Values from 'In-Reply-To' and 'Message-ID' (if any) +-- * Value from 'Message-ID' (in case it's the first reply to a parent mail) +-- * otherwise Nothing is returned indicating that the replying mail should not have a 'References' field. +-- +replyHeaderReferences :: Getter Headers (Maybe C8.ByteString) +replyHeaderReferences = to $ \hdrs -> + let xs = catMaybes + [preview (header "references") hdrs + <|> preview (header "in-reply-to") hdrs + , preview (header "message-id") hdrs + ] + in if null xs then Nothing else Just (B.intercalate " " xs) + +-- | Create a mixed `MIMEMessage` with an inline text/plain part and multiple +-- `attachments` +-- +-- Additional headers can be set (e.g. 'cc') by using `At` and `Ixed`, for +-- example: +-- +-- @ +-- λ> set (at "subject") (Just "Hey there") $ Headers [] +-- Headers [("subject", "Hey there")] +-- @ +-- +-- You can also use the `Mailbox` instances: +-- +-- @ +-- λ> let address = Mailbox (Just "roman") (AddrSpec "roman" (DomainLiteral "192.168.1.1")) +-- λ> set (at "cc") (Just $ renderMailbox address) $ Headers [] +-- Headers [("cc", "\\"roman\\" ")] +-- @ +createMultipartMixedMessage + :: B.ByteString -- ^ Boundary + -> [MIMEMessage] -- ^ attachments + -> MIMEMessage +createMultipartMixedMessage b attachments' = + let hdrs = + set + (at "Content-Type") + (Just $ printContentType (contentTypeMultipartMixed b)) $ + Headers [mimeHeader] + in Message hdrs (Multipart attachments') + +-- | Create an inline, text/plain, utf-8 encoded message +-- +createTextPlainMessage + :: T.Text -- ^ message body + -> MIMEMessage +createTextPlainMessage = + createMessage + contentTypeTextPlain + (ContentDisposition Inline $ Parameters [(CI.mk "charset", "utf-8")]) + None + . T.encodeUtf8 + +-- | Create an attachment from a given file path. +-- Note: The filename content disposition is set to the given `FilePath`. For +-- privacy reasons, you can unset/change it. See `filename` for examples. +-- +createAttachmentFromFile :: ContentType -> FilePath -> IO MIMEMessage +createAttachmentFromFile ct fp = createAttachment ct (Just fp) <$> B.readFile fp + +-- | Create an attachment from the given file contents. Optionally set the given +-- filename parameter to the given file path. +-- +createAttachment :: ContentType -> Maybe FilePath -> B.ByteString -> MIMEMessage +createAttachment ct fp = + set + (headers . contentDisposition . filenameParameter) + (newParameter . T.pack <$> fp) . + createMessage ct (ContentDisposition Attachment $ Parameters []) Base64 diff --git a/src/Data/MIME/Base64.hs b/src/Data/MIME/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/Base64.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | + +Implementation of Base64 Content-Transfer-Encoding. + + + +-} +module Data.MIME.Base64 + ( + contentTransferEncodeBase64 + , contentTransferEncodingBase64 + ) where + +import Control.Lens (prism') +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import Data.Word (Word8) + +import Data.MIME.Types (ContentTransferEncoding) + + + +isBase64Char :: Word8 -> Bool +isBase64Char c = + (c >= 0x41 && c <= 0x5a) -- A-Z + || (c >= 0x61 && c <= 0x7a) -- a-z + || (c >= 0x30 && c <= 0x39) -- 0-9 + || c == 43 -- + + || c == 47 -- / + || c == 61 -- = + +{- + +Notes about encoding requirements: + +- The encoded output stream must be represented in lines of no more + than 76 characters each. + +-} +contentTransferEncodeBase64 :: B.ByteString -> B.ByteString +contentTransferEncodeBase64 = B64.joinWith "\r\n" 76 . B64.encode + +{- + +Notes about decoding requirements: + +- All line breaks or other characters not found in Table 1 must be + ignored by decoding software. + +- In base64 data, characters other than those in Table 1, line breaks, + and other white space probably indicate a transmission error, about + which a warning message or even a message rejection might be + appropriate under some circumstances. + +-} +contentTransferDecodeBase64 :: B.ByteString -> Either String B.ByteString +contentTransferDecodeBase64 = B64.decode . B.filter isBase64Char + +contentTransferEncodingBase64 :: ContentTransferEncoding +contentTransferEncodingBase64 = prism' + contentTransferEncodeBase64 + (either (const Nothing) Just . contentTransferDecodeBase64) diff --git a/src/Data/MIME/Charset.hs b/src/Data/MIME/Charset.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/Charset.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + +MIME character sets. + +Recognised charsets: + +* @us-ascii@ / @iso646-us@ +* @utf-8@ +* @iso-8859-1@ + +-} +module Data.MIME.Charset + ( + HasCharset(..) + , CharsetName + , charsetText + , charsetText' + , CharsetError(..) + , AsCharsetError(..) + , charsetPrism + + , decodeLenient + ) where + +import Control.Lens (Getter, Prism', prism', review, to, view) +import qualified Data.ByteString as B +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T + +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + +type CharsetName = CI.CI B.ByteString +type Charset = B.ByteString -> T.Text -- eventually we might want a prism + +data CharsetError + = CharsetUnspecified + | CharsetUnsupported CharsetName + | CharsetDecodeError CharsetName + deriving (Show) + +class AsCharsetError s where + _CharsetError :: Prism' s CharsetError + _CharsetUnspecified :: Prism' s () + _CharsetUnsupported :: Prism' s CharsetName + _CharsetDecodeError :: Prism' s CharsetName + + _CharsetUnspecified = _CharsetError . _CharsetUnspecified + _CharsetUnsupported = _CharsetError . _CharsetUnsupported + _CharsetDecodeError = _CharsetError . _CharsetDecodeError + +instance AsCharsetError CharsetError where + _CharsetError = id + _CharsetUnspecified = prism' (const CharsetUnspecified) $ \case + CharsetUnspecified -> Just () ; _ -> Nothing + _CharsetUnsupported = prism' CharsetUnsupported $ \case + CharsetUnsupported k -> Just k ; _ -> Nothing + _CharsetDecodeError = prism' CharsetDecodeError $ \case + CharsetDecodeError k -> Just k ; _ -> Nothing + + +class HasCharset a where + type Decoded a + + -- | Get the declared (or default) character set name. There is no guarantee + -- that it corresponds to a registered or supported charset. + charsetName :: Getter a (Maybe CharsetName) + + -- | Return the encoded data in the structure + charsetData :: Getter a B.ByteString + + -- | Structure with the encoded data replaced with 'Text' + charsetDecoded :: AsCharsetError e => Getter a (Either e (Decoded a)) + + -- | Encode the data + charsetEncode :: Decoded a -> a + + +-- | Decode the object according to the declared charset. +charsetText :: (HasCharset a, AsCharsetError e) => Getter a (Either e T.Text) +charsetText = to $ \a -> + maybe (Left $ review _CharsetUnspecified ()) Right (view charsetName a) + >>= \k -> maybe (Left $ review _CharsetUnsupported k) Right (lookupCharset k) + >>= \f -> pure (f (view charsetData a)) + +-- | Monomorphic in error type +charsetText' :: (HasCharset a) => Getter a (Either CharsetError T.Text) +charsetText' = charsetText + +-- | Prism for charset decoded/encoded data. +-- Information about decoding failures is discarded. +charsetPrism :: forall a. (HasCharset a) => Prism' a (Decoded a) +charsetPrism = prism' charsetEncode (either (const Nothing) Just . view l) + where + l = charsetDecoded :: Getter a (Either CharsetError (Decoded a)) + +charsets :: [(CI.CI B.ByteString, Charset)] +charsets = + [ ("us-ascii", us_ascii) + , ("utf-8", utf_8) + , ("iso-8859-1", iso_8859_1) + + -- uncommon aliases + , ("ISO646-US", us_ascii) + , ("ANSI_X3.4-1968", us_ascii) + + -- , ("iso-8859-2", ...) + -- , ("iso-8859-15", ...) + -- , ("iso-2022-jp", ...) (common) + -- , ("windows-1252", ...) (common) + -- , ("windows-1256", ...) + -- , ("cp1252", ...) (same as windows-1256?) + -- , ("big5", ...) (common) + -- , ("euc-kr", ...) + -- , ("cp932", ...) + -- , ("gb2312", ...) (Chinese) + ] + +us_ascii, utf_8, iso_8859_1 :: Charset +us_ascii = decodeLenient +utf_8 = decodeLenient +iso_8859_1 = T.decodeLatin1 + +-- | Look up a character set. +-- +lookupCharset :: CI.CI B.ByteString -> Maybe Charset +lookupCharset k = lookup k charsets + +-- | Decode as UTF-8, replacing invalid sequences with placeholders. +-- +decodeLenient :: B.ByteString -> T.Text +decodeLenient = T.decodeUtf8With T.lenientDecode diff --git a/src/Data/MIME/EncodedWord.hs b/src/Data/MIME/EncodedWord.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/EncodedWord.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + +@encoded-word@s for representing non-7bit ASCII data in headers +(RFC 2047 and RFC 2231). + +-} +module Data.MIME.EncodedWord + ( + decodeEncodedWords + ) where + +import Control.Applicative ((<|>), liftA2, optional) +import Data.Bifunctor (first) +import Data.Semigroup ((<>)) + +import Control.Lens (to, clonePrism, review, view) +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 (char8) +import qualified Data.ByteString as B +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Data.MIME.Charset +import Data.MIME.TransferEncoding +import Data.MIME.QuotedPrintable +import Data.RFC5322.Internal + +data EncodedWord = EncodedWord + { _encodedWordCharset :: CI.CI B.ByteString + , _encodedWordLanguage :: Maybe (CI.CI B.ByteString) + , _encodedWordEncoding :: CI.CI B.ByteString + , _encodedWordText :: B.ByteString + } + +instance HasTransferEncoding EncodedWord where + type TransferDecoded EncodedWord = TransferDecodedEncodedWord + transferEncodingName = to _encodedWordEncoding + transferEncodedData = to _encodedWordText + transferDecoded = to $ \a@(EncodedWord charset lang _ _) -> + TransferDecodedEncodedWord charset lang <$> view transferDecodedBytes a + + +data TransferDecodedEncodedWord = TransferDecodedEncodedWord + { _transDecWordCharset :: CI.CI B.ByteString + , _transDecWordLanguage :: Maybe (CI.CI B.ByteString) + , _transDecWordText :: B.ByteString + } + +-- | 'charsetEncode' uses UTF-8, but sets the charset to @us-ascii@ +-- if the text only contains ASCII characters. No language is set +-- upon encoding. +-- +instance HasCharset TransferDecodedEncodedWord where + type Decoded TransferDecodedEncodedWord = T.Text + charsetName = to (pure . _transDecWordCharset) + charsetData = to _transDecWordText + charsetDecoded = charsetText + + charsetEncode s = + let + bs = T.encodeUtf8 s + charset = if B.all (< 0x80) bs then "us-ascii" else "utf-8" + in TransferDecodedEncodedWord charset Nothing bs + +-- NOTE: may not be > 75 chars long +-- +-- NOTE: DOES NOT PARSE THE LEADING "=?" +-- +encodedWord :: Parser EncodedWord +encodedWord = + EncodedWord + <$> ci token + <*> optional (char8 '*' *> ci token) + <*> (qmark *> ci token) + <*> (qmark *> encodedText <* qmark <* eq) + where + eq = char8 '=' + qmark = char8 '?' + token = takeWhile1 (\c -> c >= 33 && c <= 126 && notInClass "()<>@,;:\\\"/[]?.=*" c) + + -- any printable ascii char other than ? or SPACE + encodedText = takeWhile1 (\c -> (c >= 33 && c < 63) || (c > 63 && c <= 127)) + +serialiseEncodedWord :: EncodedWord -> B.ByteString +serialiseEncodedWord (EncodedWord charset lang enc s) = + "=?" <> CI.original charset + <> maybe "" (\l -> "*" <> CI.original l) lang + <> "?" <> CI.original enc <> + "?" <> s <> "?=" + +transferEncodeEncodedWord :: TransferDecodedEncodedWord -> EncodedWord +transferEncodeEncodedWord (TransferDecodedEncodedWord charset lang s) = + EncodedWord charset lang "Q" (review (clonePrism q) s) + +-- | RFC 2047 and RFC 2231 define the /encoded-words/ mechanism for +-- embedding non-ASCII data in headers. This function locates +-- encoded-words and decodes them. +-- +-- @ +-- λ> T.putStrLn $ decodeEncodedWords "hello =?utf-8?B?5LiW55WM?=!" +-- hello 世界! +-- @ +-- +-- If parsing fails or the encoding is unrecognised the encoded-word +-- is left unchanged in the result. +-- +-- @ +-- λ> T.putStrLn $ decodeEncodedWords "=?utf-8?B?bogus?=" +-- =?utf-8?B?bogus?= +-- +-- λ> T.putStrLn $ decodeEncodedWords "=?utf-8?X?unrecognised_encoding?=" +-- =?utf-8?X?unrecognised_encoding?= +-- @ +-- +-- Language specification is supported (the datum is discarded). +-- +-- @ +-- λ> T.putStrLn $ decodeEncodedWords "=?utf-8*es?Q?hola_mundo!?=" +-- hola mundo! +-- @ +-- +decodeEncodedWords :: B.ByteString -> T.Text +decodeEncodedWords s = + either (const $ decodeLenient s) merge $ fmap (g . f) <$> parseOnly tokens s + where + -- parse the ByteString into a series of tokens + -- of either raw ASCII text, or EncodedWords + tokens = liftA2 (:) (Left <$> takeTillString "=?") more + <|> ((:[]) . Left <$> takeByteString) + more = liftA2 (:) (Right <$> encodedWord <|> pure (Left "=?")) tokens + + f (Left t) = Left t + f (Right w) = first + (const $ serialiseEncodedWord w :: TransferEncodingError -> B.ByteString) + (view transferDecoded w) + g (Left t) = Left t + g (Right w) = first + (const $ serialiseEncodedWord $ transferEncodeEncodedWord w :: CharsetError -> B.ByteString) + (view charsetDecoded w) + + merge = foldMap (either decodeLenient id) diff --git a/src/Data/MIME/Error.hs b/src/Data/MIME/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/Error.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE LambdaCase #-} + +module Data.MIME.Error where + +import Control.Lens (Prism', prism') + +import Data.MIME.Charset +import Data.MIME.TransferEncoding + + +-- | Transfer or character encoding errors +-- +data EncodingError + = TransferEncodingError TransferEncodingError + | CharsetError CharsetError + deriving (Show) + +class AsEncodingError s where + _EncodingError :: Prism' s EncodingError + _EncodingErrorTransferEncodingError :: Prism' s TransferEncodingError + _EncodingErrorCharsetError :: Prism' s CharsetError + + _EncodingErrorTransferEncodingError = _EncodingError . _TransferEncodingError + _EncodingErrorCharsetError = _EncodingError . _CharsetError + +instance AsEncodingError EncodingError where + _EncodingError = id + _EncodingErrorTransferEncodingError = prism' TransferEncodingError $ \case + TransferEncodingError e -> Just e ; _ -> Nothing + _EncodingErrorCharsetError = prism' CharsetError $ \case + CharsetError e -> Just e ; _ -> Nothing + +instance AsCharsetError EncodingError where + _CharsetError = _EncodingErrorCharsetError + +instance AsTransferEncodingError EncodingError where + _TransferEncodingError = _EncodingErrorTransferEncodingError diff --git a/src/Data/MIME/Internal.hs b/src/Data/MIME/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/Internal.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.MIME.Internal + ( + hexEncode + , parseHex + ) where + +import Data.Bits ((.&.), shiftR) +import Data.Word (Word8) + +import qualified Data.ByteString as B + +{- + (1) An "=" followed by two hexadecimal digits, one or both + of which are lowercase letters in "abcdef", is formally + illegal. A robust implementation might choose to + recognize them as the corresponding uppercase letters. +-} +parseHex :: Word8 -> Maybe Word8 +parseHex c = do + let + -- to upper + c' = if c >= 0x61 && c <= 0x7a then c - 0x20 else c + fromIntegral <$> B.findIndex (== c') hexAlphabet + +hexAlphabet :: B.ByteString +hexAlphabet = "0123456789ABCDEF" + +hexEncode :: Word8 -> (Word8, Word8) +hexEncode c = + let + lkup i = B.index hexAlphabet (fromIntegral i) + in + ( lkup (c `shiftR` 4) + , lkup (c .&. 0x0f) + ) diff --git a/src/Data/MIME/Parameter.hs b/src/Data/MIME/Parameter.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/Parameter.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + +MIME parameters, per RFC 2045 and RFC 2231. + +RFC 2231 defines a mechanism for parameter continuations (for long +parameters), encoding of non-ASCII characters, and charset and +language annotation. The most common use of these capabilities is +in the @Content-Disposition@ header, for the @filename@ parameter. + +This module provides types and functions for working with parameters. + +-} +module Data.MIME.Parameter + ( + Parameters(..) + , parameterList + , parameter + , rawParameter + , newParameter + + , ParameterValue(..) + , EncodedParameterValue + , DecodedParameterValue + , value + + , HasParameters(..) + ) where + +import Control.Applicative ((<|>), optional) +import Data.Foldable (fold) +import Data.Functor (($>)) +import Data.Semigroup ((<>), Sum(..), Max(..)) +import Data.Word (Word8) +import Data.Void (Void) +import Foreign (withForeignPtr, plusPtr, minusPtr, peek, peekByteOff, poke) +import GHC.Generics (Generic) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import Control.DeepSeq (NFData) +import Control.Lens +import Data.Attoparsec.ByteString.Char8 hiding (take) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Char8 as C +import Data.CaseInsensitive (CI, foldedCase, mk, original) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Data.MIME.Charset +import Data.MIME.Internal +import Data.RFC5322.Internal (ci, isQtext, isVchar) + +type RawParameters = [(CI B.ByteString, B.ByteString)] +-- | Header parameters. Used for some headers including Content-Type +-- and Content-Disposition. This type handles parameter continuations +-- and optional charset and language information (RFC 2231). +-- +newtype Parameters = Parameters [(CI B.ByteString, B.ByteString)] + deriving (Eq, Show, Generic, NFData) + +type instance Index Parameters = CI B.ByteString +type instance IxValue Parameters = EncodedParameterValue + +paramiso :: Iso' Parameters [(CI B.ByteString, B.ByteString)] +paramiso = iso (\(Parameters raw) -> raw) Parameters + +-- Traverses 0 or 1 instances of a parameter, which may consist of +-- one or more raw parameters. +instance Ixed Parameters where + ix k = paramiso . l + where + l f kv = case getParameter k kv of + Nothing -> pure kv + Just v -> (\v' -> setParam k v' kv) <$> f v + +-- | Set the parameter (which may need to use the parameter +-- continuation mechanism). +setParam :: CI B.ByteString -> EncodedParameterValue -> RawParameters -> RawParameters +setParam k v = (renderParam k v <>) . deleteParam k + +-- | Turn a ParameterValue into a list of raw parameters +-- +-- FIXME: currently does not do continutations etc. +-- 'ParameterValue' value is used as-is. +renderParam :: CI B.ByteString -> EncodedParameterValue -> [(CI B.ByteString, B.ByteString)] +renderParam k pv = case pv of + ParameterValue Nothing Nothing v -> case extEncode minBound v of + (Plain, v') -> [(k, v')] + (Quoted, v') -> [(k, "\"" <> v' <> "\"")] + (Extended, v') -> [(k <> "*", "''" <> v')] + ParameterValue cs lang v -> + -- charset or lang has been specified; force extended syntax + [(k <> "*", f cs <> "'" <> f lang <> "'" <> snd (extEncode Extended v))] + where + f = maybe "" original + +-- | Delete all raw keys that are "part of" the extended/continued +-- parameter. +deleteParam :: CI B.ByteString -> RawParameters -> RawParameters +deleteParam k = filter (not . test . fst) + where + test x = + x == k + || (foldedCase k <> "*") `B.isPrefixOf` foldedCase x + +instance At Parameters where + at k = paramiso . l + where + l :: Lens' RawParameters (Maybe EncodedParameterValue) + l f kv = + let + g Nothing = deleteParam k kv + g (Just v) = (setParam k v . deleteParam k) kv + in + g <$> f (getParameter k kv) + +data Continued = Continued | NotContinued + deriving (Show) +data Encoded = Encoded | NotEncoded + deriving (Show) + +-- | Not percent-decoded. 'Encoded' indicates whether +-- percent-decoding is required. 'Continued' indicates whether +-- there are more sections to follow +-- +data InitialSection = InitialSection Continued Encoded B.ByteString + deriving (Show) + +-- | Not percent-decoded. 'Encoded' indicates whether +-- percent-decoding is required. +-- +data OtherSection = OtherSection Encoded B.ByteString + deriving (Show) + +initialSection + :: CI B.ByteString + -> RawParameters + -> Maybe InitialSection +initialSection k m = + InitialSection NotContinued NotEncoded <$> lookup k m + <|> InitialSection Continued NotEncoded <$> lookup (k <> "*0") m + <|> InitialSection NotContinued Encoded <$> lookup (k <> "*") m + <|> InitialSection Continued Encoded <$> lookup (k <> "*0*") m + +otherSection + :: CI B.ByteString + -> Int + -> RawParameters + -> Maybe OtherSection +otherSection k i m = + OtherSection NotEncoded <$> lookup (k <> "*" <> i') m + <|> OtherSection Encoded <$> lookup (k <> "*" <> i' <> "*") m + where + i' = mk $ C.pack (show i) + +data ParameterValue cs a = ParameterValue + (Maybe cs) -- charset + (Maybe (CI B.ByteString)) -- language + a -- value + deriving (Eq, Show, Generic, NFData) + +type EncodedParameterValue = ParameterValue CharsetName B.ByteString +type DecodedParameterValue = ParameterValue Void T.Text + +value :: Lens (ParameterValue cs a) (ParameterValue cs b) a b +value f (ParameterValue a b c) = ParameterValue a b <$> f c + +charset :: Lens (ParameterValue cs a) (ParameterValue cs' a) (Maybe cs) (Maybe cs') +charset f (ParameterValue a b c) = (\a' -> ParameterValue a' b c) <$> f a + + +-- | Convenience function to construct a parameter value. +-- If you need to to specify language, use the 'ParameterValue' +-- constructor directly. +-- +newParameter :: T.Text -> EncodedParameterValue +newParameter = review charsetPrism . ParameterValue Nothing Nothing + + +-- | The default charset @us-ascii@ is implied by the abstract of +-- RFC 2231 which states: /This memo defines … a means to specify +-- parameter values in character sets other than US-ASCII/. +-- +-- When encoding, 'utf-8' is always used, but if the whole string +-- contains only ASCII characters then the charset declaration is +-- omitted (so that it can be encoded as a non-extended parameter). +-- +instance HasCharset EncodedParameterValue where + type Decoded EncodedParameterValue = DecodedParameterValue + charsetName = to $ \(ParameterValue name _ _) -> name <|> Just "us-ascii" + charsetData = value + charsetDecoded = to $ \a -> (\t -> (set charset Nothing . set value t) a) <$> view charsetText a + charsetEncode (ParameterValue _ lang s) = + let + bs = T.encodeUtf8 s + cs = if B.all (< 0x80) bs then Nothing else Just "utf-8" + in ParameterValue cs lang bs + +getParameter :: CI B.ByteString -> RawParameters -> Maybe EncodedParameterValue +getParameter k m = do + InitialSection cont enc s <- initialSection k m + (cs, lang, v0) <- + either (const Nothing) Just $ parseOnly (parseInitialValue enc) s + let + sect0 = OtherSection enc v0 + otherSects i = maybe [] (: otherSects (i + 1)) (otherSection k i m) + sects = case cont of + NotContinued -> [sect0] + Continued -> sect0 : otherSects 1 + ParameterValue cs lang . fold <$> traverse decode sects + where + parseInitialValue NotEncoded = + (Nothing, Nothing, ) <$> takeByteString + parseInitialValue Encoded = + (,,) <$> charsetOrLang <*> charsetOrLang <*> takeByteString + charsetOrLang = optional (ci (takeWhile1 (/= '\''))) <* char8 '\'' + + decode (OtherSection enc s) = case enc of + NotEncoded -> pure s + Encoded -> decodePercent s + + +decodePercent :: B.ByteString -> Maybe B.ByteString +decodePercent (B.PS sfp soff slen) = unsafeDupablePerformIO $ do + -- Length of decoded string is not yet known, but it cannot be + -- longer than input, and is likely to be not much shorter. + -- Therefore allocate slen bytes and only use as much as we need. + dfp <- B.mallocByteString slen + + result <- withForeignPtr dfp $ \dptr -> + withForeignPtr sfp $ \sptr -> do + let + slimit = sptr `plusPtr` (soff + slen) + fill !dp !sp + | sp >= slimit = pure $ Just (dp `minusPtr` dptr) + | otherwise = do + c <- peek sp + case (c :: Word8) of + 37 {- % -} + | sp `plusPtr` 2 >= slimit -> pure Nothing + -- reached end of input during '=' decoding + | otherwise -> do + c1 <- peekByteOff sp 1 + c2 <- peekByteOff sp 2 + maybe + (pure Nothing) -- invalid hex sequence + (\(hi,lo) -> do + poke dp (hi * 16 + lo) + fill (dp `plusPtr` 1) (sp `plusPtr` 3) ) + ((,) <$> parseHex c1 <*> parseHex c2) + _ -> + poke dp c *> fill (dp `plusPtr` 1) (sp `plusPtr` 1) + + fill dptr (sptr `plusPtr` soff) + pure $ B.PS dfp 0 <$> result + +data ParameterEncoding = Plain | Quoted | Extended + deriving (Eq, Ord, Bounded) + +-- | Given a requested encoding and a string, return an encoded +-- string along with the actual encoding used. +-- +-- The requested encoding will be used when it is capable of +-- encoding the string, otherwise the first capable encoding +-- is used. +-- +extEncode :: ParameterEncoding -> B.ByteString -> (ParameterEncoding, B.ByteString) +extEncode encReq s@(B.PS sfp soff slen) = (enc, d) + where + -- regular parameter: + -- value := token / quoted-string (RFC 2045) + -- token := 1* + -- tspecials := "(" / ")" / "<" / ">" / "@" / + -- "," / ";" / ":" / "\" / <"> + -- "/" / "[" / "]" / "?" / "=" + -- + -- extended-parameter: + -- attribute-char := + -- extended-other-values := *(ext-octet / attribute-char) + -- ext-octet := "%" 2(DIGIT / "A" / "B" / "C" / "D" / "E" / "F") + -- + isTspecial = (`B.elem` "()<>@,;:\\\"/[]?=") + isAttrChar c = isVchar c && c `B.notElem` "*'%" && not (isTspecial c) + numEncChars c = if isAttrChar c then 1 else 3 -- conservative estimate of bytes + -- needed to encode char + charEncoding c + | isAttrChar c = Plain + | isVchar c || c == 0x20 || c == 0x09 = Quoted + | otherwise = Extended + charInfo c = (Sum (numEncChars c), Max (charEncoding c)) + (Sum dlenMax, encCap) = foldMap charInfo $ B.unpack s + enc + | B.null s = Quoted -- Plain cannot encode empty string + | otherwise = getMax (Max encReq <> encCap) + + -- poke the char (possibly encoded) and return updated dest ptr + poke' ptr c = case enc of + Plain -> poke ptr c $> ptr `plusPtr` 1 + Quoted + | isQtext c -> poke ptr c $> ptr `plusPtr` 1 + | otherwise -> do + poke ptr 0x5c -- backslash + poke (ptr `plusPtr` 1) c + pure (ptr `plusPtr` 2) + Extended + | isAttrChar c -> poke ptr c $> ptr `plusPtr` 1 + | otherwise -> do + let (hi, lo) = hexEncode c + poke ptr 37 {- % -} + poke (ptr `plusPtr` 1) hi + poke (ptr `plusPtr` 2) lo + pure (ptr `plusPtr` 3) + + d = unsafeDupablePerformIO $ do + dfp <- B.mallocByteString dlenMax + dlen <- withForeignPtr dfp $ \dptr -> + withForeignPtr sfp $ \sptr -> do + let + slimit = sptr `plusPtr` (soff + slen) + fill !sp !dp + | sp >= slimit = pure (dp `minusPtr` dptr) + | otherwise = peek sp >>= poke' dp >>= fill (sp `plusPtr` 1) + fill sptr dptr + pure $ B.PS dfp 0 dlen + +-- | Types that have 'Parameters' +class HasParameters a where + parameters :: Lens' a Parameters + +instance HasParameters Parameters where + parameters = id + +-- Access the 'Parameters' as a @[(CI B.ByteString, B.ByteString)]@ +parameterList :: HasParameters a => Lens' a RawParameters +parameterList = parameters . coerced + +-- | Access parameter value. Continuations, encoding and charset +-- are processed. +-- +parameter + :: HasParameters a + => CI B.ByteString -> Lens' a (Maybe EncodedParameterValue) +parameter k = parameters . at k + +-- | Raw parameter. The key is used as-is. No processing of +-- continuations, encoding or charset is performed. +-- +rawParameter :: HasParameters a => CI B.ByteString -> Traversal' a B.ByteString +rawParameter k = parameters . paramiso . traversed . filtered ((k ==) . fst) . _2 diff --git a/src/Data/MIME/QuotedPrintable.hs b/src/Data/MIME/QuotedPrintable.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/QuotedPrintable.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | + +Implementation of Quoted-Printable Content-Transfer-Encoding. + + + +-} +module Data.MIME.QuotedPrintable + ( + contentTransferEncodingQuotedPrintable + , q + ) where + +import Control.Lens (APrism', prism') +import Data.Bool (bool) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import Data.Word (Word8) +import Foreign + ( Ptr, withForeignPtr, nullPtr, plusPtr, minusPtr + , peek, peekByteOff, poke + ) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import Data.MIME.Internal +import Data.MIME.Types + +data QuotedPrintableMode = QuotedPrintable | Q + deriving (Eq) + +-- | Whether it is required to encode a character +-- (where that character does not precede EOL). +encodingRequiredNonEOL :: QuotedPrintableMode -> Word8 -> Bool +encodingRequiredNonEOL mode c = not ( + (c >= 33 && c <= 60) + || (c >= 62 && c <= 126) + || c == 9 + || c == 32 + ) || (mode == Q && c == 95 {- underscore -}) + + +-- | Whether it is required to encode a character +-- (where that character does precede EOL). +encodingRequiredEOL :: QuotedPrintableMode -> Word8 -> Bool +encodingRequiredEOL mode c = not ( + (c >= 33 && c <= 60) + || (c >= 62 && c <= 126) + ) || (mode == Q && c == 95 {- underscore -}) + +-- | Two-pass solution: first determine output length, then +-- do the copy. +-- output length. +encodeQuotedPrintable :: QuotedPrintableMode -> B.ByteString -> B.ByteString +encodeQuotedPrintable mode s = unsafeDupablePerformIO $ do + l <- encodeQuotedPrintable' mode + (\_ _ -> pure ()) id nullPtr s + dfp <- B.mallocByteString l + withForeignPtr dfp $ \dptr -> + encodeQuotedPrintable' mode + poke (B.PS dfp 0) dptr s + +encodeQuotedPrintable' + :: QuotedPrintableMode + -> (Ptr Word8 -> Word8 -> IO ()) -- "poke" function + -> (Int -> r) -- "return" function + -> Ptr Word8 + -- ^ dest pointer; **assumed to be big enough to hold output**. + -- Can pass a bogus pointer (e.g. nullPtr) if the poke function + -- ignores its argument; this can be used for a first pass that + -- just computes the required length. + -> B.ByteString + -- ^ input string + -> IO r +encodeQuotedPrintable' mode poke' mkResult dptr (B.PS sfp soff slen) = + fmap mkResult $ withForeignPtr sfp $ \sptr -> do + let + slimit = sptr `plusPtr` (soff + slen) + + -- is there a crlf at this location? + crlf :: Ptr Word8 -> IO Bool + crlf ptr + | ptr `plusPtr` 1 >= slimit = pure False + | otherwise = do + c1 <- peek ptr + c2 <- peekByteOff ptr 1 + pure $ (c1 :: Word8) == 13 && (c2 :: Word8) == 10 + + pokeHardLineBreak ptr = + poke' ptr 13 *> poke' (ptr `plusPtr` 1) 10 + + pokeSoftLineBreak ptr = + poke' ptr 61 {- = -} *> pokeHardLineBreak (ptr `plusPtr` 1) + + pokeEncoded ptr c = + let (hi, lo) = hexEncode c + in poke' ptr 61 {- = -} + *> poke' (ptr `plusPtr` 1) hi + *> poke' (ptr `plusPtr` 2) lo + + mapChar 32 {- ' ' -} | mode == Q = 95 {- _ -} + mapChar c = c + + fill col !dp !sp + | sp >= slimit = pure $ dp `minusPtr` dptr + | otherwise = do + atEOL <- crlf sp + if atEOL + then pokeHardLineBreak dp + *> fill 0 (dp `plusPtr` 2) (sp `plusPtr` 2) + else do + c <- peek sp + cAtEOL <- crlf (sp `plusPtr` 1) + let + encodingRequired = + (cAtEOL && encodingRequiredEOL mode c) + || encodingRequiredNonEOL mode c + bytesNeeded = bool 1 3 encodingRequired + c' = mapChar c + case (col + bytesNeeded >= 76, encodingRequired) of + (False, False) -> + poke' dp c' + *> fill (col + bytesNeeded) (dp `plusPtr` bytesNeeded) (sp `plusPtr` 1) + (False, True) -> + pokeEncoded dp c' + *> fill (col + bytesNeeded) (dp `plusPtr` bytesNeeded) (sp `plusPtr` 1) + (True, False) -> + pokeSoftLineBreak dp + *> poke' (dp `plusPtr` 3) c' + *> fill 1 (dp `plusPtr` 4) (sp `plusPtr` 1) + (True, True) -> + pokeSoftLineBreak dp + *> pokeEncoded (dp `plusPtr` 3) c' + *> fill 3 (dp `plusPtr` 6) (sp `plusPtr` 1) + fill 0 dptr (sptr `plusPtr` soff) + +decodeQuotedPrintable :: QuotedPrintableMode -> B.ByteString -> Either String B.ByteString +decodeQuotedPrintable mode (B.PS sfp soff slen) = unsafeDupablePerformIO $ do + -- Precise length of decoded string is not yet known, but + -- it cannot be longer than input, and is likely to be not + -- much shorter. Therefore allocate slen bytes and only + -- use as much as we need. + dfp <- B.mallocByteString slen + + result <- withForeignPtr dfp $ \dptr -> + withForeignPtr sfp $ \sptr -> do + let + slimit = sptr `plusPtr` (soff + slen) + fill !dp !sp + | sp >= slimit = pure $ Right (dp `minusPtr` dptr) + | otherwise = do + c <- peek sp + case (c :: Word8) of + 61 {- = -} -> + -- NOTE: strictly, only =\r\n is a valid soft line + -- break, but we accept =\n as well. + if sp `plusPtr` 1 >= slimit + then pure $ Left "reached end of input during '=' decoding" + else do + c1 <- peekByteOff sp 1 + case c1 of + 10 -> fill dp (sp `plusPtr` 2) -- soft line break (=\n) + _ -> + if sp `plusPtr` 2 >= slimit + then pure $ Left "reached end of input during '=' decoding" + else do + c2 <- peekByteOff sp 2 + case (c1, c2) of + (13, 10) {- CRLF -} -> + -- Soft Line Break (=\r\n) + fill dp (sp `plusPtr` 3) + _ -> + maybe + (pure $ Left "invalid hex sequence") + (\(hi,lo) -> do + poke dp (hi * 16 + lo) + fill (dp `plusPtr` 1) (sp `plusPtr` 3) ) + ((,) <$> parseHex c1 <*> parseHex c2) + + -- otherwise assume that the char is valid and copy it to dst + + 95 {- _ -} | mode == Q -> + poke dp 32 {- ' ' -} *> fill (dp `plusPtr` 1) (sp `plusPtr` 1) + + 32 {- ' ' -} | mode == Q -> + pure $ Left "space cannot appear in 'Q' encoding" + + _ -> + poke dp c *> fill (dp `plusPtr` 1) (sp `plusPtr` 1) + + fill dptr (sptr `plusPtr` soff) + pure $ B.PS dfp 0 <$> result + +mkPrism :: QuotedPrintableMode -> APrism' B.ByteString B.ByteString +mkPrism mode = prism' + (encodeQuotedPrintable mode) + (either (const Nothing) Just . decodeQuotedPrintable mode) + +contentTransferEncodingQuotedPrintable :: ContentTransferEncoding +contentTransferEncodingQuotedPrintable = mkPrism QuotedPrintable + +q :: EncodedWordEncoding +q = mkPrism Q diff --git a/src/Data/MIME/TransferEncoding.hs b/src/Data/MIME/TransferEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/TransferEncoding.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + +MIME content transfer encodings. + +-} +module Data.MIME.TransferEncoding + ( + HasTransferEncoding(..) + , TransferEncodingName + , transferDecodedBytes + , transferEncodings + , transferEncodeData + , TransferEncodingError(..) + , AsTransferEncodingError(..) + , TransferEncoding + ) where + +import Control.Lens + ( APrism', Getter, Prism', clonePrism, preview, prism', review, to, view ) +import qualified Data.ByteString as B +import qualified Data.CaseInsensitive as CI + +import Data.MIME.Base64 +import Data.MIME.QuotedPrintable +import Data.MIME.Types (Encoding(..)) + +type TransferEncodingName = CI.CI B.ByteString +type TransferEncoding = APrism' B.ByteString B.ByteString + +data TransferEncodingError + = TransferEncodingUnsupported TransferEncodingName + | TransferDecodeError TransferEncodingName + deriving (Show) + +class AsTransferEncodingError s where + _TransferEncodingError :: Prism' s TransferEncodingError + _TransferEncodingUnsupported :: Prism' s TransferEncodingName + _TransferDecodeError :: Prism' s TransferEncodingName + + _TransferEncodingUnsupported = _TransferEncodingError . _TransferEncodingUnsupported + _TransferDecodeError = _TransferEncodingError . _TransferDecodeError + +instance AsTransferEncodingError TransferEncodingError where + _TransferEncodingError = id + _TransferEncodingUnsupported = prism' TransferEncodingUnsupported $ \case + TransferEncodingUnsupported k -> Just k ; _ -> Nothing + _TransferDecodeError = prism' TransferDecodeError $ \case + TransferDecodeError k -> Just k ; _ -> Nothing + + +class HasTransferEncoding a where + type TransferDecoded a + + -- | Get the declared or default transfer encoding name. + transferEncodingName :: Getter a TransferEncodingName + + -- | Return the encoded data in the structure. + transferEncodedData :: Getter a B.ByteString + + -- | Perform content transfer decoding. + transferDecoded :: AsTransferEncodingError e => Getter a (Either e (TransferDecoded a)) + +-- | Decode the object according to the declared content transfer encoding. +transferDecodedBytes + :: (HasTransferEncoding a, AsTransferEncodingError e) + => Getter a (Either e B.ByteString) +transferDecodedBytes = to $ \a -> do + let encName = view transferEncodingName a + enc <- maybe (Left $ review _TransferEncodingUnsupported encName) Right + (lookup encName transferEncodings) + let s = view transferEncodedData a + maybe (Left $ review _TransferDecodeError encName) Right (preview (clonePrism enc) s) + +-- Message instance: + --v = fromMaybe "7bit" $ preview (header "content-transfer-encoding") h +-- | Get the Content-Transfer-Encoding for an entity. +-- Defaults to @7bit@ (RFC 2045 §6.1) if the header is +-- not present. Fails on /unrecognised/ values. +-- + +transferEncodings :: [(CI.CI B.ByteString, TransferEncoding)] +transferEncodings = + [ ("7bit", id) + , ("8bit", id) + , ("binary", id) + , ("quoted-printable", contentTransferEncodingQuotedPrintable) + , ("base64", contentTransferEncodingBase64) + , ("q", q) + , ("b", contentTransferEncodingBase64) + ] + +transferEncodeData :: Encoding -> B.ByteString -> B.ByteString +transferEncodeData Base64 = contentTransferEncodeBase64 +transferEncodeData _ = id diff --git a/src/Data/MIME/Types.hs b/src/Data/MIME/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/MIME/Types.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE RankNTypes #-} + +module Data.MIME.Types + ( + ContentTransferEncoding + , EncodedWordEncoding + , Encoding(..) + ) where + +import Control.Lens (APrism') +import qualified Data.ByteString as B + +type ContentTransferEncoding = APrism' B.ByteString B.ByteString +data Encoding = None | Base64 + +type EncodedWordEncoding = APrism' B.ByteString B.ByteString diff --git a/src/Data/RFC5322.hs b/src/Data/RFC5322.hs new file mode 100644 --- /dev/null +++ b/src/Data/RFC5322.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + +Email messages. Deals specifically with RFC 5322, which is stricter +than RFC 822 or RFC 2822. If you have to deal with messages that +comply with the older specifications but not RFC 5322, preprocess +the input and massage it to be RFC 5322 compliant. + +This parser allows LF line endings in addition to CRLF (RFC 5322 +demands CRLF but LF-only is common in on-disk formats). + +The main parsing function is 'message'. It takes a second function +that can inspect the headers to determine how to parse the body. + +@ +'message' :: ('Headers' -> Parser a) -> Parser (Message ctx a) +@ + +The 'Message' type is parameterised over the body type, and a +phantom type that can be used for context. + +@ +data 'Message' ctx a = Message 'Headers' a +@ + +Headers and body can be accessed via the 'headers', 'header' and +'body' optics. + +@ +'headers' :: Lens' (Message ctx a) Headers +'header' :: CI B.ByteString -> Fold Headers B.ByteString +'body' :: Lens (Message ctx a) (Message ctx' b) a b +@ + +The following example program parses an input, interpreting the body +as a raw @ByteString@, and prints the subject (if present), the +number of headers and the body length. The message context type is +@()@. + +@ +analyse :: B.ByteString -> IO () +analyse input = + case 'parse' ('message' (const takeByteString)) of + Left errMsg -> hPutStrLn stderr errMsg *> exitFailure + Right (msg :: Message () B.ByteString) -> do + B.putStrLn $ "subject: " <> foldOf ('headers' . 'header' "subject") msg + putStrLn $ "num headers: " <> show (length (view 'headers' msg)) + putStrLn $ "body length: " <> show (B.length (view 'body' msg)) +@ + +-} +module Data.RFC5322 + ( + -- * Message types + Message(..) + , message + , headers + , headerList + , body + , Headers(..) + , Header + , header + , Address(..) + , address + , addressList + , AddrSpec(..) + , Domain(..) + , Mailbox(..) + , mailbox + , mailboxList + + -- * Parsers + , parse + , parsed + , parsePrint + , crlf + , quotedString + + -- * Helpers + , field + , rfc5422DateTimeFormat + + -- * Serialisation + , renderRFC5422Date + , buildFields + , buildField + , renderMailbox + , renderMailboxes + , renderAddress + , renderAddresses + ) where + +import Control.Applicative +import Data.Foldable (fold) +import Data.List (findIndex, intersperse) +import Data.List.NonEmpty (intersperse) +import Data.Semigroup ((<>)) +import Data.Word (Word8) +import GHC.Generics (Generic) + +import Control.DeepSeq (NFData) +import Control.Lens +import Control.Lens.Cons.Extras (recons) +import Data.Attoparsec.ByteString as A hiding (parse, take) +import Data.Attoparsec.ByteString.Char8 (char8) +import qualified Data.Attoparsec.ByteString.Lazy as AL +import qualified Data.ByteString as B +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime) + +import Data.RFC5322.Internal +import Data.RFC5322.Address.Types +import Data.MIME.Charset (decodeLenient) + +type Header = (CI B.ByteString, B.ByteString) +newtype Headers = Headers [Header] + deriving (Eq, Show, Generic, NFData) + +type instance Index Headers = CI B.ByteString +type instance IxValue Headers = B.ByteString + +instance Ixed Headers where + ix = header + +hdriso :: Iso' Headers [(CI B.ByteString, B.ByteString)] +hdriso = iso (\(Headers xs) -> xs) Headers + +-- | Acts upon the first occurrence of the header only. +-- +instance At Headers where + at k = hdriso . l + where + l :: Lens' [(CI B.ByteString, B.ByteString)] (Maybe B.ByteString) + l f kv = + let + i = findIndex ((== k) . fst) kv + g Nothing = maybe kv (\j -> take j kv <> drop (j + 1) kv) i + g (Just v) = maybe ((k,v):kv) (\j -> set (ix j) (k,v) kv) i + in + g <$> f (lookup k kv) + + +-- | Get all values of the given header +header :: CI B.ByteString -> Traversal' Headers B.ByteString +header k = hdriso . traversed . filtered ((k ==) . fst) . _2 + +-- | Message type, parameterised over context and body type. The +-- context type is not used in this module but is provided for uses +-- such as tracking the transfer/charset encoding state in MIME +-- messages. +-- +data Message s a = Message Headers a + deriving (Eq, Show, Generic, NFData) + +headers :: Lens' (Message s a) Headers +headers f (Message h b) = fmap (\h' -> Message h' b) (f h) +{-# ANN headers ("HLint: ignore Avoid lambda" :: String) #-} + +-- | Access headers as a list of key/value pairs. +headerList :: Lens' (Message s a) [(CI B.ByteString, B.ByteString)] +headerList = headers . coerced + +body :: Lens (Message ctx a) (Message ctx' b) a b +body f (Message h b) = fmap (\b' -> Message h b') (f b) +{-# ANN body ("HLint: ignore Avoid lambda" :: String) #-} + +isSpecial :: Word8 -> Bool +isSpecial = inClass "()<>[]:;@\\,.\"" + +special :: Parser Word8 +special = satisfy isSpecial + + +-- §3.3 Date and Time Specification +-- Sat, 29 Sep 2018 12:51:05 +1000 +rfc5422DateTimeFormat :: String +rfc5422DateTimeFormat = "%a, %d %b %Y %T %z" + +renderRFC5422Date :: UTCTime -> B.ByteString +renderRFC5422Date = Char8.pack . formatTime defaultTimeLocale rfc5422DateTimeFormat + +-- §3.4 Address Specification +buildMailbox :: Mailbox -> Builder.Builder +buildMailbox (Mailbox n a) = + maybe a' (\n' -> renderDisplayName n' <> "<" <> a' <> ">") n + where + a' = renderAddressSpec a + +renderDisplayName :: T.Text -> Builder.Builder +renderDisplayName x = + mconcat + [ "\"" + , Builder.byteString (T.encodeUtf8 x) + , "\" "] + +renderMailboxes :: [Mailbox] -> B.ByteString +renderMailboxes = toStrict . Builder.toLazyByteString . buildMailboxes + +buildMailboxes :: [Mailbox] -> Builder.Builder +buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox + +renderMailbox :: Mailbox -> B.ByteString +renderMailbox = toStrict . Builder.toLazyByteString . buildMailbox + +mailbox :: Parser Mailbox +mailbox = Mailbox <$> optional displayName <*> angleAddr + <|> Mailbox Nothing <$> addressSpec + +displayName :: Parser T.Text +displayName = decodeLenient <$> phrase + +angleAddr :: Parser AddrSpec +angleAddr = optionalCFWS *> + char8 '<' *> addressSpec <* char8 '>' + <* optionalCFWS + +renderAddressSpec :: AddrSpec -> Builder.Builder +renderAddressSpec (AddrSpec lp (DomainDotAtom b)) + | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest + | otherwise = buildLP <> rest + where + buildLP = Builder.byteString lp + rest = "@" <> foldMap Builder.byteString (Data.List.NonEmpty.intersperse "." b) +renderAddressSpec (AddrSpec lp (DomainLiteral b)) = + foldMap Builder.byteString [lp, "@", b] + +addressSpec :: Parser AddrSpec +addressSpec = AddrSpec <$> localPart <*> (char8 '@' *> domain) + +-- | Printable US-ASCII excl "[", "]", or "\" +isDtext :: Word8 -> Bool +isDtext c = (c >= 33 && c <= 90) || (c >= 94 && c <= 126) + +domain :: Parser Domain +domain = (DomainDotAtom <$> (pure <$> dotAtom)) + <|> (DomainLiteral <$> domainLiteral) + +mailboxList :: Parser [Mailbox] +mailboxList = mailbox `sepBy` char8 ',' + +renderAddresses :: [Address] -> B.ByteString +renderAddresses xs = B.intercalate ", " $ renderAddress <$> xs + +renderAddress :: Address -> B.ByteString +renderAddress (Single m) = renderMailbox m +renderAddress (Group name xs) = T.encodeUtf8 name <> ":" <> renderMailboxes xs <> ";" + +addressList :: Parser [Address] +addressList = address `sepBy` char8 ',' + +group :: Parser Address +group = Group <$> displayName <* char8 ':' <*> mailboxList <* char8 ';' <* optionalCFWS + +address :: Parser Address +address = group <|> Single <$> mailbox + +-- §3.5. Overall Message Syntax + + +-- | Parse a message, given function from headers to body parser +-- +-- This parser does not handle the legitimate but obscure case +-- of a message with no body (empty body is fine, though). +-- +message :: (Headers -> Parser a) -> Parser (Message s a) +message f = fields >>= \hdrs -> Message hdrs <$> (crlf *> f hdrs) + +fields :: Parser Headers +fields = Headers <$> many field + +-- Header serialisation +buildFields :: Headers -> Builder.Builder +buildFields = foldMapOf (hdriso . traversed) buildField + +buildField :: (CI B.ByteString, B.ByteString) -> Builder.Builder +buildField (k,v) = + let key = original k + in + Builder.byteString key + <> ": " + <> Builder.byteString (foldUnstructured (B.length key) v) + <> "\r\n" + + +-- | Render a field body with proper folding +-- +-- Algorithm: +-- * Break the string on white space +-- * Use a counter which indicates a new folding line if it exceeds 77 characters +-- * Whenever we create a new line, concatenate all words back with white space and push it into the result +-- * The result is a list of byte strings, which is concatenated with \r\n\s +-- +-- Notes: +-- * First take at this, so possibly very inefficient +-- * No other delimiters (e.g. commas, full stops, etc) are considered for +-- folding other than whitespace +-- * Attaches an additional whitespace when joining +-- +foldUnstructured :: Int -> B.ByteString -> B.ByteString +foldUnstructured i b = + let xs = chunk (i + 2) (Char8.words b) [] [] + in B.intercalate "\r\n " xs + +chunk :: Int -> [B.ByteString] -> [B.ByteString] -> [B.ByteString] -> [B.ByteString] +chunk _ [] xs result = result <> [Char8.unwords xs] +chunk max' (x:rest) xs result = if (max' + B.length x + 1) >= 77 + then result <> [Char8.unwords xs] <> chunk (B.length x + 1) rest [x] [] + else result <> chunk (max' + B.length x + 1) rest (xs <> [x]) result + +-- | Printable ASCII excl. ':' +isFtext :: Word8 -> Bool +isFtext c = (c >= 33 && c <= 57) || (c >= 59 && c <= 126) + +field :: Parser (CI B.ByteString, B.ByteString) +field = (,) + <$> ci (takeWhile1 isFtext) + <* char8 ':' <* many wsp + <*> unstructured <* crlf + +unstructured :: Parser B.ByteString +unstructured = + foldMany (optionalFWS <<>> (B.singleton <$> vchar)) + <<>> A.takeWhile isWsp + + +-- | Given a parser, construct a 'Fold' +-- +-- See 'parse' for discussion of performance. +-- +parsed :: (Cons s s Word8 Word8) => Parser a -> Fold s a +parsed p = to (parse p) . folded +{-# INLINE parsed #-} + +-- | Construct a prism from a parser and a printer +parsePrint :: Parser a -> (a -> B.ByteString) -> Prism' B.ByteString a +parsePrint fwd rev = prism' rev (AL.maybeResult . AL.parse fwd . view recons) + +-- | Parse an @a@. +-- +-- The input is convered to a /lazy/ @ByteString@. +-- Build with rewrite rules enabled (@-O@, cabal's default) +-- to achieve the following conversion overheads: +-- +-- * Lazy @ByteString@: no conversion +-- * Strict @ByteString@: /O(1)/ conversion +-- * @[Word8]@: /O(n)/ conversion +-- +-- It is __recommended to use strict bytestring__ input. Parsing a +-- lazy bytestring will cause numerous parser buffer resizes. The +-- lazy chunks in the input can be GC'd but the buffer keeps growing +-- so you don't actually keep the memory usage low by using a lazy +-- bytestring. +-- +parse :: (Cons s s Word8 Word8) => Parser a -> s -> Either String a +parse p = AL.eitherResult . AL.parse p . view recons +{-# INLINE parse #-} diff --git a/src/Data/RFC5322/Address/Text.hs b/src/Data/RFC5322/Address/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/RFC5322/Address/Text.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + +Parser for roundtripping Text based `Mailbox`es and addresses. + +-} +module Data.RFC5322.Address.Text + ( + mailbox + , address + -- * Pretty printing + , renderMailbox + , renderMailboxes + ) where + +import Control.Applicative ((<|>), optional) +import Data.Foldable (fold) +import Data.Semigroup ((<>)) +import Data.List (intersperse) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Internal.Builder as Builder +import qualified Data.ByteString as B +import Data.Attoparsec.Text as A hiding (parse, take) +import Data.List.NonEmpty (intersperse) + +import Data.MIME.Charset (decodeLenient) +import Data.RFC5322.Address.Types +import Data.RFC5322.Internal + + +renderMailboxes :: [Mailbox] -> T.Text +renderMailboxes = LT.toStrict . Builder.toLazyText . buildMailboxes + +buildMailboxes :: [Mailbox] -> Builder.Builder +buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox + +renderMailbox :: Mailbox -> T.Text +renderMailbox = LT.toStrict . Builder.toLazyText . buildMailbox + +-- | Printing function to "pretty print" the mailbox for display purposes +buildMailbox :: Mailbox -> Builder.Builder +buildMailbox (Mailbox n a) = + maybe a' (\n' -> "\"" <> Builder.fromText n' <> "\" " <> "<" <> a' <> ">") n + where + a' = renderAddressSpec a + +renderAddressSpec :: AddrSpec -> Builder.Builder +renderAddressSpec (AddrSpec lp (DomainDotAtom b)) + | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest + | otherwise = buildLP <> rest + where + buildLP = Builder.fromText $ decodeLenient lp + rest = "@" <> foldMap Builder.fromText (decodeLenient <$> Data.List.NonEmpty.intersperse "." b) +renderAddressSpec (AddrSpec lp (DomainLiteral b)) = + foldMap Builder.fromText [decodeLenient lp, "@", decodeLenient b] + + +-- §3.4 Address Specification +mailbox :: Parser Mailbox +mailbox = Mailbox <$> optional displayName <*> angleAddr + <|> Mailbox Nothing <$> addressSpec + +displayName :: Parser T.Text +displayName = phrase + +mailboxList :: Parser [Mailbox] +mailboxList = mailbox `sepBy` char ',' + +group :: Parser Address +group = Group <$> displayName <* char ':' <*> mailboxList <* char ';' <* optionalCFWS + +address :: Parser Address +address = group <|> Single <$> mailbox + +angleAddr :: Parser AddrSpec +angleAddr = optionalCFWS *> + char '<' *> addressSpec <* char '>' + <* optionalCFWS + +addressSpec :: Parser AddrSpec +addressSpec = AddrSpec <$> (T.encodeUtf8 <$> localPart) <*> (char '@' *> domain) + +domain :: Parser Domain +domain = (DomainDotAtom <$> (pure . T.encodeUtf8 <$> dotAtom)) + <|> (DomainLiteral <$> (T.encodeUtf8 <$> domainLiteral)) diff --git a/src/Data/RFC5322/Address/Types.hs b/src/Data/RFC5322/Address/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/RFC5322/Address/Types.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.RFC5322.Address.Types + ( + Mailbox(..) + , Address(..) + , AddrSpec(..) + , Domain(..) + ) where + +import Control.DeepSeq (NFData) +import qualified Data.Text as T +import qualified Data.ByteString as B +import Data.List.NonEmpty (NonEmpty) +import GHC.Generics (Generic) + +data Mailbox = + Mailbox (Maybe T.Text {- display name -}) + AddrSpec + deriving (Show, Eq, Generic, NFData) + +data AddrSpec = + AddrSpec B.ByteString {- local part -} + Domain + deriving (Show, Eq, Generic, NFData) + +data Address + = Single Mailbox + | Group T.Text {- display name -} + [Mailbox] + deriving (Show, Eq, Generic, NFData) + +data Domain + = DomainDotAtom (NonEmpty B.ByteString {- printable ascii -}) + | DomainLiteral B.ByteString + deriving (Show, Eq, Generic, NFData) diff --git a/src/Data/RFC5322/Internal.hs b/src/Data/RFC5322/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/RFC5322/Internal.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.RFC5322.Internal + ( + -- * Case-insensitive value parsers + ci + , CI + , original + + -- * Abstract character parsers + , wsp + , optionalFWS + , optionalCFWS + , crlf + , vchar + , quotedString + , phrase + , dotAtom + , localPart + , domainLiteral + + -- ** Helpers for building parsers + , isAtext + , isQtext + , isVchar + , isWsp + + -- * Semigroup and monoid folding combinators + , (<<>>) + , foldMany + , foldMany1 + + -- * General parsers and combinators + , skipTill + , takeTill' + + -- * Efficient string search + , skipTillString + , takeTillString + + ) where + +import Prelude hiding (takeWhile) +import Control.Applicative ((<|>), Alternative, liftA2, many, optional) +import Control.Monad (void) +import Control.Lens.Cons (Cons, cons) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.Internal as A +import qualified Data.Attoparsec.Internal.Types as AT +import qualified Data.Attoparsec.Text as AText +import qualified Data.ByteString as B +import Data.ByteString.Internal (c2w, w2c) +import Data.ByteString.Search (indices) +import Data.CaseInsensitive (CI, FoldCase, mk, original) +import Data.Char (chr) +import Data.Foldable (fold) +import Data.Functor (($>)) +import Data.List.NonEmpty (fromList) +import Data.Semigroup (Semigroup((<>))) +import Data.Semigroup.Foldable (fold1) +import qualified Data.Text as T +import Data.Word (Word8) + + +-- | Constraint synonym to handle the Semigroup Monoid Proposal +-- transition gracefully. +#if MIN_VERSION_base(4,11,0) +type SM a = Monoid a +#else +type SM a = (Semigroup a, Monoid a) +#endif + +class IsChar a where + toChar :: a -> Char + fromChar :: Char -> a + +instance IsChar Char where + toChar = id + fromChar = id + +instance IsChar Word8 where + toChar = w2c + fromChar = c2w + +class IsChar a => CharParsing f s a | s -> a, a -> f s where + singleton :: Char -> s + satisfy :: (Char -> Bool) -> (f s) a + takeWhile :: (Char -> Bool) -> (f s) s + takeWhile1 :: (Char -> Bool) -> (f s) s + +instance CharParsing AT.Parser B.ByteString Word8 where + singleton = B.singleton . c2w + satisfy f = A.satisfy (f . w2c) + takeWhile f = A.takeWhile (f . w2c) + takeWhile1 f = A.takeWhile1 (f . w2c) + +instance CharParsing AT.Parser T.Text Char where + singleton = T.singleton + satisfy = AText.satisfy + takeWhile = AText.takeWhile + takeWhile1 = AText.takeWhile1 + +char :: CharParsing f s a => Char -> (f s) a +char c = satisfy (== c) + +isWsp :: IsChar c => c -> Bool +isWsp = AText.inClass "\t " . toChar + +wsp :: CharParsing f s a => (f s) a +wsp = satisfy isWsp + +isVchar :: IsChar c => c -> Bool +isVchar c = + let c' = toChar c + in c' >= chr 0x21 && c' <= chr 0x7e + +vchar :: CharParsing f s a => (f s) a +vchar = satisfy isVchar + +dquote :: CharParsing f s a => (f s) a +dquote = char '"' + +quotedPair :: (Alternative (f s)) => CharParsing f s a => (f s) a +quotedPair = char '\\' *> (vchar <|> wsp) + +-- §3.2.4. Quoted Strings + +isQtext :: IsChar c => c -> Bool +isQtext c' = + let c = toChar c' + in + c == chr 33 + || (c >= chr 35 && c <= chr 91) + || (c >= chr 93 && c <= chr 126) + +quotedString :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +quotedString = + optionalCFWS *> dquote + *> foldMany (optionalFWS <<>> qcontent) <<>> optionalFWS + <* dquote <* optionalCFWS + where + qcontent = + (singleton . toChar <$> satisfy isQtext) + <|> (singleton . toChar <$> quotedPair) + +isAtext :: IsChar c => c -> Bool +isAtext = AText.inClass "-A-Za-z0-9!#$%&'*+/=?^_`{|}~" . toChar + +atext :: CharParsing f s a => (f s) a +atext = satisfy isAtext + +-- | Either CRLF or LF (lots of mail programs transform CRLF to LF) +crlf :: (Alternative (f s)) => CharParsing f s a => (f s) () +crlf = void ((char '\r' *> char '\n') <|> char '\n') + +-- §3.2.2. Folding White Space and Comments +-- +-- "The general rule is that wherever this specification allows for folding +-- white space (not simply WSP characters), a CRLF may be inserted before any +-- WSP." + +fws :: (Alternative (f s), CharParsing f s a) => (f s) s +fws = optional (takeWhile isWsp *> crlf) + *> takeWhile1 isWsp + *> pure (singleton ' ') + +-- | FWS collapsed to a single SPACE character, or empty string +-- +optionalFWS :: (Alternative (f s), CharParsing f s a, Monoid s) => (f s) s +optionalFWS = fws <|> pure mempty + +-- | Printable ASCII excl. '(', ')', '\' +isCtext :: Char -> Bool +isCtext c = + c >= chr 33 && c <= chr 39 + || c >= chr 42 && c <= chr 91 + || c >= chr 93 && c <= chr 126 + +ccontent :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +ccontent = (singleton . toChar <$> satisfy isCtext) <|> comment + +comment :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +comment = + char '(' *> foldMany (optionalFWS <<>> ccontent) <* optionalFWS <* char ')' + +cfws :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +cfws = + foldMany1 (optionalFWS <<>> comment) *> optionalFWS *> pure (singleton ' ') + <|> fws + +-- | CFWS collapsed to a single SPACE character, or empty string +-- +optionalCFWS :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +optionalCFWS = cfws <|> pure mempty + +atom :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +atom = optionalCFWS *> foldMany1 (singleton . toChar <$> atext) <* optionalCFWS + +word :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +word = atom <|> quotedString + +phrase :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +phrase = foldMany1 word + +dotAtomText :: (Alternative (f s), CharParsing f s a, SM s, Cons s s a a) => (f s) s +dotAtomText = + takeWhile1 isAtext + <<>> foldMany (char '.' *> (cons (fromChar '.') <$> takeWhile1 isAtext)) + +dotAtom :: (Alternative (f s), CharParsing f s a, SM s, Cons s s a a) => (f s) s +dotAtom = optionalCFWS *> dotAtomText <* optionalCFWS + +localPart :: (Alternative (f s), CharParsing f s a, SM s, Cons s s a a) => (f s) s +localPart = dotAtom <|> quotedString + +-- | Printable US-ASCII excl "[", "]", or "\" +isDtext :: Char -> Bool +isDtext c = (c >= chr 33 && c <= chr 90) || (c >= chr 94 && c <= chr 126) + +dText :: CharParsing f s a => (f s) a +dText = satisfy isDtext + +domainLiteral :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s +domainLiteral = + optionalCFWS *> char '[' + *> foldMany (optionalFWS <<>> (singleton . toChar <$> dText) <<>> optionalFWS) + <* char ']' <* optionalFWS + + +-- | Modify a parser to produce a case-insensitive value +-- +ci :: FoldCase s => A.Parser s -> A.Parser (CI s) +ci = fmap mk + + +-- | Combine two semigroup parsers into one +(<<>>) :: (Semigroup m, Applicative f) => f m -> f m -> f m +(<<>>) = liftA2 (<>) + +-- | Parse zero or more values and fold them +foldMany :: (Monoid m, Alternative f) => f m -> f m +foldMany = fmap fold . many + +-- | Parse one or more values and fold them +foldMany1 :: (Semigroup m, Alternative f) => f m -> f m +foldMany1 = fmap (fold1 . fromList) . A.many1 + +-- | Skip until the given parser succeeds +-- +-- @@ +-- λ> parseOnly (string "foo" *> skipTill (string ".") *> endOfInput) "foobar." +-- Right () +-- @@ +-- +skipTill :: A.Parser a -> A.Parser () +skipTill = void . spanTill + +-- | Current offset in the input +position :: AT.Parser i Int +position = AT.Parser $ \t pos more _lose suc -> suc t pos more (AT.fromPos pos) + +-- | Number of elements between current position and first position +-- at which parser matches (fails if it never matches). Also +-- consumes the input on which the parser succeeds. +-- +-- @@ +-- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar." +-- Right 3 +-- λ> parseOnly (string "foo" *> spanTill (string ".")) "foobar" +-- Left "not enough input" +-- @@ +-- +spanTill :: A.Parser a -> A.Parser Int +spanTill p = liftA2 (flip (-)) position q + where + q = position <* p <|> A.anyWord8 *> q + +-- | Run the parser from the specified offset. +-- +-- Should only be used to seek backwards, otherwise +-- you could seek beyond the buffer. User beware. +-- +-- @@ +-- λ> parseOnly (seek 3 *> takeByteString) "foobar" +-- Right "bar" +-- @@ +-- +seek :: Int -> A.Parser () +seek pos = AT.Parser $ \t _pos more _lose win -> win t (AT.Pos pos) more () + +-- | Take until the parser matches (fails if it never matches). +-- +-- @@ +-- λ> parseOnly (takeTill' (string "bar") <* endOfInput) "foobar" +-- Right "foo" +-- @@ +-- +takeTill' :: A.Parser a -> A.Parser B.ByteString +takeTill' p = do + pos <- position + off <- spanTill p + newPos <- position + seek pos *> A.take off <* seek newPos + +-- | Number of elements between current position and first position +-- at which the pattern matches (fails if it never matches). Also +-- consumes the pattern. +-- +-- Uses Boyer-Moore algorithm to efficiently search the input. +-- +-- @@ +-- λ> parseOnly (string "foo" *> spanTillString ".") "foobar." +-- Right 3 +-- λ> parseOnly (string "foo" *> spanTillString ".") "foobar" +-- Left "not enough input" +-- @@ +-- +spanTillString :: B.ByteString -> A.Parser Int +spanTillString pat + | B.null pat = position + | otherwise = go + where + search = indices pat + go = do + start <- position + buf <- takeBuffer + case search buf of + (offset:_) -> + -- Pattern was found. Seek to end of pattern and return the span + seek (start + offset + B.length pat) $> offset + _ -> + -- We hit the end of the buffer without a match. Seek to + -- (length buf - length pat + 1), demand more input and go again. + seek (B.length buf - B.length pat + 1) *> A.demandInput *> go + +-- | Efficient skip, using Boyer-Moore to locate the pattern. +-- +-- @@ +-- λ> parseOnly (string "foo" *> skipTillString "." *> endOfInput) "foobar." +-- Right () +-- @@ +-- +skipTillString :: B.ByteString -> A.Parser () +skipTillString = void . spanTillString + +-- | Efficient take, using Boyer-Moore to locate the pattern. +-- +-- @@ +-- λ> parseOnly (takeTillString "bar" <* endOfInput) "foobar" +-- Right "foo" +-- @@ +-- +takeTillString :: B.ByteString -> A.Parser B.ByteString +takeTillString pat = do + pos <- position + off <- spanTillString pat + newPos <- position + seek pos *> A.take off <* seek newPos + +-- | /O(1)/ Take the rest of the buffer, but do not demand +-- any more input. +-- +takeBuffer :: A.Parser B.ByteString +takeBuffer = do + start <- position + end <- bufSize + A.take (end - start) + +bufSize :: forall t. AT.Chunk t => AT.Parser t Int +bufSize = AT.Parser $ + \t pos more _lose win -> + win t pos more + (AT.fromPos $ AT.atBufferEnd (undefined :: t) t) diff --git a/test-vectors/multipart-alternative.eml b/test-vectors/multipart-alternative.eml new file mode 100644 --- /dev/null +++ b/test-vectors/multipart-alternative.eml @@ -0,0 +1,24 @@ +From: Nathaniel Borenstein +To: Ned Freed +Date: Mon, 22 Mar 1993 09:41:09 -0800 (PST) +Subject: Formatted text mail +MIME-Version: 1.0 +Content-Type: multipart/alternative; boundary=boundary42 + +--boundary42 +Content-Type: text/plain; charset=us-ascii + + ... plain text version of message goes here ... + +--boundary42 +Content-Type: text/enriched + + ... RFC 1896 text/enriched version of same message + goes here ... + +--boundary42 +Content-Type: application/x-whatever + + ... fanciest version of same message goes here ... + +--boundary42-- diff --git a/test-vectors/multipart-digest.eml b/test-vectors/multipart-digest.eml new file mode 100644 --- /dev/null +++ b/test-vectors/multipart-digest.eml @@ -0,0 +1,35 @@ +From: Moderator-Address +To: Recipient-List +Date: Mon, 22 Mar 1994 13:34:51 +0000 +Subject: Internet Digest, volume 42 +MIME-Version: 1.0 +Content-Type: multipart/mixed; + boundary="---- main boundary ----" + +------ main boundary ---- + + ...Introductory text or table of contents... + +------ main boundary ---- +Content-Type: multipart/digest; + boundary="---- next message ----" + +------ next message ---- + +From: someone-else +Date: Fri, 26 Mar 1993 11:13:32 +0200 +Subject: my opinion + + ...body goes here ... + +------ next message ---- + +From: someone-else-again +Date: Fri, 26 Mar 1993 10:07:13 -0500 +Subject: my different opinion + + ... another body goes here ... + +------ next message ------ + +------ main boundary ------ diff --git a/test-vectors/multipart-mixed.eml b/test-vectors/multipart-mixed.eml new file mode 100644 --- /dev/null +++ b/test-vectors/multipart-mixed.eml @@ -0,0 +1,24 @@ +From: Nathaniel Borenstein +To: Ned Freed +Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST) +Subject: Sample message +MIME-Version: 1.0 +Content-type: multipart/mixed; boundary="simple boundary" + +This is the preamble. It is to be ignored, though it +is a handy place for composition agents to include an +explanatory note to non-MIME conformant readers. + +--simple boundary + +This is implicitly typed plain US-ASCII text. +It does NOT end with a linebreak. +--simple boundary +Content-type: text/plain; charset=us-ascii + +This is explicitly typed plain US-ASCII text. +It DOES end with a linebreak. + +--simple boundary-- + +This is the epilogue. It is also to be ignored. diff --git a/tests/ContentTransferEncodings.hs b/tests/ContentTransferEncodings.hs new file mode 100644 --- /dev/null +++ b/tests/ContentTransferEncodings.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module ContentTransferEncodings where + +import Data.Word + +import Control.Lens (clonePrism, preview, review) +import qualified Data.ByteString as B + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.QuickCheck.Instances () + +import Data.MIME.Base64 (contentTransferEncodingBase64) +import Data.MIME.QuotedPrintable +import Data.MIME.Types + + +properties :: TestTree +properties = localOption (QuickCheckMaxSize 1000) $ + testGroup "codec properties" + [ testGroup "Content-Transfer-Encoding properties" + [ testProperty "base64 round-trip" + (prop_roundtrip contentTransferEncodingBase64) + , testProperty "quoted-printable round-trip" + (prop_roundtrip contentTransferEncodingQuotedPrintable) + , testProperty "base64 line length <= 76" + (prop_linelength contentTransferEncodingBase64) + , testProperty "quoted-printable line length <= 76" + (prop_linelength contentTransferEncodingQuotedPrintable) + ] + , testGroup "encoded-word codec properties" + [ testProperty "Q round-trip" (prop_roundtrip q) + , testProperty "Q does not contain spaces" (prop_notElem q 32 {- ' ' -}) + ] + ] + + +prop_roundtrip :: ContentTransferEncoding -> B.ByteString -> Bool +prop_roundtrip p s = preview (clonePrism p) (review (clonePrism p) s) == Just s + +prop_linelength :: ContentTransferEncoding -> B.ByteString -> Property +prop_linelength p s = + let + encoded = review (clonePrism p) s + prop = all ((<= 76) . B.length) (splitOnCRLF encoded) + in +#if ! MIN_VERSION_QuickCheck(2,12,0) + cover (B.length encoded > 100) 50 "long output" prop +#else + checkCoverage $ cover 50 (B.length encoded > 100) "long output" prop +#endif + +prop_notElem :: EncodedWordEncoding -> Word8 -> B.ByteString -> Bool +prop_notElem enc c = B.notElem c . review (clonePrism enc) + +splitOnCRLF :: B.ByteString -> [B.ByteString] +splitOnCRLF s = + let (l, r) = B.breakSubstring "\r\n" s + in + if B.null r + then [l] + else l : splitOnCRLF (B.drop 2 r) diff --git a/tests/Generator.hs b/tests/Generator.hs new file mode 100644 --- /dev/null +++ b/tests/Generator.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Generator where + +import Test.Tasty +import Test.QuickCheck.Instances () +import Test.Tasty.HUnit ((@=?), testCase) +import Test.Tasty.Golden (goldenVsStringDiff) +import Control.Lens (over, (&), set, at) +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Lazy as LB +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) +import Data.Time.Calendar (Day(..)) + +import qualified Data.CaseInsensitive as CI + +import Data.MIME + +properties :: TestTree +properties = + testGroup + "message rendering tests" + [ renderSimpleMailSuccessfully + , rendersMultiPartSuccessfully + , exampleMailsParseSuccessfully + ] + +renderSimpleMailSuccessfully :: TestTree +renderSimpleMailSuccessfully = + goldenVsStringDiff + "renders simple mail" + diffCommand + "tests/golden/textplain7bit.golden" + (pure $ LB.fromStrict $ renderMessage textPlain7bit) + +diffCommand :: FilePath -> FilePath -> [String] +diffCommand ref new = + [ "diff" + , "--minimal" + , "--unified" + , ref + , new] + +rendersMultiPartSuccessfully :: TestTree +rendersMultiPartSuccessfully = + goldenVsStringDiff + "renders simple, multi-part mail" + diffCommand + "tests/golden/multipart.golden" + (pure $ LB.fromStrict $ renderMessage multiPartMail) + +exampleMailsParseSuccessfully :: TestTree +exampleMailsParseSuccessfully = + testGroup "example test mails can be round tripped" $ + (\(desc,m) -> + testCase desc (Right m @=? parse (message mime) (renderMessage m))) <$> + inputs + where + inputs = [("simple mail", textPlain7bit), ("multi part mail", multiPartMail)] + +textPlain7bit :: MIMEMessage +textPlain7bit = + let m = createTextPlainMessage "This is a simple mail." + in over headers (\(Headers xs) -> Headers $ (CI.mk "Subject", "Hello there") : xs) m + +multiPartMail :: MIMEMessage +multiPartMail = + let from' = Mailbox (Just "Roman Joost") (AddrSpec "foo" (DomainDotAtom $ pure "bar.com")) + to' = Single $ Mailbox Nothing (AddrSpec "bar" (DomainDotAtom $ pure "bar.com")) + subject = "Hello there" + p = createTextPlainMessage "This is a simple mail." + a = createAttachment + contentTypeApplicationOctetStream + (Just "foo.bin") + "fileContentsASDF" + now = UTCTime (ModifiedJulianDay 123) (secondsToDiffTime 123) + in createMultipartMixedMessage "asdf" [p, a] + & set (headers . at "From") (Just $ renderMailboxes [from']) + . set (headers . at "To") (Just $ renderAddresses [to']) + . set (headers . at "Date") (Just $ renderRFC5422Date now) + . set (headers . at "Subject") (Just $ T.encodeUtf8 subject) diff --git a/tests/Headers.hs b/tests/Headers.hs new file mode 100644 --- /dev/null +++ b/tests/Headers.hs @@ -0,0 +1,310 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE OverloadedStrings #-} +module Headers where + +import Control.Lens +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.String (IsString) +import Data.Semigroup ((<>)) +import Data.Word (Word8) + +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString as B +import Data.ByteString.Lazy (toStrict) +import Data.Attoparsec.ByteString.Char8 (parseOnly) +import qualified Data.Attoparsec.Text as AText (parseOnly) +import qualified Data.ByteString.Builder as Builder +import qualified Data.CaseInsensitive as CI +import Data.Either (isLeft) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, (@=?), (@?=), testCase, Assertion) +import Test.Tasty.QuickCheck +import Test.QuickCheck.Instances () + +import Data.MIME +import qualified Data.RFC5322.Address.Text as AddressText (mailbox, address) + +renderField :: (CI.CI B.ByteString, B.ByteString) -> B.ByteString +renderField = toStrict . Builder.toLazyByteString . buildField + +unittests :: TestTree +unittests = testGroup "Headers" + [ parsesMailboxesSuccessfully + , parsesTextMailboxesSuccessfully + , parsesAddressesSuccessfully + , parsesTextAddressesSuccessfully + , testRenderMailboxes + , rendersFieldsSuccessfully + , ixAndAt + , contentTypeTests + , parameterTests + , testReferencesField + , testProperty "field rendering round-trip" prop_renderHeadersRoundtrip + , testProperty "folded fields no longer than 78 chars" prop_foldedUnstructuredLimited + ] + +rendersFieldsSuccessfully :: TestTree +rendersFieldsSuccessfully = + testGroup "correct folding for unstructured" $ + (\(description,h,expected) -> + testCase description (expected @=? renderField h)) <$> + inputs + where + inputs = + [ ( "no folding" + , ("Subject", "Re: Simple Subject") + , "Subject: Re: Simple Subject\r\n") + , ( "continuous line" + , ("Subject", "ThisisalongcontiniousLineWithoutAnyWhiteSpaceandNowSomeGarbageASDFASDFASDFASDF") + , "Subject: \r\n ThisisalongcontiniousLineWithoutAnyWhiteSpaceandNowSomeGarbageASDFASDFASDFASDF\r\n") + , ( "folding" + , ( "Received" + , "from adsl-33-138-215-182-129-129.test.example ([XX.XX.XXX.XXX]) by this.is.another.hostname.example with esmtp (Exim 4.24) id 1Akwaj-00035l-NT for me@test.example; Sun, 25 2004 21:35:09 -0500") + , "Received: from adsl-33-138-215-182-129-129.test.example ([XX.XX.XXX.XXX])\r\n by this.is.another.hostname.example with esmtp (Exim 4.24) id\r\n 1Akwaj-00035l-NT for me@test.example; Sun, 25 2004 21:35:09 -0500\r\n") + , ( "folding with long words" + , ( "X-Test" , "these are short words and more and more and more and all asdfsdf of a suddenALongWordAppears") + , "X-Test: these are short words and more and more and more and all asdfsdf of\r\n a suddenALongWordAppears\r\n") + ] + +testRenderMailboxes :: TestTree +testRenderMailboxes = testCase "test renderMailboxes" $ + renderMailboxes xs @?= "\"Roman Joost\" , bar@bar.com" + where + xs = [ Mailbox (Just "Roman Joost") (AddrSpec "foo" (DomainDotAtom ("bar" :| ["com"]))) + , Mailbox Nothing (AddrSpec "bar" (DomainDotAtom ("bar" :| ["com"]))) + ] + +-- | Note some examples are taken from https://tools.ietf.org/html/rfc3696#section-3 +mailboxFixtures :: IsString s => [(String, Either String Mailbox -> Assertion, s)] +mailboxFixtures = + [ ( "address with FQDN" + , (Right (Mailbox Nothing (AddrSpec "foo" (DomainDotAtom $ pure "bar.com"))) @=?) + , "foo@bar.com") + , ( "just with a host name" + , (Right (Mailbox Nothing (AddrSpec "foo" (DomainDotAtom $ pure "bar"))) @=?) + , "foo@bar") + , ( "domain as IPv4" + , (Right (Mailbox (Just "roman") (AddrSpec "roman" (DomainLiteral "192.168.1.1"))) @=?) + , "roman ") + , ( "domain as IPv6" + , (Right (Mailbox (Just "roman") (AddrSpec "roman" (DomainLiteral "::1"))) @=?) + , "roman ") + , ( "without TLD" + , (Right (Mailbox Nothing (AddrSpec "roman" (DomainDotAtom $ pure "host"))) @=?) + , "roman@host") + , ( "with quotes in local-part" + , (Right (Mailbox Nothing (AddrSpec "roman" (DomainDotAtom $ pure "host"))) @=?) + , "\"roman\"@host") + , ( "quoted localpart with @" + , (Right (Mailbox Nothing (AddrSpec "Abc@def" (DomainDotAtom $ pure "host"))) @=?) + , "\"Abc\\@def\"@host") + , ( "whitespace in quoted local-part" + , (Right (Mailbox Nothing (AddrSpec "Mr Whitespace" (DomainDotAtom $ pure "host"))) @=?) + , "\"Mr Whitespace\"@host") + , ( "special chars in local-part" + , (Right (Mailbox Nothing (AddrSpec "customer/department=shipping" (DomainDotAtom $ pure "host"))) @=?) + , "") + , ( "special chars in local-part" + , (Right (Mailbox Nothing (AddrSpec "!def!xyz%abc" (DomainDotAtom $ pure "host"))) @=?) + , "!def!xyz%abc@host") + , ( "garbled address" + , assertBool "Parse error expected" . isLeft + , "fasdf@") + , ( "wrong: comma in front of domain" + , assertBool "Parse error expected" . isLeft + , "foo@,bar,com") + ] + +parsesMailboxesSuccessfully :: TestTree +parsesMailboxesSuccessfully = + testGroup "parsing mailboxes" $ + (\(desc,f,input) -> + testCase desc $ f (AText.parseOnly AddressText.mailbox input)) <$> + mailboxFixtures + +parsesTextMailboxesSuccessfully :: TestTree +parsesTextMailboxesSuccessfully = + testGroup "parsing mailboxes (text)" $ + (\(desc,f,input) -> + testCase desc $ f (parseOnly mailbox input)) <$> + mailboxFixtures + +addresses :: IsString s => [(String, Either String Address -> Assertion, s)] +addresses = + [ ( "single address" + , (Right (Single (Mailbox Nothing (AddrSpec "foo" (DomainDotAtom $ pure "bar.com")))) @=?) + , "") + , ( "group of addresses" + , (Right + (Group + "Group" + [ Mailbox (Just "Mr Foo") (AddrSpec "foo" (DomainDotAtom $ pure "bar.com")) + , Mailbox (Just "Mr Bar") (AddrSpec "bar" (DomainDotAtom $ pure "bar.com"))]) @=?) + , "Group: \"Mr Foo\" , \"Mr Bar\" ;") + , ( "group of undisclosed recipients" + , (Right (Group "undisclosed-recipients" []) @=?) + , "undisclosed-recipients:;") + ] + +parsesAddressesSuccessfully :: TestTree +parsesAddressesSuccessfully = + testGroup "parsing addresses" $ + (\(desc,f,input) -> testCase desc $ f (parseOnly address input)) + <$> addresses + +parsesTextAddressesSuccessfully :: TestTree +parsesTextAddressesSuccessfully = + testGroup "parsing addresses (text)" $ + (\(desc,f,input) -> testCase desc $ f (AText.parseOnly AddressText.address input)) + <$> addresses + +-- | Sanity check Ixed and At instances +ixAndAt :: TestTree +ixAndAt = testGroup "Ix and At instances" + [ testCase "set header" $ + set (at "content-type") (Just "text/plain") empty @?= textPlain + , testCase "set header (multiple)" $ + set (at "content-type") (Just "text/html") multi + @?= Headers [("Content-Type", "text/html"), ("Content-Type", "text/plain")] + , testCase "update header (case differs)" $ + set (at "content-type") (Just "text/html") textPlain @?= textHtml + , testCase "delete header (one)" $ + sans "content-type" textPlain @?= empty + , testCase "delete header (one)" $ + sans "content-type" textPlain @?= empty + , testCase "delete header (multiple)" $ + sans "content-type" multi @?= textPlain + , testCase "delete header (no match)" $ + sans "subject" textPlain @?= textPlain + , testCase "ix targets all" $ + toListOf (ix "content-type") multi @?= ["foo/bar", "text/plain"] + ] + + +contentTypeTests :: TestTree +contentTypeTests = testGroup "Content-Type header" + [ testCase "parsing header" $ + view contentType textHtml @?= ctTextHtml + , testCase "no header yields default" $ + view contentType empty @?= defaultContentType + , testCase "set when undefined" $ + set contentType ctTextHtml empty @?= textHtml + , testCase "set when defined (update)" $ + set contentType ctTextHtml textPlain @?= textHtml + , testCase "update undefined content type" $ + over (contentType . parameterList) (("foo","bar"):) empty @?= defaultFoobar + , testCase "update defined content type" $ + over (contentType . parameterList) (("foo","bar"):) textHtml @?= textHtmlFoobar + ] + where + ctTextHtml = ContentType "text" "html" (Parameters []) + +empty, textPlain, textHtml, multi, defaultFoobar, textHtmlFoobar :: Headers +empty = Headers [] +textPlain = Headers [("Content-Type", "text/plain")] +textHtml = Headers [("Content-Type", "text/html")] +multi = Headers [("Content-Type", "foo/bar"), ("Content-Type", "text/plain")] +defaultFoobar = Headers [("Content-Type", "text/plain; foo=bar; charset=us-ascii")] +textHtmlFoobar = Headers [("Content-Type", "text/html; foo=bar")] + +parameterTests :: TestTree +parameterTests = testGroup "parameter handling" + [ testCase "RFC 2231 §3 example" $ + view (contentType . parameter "url") + (Headers [("Content-Type", "message/external-body; access-type=URL; URL*0=\"ftp://\"; URL*1=\"cs.utk.edu/pub/moore/bulk-mailer/bulk-mailer.tar\"")]) + @?= Just (ParameterValue Nothing Nothing "ftp://cs.utk.edu/pub/moore/bulk-mailer/bulk-mailer.tar") + , testCase "RFC 2231 §4 example" $ + view (contentType . parameter "title") + (Headers [("Content-Type", "application/x-stuff; title*=us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A")]) + @?= Just (ParameterValue (Just "us-ascii") (Just "en-us") "This is ***fun***") + , testCase "RFC 2231 §4.1 example" $ + view (contentType . parameter "title") + (Headers [("Content-Type", "application/x-stuff; title*0*=us-ascii'en'This%20is%20even%20more%20; title*1*=%2A%2A%2Afun%2A%2A%2A%20; title*2=\"isn't it!\"")]) + @?= Just (ParameterValue (Just "us-ascii") (Just "en") "This is even more ***fun*** isn't it!") + , testCase "set filename parameter in Content-Disposition" $ + set (contentDisposition . parameter "filename") (Just (ParameterValue Nothing Nothing "foo.pdf")) + (Headers [("Content-Disposition", "attachment")]) + @?= Headers [("Content-Disposition", "attachment; filename=foo.pdf")] + , testCase "unset filename parameter in Content-Disposition" $ + set (contentDisposition . parameter "filename") Nothing + (Headers [("Content-Disposition", "attachment; foo=bar; filename=foo.pdf")]) + @?= Headers [("Content-Disposition", "attachment; foo=bar")] + ] + +-- RFC5322 - 3.6.4. Identification Fields +testReferencesField :: TestTree +testReferencesField = + testGroup "references field in reply" $ + (\(desc, hdrs, expected) -> + testCase desc $ expected @=? view replyHeaderReferences hdrs) <$> + fixtures + where + fixtures = + [ ("no ident fields", empty, Nothing) + , ( "messageid only" + , empty & set (at "message-id") (Just "asdf") + , Just "asdf") + , ( "references only" + , empty & set (at "references") (Just "references") + , Just "references") + , ( "references & message id" + , empty & + set (at "references") (Just "references") . + set (at "message-id") (Just "messageid") + , Just "references messageid") + , ( "in-reply-to and no references" + , empty & set (at "in-reply-to") (Just "replyto") + , Just "replyto") + , ( "in-reply-to and message-id" + , empty & + set (at "in-reply-to") (Just "replyto") . + set (at "message-id") (Just "message-id") + , Just "replyto message-id") + , ( "in-reply-to and references" + , empty & + set (at "in-reply-to") (Just "replyto") . + set (at "references") (Just "references") . + set (at "message-id") (Just "messageid") + , Just "references messageid") + ] + +multipleMailboxes :: [Mailbox] +multipleMailboxes = + [ Mailbox (Just "Mr Bar") (AddrSpec "bar" (DomainDotAtom $ pure "bar.com")) + , Mailbox Nothing (AddrSpec "roman" (DomainDotAtom $ pure "mail.test"))] + +-- | Generate headers +genFieldItem :: Gen B.ByteString +genFieldItem = resize 55 $ listOf1 (suchThat arbitrary isFtext) >>= pure . B.pack + +isFtext :: Word8 -> Bool +isFtext c = (c >= 33 && c <= 57) || (c >= 59 && c <= 126) + +-- * generate a growing list of words +-- * join all words by a whitespace +-- +genFieldBody :: Gen B.ByteString +genFieldBody = do + nonWspStart <- suchThat arbitrary vchar + t <- listOf1 $ resize 30 $ listOf1 (suchThat arbitrary vchar) + pure (nonWspStart `B.cons` foldl (\acc x -> acc <> " " <> B.pack x) B.empty t) -- urks that's going to be costly + +vchar :: Word8 -> Bool +vchar c = c >= 33 && c <= 126 + +genField :: Gen (CI.CI B.ByteString, B.ByteString) +genField = (,) <$> (CI.mk <$> genFieldItem) <*> genFieldBody + +newtype MailHeaders = MailHeaders { unHeader :: (CI.CI B.ByteString, B.ByteString)} + deriving (Show) + +instance Arbitrary MailHeaders where + arbitrary = MailHeaders <$> genField + +prop_renderHeadersRoundtrip :: MailHeaders -> Bool +prop_renderHeadersRoundtrip h = parse field (renderField (unHeader h)) == Right (unHeader h) + +prop_foldedUnstructuredLimited :: MailHeaders -> Bool +prop_foldedUnstructuredLimited h = let xs = BC.lines $ renderField (unHeader h) + in all (== True) ((\x -> B.length x <= 78) <$> xs) diff --git a/tests/MIME.hs b/tests/MIME.hs new file mode 100644 --- /dev/null +++ b/tests/MIME.hs @@ -0,0 +1,135 @@ +-- This file is part of purebred-email +-- Copyright (C) 2018 Fraser Tweedale +-- +-- purebred-email is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero 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 Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +module MIME where + +import Data.Char (toUpper) + +import Control.Lens +import qualified Data.Text as T + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) +import Test.Tasty.QuickCheck +import Test.QuickCheck.Instances () + +import Data.MIME + +unittests :: TestTree +unittests = + testGroup "content disposition" + [ testCase "read empty (plain; should fail)" $ + preview lFilename + (Message (Headers [("Content-Disposition", "attachment; filename=")]) (Part "")) + @?= Nothing + , testCase "read empty (quoted)" $ + preview lFilename + (Message (Headers [("Content-Disposition", "attachment; filename=\"\"")]) (Part "")) + @?= Just "" + , testCase "read empty (extended)" $ + preview lFilename + (Message (Headers [("Content-Disposition", "attachment; filename*=''")]) (Part "")) + @?= Just "" + , testCase "read plain" $ + preview lFilename + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Just "foo.pdf" + , testCase "read quoted" $ + preview lFilename + (Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part "")) + @?= Just "/tmp/foo.pdf" + , testCase "set quoted (empty string)" $ + (view headers . set lFilename "") + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Headers [("Content-Disposition", "attachment; filename=\"\"")] + , testCase "set quoted (space char)" $ + (view headers . set lFilename "hello world.txt") + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Headers [("Content-Disposition", "attachment; filename=\"hello\\ world.txt\"")] + , testCase "set quoted (backslash char)" $ + (view headers . set lFilename "hello\\world.txt") + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Headers [("Content-Disposition", "attachment; filename=\"hello\\\\world.txt\"")] + , testCase "set quoted (=)" $ + (view headers . set lFilename "hello=world.txt") + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Headers [("Content-Disposition", "attachment; filename=\"hello=world.txt\"")] + , testCase "set quoted (\")" $ + (view headers . set lFilename "hello\"world\".txt") + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Headers [("Content-Disposition", "attachment; filename=\"hello\\\"world\\\".txt\"")] + , testCase "modify plain -> plain" $ + (preview lFilename . over lFilename (T.drop 1)) + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Just "oo.pdf" + , testCase "modify plain -> quoted" $ + (preview lFilename . over lFilename (T.map (\c -> if c == '.' then '\\' else c))) + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + @?= Just "foo\\pdf" + , testCase "modify quoted -> plain" $ + (preview lFilename . over lFilename stripPath) + (Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part "")) + @?= Just "foo.pdf" + , testCase "modify quoted -> quoted" $ + (preview lFilename . over lFilename (T.map toUpper)) + (Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part "")) + @?= Just "/TMP/FOO.PDF" + , testCase "set extended (utf-8; raw)" $ + (view headers . set lFilename "hello世界.txt") + (Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part "")) + @?= Headers [("Content-Disposition", "attachment; filename*=utf-8''hello%E4%B8%96%E7%95%8C.txt")] + , testCase "set extended (utf-8; readback)" $ + (preview lFilename . set lFilename "hello世界.txt") + (Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part "")) + @?= Just "hello世界.txt" + , testCase "set extended (us-ascii; charset omitted; raw)" $ + -- control characters will force it to use percent-encoded extended param, + -- but all chars are in us-ascii so charset should be omitted + (view headers . set lFilename "new\nline") + (Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part "")) + @?= Headers [("Content-Disposition", "attachment; filename*=''new%0Aline")] + , testCase "set extended (us-ascii; charset omitted; readback)" $ + -- control characters will force it to use percent-encoded extended param, + -- but all chars are in us-ascii so charset should be omitted + (preview lFilename . set lFilename "new\nline") + (Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part "")) + @?= Just "new\nline" + , testProperty "filename round-trip" $ \s -> + (preview lFilename . set lFilename s) + (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")) + == Just s + , testCase "unset multiple filenames" $ + set (attachments . headers . contentDisposition . filenameParameter) Nothing + (Message (Headers []) (Multipart + [ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "") + , Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "") + , Message (Headers [("Content-Disposition", "attachment; filename=bar.pdf")]) (Part "") + ] + )) + @?= + Message (Headers []) (Multipart + [ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "") + , Message (Headers [("Content-Disposition", "attachment")]) (Part "") + , Message (Headers [("Content-Disposition", "attachment")]) (Part "") + ] + ) + ] + where + lFilename = headers . contentDisposition . filename + stripPath = snd . T.breakOnEnd "/" diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,16 @@ +import Test.Tasty +import Test.Tasty.QuickCheck + +import ContentTransferEncodings as CTE +import MIME +import Headers +import Generator + +main :: IO () +main = + defaultMain $ testGroup "Tests" + [ CTE.properties + , Headers.unittests + , Generator.properties + , MIME.unittests + ] diff --git a/tests/golden/multipart.golden b/tests/golden/multipart.golden new file mode 100644 --- /dev/null +++ b/tests/golden/multipart.golden @@ -0,0 +1,23 @@ +From: "Roman Joost" +To: bar@bar.com +Date: Sun, 20 Mar 1859 00:02:03 +0000 +Subject: Hello there +Content-Type: multipart/mixed; boundary=asdf +MIME-Version: 1.0 + +--asdf +Content-Type: text/plain +Content-Disposition: inline; charset=utf-8 +Content-Transfer-Encoding: 7bit +MIME-Version: 1.0 + +This is a simple mail. +--asdf +Content-Type: application/octet-stream +Content-Disposition: attachment; filename=foo.bin +Content-Transfer-Encoding: base64 +MIME-Version: 1.0 + +ZmlsZUNvbnRlbnRzQVNERg== + +--asdf-- diff --git a/tests/golden/textplain7bit.golden b/tests/golden/textplain7bit.golden new file mode 100644 --- /dev/null +++ b/tests/golden/textplain7bit.golden @@ -0,0 +1,7 @@ +Subject: Hello there +Content-Type: text/plain +Content-Disposition: inline; charset=utf-8 +Content-Transfer-Encoding: 7bit +MIME-Version: 1.0 + +This is a simple mail. diff --git a/tools/Parse.hs b/tools/Parse.hs new file mode 100644 --- /dev/null +++ b/tools/Parse.hs @@ -0,0 +1,53 @@ +{- + +Parse all mail files given (linewise by filename) on stdin. +Print filenames that had parse failures, along with an attempted +diagnosis of the problem. + +-} + +import Data.Foldable (traverse_) +import Data.Semigroup ((<>)) +import System.Environment (getArgs) + +import qualified Data.ByteString as B +import Data.MIME + + +main :: IO () +main = do + files <- lines <$> getContents + fileFilter <- processOpts . pairwise <$> getArgs + traverse_ parseMail (fileFilter files) + +parseMail :: FilePath -> IO () +parseMail filename = do + msgData <- B.readFile filename + case parse (message mime) msgData of + Left e -> putStrLn (filename <> " (" <> e <> ") " <> analyse msgData) + Right _ -> pure () + +analyse :: B.ByteString -> String +analyse s = fst $ head $ filter snd $ fmap (fmap ($ s)) tests + where + tests = + [ ("non-ascii chars", B.any (> 127)) + , ("unknown", const True) + ] + +pairwise :: [a] -> [(a, a)] +pairwise (k:v:t) = (k, v) : pairwise t +pairwise (_:_) = error "uneven number of args" +pairwise [] = [] + +-- Process options, returning a function for how to filter +-- the list of files +-- +-- Recognised options: +-- +-- ("-l", N) -> limit to first N files in inputs +-- +processOpts :: [(String, String)] -> ([String] -> [String]) +processOpts [] = id +processOpts (("-l", s):t) = take (read s) . processOpts t +processOpts (opt:_) = error ("unrecognised option: " <> show opt)