packages feed

purebred-email (empty) → 0.1.0.0

raw patch · 29 files changed

+4290/−0 lines, 29 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, base64-bytestring, bytestring, case-insensitive, concise, deepseq, lens, purebred-email, quickcheck-instances, semigroupoids, semigroups, stringsearch, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, text, time

Files

+ LICENSE view
@@ -0,0 +1,661 @@+                    GNU AFFERO GENERAL PUBLIC LICENSE+                       Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ 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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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 <http://www.gnu.org/licenses/>.++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+<http://www.gnu.org/licenses/>.
+ README.rst view
@@ -0,0 +1,1 @@+Email handling library.  Groks RFC 5322 and MIME.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ purebred-email.cabal view
@@ -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
+ src/Data/MIME.hs view
@@ -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+-- <https://tools.ietf.org/html/rfc2045#section-5.2>.+--+-- If the Content-Transfer-Encoding is unrecognised, the+-- actual Content-Type value is ignored and+-- @application/octet-stream@ is returned, as required by+-- <https://tools.ietf.org/html/rfc2049#section-2>.+--+-- 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\\" <roman@192.168.1.1>")]+-- @+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
+ src/Data/MIME/Base64.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++{- |++Implementation of Base64 Content-Transfer-Encoding.++<https://tools.ietf.org/html/rfc2045#section-6.8>++-}+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)
+ src/Data/MIME/Charset.hs view
@@ -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
+ src/Data/MIME/EncodedWord.hs view
@@ -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)
+ src/Data/MIME/Error.hs view
@@ -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
+ src/Data/MIME/Internal.hs view
@@ -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)+    )
+ src/Data/MIME/Parameter.hs view
@@ -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*<any (US-ASCII) CHAR except SPACE, CTLs, or tspecials>+  --  tspecials :=  "(" / ")" / "<" / ">" / "@" /+  --                "," / ";" / ":" / "\" / <">+  --                "/" / "[" / "]" / "?" / "="+  --+  -- extended-parameter:+  --  attribute-char := <any (US-ASCII) CHAR except SPACE, CTLs, "*", "'", "%", or tspecials>+  --  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
+ src/Data/MIME/QuotedPrintable.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++{- |++Implementation of Quoted-Printable Content-Transfer-Encoding.++<https://tools.ietf.org/html/rfc2045#section-6.7>++-}+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
+ src/Data/MIME/TransferEncoding.hs view
@@ -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
+ src/Data/MIME/Types.hs view
@@ -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
+ src/Data/RFC5322.hs view
@@ -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 #-}
+ src/Data/RFC5322/Address/Text.hs view
@@ -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))
+ src/Data/RFC5322/Address/Types.hs view
@@ -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)
+ src/Data/RFC5322/Internal.hs view
@@ -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)
+ test-vectors/multipart-alternative.eml view
@@ -0,0 +1,24 @@+From: Nathaniel Borenstein <nsb@bellcore.com>+To: Ned Freed <ned@innosoft.com>+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--
+ test-vectors/multipart-digest.eml view
@@ -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 ------
+ test-vectors/multipart-mixed.eml view
@@ -0,0 +1,24 @@+From: Nathaniel Borenstein <nsb@bellcore.com>+To: Ned Freed <ned@innosoft.com>+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.
+ tests/ContentTransferEncodings.hs view
@@ -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)
+ tests/Generator.hs view
@@ -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)
+ tests/Headers.hs view
@@ -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\" <foo@bar.com>, 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 <roman@[192.168.1.1]>")+    , ( "domain as IPv6"+      , (Right (Mailbox (Just "roman") (AddrSpec "roman" (DomainLiteral "::1"))) @=?)+      , "roman <roman@[::1]>")+    , ( "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"))) @=?)+      , "<customer/department=shipping@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")))) @=?)+      , "<foo@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\" <foo@bar.com>, \"Mr Bar\" <bar@bar.com>;")+    , ( "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)
+ tests/MIME.hs view
@@ -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 <http://www.gnu.org/licenses/>.++{-# 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 "/"
+ tests/Test.hs view
@@ -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+    ]
+ tests/golden/multipart.golden view
@@ -0,0 +1,23 @@+From: "Roman Joost" <foo@bar.com>
+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--
+ tests/golden/textplain7bit.golden view
@@ -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.
+ tools/Parse.hs view
@@ -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)