MissingH-1.6.0.1/0000755000000000000000000000000007346545000011567 5ustar0000000000000000MissingH-1.6.0.1/3rd-party-licenses/0000755000000000000000000000000007346545000015217 5ustar0000000000000000MissingH-1.6.0.1/3rd-party-licenses/BSD0000644000000000000000000000300307346545000015546 0ustar0000000000000000Copyright (c) The Regents of the University of California. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # arch-tag: 3-clause BSD license text MissingH-1.6.0.1/3rd-party-licenses/LGPL-2.10000644000000000000000000006370207346545000016206 0ustar0000000000000000 GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, 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 this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), 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 distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser 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 Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "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 LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY 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 LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! # arch-tag: LGPL 2.1 license text MissingH-1.6.0.1/CHANGES.md0000644000000000000000000000471307346545000013166 0ustar0000000000000000# 1.6.0.1 _Andreas Abel, 2023-09-11_ - Repair build on Windows with GHC 9.6 (`directory-1.3.8.*`): Revoke `Safe` status of these modules: * `System.IO.WindowsCompat` * `System.IO.PlafCompat` - Tested with GHC 7.10 - 9.8 alpha1. # 1.6.0.0 _Andreas Abel, 2023-01-14_ - Allow `directory-1.3.8.0` which is no longer `Safe` Haskell. Thus, we need to revoke `Safe` status of the following modules: * `Data.MIME.Types` * `Network.Email.Sendmail` * `System.IO.HVFS` * `System.IO.HVFS.Combinators` * `System.IO.HVFS.InstanceHelpers` * `System.Path` * `System.Path.Glob` * `System.Path.NameManip` - Allow `unix-2.8.0.0` (enables `directory-1.3.8.0`). - Tested with GHC 7.10 - 9.6 alpha1. ### 1.5.0.1 _Andreas Abel, 2022-03-14_ - Repair build on Windows (regression in 1.5.0.0, [#59](https://github.com/haskell-hvr/missingh/issues/59)). - Tested with GHC 7.10 - 9.2. # 1.5.0.0 _Andreas Abel, 2022-02-12_ - Dropped support for GHC ≤ 7.8. - Support `mtl-2.3`: removed `Error` instance for `BinPackerError` and `GZipError`. - Use `sortOn` in `packLargeFirst` ([#41](https://github.com/haskell-hvr/missingh/issues/41)). - Fix warnings for `-Wall` and `-Wcompat`. - Hardened code by making all imports explicit. - Tested with GHC 7.10 - 9.2. ### 1.4.3.1 _Andreas Abel, 2022-02-12_ - Remove spurious dependency on `random`. - Bump upper bounds on `base` and `time`. - Tested with GHC 7.0 - 9.2. ## 1.4.3.0 _Herbert Valerio Riedel, 2020-04-09_ - New tuple construction helpers `Data.Tuple.Utils.dup` and `Data.Tuple.Utils.triple` - Close sockets on connection failure in `connectTCPAddr` ([#50](https://github.com/haskell-hvr/missingh/issues/50)) ### 1.4.2.1 _Herbert Valerio Riedel, 2019-05-20_ - GHC 7.0 only compat release ## 1.4.2.0 _Herbert Valerio Riedel, 2019-05-14_ - Fix regression (introduced in 1.4.1.0 release) in `Data.Compression.Inflate` - Drop redundant dependency on `HUnit` - Add more explicit `SafeHaskell` annotations to modules; all modules except for `System.Debian` are now explicitly either `Safe` or `Trustworthy` - Add support for `network-3.0` and `network-3.1` ## 1.4.1.0 _John Goerzen, 2018-10-13_ - Support for GHC 8.6.1 / `base-4.12` ([#45](https://github.com/haskell-hvr/missingh/issues/45)) ### 1.4.0.1 _John Goerzen, 2016-06-15_ - Restore compatibility with GHC 7.4.2 # 1.4.0.0 _John Goerzen, 2016-06-29_ - Removal of `Data.Hash.CRC32.Posix` and `System.Time.Utils.ParseDate` - Added explicit `SafeHaskell` annotations to modules MissingH-1.6.0.1/LICENSE0000644000000000000000000000633407346545000012602 0ustar0000000000000000Copyright (c) 2004 - 2011 John Goerzen All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of John Goerzen nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ============================================================================ Special Notes for Included Code ============================================================================ If you split out the parts originally from other authors, and use them completely independently of the rest of the library, you may treat them under the licenses shown below. ---------------------------------------------------- Portions of System.Path come from Volker Wysk's HsShellScript library, version 2.1.0. That code is Copyright (c) 2004 Volker Wysk and was originally licensed under the GNU LGPL 2.1. Volker gave permission on Aug. 10, 2011, to John Goerzen to relicense it under the same 3-clause BSD license as MissingH itself. ---------------------------------------------------- Data.Compression.Inflate is Copyright 2004 Ian Lynagh Licence: 3 clause BSD. Debian GNU/Linux users may find the 3-clause BSD license at /usr/share/common-licenses/BSD. Alternatively, you may find it at 3rd-party-licenses/BSD. Please note that the University of California has no claim on this code; simply substitute Ian Lynagh for the University wherever it may occur in that file. The code was obtained from http://urchin.earth.li/darcs/ian/inflate/Inflate.lhs ---------------------------------------------------- Data.Hash.MD5* is Copyright 2001 Ian Lynagh Licence: GPL or 3 clause BSD Debian GNU/Linux users may find the 3-clause BSD license at /usr/share/common-licenses/BSD. Alternatively, you may find it at 3rd-party-licenses/BSD. Please note that the University of California has no claim on this code; simply substitute Ian Lynagh for the University wherever it may occur in that file. The code was obtained from http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/md5/ MissingH-1.6.0.1/MissingH.cabal0000644000000000000000000001107307346545000014276 0ustar0000000000000000cabal-version: 1.12 name: MissingH version: 1.6.0.1 build-type: Simple license: BSD3 author: John Goerzen copyright: Copyright (c) 2004-2018 John Goerzen maintainer: Andreas Abel license-file: LICENSE tested-with: GHC == 9.8.0 GHC == 9.6.2 GHC == 9.4.7 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4 GHC == 8.6.5 GHC == 8.4.4 GHC == 8.2.2 GHC == 8.0.2 GHC == 7.10.3 synopsis: Large utility library description: @MissingH@ is a library of all sorts of utility functions for Haskell programmers. It is written in pure Haskell and thus should be extremely portable and easy to use. category: Unclassified bug-reports: https://github.com/haskell-hvr/missingh/issues extra-source-files: CHANGES.md LICENSE announcements/0.10.0.txt announcements/0.8.0.txt announcements/0.9.0.txt testsrc/gzfiles/empty.gz testsrc/gzfiles/t1.gz testsrc/gzfiles/t1bad.gz testsrc/gzfiles/t2.gz testsrc/gzfiles/zeros.gz testsrc/mime.types.test 3rd-party-licenses/BSD 3rd-party-licenses/LGPL-2.1 examples/simplegrep.hs examples/test2.hs examples/test3.hs flag network--GE-3_0_0 description: [network](http://hackage.haskell.org/package/network) ≥ 3.0.0 default: True manual: False source-repository head type: git location: https://github.com/haskell-hvr/missingh.git library hs-source-dirs: src exposed-modules: Control.Concurrent.Thread.Utils Data.BinPacking Data.Bits.Utils Data.CSV Data.Compression.Inflate Data.Either.Utils Data.Hash.CRC32.GZip Data.Hash.MD5 Data.Hash.MD5.Zord64_HARD Data.List.Utils Data.MIME.Types Data.Map.Utils Data.Maybe.Utils Data.Progress.Meter Data.Progress.Tracker Data.Quantity Data.String.Utils Data.Tuple.Utils Network.Email.Mailbox Network.Email.Sendmail Network.SocketServer Network.Utils System.Cmd.Utils System.Console.GetOpt.Utils System.Daemon System.Debian System.Debian.ControlParser System.FileArchive.GZip System.IO.Binary System.IO.HVFS System.IO.HVFS.Combinators System.IO.HVFS.InstanceHelpers System.IO.HVFS.Utils System.IO.HVIO System.IO.PlafCompat System.IO.StatCompat System.IO.Utils System.IO.WindowsCompat System.Path System.Path.Glob System.Path.NameManip System.Path.WildMatch System.Posix.Consts System.Time.Utils Text.ParserCombinators.Parsec.Utils default-language: Haskell2010 default-extensions: ExistentialQuantification FlexibleContexts FlexibleInstances LambdaCase MultiParamTypeClasses Rank2Types ScopedTypeVariables UndecidableInstances other-extensions: CPP Safe Trustworthy TypeSynonymInstances build-depends: array >= 0.4.0.0 && < 0.6 , base >= 4.8.0.0 && < 5 , containers >= 0.4.2.1 && < 0.7 , directory >= 1.1.0.2 && < 1.4 , filepath >= 1.3.0.0 && < 1.5 , hslogger >= 1.3.0.0 && < 1.4 , mtl >= 1.1.1.0 && < 2.4 , old-locale == 1.0.* , old-time == 1.1.* , parsec == 3.1.* && (< 3.1.12 || >= 3.1.13) , process >= 1.1.0.1 && < 1.7 , regex-compat >= 0.95.1 && < 0.96 , time >= 1.4 && < 1.13 if flag(network--GE-3_0_0) build-depends: network-bsd >= 2.8.1 && <2.9, network >= 3.0 && <3.2 else build-depends: network >= 2.6.3.1 && <2.9 If !os(windows) Build-Depends: unix >= 2.5.1.0 && < 2.9 ghc-options: -Wall if impl(ghc >= 8) ghc-options: -Wcompat ---------------------------------------------------------------------------- test-suite runtests type: exitcode-stdio-1.0 hs-source-dirs: testsrc main-is: runtests.hs other-modules: TestUtils Bitstest CRC32GZIPtest Eithertest GZiptest Globtest HVFStest HVIOtest IOtest Listtest MIMETypestest Maptest Pathtest ProgressTrackertest Str.CSVtest Strtest Tests Timetest WildMatchtest default-language: Haskell2010 other-extensions: CPP -- intra-package dependency build-depends: MissingH -- deps with version bounds inherited via lib:MissingH component build-depends: base , containers , directory , filepath , old-time , parsec , regex-compat , time if !os(windows) build-depends: unix -- additional testsuite-specific dependencies build-depends: HUnit == 1.6.* if impl(ghc >= 8) ghc-options: -Wcompat MissingH-1.6.0.1/announcements/0000755000000000000000000000000007346545000014444 5ustar0000000000000000MissingH-1.6.0.1/announcements/0.10.0.txt0000644000000000000000000000454607346545000015732 0ustar0000000000000000MissingH 0.10.0 New feature summary: * Compatibility with Hugs 2005xx and GHC 6.4. Compatibility with GHC 6.2 has been retained. Compatibility with Hugs 2003xx is mostly retained but not completely possible. * Tighter integration with Cabal. * Better installation instructions. * New parser for debian/control files and similar Debian commands (does not require Debian to build/run) * New parser for CSV files * New utility for Maybe type * New binary I/O utilities (readBinaryFile, writeBinaryFile) * Powerful new list mainpulation functions: wholeMap, fixedWidth * New function: epochToClockTime ------------------------- What is MissingH? ------------------------- It's a collection of Haskell-related utilities. It is an extension of my earlier work developing MissingLib for OCaml. You can download MissingH from http://quux.org/devel/missingh. There is a mirror, with a few days' lag, at http://ftp.debian.org/debian/pool/main/m/missingh. ------------------------- Major Features ------------------------- * Powerful Logging Framework for Haskell This framework provides a system of hierarchical loggers and modular handlers permitting fine-grained logging with a great deal of control and yet a simple and fast interface. It's based on log4j for Java and logging for Python. Also included is a native-Haskell Syslog client. * Versatile modules to simplify everyday tasks: + FTP client library + E-mail client library + MIME types library to determine MIME types from files or URLs + Configuration file parser/generator * IO utilities make it easier to work with line-based text files and binary files * IO object virtualization so you can use one set of code to work on files of many different types * Filesystem virtualization so you can access variuos items with the same ease as your system's filesystem * Network utilities to streamline connections * List utilities including association list tools, list splitting, truncation, and delimiter joining * String utilities including removal of leading or trailing whitespace, joining, splitting, and truncation * Other utilities for threads, parers, filenames, etc. * Printf utilities for formatting strings * GZip decompression * Hundreds of unit tests to verify proper functionality * DBM module abstraction # arch-tag: 0.10.0 announcement MissingH-1.6.0.1/announcements/0.8.0.txt0000644000000000000000000000370407346545000015654 0ustar0000000000000000MissingH 0.8.0 -- the "Festive Lambda" release New feature summary: * Virtualized I/O system Use familiar functions to work on not just Handles but all sorts of other types, including in-memory buffers. (HVIO module) * Virtualized filesystem Extends the virtual I/O concept to the filesystem, supporting entire virtual filesystems, and operations such as renames, stat(), etc. on them. (HVFS module) * Network server infrastructure Makes it easy to write a network server in Haskell. Functional interface permits easy adding of things such as multithreading, logging, etc. Functions to do these things are provided. Patterned loosely after Python's SocketServer system. (SocketServer module) * Full, pure-Haskell FTP server Provides a full FTP server over a real or virtual (HVFS) filesystem. It's a SocketServer server, so you get multithreading for free. Supports passive eand port modes. See below for an example: * Many path/file manipulation functions imported from Volker's HsShellScript. * Existing MissingH.IO functions updated to be HVIO compatible. MissingH 0.8.0 is available from: gopher://gopher.quux.org/1/devel/missingh or http://gopher.quux.org:70/devel/missingh ------------------------------------------------------------ Here is an example of a fully self-contained FTP server that serves up the local filesystem in read-only mode: import MissingH.Network.FTP.Server import MissingH.Network.SocketServer import MissingH.Logging.Logger import MissingH.IO.HVFS import MissingH.IO.HVFS.Combinators main = do updateGlobalLogger "" (setLevel DEBUG) updateGlobalLogger "MissingH.Network.FTP.Server" (setLevel DEBUG) let opts = (simpleTCPOptions 12345) {reuse = True} serveTCPforever opts $ threadedHandler $ loggingHandler "" INFO $ handleHandler $ anonFtpHandler (HVFSReadOnly SystemFS) # arch-tag: 0.8.0 announcement MissingH-1.6.0.1/announcements/0.9.0.txt0000644000000000000000000000544007346545000015654 0ustar0000000000000000MissingH 0.9.0 New feature summary: * Perl-like regular expression operators (MissingH.Regex.Pesco) This module builds atop the standard POSIX Text.Regex module, extending it to be far more convenient with easier maching, grouping, and substitution operations. (Integrated from Pesco) * strToAL, strFomAL (MissingH.List) Converts any [(String, String)] and many other association lists to a simple string representation that can be stored on-disk or sent across the network. Also, re-generates the original list upon parsing the string representation. Used internally by MissingH.AnyDBM.StringDBM. * Persistent or non-persistent DBM storage class MissingH.AnyDBM is an abstraction for various mapping systems. MissingH itself provides an implementation using a non-persistent HashTable or FiniteMap, as well as a persistent StringDBM. Bindings to dbm, gdbm, dbhash, etc. are in the works and will be simple members of this typeclass. * Major cleaning up of the build system. Description of MissingH from README: ------------------------- What is MissingH? ------------------------- It's a collection of Haskell-related utilities. It is an extension of my earlier work developing MissingLib for OCaml. You can download MissingH from http://quux.org/devel/missingh. There is a mirror, with a few days' lag, at http://ftp.debian.org/debian/pool/main/m/missingh. ------------------------- Major Features ------------------------- * Powerful Logging Framework for Haskell This framework provides a system of hierarchical loggers and modular handlers permitting fine-grained logging with a great deal of control and yet a simple and fast interface. It's based on log4j for Java and logging for Python. Also included is a native-Haskell Syslog client. * Versatile modules to simplify everyday tasks: + FTP client library + E-mail client library + MIME types library to determine MIME types from files or URLs + Configuration file parser/generator * IO utilities make it easier to work with line-based text files and binary files * IO object virtualization so you can use one set of code to work on files of many different types * Filesystem virtualization so you can access variuos items with the same ease as your system's filesystem * Network utilities to streamline connections * List utilities including association list tools, list splitting, truncation, and delimiter joining * String utilities including removal of leading or trailing whitespace, joining, splitting, and truncation * Other utilities for threads, parers, filenames, etc. * Printf utilities for formatting strings * GZip decompression * Hundreds of unit tests to verify proper functionality * DBM module abstraction # arch-tag: 0.9.0 announcement MissingH-1.6.0.1/examples/0000755000000000000000000000000007346545000013405 5ustar0000000000000000MissingH-1.6.0.1/examples/simplegrep.hs0000644000000000000000000000022707346545000016111 0ustar0000000000000000import MissingH.List main = do c <- getContents putStr (unlines(filter (\line -> contains "Haskell" line) (lines c))) MissingH-1.6.0.1/examples/test2.hs0000644000000000000000000000171607346545000015007 0ustar0000000000000000-- example code 2 for socketserver import MissingH.Network.SocketServer import MissingH.IO import MissingH.Logging.Logger import Data.Char import System.IO import MissingH.Str lineInteraction :: [String] -> [String] lineInteraction inp = let realInteract :: [String] -> [String] realInteract [] = [] realInteract ("QUIT":_) = ["Goodbye!"] realInteract ("easeregg":_) = ["Yow!"] realInteract (x:xs) = map toUpper x : realInteract xs in ("Welcome to the uppercase server. I'll echo everything back to\n" ++ "you in uppercase. When done, just type \"QUIT\" to exit.\n") : realInteract (map rstrip inp) realhandler h = do hLineInteract h h lineInteraction hClose h handler = threadedHandler $ loggingHandler "main" INFO $ handleHandler $ realhandler main = do updateGlobalLogger "main" (setLevel DEBUG) serveTCPforever ((simpleInetOptions 12345) {reuse = True}) handler MissingH-1.6.0.1/examples/test3.hs0000644000000000000000000000304307346545000015003 0ustar0000000000000000-- example code 3 for socketserver import MissingH.Network.SocketServer import MissingH.IO import MissingH.Logging.Logger import Data.Char import System.IO import MissingH.Str import System.Time realhandler h = let loop = do e <- hIsEOF h if e then return () else do c <- hGetLine h case (rstrip c) of "QUIT" -> hPutStr h "Goodbye!\n" "COMMANDS" -> do hPutStrLn h "You can type TIME for the current time" loop "TIME" -> do ct <- getClockTime calt <- toCalendarTime ct hPutStrLn h $ calendarTimeToString calt loop x -> do hPutStrLn h (map toUpper x) loop in do hPutStrLn h "Welcome to the uppercase server. I'll echo" hPutStrLn h "everything back to you in uppercase. When done," hPutStrLn h "just type \"QUIT\" to exit." hPutStrLn h "You can also type \"COMMANDS\" for some fun stuff." hPutStrLn h "" loop hClose h handler = threadedHandler $ loggingHandler "main" INFO $ handleHandler $ realhandler main = do updateGlobalLogger "main" (setLevel DEBUG) serveTCPforever ((simpleInetOptions 12345) {reuse = True}) handler MissingH-1.6.0.1/src/Control/Concurrent/Thread/0000755000000000000000000000000007346545000017327 5ustar0000000000000000MissingH-1.6.0.1/src/Control/Concurrent/Thread/Utils.hs0000644000000000000000000000202507346545000020762 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Thread utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Control.Concurrent.Thread.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with threads. Written by John Goerzen, jgoerzen\@complete.org -} module Control.Concurrent.Thread.Utils(-- * I\/O utilities runInThread ) where import safe Control.Concurrent ( forkIO, ThreadId ) {- | Takes a IO action and a function. The IO action will be called in a separate thread. When it is completed, the specified function is called with its result. This is a simple way of doing callbacks. -} runInThread :: IO a -> (a -> IO b) -> IO ThreadId runInThread action callback = forkIO $ action >>= callback >> return () MissingH-1.6.0.1/src/Data/0000755000000000000000000000000007346545000013227 5ustar0000000000000000MissingH-1.6.0.1/src/Data/BinPacking.hs0000644000000000000000000001134007346545000015567 0ustar0000000000000000{-# LANGUAGE Safe #-} {- Copyright (c) 2008-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.BinPacking Copyright : Copyright (C) 2008-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Tools for packing into bins Written by John Goerzen, jgoerzen\@complete.org This module is designed to solve this type of problem: Given a bunch of objects of varying sizes, what is the best possible way to pack them into fixed-size bins? This can be used, for instance, by the datapacker program to pack files onto CDs or DVDs; by manufacturing environments to pack physical items into physicl bins; etc. A description of bin packing algorithms can be found at . -} module Data.BinPacking (BinPacker, BinPackerError(..), packByOrder, packLargeFirst ) where import Data.List (sortOn) {- | Potential errors returned as Left values by 'BinPacker' functions. Calling 'show' on this value will produce a nice error message suitable for display. -} data (Num size, Ord size, Show size, Show obj) => BinPackerError size obj = BPTooFewBins [(size, obj)] -- ^ Ran out of bins; attached value is the list of objects that do not fit | BPSizeTooLarge size (size, obj) -- ^ Bin size1 exceeded by at least the given object and size | BPOther String -- ^ Other error deriving (Eq, Read) instance (Num size, Ord size, Show size, Show obj) => Show (BinPackerError size obj) where show (BPTooFewBins _) = "Too few bins" show (BPSizeTooLarge binsize (objsize, obj)) = "Size " ++ show objsize ++ " greater than bin size " ++ show binsize ++ " at " ++ show obj show (BPOther x) = x {- | The primary type for bin-packing functions. These functions take a list of size of bins. If every bin is the same size, you can pass @repeat binSize@ to pass an infinite list of bins if the same size. Any surplus bins will simply be ignored. > [size] is the sizes of bins > [(size, obj)] is the sizes and objects > result is Either error or results -} type BinPacker = forall size obj. (Num size, Ord size, Show size, Show obj) => [size] -- The sizes of bins -> [(size, obj)] -- The sizes and objects -> Either (BinPackerError size obj) [[(size, obj)]] -- Either error or results {- | Pack objects into bins, preserving order. Objects will be taken from the input list one by one, and added to each bin until the bin is full. Work will then proceed on the next bin. No attempt is made to optimize allocations to bins. This is the simplest and most naive bin-packing algorithm, but may not make very good use of bin space. -} packByOrder :: BinPacker packByOrder _ [] = Right [] -- Ran out of sizes packByOrder [] remainder = Left (BPTooFewBins remainder) packByOrder (thisbinsize:otherbins) sizes = let fillBin _ [] = Right [] fillBin accumsize ((s, o):xs) | s > thisbinsize = Left $ BPSizeTooLarge thisbinsize (s, o) | s + accumsize > thisbinsize = Right [] | otherwise = do next <- fillBin (accumsize + s) xs return $ (s, o) : next in do thisset <- fillBin 0 sizes next <- packByOrder otherbins (drop (length thisset) sizes) return (thisset : next) {- | Pack objects into bins. For each bin, start with the largest objects, and keep packing the largest object from the remainder until no object can be found to put in the bin. This is substantially more efficient than 'packByOrder', but requires sorting the input. -} packLargeFirst :: BinPacker packLargeFirst bins sizes = packLargeFirst' bins (sortOn fst sizes) packLargeFirst' :: BinPacker packLargeFirst' _ [] = Right [] -- Ran out of sizes packLargeFirst' [] remainder = Left (BPTooFewBins remainder) packLargeFirst' (thisbinsize:otherbins) sizes = let fillBin _ [] = Right [] fillBin accumsize sizelist = case break (\x -> (fst x) + accumsize <= thisbinsize) sizelist of (_, []) -> if accumsize == 0 then Left $ BPSizeTooLarge thisbinsize (head sizelist) else Right [] (nonmatches, ((s, o):matchxs)) -> do next <- fillBin (accumsize + s) (nonmatches ++ matchxs) return $ (s, o) : next in do thisset <- fillBin 0 sizes next <- packLargeFirst' otherbins (drop (length thisset) sizes) return (thisset : next) MissingH-1.6.0.1/src/Data/Bits/0000755000000000000000000000000007346545000014130 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Bits/Utils.hs0000644000000000000000000000354107346545000015567 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Bit utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Bits.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable to platforms with rawSystem Bit-related utilities Written by John Goerzen, jgoerzen\@complete.org -} module Data.Bits.Utils(getBytes, fromBytes, c2w8, s2w8, w82c, w82s) where import safe Data.Bits ( Bits((.|.), (.&.), shiftR, bitSizeMaybe, shiftL) ) import safe Data.Word ( Word8 ) {- | Returns a list representing the bytes that comprise a data type. Example: > getBytes (0x12345678::Int) -> [0x12, 0x34, 0x56, 0x78] -} getBytes :: (Integral a, Bounded a, Bits a) => a -> [a] getBytes input | Just size <- bitSizeMaybe input, size `mod` 8 == 0 = reverse $ getByte input $ size `div` 8 | otherwise = error "Input data bit size must be a multiple of 8" where getByte _ 0 = [] getByte x remaining = (x .&. 0xff) : getByte (shiftR x 8) (remaining - 1) {- | The opposite of 'getBytes', this function builds a number based on its component bytes. Results are undefined if any components of the input list are > 0xff! -} fromBytes :: (Bits a, Num a) => [a] -> a fromBytes input = let dofb accum [] = accum dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs in dofb 0 input {- | Converts a Char to a Word8. -} c2w8 :: Char -> Word8 c2w8 = fromIntegral . fromEnum {- | Converts a String to a [Word8]. -} s2w8 :: String -> [Word8] s2w8 = map c2w8 {- | Converts a Word8 to a Char. -} w82c :: Word8 -> Char w82c = toEnum . fromIntegral {- | Converts a [Word8] to a String. -} w82s :: [Word8] -> String w82s = map w82c MissingH-1.6.0.1/src/Data/CSV.hs0000644000000000000000000000613507346545000014223 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: CSV and TSV utilities Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.CSV Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Haskell Parsec parsers for comma-separated value (CSV) files. Written by John Goerzen, jgoerzen\@complete.org -} module Data.CSV (csvFile, genCsvFile) where import safe Text.ParserCombinators.Parsec ( char, noneOf, string, endBy, sepBy, (), (<|>), many, try, GenParser, CharParser ) import Data.List (intersperse) eol :: forall st. GenParser Char st String eol = (try $ string "\n\r") <|> (try $ string "\r\n") <|> string "\n" <|> string "\r" "End of line" cell :: GenParser Char st String cell = quotedcell <|> many (noneOf ",\n\r") quotedchar :: GenParser Char st Char quotedchar = noneOf "\"" <|> (try $ do _ <- string "\"\"" return '"' ) quotedcell :: CharParser st String quotedcell = do _ <- char '"' content <- many quotedchar _ <- char '"' return content line :: GenParser Char st [String] line = sepBy cell (char ',') {- | Parse a Comma-Separated Value (CSV) file. The return value is a list of lines; each line is a list of cells; and each cell is a String. Please note that CSV files may have a different number of cells on each line. Also, it is impossible to distinguish a CSV line that has a cell with no data from a CSV line that has no cells. Here are some examples: >Input (literal strings) Parses As (Haskell String syntax) >-------------------------------- --------------------------------- >1,2,3 [["1", "2", "3"]] > >l1 [["l1"], ["l2"]] >l2 > > (empty line) [[""]] > >NQ,"Quoted" [["NQ", "Quoted"]] > >NQ,"Embedded""Quote" [["NQ", "Embedded\"Quote"]] To parse a String, you might use: >import Text.ParserCombinators.Parsec >import Data.String.CSV >.... >parse csvFile "" mystring To parse a file, you might instead use: >do result <- parseFromFile csvFile "/path/to/file" Please note that the result of parsing will be of type (Either ParseError [[String]]). A Left result indicates an error. For more details, see the Parsec information. -} csvFile :: CharParser st [[String]] csvFile = endBy line eol {- | Generate CSV data for a file. The resulting string can be written out to disk directly. -} genCsvFile :: [[String]] -> String genCsvFile inp = unlines . map csvline $ inp where csvline :: [String] -> String csvline l = concat . intersperse "," . map csvcells $ l csvcells :: String -> String csvcells "" = "" csvcells c = '"' : convcell c ++ "\"" convcell :: String -> String convcell c = concatMap convchar c convchar '"' = "\"\"" convchar x = [x] MissingH-1.6.0.1/src/Data/Compression/0000755000000000000000000000000007346545000015530 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Compression/Inflate.hs0000644000000000000000000003103707346545000017452 0ustar0000000000000000{-# LANGUAGE Safe #-} -- arch-tag: Inflate implementation for Haskell {- Inflate implementation for Haskell Copyright 2004 Ian Lynagh Licence: 3 clause BSD. \section{Inflate} This module provides a Haskell implementation of the inflate function, as described by RFC 1951. -} {- | Module : Data.Compression.Inflate Copyright : Copyright (C) 2004 Ian Lynagh SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Inflate algorithm implementation Copyright (C) 2004 Ian Lynagh -} module Data.Compression.Inflate (inflate_string, inflate_string_remainder, inflate, Output, Bit, bits_to_word32) where import safe Control.Monad ( ap, unless ) import safe Data.Array ( Array, array, (!), (//) ) import qualified Data.Char import Data.List ( mapAccumL, genericDrop, genericReplicate, genericSplitAt, genericTake , sort ) import safe Data.Maybe () import safe Data.Bits ( Bits(testBit) ) import safe Data.Word ( Word8, Word32 ) inflate_string :: String -> String inflate_string = fst . inflate_string_remainder -- map (Data.Char.chr . fromIntegral) $ fst $ inflate $ map Data.Char.ord s -- | Returns (Data, Remainder) inflate_string_remainder :: String -> (String, String) inflate_string_remainder s = let res = inflate $ map Data.Char.ord s convw32l l = map (Data.Char.chr . fromIntegral) l output = convw32l $ fst res b2w32 [] = [] b2w32 b = let (this, next) = splitAt 8 b in bits_to_word32 this : b2w32 next remainder = convw32l $ b2w32 $ snd res in (output, remainder) {- \section{Types} Type synonyms are your friend. -} type Output = [Word32] -- The final output type Code = Word32 -- A generic code type Dist = Code -- A distance code type LitLen = Code -- A literal/length code type Length = Word32 -- Number of bits needed to identify a code type Table = InfM Code -- A Huffman table type Tables = (Table, Table) -- lit/len and dist Huffman tables {- The \verb!Bit! datatype is used for the input. We can show values and convert from the input we are given and to \verb!Word32!s which we us to represent most values. -} newtype Bit = Bit Bool deriving Eq instance Show Bit where show = (\x -> [x]) . show_b showList bs = showString $ "'" ++ map show_b bs ++ "'" show_b :: Bit -> Char show_b (Bit True) = '1' show_b (Bit False) = '0' int_to_bits :: Int -> [Bit] int_to_bits = word8_to_bits . fromIntegral word8_to_bits :: Word8 -> [Bit] word8_to_bits n = map (\i -> Bit (testBit n i)) [0..7] bits_to_word32 :: [Bit] -> Word32 bits_to_word32 = foldr (\(Bit b) i -> 2 * i + (if b then 1 else 0)) 0 {- \section{Monad} offset is rarely used, so make it strict to avoid building huge closures. -} data State = State { bits :: [Bit], -- remaining input bits offset :: !Word32, -- num bits consumed mod 8 history :: Array Word32 Word32, -- last 32768 output words loc :: Word32 -- where in history we are } data InfM a = InfM (State -> (a, State)) instance Monad InfM where -- (>>=) :: InfM a -> (a -> InfM b) -> InfM b InfM v >>= f = InfM $ \s -> let (x, s') = v s InfM y = f x in y s' -- return :: a -> InfM a return = pure instance Applicative InfM where pure x = InfM $ \s -> (x, s) (<*>) = ap instance Functor InfM where fmap f (InfM g) = InfM $ \s -> case g s of ~(a, s') -> (f a, s') set_bits :: [Bit] -> InfM () set_bits bs = InfM $ const ((), State bs 0 (array (0, 32767) []) 0) {- no_bits :: InfM Bool no_bits = InfM $ \s -> (null (bits s), s) -} align_8_bits :: InfM () align_8_bits = InfM $ \s -> ((), s { bits = genericDrop ((8 - offset s) `mod` 8) (bits s), offset = 0 }) get_bits :: Word32 -> InfM [Bit] get_bits n = InfM $ \s -> case need n (bits s) of (ys, zs) -> (ys, s { bits = zs, offset = (n + offset s) `mod` 8 } ) where need 0 xs = ([], xs) need _ [] = error "get_bits: Don't have enough!" need i (x:xs) = let (ys, zs) = need (i-1) xs in (x:ys, zs) extract_InfM :: InfM a -> (a, [Bit]) extract_InfM (InfM f) = let (x, s) = f undefined in (x, bits s) output_w32 :: Word32 -> InfM () output_w32 w = InfM $ \s -> let l = loc s in ((), s { history = history s // [(l, w)], loc = l + 1 }) repeat_w32s :: Word32 -> Word32 -> InfM [Word32] repeat_w32s len dist = InfM $ \s -> let l = loc s h = history s new = map (h!) $ genericTake dist ([(l - dist) `mod` 32768..32767] ++ [0..]) new_bit = genericTake len (cycle new) h' = h // zip (map (`mod` 32768) [l..]) new_bit in (new_bit, s { history = h', loc = (l + len) `mod` 32768 }) ----------------------------------- get_word32s :: Word32 -> Word32 -> InfM [Word32] get_word32s _ 0 = return [] get_word32s b n = do w <- get_w32 b ws <- get_word32s b (n-1) return (w:ws) get_w32 :: Word32 -> InfM Word32 get_w32 i = do bs <- get_bits i return (bits_to_word32 bs) get_bit :: InfM Bit get_bit = do res <- get_bits 1 case res of [x] -> return x _ -> error $ "get_bit: expected exactly one bit" {- \section{Inflate itself} The hardcore stuff! -} inflate :: [Int] -> (Output, [Bit]) inflate is = extract_InfM $ do set_bits $ concatMap int_to_bits is x <- inflate_blocks False align_8_bits return x -- Bool is true if we have seen the "last" block inflate_blocks :: Bool -> InfM Output inflate_blocks True = return [] inflate_blocks False = do res <- get_bits 3 case res of [Bit is_last, Bit t1, Bit t2] -> case (t1, t2) of (False, False) -> do align_8_bits len <- get_w32 16 nlen <- get_w32 16 unless (len + nlen == 2^(32 :: Int) - 1) $ error "inflate_blocks: Mismatched lengths" ws <- get_word32s 8 len mapM_ output_w32 ws return ws (True, False) -> inflate_codes is_last inflate_trees_fixed (False, True) -> do tables <- inflate_tables inflate_codes is_last tables (True, True) -> error ("inflate_blocks: case 11 reserved") _ -> error ("inflate_blocks: expected 3 bits") inflate_tables :: InfM Tables inflate_tables = do hlit <- get_w32 5 hdist <- get_w32 5 hclen <- get_w32 4 llc_bs <- get_bits ((hclen + 4) * 3) let llc_bs' = zip (map bits_to_word32 $ triple llc_bs) [16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15] tab = make_table llc_bs' lit_dist_lengths <- make_lit_dist_lengths tab (258 + hlit + hdist) (error "inflate_tables dummy") let (lit_lengths, dist_lengths) = genericSplitAt (257 + hlit) lit_dist_lengths lit_table = make_table (zip lit_lengths [0..]) dist_table = make_table (zip dist_lengths [0..]) return (lit_table, dist_table) triple :: [a] -> [[a]] triple (a:b:c:xs) = [a,b,c]:triple xs triple [] = [] triple _ = error "triple: can't happen" make_lit_dist_lengths :: Table -> Word32 -> Word32 -> InfM [Word32] make_lit_dist_lengths _ i _ | i < 0 = error "make_lit_dist_lengths i < 0" make_lit_dist_lengths _ 0 _ = return [] make_lit_dist_lengths tab i last_thing = do c <- tab (ls, i', last_thing') <- meta_code i c last_thing ws <- make_lit_dist_lengths tab i' last_thing' return (ls ++ ws) meta_code :: Word32 -> Code -> Word32 -> InfM ([Word32], Word32, Word32) meta_code c i _ | i < 16 = return ([i], c - 1, i) meta_code c 16 last_thing = do xs <- get_bits 2 let l = 3 + bits_to_word32 xs return (genericReplicate l last_thing, c - l, last_thing) meta_code c 17 _ = do xs <- get_bits 3 let l = 3 + bits_to_word32 xs return (genericReplicate l 0, c - l, 0) meta_code c 18 _ = do xs <- get_bits 7 let l = 11 + bits_to_word32 xs return (genericReplicate l 0, c - l, 0) meta_code _ i _ = error $ "meta_code: " ++ show i inflate_codes :: Bool -> Tables -> InfM Output inflate_codes seen_last tabs@(tab_litlen, tab_dist) = {- do done <- no_bits if done then return [] -- XXX Is this right? else -} do i <- tab_litlen; if i == 256 then inflate_blocks seen_last else do pref <- if i < 256 then do output_w32 i return [i] else case lookup i litlens of Nothing -> error "do_code_litlen" Just (base, num_bits) -> do extra <- get_w32 num_bits let l = base + extra dist <- dist_code tab_dist repeat_w32s l dist o <- inflate_codes seen_last tabs return (pref ++ o) litlens :: [(Code, (LitLen, Word32))] litlens = zip [257..285] $ mk_bases 3 litlen_counts ++ [(258, 0)] where litlen_counts = [(8,0),(4,1),(4,2),(4,3),(4,4),(4,5)] dist_code :: Table -> InfM Dist dist_code tab = do code <- tab case lookup code dists of Nothing -> error "dist_code" Just (base, num_bits) -> do extra <- get_w32 num_bits return (base + extra) dists :: [(Code, (Dist, Word32))] dists = zip [0..29] $ mk_bases 1 dist_counts where dist_counts = (4,0):map ((,) 2) [1..13] mk_bases :: Word32 -> [(Int, Word32)] -> [(Word32, Word32)] mk_bases base counts = snd $ mapAccumL next_base base incs where next_base current bs = (current + 2^bs, (current, bs)) incs = concat $ map (uncurry replicate) counts {- \section{Fixed tables} The fixed tables. Not much to say really. -} inflate_trees_fixed :: Tables inflate_trees_fixed = (make_table $ [(8, c) | c <- [0..143]] ++ [(9, c) | c <- [144..255]] ++ [(7, c) | c <- [256..279]] ++ [(8, c) | c <- [280..287]], make_table [(5, c) | c <- [0..29]]) {- \section{The Huffman Tree} As the name suggests, the obvious way to store Huffman trees is in a tree datastructure. Externally we want to view them as functions though, so we wrap the tree with \verb!get_code! which takes a list of bits and returns the corresponding code and the remaining bits. To make a tree from a list of length code pairs is a simple recursive process. -} data Tree = Branch Tree Tree | Leaf Word32 | Null make_table :: [(Length, Code)] -> Table make_table lcs = case make_tree 0 $ sort $ filter ((/= 0) . fst) lcs of (tree, []) -> get_code tree _ -> error $ "make_table: Left-over lcs from" get_code :: Tree -> InfM Code get_code (Branch zero_tree one_tree) = do Bit b <- get_bit if b then get_code one_tree else get_code zero_tree get_code (Leaf w) = return w get_code Null = error "get_code Null" make_tree :: Word32 -> [(Length, Code)] -> (Tree, [(Length, Code)]) make_tree _ [] = (Null, []) make_tree i lcs@((l, c):lcs') | i == l = (Leaf c, lcs') | i < l = let (zero_tree, lcs_z) = make_tree (i+1) lcs (one_tree, lcs_o) = make_tree (i+1) lcs_z in (Branch zero_tree one_tree, lcs_o) | otherwise = error "make_tree: can't happen" MissingH-1.6.0.1/src/Data/Either/0000755000000000000000000000000007346545000014447 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Either/Utils.hs0000644000000000000000000000461707346545000016113 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Either utilities Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Either.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Utilities for working with the Either data type -} module Data.Either.Utils ( maybeToEither, forceEither, forceEitherMsg, eitherToMonadError, fromLeft, fromRight, fromEither ) where import Control.Monad.Except ( MonadError(..) ) {- | Converts a Maybe value to an Either value, using the supplied parameter as the Left value if the Maybe is Nothing. This function can be interpreted as: @maybeToEither :: e -> Maybe a -> Either e a@ Its definition is given as it is so that it can be used in the Error and related monads. -} maybeToEither :: MonadError e m => e -- ^ (Left e) will be returned if the Maybe value is Nothing -> Maybe a -- ^ (Right a) will be returned if this is (Just a) -> m a maybeToEither errorval Nothing = throwError errorval maybeToEither _ (Just normalval) = return normalval {- | Pulls a "Right" value out of an Either value. If the Either value is Left, raises an exception with "error". -} forceEither :: Show e => Either e a -> a forceEither (Left x) = error (show x) forceEither (Right x) = x {- | Like 'forceEither', but can raise a specific message with the error. -} forceEitherMsg :: Show e => String -> Either e a -> a forceEitherMsg msg (Left x) = error $ msg ++ ": " ++ show x forceEitherMsg _ (Right x) = x {- | Takes an either and transforms it into something of the more generic MonadError class. -} eitherToMonadError :: MonadError e m => Either e a -> m a eitherToMonadError (Left x) = throwError x eitherToMonadError (Right x) = return x -- | Take a Left to a value, crashes on a Right fromLeft :: Either a b -> a fromLeft (Left a) = a fromLeft _ = error "Data.Either.Utils.fromLeft: Right" -- | Take a Right to a value, crashes on a Left fromRight :: Either a b -> b fromRight (Right a) = a fromRight _ = error "Data.Either.Utils.fromRight: Left" -- | Take an Either, and return the value inside it fromEither :: Either a a -> a fromEither (Left a) = a fromEither (Right a) = a MissingH-1.6.0.1/src/Data/Hash/CRC32/0000755000000000000000000000000007346545000014666 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Hash/CRC32/GZip.hs0000644000000000000000000001052507346545000016076 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: GZIP CRC32 implementation in pure Haskell Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Hash.CRC32.GZip Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable CRC32 checksumming using the GZIP\/PKZIP algorithm as used in both ISO 3309 and section 8.1.1.6.2 of ITU-T V.42 and referenced in RFC1952. -} module Data.Hash.CRC32.GZip where import safe Data.Array ( Array, array, (!) ) import safe Data.Bits ( Bits(xor, (.&.), shiftR) ) import safe Data.Char ( ord ) import safe Data.Word ( Word32 ) update_crc :: Word32 -> Char -> Word32 update_crc crc ch = let c = crc `xor` 0xFFFFFFFF newval = (gzipcrctab ! fromIntegral ((c `xor` fromIntegral (ord ch)) .&. 0xff)) `xor` (c `shiftR` 8) in newval `xor` 0xFFFFFFFF update_crc_list :: Word32 -> [Char] -> Word32 update_crc_list start list = foldl update_crc start list calc_crc32 :: [Char] -> Word32 calc_crc32 s = update_crc_list 0 s gzipcrctab :: Array Int Word32 gzipcrctab = array (0,255) (zip [0..255] [ 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d ]) MissingH-1.6.0.1/src/Data/Hash/0000755000000000000000000000000007346545000014112 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Hash/MD5.hs0000644000000000000000000003135507346545000015042 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {- | Module : Data.Hash.MD5 Copyright : Copyright (C) 2001 Ian Lynagh SPDX-License-Identifier: BSD-3-Clause OR GPL-2.0-or-later Maintainer : Ian Lynagh Stability : stable Portability: portable Generation of MD5sums Written by Ian Lynagh, igloo\@earth.li -} module Data.Hash.MD5 ( md5 , md5s , md5i , MD5(..) , ABCD(..) , Zord64 , Str(..) , BoolList(..) , WordList(..) ) where import safe Data.Bits (Bits (complement, rotateL, shiftL, shiftR, xor, (.&.), (.|.))) import safe Data.Char (chr, ord) import safe Data.Word (Word32, Word64) -- | Synonym for 'Word64' due to historic reasons type Zord64 = Word64 -- ======================== TYPES AND CLASS DEFINTIONS ======================== type XYZ = (Word32, Word32, Word32) type Rotation = Int newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) newtype Str = Str String newtype BoolList = BoolList [Bool] newtype WordList = WordList ([Word32], Zord64) -- | Anything we want to work out the MD5 of must be an instance of class MD5 class MD5 a where get_next :: a -> ([Word32], Int, a) -- get the next blocks worth -- \ \ \------ the rest of the input -- \ \--------- the number of bits returned -- \--------------- the bits returned in 32bit words len_pad :: Zord64 -> a -> a -- append the padding and length finished :: a -> Bool -- Have we run out of input yet? -- Mainly exists because it's fairly easy to do MD5s on input where the -- length is not a multiple of 8 instance MD5 BoolList where get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) where (ys, zs) = splitAt 512 s len_pad l (BoolList bs) = BoolList (bs ++ [True] ++ replicate (fromIntegral $ (447 - l) .&. 511) False ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] ) where mangle [] = [] mangle xs = reverse ys ++ mangle zs where (ys, zs) = splitAt 8 xs finished (BoolList s) = s == [] -- The string instance is fairly straightforward instance MD5 Str where get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) where (ys, zs) = splitAt 64 s len_pad c64 (Str s) = Str (s ++ padding ++ l) where padding = '\128':replicate (fromIntegral zeros) '\000' zeros = shiftR ((440 - c64) .&. 511) 3 l = length_to_chars 8 c64 finished (Str s) = s == "" -- YA instance that is believed will be useful instance MD5 WordList where get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) where (xs, ys) = splitAt 16 ws taken = if l > 511 then 512 else l .&. 511 len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) where beginning = if length ws > 0 then start ++ lastone' else [] start = init ws lastone = last ws offset = c64 .&. 31 lastone' = [if offset > 0 then lastone + theone else lastone] theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) (fromIntegral $ offset .&. (31 - 7)) nextish = if offset == 0 then [128] else [] c64' = c64 + (32 - offset) num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) blanks = replicate num_blanks 0 lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) topsize = fromIntegral $ shiftR c64 32 size = [lowsize, topsize] newlen = l .&. (complement 511) + if c64 .&. 511 >= 448 then 1024 else 512 finished (WordList (_, z)) = z == 0 -- | __WARNING__: This instance only defines the '+' operation instance Num ABCD where ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) -- ======================== EXPORTED FUNCTIONS ======================== {- | The simplest function, gives you the MD5 of a string as 4-tuple of 32bit words. -} md5 :: (MD5 a) => a -> ABCD md5 m = md5_main False 0 magic_numbers m {- | Returns a hex number ala the md5sum program. -} md5s :: (MD5 a) => a -> String md5s = abcd_to_string . md5 {- | Returns an integer equivalent to hex number from 'md5s'. -} md5i :: (MD5 a) => a -> Integer md5i = abcd_to_integer . md5 -- ======================== THE CORE ALGORITHM ======================== -- Decides what to do. The first argument indicates if padding has been -- added. The second is the length mod 2^64 so far. Then we have the -- starting state, the rest of the string and the final state. md5_main :: (MD5 a) => Bool -- Have we added padding yet? -> Zord64 -- The length so far mod 2^64 -> ABCD -- The initial state -> a -- The non-processed portion of the message -> ABCD -- The resulting state md5_main padded ilen abcd m = if finished m && padded then abcd else md5_main padded' (ilen + 512) (abcd + abcd') m'' where (m16, l, m') = get_next m len' = ilen + fromIntegral l ((m16', _, m''), padded') = if not padded && l < 512 then (get_next $ len_pad len' m, True) else ((m16, l, m'), padded) abcd' = md5_do_block abcd m16' -- md5_do_block processes a 512 bit block by calling md5_round 4 times to -- apply each round with the correct constants and permutations of the -- block md5_do_block :: ABCD -- Initial state -> [Word32] -- The block to be processed - 16 32bit words -> ABCD -- Resulting state md5_do_block abcd0 w = abcd4 where (r1, r2, r3, r4) = rounds {- map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] -- [(5 * x + 1) `mod` 16 | x <- [0..15]] map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] -- [(3 * x + 5) `mod` 16 | x <- [0..15]] map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] -- [(7 * x) `mod` 16 | x <- [0..15]] -} perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] perm5 _ = error "broke at perm5" perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] perm3 _ = error "broke at perm3" perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] perm7 _ = error "broke at perm7" abcd1 = md5_round md5_f abcd0 w r1 abcd2 = md5_round md5_g abcd1 (perm5 w) r2 abcd3 = md5_round md5_h abcd2 (perm3 w) r3 abcd4 = md5_round md5_i abcd3 (perm7 w) r4 -- md5_round does one of the rounds. It takes an auxiliary function and foldls -- (md5_inner_function f) to repeatedly apply it to the initial state with the -- correct constants md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I -- for those of you with a copy of -- the prayer book^W^WRFC) -> ABCD -- Initial state -> [Word32] -- The 16 32bit words of input -> [(Rotation, Word32)] -- The list of 16 rotations and -- additive constants -> ABCD -- Resulting state md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns -- Apply one of the functions md5_[fghi] and put the new ABCD together md5_inner_function :: (XYZ -> Word32) -- Auxiliary function -> ABCD -- Initial state -> (Rotation, Word32) -- The rotation and additive -- constant (X[i] + T[j]) -> ABCD -- Resulting state md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) where mid_a = a + f(b,c,d) + ki rot_a = rotateL mid_a s a' = b + rot_a -- The 4 auxiliary functions md5_f :: XYZ -> Word32 md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) {- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} md5_g :: XYZ -> Word32 md5_g (x, y, z) = md5_f (z, x, y) {- was: (x .&. z) .|. (y .&. (complement z)) -} md5_h :: XYZ -> Word32 md5_h (x, y, z) = x `xor` y `xor` z md5_i :: XYZ -> Word32 md5_i (x, y, z) = y `xor` (x .|. (complement z)) -- The magic numbers from the RFC. magic_numbers :: ABCD magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) -- The 4 lists of (rotation, additive constant) tuples, one for each round rounds :: ([(Rotation, Word32)], [(Rotation, Word32)], [(Rotation, Word32)], [(Rotation, Word32)]) rounds = (r1, r2, r3, r4) where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), (s14, 0x49b40821)] r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), (s24, 0x8d2a4c8a)] r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), (s34, 0xc4ac5665)] r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), (s44, 0xeb86d391)] s11 = 7 s12 = 12 s13 = 17 s14 = 22 s21 = 5 s22 = 9 s23 = 14 s24 = 20 s31 = 4 s32 = 11 s33 = 16 s34 = 23 s41 = 6 s42 = 10 s43 = 15 s44 = 21 -- ======================== CONVERSION FUNCTIONS ======================== -- Turn the 4 32 bit words into a string representing the hex number they -- represent. abcd_to_string :: ABCD -> String abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] -- Split the 32 bit word up, swap the chunks over and convert the numbers -- to their hex equivalents. display_32bits_as_hex :: Word32 -> String display_32bits_as_hex w = swap_pairs cs where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs swap_pairs _ = [] -- Convert to an integer, performing endianness magic as we go abcd_to_integer :: ABCD -> Integer abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + rev_num b * 2^(64 :: Int) + rev_num c * 2^(32 :: Int) + rev_num d rev_num :: Word32 -> Integer rev_num i = toInteger j `mod` (2^(32 :: Int)) -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) 0 [0,8,16,24] -- Used to convert a 64 byte string to 16 32bit words string_to_word32s :: String -> [Word32] string_to_word32s "" = [] string_to_word32s ss = this:string_to_word32s ss' where (s, ss') = splitAt 4 ss this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s -- Used to convert a list of 512 bools to 16 32bit words bools_to_word32s :: [Bool] -> [Word32] bools_to_word32s [] = [] bools_to_word32s bs = this:bools_to_word32s rest where (bs1, bs1') = splitAt 8 bs (bs2, bs2') = splitAt 8 bs1' (bs3, bs3') = splitAt 8 bs2' (bs4, rest) = splitAt 8 bs3' this = boolss_to_word32 [bs1, bs2, bs3, bs4] bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 -- Convert the size into a list of characters used by the len_pad function -- for strings length_to_chars :: Int -> Zord64 -> String length_to_chars 0 _ = [] length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) where this = chr $ fromIntegral $ n .&. 255 MissingH-1.6.0.1/src/Data/Hash/MD5/0000755000000000000000000000000007346545000014477 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Hash/MD5/Zord64_HARD.hs0000644000000000000000000000350107346545000016720 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | Obsolete legacy module module Data.Hash.MD5.Zord64_HARD (Zord64) where import safe Data.Bits ( Bits(complement, (.&.), (.|.), shift) ) import safe Data.Word ( Word32 ) data Zord64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded) w64ToInteger :: Zord64 -> Integer w64ToInteger W64{lo=lo,hi=hi} = toInteger lo + 0x100000000 * toInteger hi integerToW64 :: Integer -> Zord64 integerToW64 x = case x `quotRem` 0x100000000 of (h,l) -> W64{lo=fromInteger l, hi=fromInteger h} instance Show Zord64 instance Read Zord64 instance Num Zord64 where W64{lo=lo_a,hi=hi_a} + W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} where lo' = lo_a + lo_b hi' = hi_a + hi_b + if lo' < lo_a then 1 else 0 W64{lo=lo_a,hi=hi_a} - W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} where lo' = lo_a - lo_b hi' = hi_a - hi_b + if lo' > lo_a then 1 else 0 fromInteger = integerToW64 instance Bits Zord64 where W64{lo=lo_a,hi=hi_a} .&. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} where lo' = lo_a .&. lo_b hi' = hi_a .&. hi_b W64{lo=lo_a,hi=hi_a} .|. W64{lo=lo_b,hi=hi_b} = W64{lo=lo', hi=hi'} where lo' = lo_a .|. lo_b hi' = hi_a .|. hi_b shift w@W64{lo=lo,hi=hi} x | x == 0 = w | x > 63 = W64{lo=0,hi=0} | x > 31 = W64{lo = 0, hi = shift lo (x-32)} | x > 0 = W64{lo = shift lo x, hi = shift hi x .|. shift lo (x-32)} | x < -63 = W64{lo=0,hi=0} | x < -31 = W64{lo = shift hi (x+32), hi = 0} | x < 0 = W64{lo = shift lo x .|. shift hi (x+32), hi = shift hi x} | otherwise = error "impossible" complement W64{lo=lo,hi=hi} = W64{lo=complement lo,hi=complement hi} instance Integral Zord64 where toInteger = w64ToInteger instance Real Zord64 instance Enum Zord64 MissingH-1.6.0.1/src/Data/List/0000755000000000000000000000000007346545000014142 5ustar0000000000000000MissingH-1.6.0.1/src/Data/List/Utils.hs0000644000000000000000000003550307346545000015604 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: List utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.List.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with lists. Written by John Goerzen, jgoerzen\@complete.org -} module Data.List.Utils(-- * Merging merge, mergeBy, -- * Tests startswith, endswith, contains, hasAny, -- * Association List Utilities {- | These functions are designed to augment the association list functions in "Data.List" and provide an interface similar to "Data.FiniteMap" or "Data.Map" for association lists. -} addToAL, delFromAL, flipAL, keysAL, valuesAL, hasKeyAL, -- ** Association List Conversions strFromAL, strToAL, -- * Conversions split, join, replace, genericJoin, takeWhileList, dropWhileList, spanList, breakList, -- ** Advanced Conversions WholeFunc(..), wholeMap, fixedWidth, -- * Fixed-Width and State Monad Utilities grab, -- * Miscellaneous countElem, elemRIndex, alwaysElemRIndex, seqList, subIndex, uniq -- -- * Sub-List Selection -- sub, ) where import Control.Monad.State (State, get, put) import Data.List (elemIndices, findIndex, intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, tails) {- | Merge two sorted lists into a single, sorted whole. Example: > merge [1,3,5] [1,2,4,6] -> [1,1,2,3,4,5,6] QuickCheck test property: prop_merge xs ys = merge (sort xs) (sort ys) == sort (xs ++ ys) where types = xs :: [Int] -} merge :: (Ord a) => [a] -> [a] -> [a] merge = mergeBy (compare) {- | Merge two sorted lists using into a single, sorted whole, allowing the programmer to specify the comparison function. QuickCheck test property: prop_mergeBy xs ys = mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys) where types = xs :: [ (Int, Int) ] cmp (x1,_) (x2,_) = compare x1 x2 -} mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] mergeBy _ [] ys = ys mergeBy _ xs [] = xs mergeBy cmp (allx@(x:xs)) (ally@(y:ys)) -- Ordering derives Eq, Ord, so the comparison below is valid. -- Explanation left as an exercise for the reader. -- Someone please put this code out of its misery. | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally | otherwise = y : mergeBy cmp allx ys {- | Returns true if the given list starts with the specified elements; false otherwise. (This is an alias for 'Data.List.isPrefixOf'.) Example: > startswith "He" "Hello" -> True -} startswith :: Eq a => [a] -> [a] -> Bool startswith = isPrefixOf {- | Returns true if the given list ends with the specified elements; false otherwise. (This is an alias for 'Data.List.isSuffixOf'.) Example: > endswith "lo" "Hello" -> True -} endswith :: Eq a => [a] -> [a] -> Bool endswith = isSuffixOf {- | Returns true if the given list contains any of the elements in the search list. -} hasAny :: Eq a => [a] -- ^ List of elements to look for -> [a] -- ^ List to search -> Bool -- ^ Result hasAny [] _ = False -- An empty search list: always false hasAny _ [] = False -- An empty list to scan: always false hasAny search (x:xs) = if x `elem` search then True else hasAny search xs {- | Similar to 'Data.List.takeWhile', takes elements while the func is true. The function is given the remainder of the list to examine. -} takeWhileList :: ([a] -> Bool) -> [a] -> [a] takeWhileList _ [] = [] takeWhileList func list@(x:xs) = if func list then x : takeWhileList func xs else [] {- | Similar to 'Data.List.dropWhile', drops elements while the func is true. The function is given the remainder of the list to examine. -} dropWhileList :: ([a] -> Bool) -> [a] -> [a] dropWhileList _ [] = [] dropWhileList func list@(_:xs) = if func list then dropWhileList func xs else list {- | Similar to 'Data.List.span', but performs the test on the entire remaining list instead of just one element. @spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ -} spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) spanList _ [] = ([],[]) spanList func list@(x:xs) = if func list then (x:ys,zs) else ([],list) where (ys,zs) = spanList func xs {- | Similar to 'Data.List.break', but performs the test on the entire remaining list instead of just one element. -} breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) breakList func = spanList (not . func) {- | Given a delimiter and a list (or string), split into components. Example: > split "," "foo,bar,,baz," -> ["foo", "bar", "", "baz", ""] > split "ba" ",foo,bar,,baz," -> [",foo,","r,,","z,"] -} split :: Eq a => [a] -> [a] -> [[a]] split _ [] = [] split delim str = let (firstline, remainder) = breakList (startswith delim) str in firstline : case remainder of [] -> [] x -> if x == delim then [] : [] else split delim (drop (length delim) x) {- | Given a list and a replacement list, replaces each occurance of the search list with the replacement list in the operation list. Example: >replace "," "." "127,0,0,1" -> "127.0.0.1" This could logically be thought of as: >replace old new l = join new . split old $ l -} replace :: Eq a => [a] -> [a] -> [a] -> [a] replace old new l = join new . split old $ l {- | Given a delimiter and a list of items (or strings), join the items by using the delimiter. Alias for 'Data.List.intercalate'. Example: > join "|" ["foo", "bar", "baz"] -> "foo|bar|baz" -} join :: [a] -> [[a]] -> [a] join = intercalate {- | Like 'join', but works with a list of anything showable, converting it to a String. Examples: > genericJoin ", " [1, 2, 3, 4] -> "1, 2, 3, 4" > genericJoin "|" ["foo", "bar", "baz"] -> "\"foo\"|\"bar\"|\"baz\"" -} genericJoin :: Show a => String -> [a] -> String genericJoin delim l = join delim (map show l) {- | Returns true if the given parameter is a sublist of the given list; false otherwise. Alias for 'Data.List.isInfixOf'. Example: > contains "Haskell" "I really like Haskell." -> True > contains "Haskell" "OCaml is great." -> False -} contains :: Eq a => [a] -> [a] -> Bool contains = isInfixOf -- above function submitted to GHC as Data.List.isInfixOf on 8/31/2006 {- | Adds the specified (key, value) pair to the given list, removing any existing pair with the same key already present. -} addToAL :: Eq key => [(key, elt)] -> key -> elt -> [(key, elt)] addToAL l key value = (key, value) : delFromAL l key {- | Removes all (key, value) pairs from the given list where the key matches the given one. -} delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)] delFromAL l key = filter (\a -> (fst a) /= key) l {- | Returns the keys that comprise the (key, value) pairs of the given AL. Same as: >map fst -} keysAL :: [(key, a)] -> [key] keysAL = map fst {- | Returns the values the comprise the (key, value) pairs of the given AL. Same as: >map snd -} valuesAL :: [(a, value)] -> [value] valuesAL = map snd {- | Indicates whether or not the given key is in the AL. -} hasKeyAL :: Eq a => a -> [(a, b)] -> Bool hasKeyAL key list = elem key (keysAL list) {- | Flips an association list. Converts (key1, val), (key2, val) pairs to (val, [key1, key2]). -} flipAL :: (Eq key, Eq val) => [(key, val)] -> [(val, [key])] flipAL oldl = let worker :: (Eq key, Eq val) => [(key, val)] -> [(val, [key])] -> [(val, [key])] worker [] accum = accum worker ((k, v):xs) accum = case lookup v accum of Nothing -> worker xs ((v, [k]) : accum) Just y -> worker xs (addToAL accum v (k:y)) in worker oldl [] {- | Converts an association list to a string. The string will have one pair per line, with the key and value both represented as a Haskell string. This function is designed to work with [(String, String)] association lists, but may work with other types as well. -} strFromAL :: (Show a, Show b) => [(a, b)] -> String strFromAL inp = let worker (key, val) = show key ++ "," ++ show val in unlines . map worker $ inp {- | The inverse of 'strFromAL', this function reads a string and outputs the appropriate association list. Like 'strFromAL', this is designed to work with [(String, String)] association lists but may also work with other objects with simple representations. -} strToAL :: (Read a, Read b) => String -> [(a, b)] strToAL inp = let worker line = case reads line of [(key, remainder)] -> case remainder of ',':valstr -> (key, read valstr) _ -> error "Data.List.Utils.strToAL: Parse error on value" _ -> error "Data.List.Utils.strToAL: Parse error on key" in map worker (lines inp) {- FIXME TODO: sub -} {- | Returns a count of the number of times the given element occured in the given list. -} countElem :: Eq a => a -> [a] -> Int countElem i = length . filter (i==) {- | Returns the rightmost index of the given element in the given list. -} elemRIndex :: Eq a => a -> [a] -> Maybe Int elemRIndex item l = case reverse $ elemIndices item l of [] -> Nothing (x:_) -> Just x {- | Like elemRIndex, but returns -1 if there is nothing found. -} alwaysElemRIndex :: Eq a => a -> [a] -> Int alwaysElemRIndex item list = case elemRIndex item list of Nothing -> -1 Just x -> x {- | Forces the evaluation of the entire list. -} seqList :: [a] -> [a] seqList [] = [] seqList list@(_:xs) = seq (seqList xs) list -------------------------------------------------- -- Advanced Conversions -------------------------------------------------- {- | The type used for functions for 'wholeMap'. See 'wholeMap' for details. -} newtype WholeFunc a b = WholeFunc ([a] -> (WholeFunc a b, [a], [b])) {- | This is an enhanced version of the concatMap or map functions in Data.List. Unlike those functions, this one: * Can consume a varying number of elements from the input list during each iteration * Can arbitrarily decide when to stop processing data * Can return a varying number of elements to insert into the output list * Can actually switch processing functions mid-stream * Is not even restricted to processing the input list intact The function used by wholeMap, of type 'WholeFunc', is repeatedly called with the input list. The function returns three things: the function to call for the next iteration (if any), what remains of the input list, and the list of output elements generated during this iteration. The return value of 'wholeMap' is the concatenation of the output element lists from all iterations. Processing stops when the remaining input list is empty. An example of a 'WholeFunc' is 'fixedWidth'. -} wholeMap :: WholeFunc a b -> [a] -> [b] wholeMap _ [] = [] -- Empty input, empty output. wholeMap (WholeFunc func) inplist = let (nextfunc, nextlist, output) = func inplist in output ++ wholeMap nextfunc nextlist {- | A parser designed to process fixed-width input fields. Use it with 'wholeMap'. The Int list passed to this function is the list of the field widths desired from the input. The result is a list of those widths, if possible. If any of the input remains after processing this list, it is added on as the final element in the result list. If the input is less than the sum of the requested widths, then the result list will be short the appropriate number of elements, and its final element may be shorter than requested. Examples: >wholeMap (fixedWidth [1, 2, 3]) "1234567890" > --> ["1","23","456","7890"] >wholeMap (fixedWidth (repeat 2)) "123456789" > --> ["12","34","56","78","9"] >wholeMap (fixedWidth []) "123456789" > --> ["123456789"] >wholeMap (fixedWidth [5, 3, 6, 1]) "Hello, This is a test." > --> ["Hello",", T","his is"," ","a test."] -} fixedWidth :: [Int] -> WholeFunc a [a] fixedWidth = WholeFunc . fixedWidthFunc where -- Empty input: Empty output, stop fixedWidthFunc _ [] = ((fixedWidth []), [], []) -- Empty length: Stop here. fixedWidthFunc [] x = ((fixedWidth []), [], [x]) -- Stuff to process: Do it. fixedWidthFunc (len:lenxs) input = (fixedWidth lenxs, next, [this]) where (this, next) = splitAt len input {- | Helps you pick out fixed-width components from a list. Example: >conv :: String -> (String,String) >conv = runState $ > do f3 <- grab 3 > n2 <- grab 2 > return $ f3 ++ "," ++ n2 > >main = print $ conv "TestIng" Prints: >("Tes,tI","ng") -} grab :: Int -> State [a] [a] grab count = do g <- get (x, g') <- return $ splitAt count g put g' return x {- | Similar to Data.List.elemIndex. Instead of looking for one element in a list, this function looks for the first occurance of a sublist in the list, and returns the index of the first element of that occurance. If there is no such list, returns Nothing. If the list to look for is the empty list, will return Just 0 regardless of the content of the list to search. Examples: >subIndex "foo" "asdfoobar" -> Just 3 >subIndex "foo" [] -> Nothing >subIndex "" [] -> Just 0 >subIndex "" "asdf" -> Just 0 >subIndex "test" "asdftestbartest" -> Just 4 >subIndex [(1::Int), 2] [0, 5, 3, 2, 1, 2, 4] -> Just 4 -} subIndex :: Eq a => [a] -> [a] -> Maybe Int subIndex substr str = findIndex (isPrefixOf substr) (tails str) {- | Given a list, returns a new list with all duplicate elements removed. For example: >uniq "Mississippi" -> "Misp" You should not rely on this function necessarily preserving order, though the current implementation happens to. This function is not compatible with infinite lists. This is presently an alias for 'Data.List.nub'. -} uniq :: Eq a => [a] -> [a] uniq = nub ----- same as --uniq (x:xs) = x : [y | y <- uniq xs, y /= x] MissingH-1.6.0.1/src/Data/MIME/0000755000000000000000000000000007346545000013756 5ustar0000000000000000MissingH-1.6.0.1/src/Data/MIME/Types.hs0000644000000000000000000004343607346545000015430 0ustar0000000000000000{- arch-tag: MIME Types main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.MIME.Types Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Utilities for guessing MIME types of files. Written by John Goerzen, jgoerzen\@complete.org -} module Data.MIME.Types (-- * Creating Lookup Objects defaultmtd, readMIMETypes, hReadMIMETypes, readSystemMIMETypes, -- * Basic Access MIMEResults, MIMETypeData(..), guessType, guessExtension, guessAllExtensions ) where import qualified Data.Map as Map import qualified Control.Exception (try, IOException) import Control.Monad ( foldM ) import System.IO ( Handle, hClose, openFile, IOMode(ReadMode) ) import System.IO.Error () import System.IO.Utils ( hGetLines ) import System.Path ( splitExt ) import Data.Map.Utils ( flippedLookupM ) import Data.Char ( toLower ) ---------------------------------------------------------------------- -- Basic type declarations ---------------------------------------------------------------------- data MIMETypeData = MIMETypeData { -- | A mapping used to expand common suffixes into equivolent, -- better-parsed versions. For instance, ".tgz" would expand -- into ".tar.gz". suffixMap :: Map.Map String String, -- | A mapping used to determine the encoding of a file. -- This is used, for instance, to map ".gz" to "gzip". encodingsMap :: Map.Map String String, -- | A mapping used to map extensions to MIME types. typesMap :: Map.Map String String, -- | A mapping used to augment the 'typesMap' when non-strict -- lookups are used. commonTypesMap :: Map.Map String String } {- | Return value from guessing a file's type. The first element of the tuple gives the MIME type. It is Nothing if no suitable type could be found. The second element gives the encoding. It is Nothing if there was no particular encoding for the file, or if no encoding could be found. -} type MIMEResults = (Maybe String, -- The MIME type Maybe String -- Encoding ) {- | Read the given mime.types file and add it to an existing object. Returns new object. -} readMIMETypes :: MIMETypeData -- ^ Data to work with -> Bool -- ^ Whether to work on strict data -> FilePath -- ^ File to read -> IO MIMETypeData -- ^ New object readMIMETypes mtd strict fn = do h <- openFile fn ReadMode hReadMIMETypes mtd strict h {- | Load a mime.types file from an already-open handle. -} hReadMIMETypes :: MIMETypeData -- ^ Data to work with -> Bool -- ^ Whether to work on strict data -> Handle -- ^ Handle to read from -> IO MIMETypeData -- ^ New object hReadMIMETypes mtd strict h = foldl parseline mtd <$> hGetLines h where parseline :: MIMETypeData -> String -> MIMETypeData parseline obj line = let l1 = words line procwords [] = [] procwords (('#':_) :_) = [] procwords (x:xs) = x : procwords xs l2 = procwords l1 in if (length l2) >= 2 then let thetype = head l2 suffixlist = tail l2 in foldl (\o suff -> addType o strict thetype ('.' : suff)) obj suffixlist else obj {- | Guess the type of a file given a filename or URL. The file is not opened; only the name is considered. -} guessType :: MIMETypeData -- ^ Source data for guessing -> Bool -- ^ Whether to limit to strict data -> String -- ^ File or URL name to consider -> MIMEResults -- ^ Result of guessing (see 'MIMEResults' for details on interpreting it) guessType mtd strict fn = let mapext (base, ex) = case Map.lookup ex (suffixMap mtd) of Nothing -> (base, ex) Just x -> mapext (splitExt (base ++ x)) checkencodings (base, ex) = case Map.lookup ex (encodingsMap mtd) of Nothing -> (base, ex, Nothing) Just x -> (fst (splitExt base), snd (splitExt base), Just x) (_, ext, enc) = checkencodings . mapext $ splitExt fn typemap = getStrict mtd strict in case Map.lookup ext typemap of Nothing -> (Map.lookup (map toLower ext) typemap, enc) Just x -> (Just x, enc) {- | Guess the extension of a file based on its MIME type. The return value includes the leading dot. Returns Nothing if no extension could be found. In the event that multiple possible extensions are available, one of them will be picked and returned. The logic to select one of these should be considered undefined. -} guessExtension :: MIMETypeData -- ^ Source data for guessing -> Bool -- ^ Whether to limit to strict data -> String -- ^ MIME type to consider -> Maybe String -- ^ Result of guessing, or Nothing if no match possible guessExtension mtd strict fn = case guessAllExtensions mtd strict fn of [] -> Nothing (x:_) -> Just x {- | Similar to 'guessExtension', but returns a list of all possible matching extensions, or the empty list if there are no matches. -} guessAllExtensions :: MIMETypeData -- ^ Source data for guessing -> Bool -- ^ Whether to limit to strict data -> String -- ^ MIME type to consider -> [String] -- ^ Result of guessing guessAllExtensions mtd strict fn = let mimetype = map toLower fn themap = getStrict mtd strict in flippedLookupM mimetype themap {- | Adds a new type to the data structures, replacing whatever data may exist about it already. That is, it overrides existing information about the given extension, but the same type may occur more than once. -} addType :: MIMETypeData -- ^ Source data -> Bool -- ^ Whether to add to strict data set -> String -- ^ MIME type to add -> String -- ^ Extension to add -> MIMETypeData -- ^ Result of addition addType mtd strict thetype theext = setStrict mtd strict (\m -> Map.insert theext thetype m) {- | Default MIME type data to use -} defaultmtd :: MIMETypeData defaultmtd = MIMETypeData {suffixMap = default_suffix_map, encodingsMap = default_encodings_map, typesMap = default_types_map, commonTypesMap = default_common_types} {- | Read the system's default mime.types files, and add the data contained therein to the passed object, then return the new one. -} readSystemMIMETypes :: MIMETypeData -> IO MIMETypeData readSystemMIMETypes mtd = let tryread :: MIMETypeData -> String -> IO MIMETypeData tryread inputobj filename = do fn <- Control.Exception.try (openFile filename ReadMode) case fn of Left (_ :: Control.Exception.IOException) -> return inputobj Right h -> do x <- hReadMIMETypes inputobj True h hClose h return x in do foldM tryread mtd defaultfilelocations ---------------------------------------------------------------------- -- Internal utilities ---------------------------------------------------------------------- getStrict :: MIMETypeData -> Bool -> Map.Map String String getStrict mtd True = typesMap mtd getStrict mtd False = Map.union (typesMap mtd) (commonTypesMap mtd) setStrict :: MIMETypeData -> Bool -> (Map.Map String String -> Map.Map String String) -> MIMETypeData setStrict mtd True func = mtd{typesMap = func (typesMap mtd)} setStrict mtd False func = mtd{commonTypesMap = func (commonTypesMap mtd)} ---------------------------------------------------------------------- -- Default data structures ---------------------------------------------------------------------- defaultfilelocations :: [String] defaultfilelocations = [ "/etc/mime.types", "/usr/local/etc/httpd/conf/mime.types", "/usr/local/lib/netscape/mime.types", "/usr/local/etc/httpd/conf/mime.types", -- Apache 1.2 "/usr/local/etc/mime.types" -- Apache 1.3 ] default_encodings_map, default_suffix_map, default_types_map, default_common_types :: Map.Map String String default_encodings_map = Map.fromList [ (".Z", "compress"), (".gz", "gzip"), (".bz2", "bzip2") ] default_suffix_map = Map.fromList [ (".tgz", ".tar.gz"), (".tz", ".tar.gz"), (".taz", ".tar.gz") ] default_types_map = Map.fromList [ (".a", "application/octet-stream"), (".ai", "application/postscript"), (".aif", "audio/x-aiff"), (".aifc", "audio/x-aiff"), (".aiff", "audio/x-aiff"), (".au", "audio/basic"), (".avi", "video/x-msvideo"), (".bat", "text/plain"), (".bcpio", "application/x-bcpio"), (".bin", "application/octet-stream"), (".bmp", "image/x-ms-bmp"), (".c", "text/plain"), (".cdf", "application/x-netcdf"), (".cpio", "application/x-cpio"), (".csh", "application/x-csh"), (".css", "text/css"), (".dll", "application/octet-stream"), (".doc", "application/msword"), (".dot", "application/msword"), (".dvi", "application/x-dvi"), (".eml", "message/rfc822"), (".eps", "application/postscript"), (".etx", "text/x-setext"), (".exe", "application/octet-stream"), (".gif", "image/gif"), (".gtar", "application/x-gtar"), (".h", "text/plain"), (".hdf", "application/x-hdf"), (".htm", "text/html"), (".html", "text/html"), (".ief", "image/ief"), (".jpe", "image/jpeg"), (".jpeg", "image/jpeg"), (".jpg", "image/jpeg"), (".js", "application/x-javascript"), (".ksh", "text/plain"), (".latex", "application/x-latex"), (".m1v", "video/mpeg"), (".man", "application/x-troff-man"), (".me", "application/x-troff-me"), (".mht", "message/rfc822"), (".mhtml", "message/rfc822"), (".mif", "application/x-mif"), (".mov", "video/quicktime"), (".movie", "video/x-sgi-movie"), (".mp2", "audio/mpeg"), (".mp3", "audio/mpeg"), (".mpa", "video/mpeg"), (".mpe", "video/mpeg"), (".mpeg", "video/mpeg"), (".mpg", "video/mpeg"), (".ms", "application/x-troff-ms"), (".nc", "application/x-netcdf"), (".nws", "message/rfc822"), (".o", "application/octet-stream"), (".obj", "application/octet-stream"), (".oda", "application/oda"), (".p12", "application/x-pkcs12"), (".p7c", "application/pkcs7-mime"), (".pbm", "image/x-portable-bitmap"), (".pdf", "application/pdf"), (".pfx", "application/x-pkcs12"), (".pgm", "image/x-portable-graymap"), (".pl", "text/plain"), (".png", "image/png"), (".pnm", "image/x-portable-anymap"), (".pot", "application/vnd.ms-powerpoint"), (".ppa", "application/vnd.ms-powerpoint"), (".ppm", "image/x-portable-pixmap"), (".pps", "application/vnd.ms-powerpoint"), (".ppt", "application/vnd.ms-powerpoint"), (".ps", "application/postscript"), (".pwz", "application/vnd.ms-powerpoint"), (".py", "text/x-python"), (".pyc", "application/x-python-code"), (".pyo", "application/x-python-code"), (".qt", "video/quicktime"), (".ra", "audio/x-pn-realaudio"), (".ram", "application/x-pn-realaudio"), (".ras", "image/x-cmu-raster"), (".rdf", "application/xml"), (".rgb", "image/x-rgb"), (".roff", "application/x-troff"), (".rtx", "text/richtext"), (".sgm", "text/x-sgml"), (".sgml", "text/x-sgml"), (".sh", "application/x-sh"), (".shar", "application/x-shar"), (".snd", "audio/basic"), (".so", "application/octet-stream"), (".src", "application/x-wais-source"), (".sv4cpio", "application/x-sv4cpio"), (".sv4crc", "application/x-sv4crc"), (".swf", "application/x-shockwave-flash"), (".t", "application/x-troff"), (".tar", "application/x-tar"), (".tcl", "application/x-tcl"), (".tex", "application/x-tex"), (".texi", "application/x-texinfo"), (".texinfo", "application/x-texinfo"), (".tif", "image/tiff"), (".tiff", "image/tiff"), (".tr", "application/x-troff"), (".tsv", "text/tab-separated-values"), (".txt", "text/plain"), (".ustar", "application/x-ustar"), (".vcf", "text/x-vcard"), (".wav", "audio/x-wav"), (".wiz", "application/msword"), (".xbm", "image/x-xbitmap"), (".xlb", "application/vnd.ms-excel"), (".xls", "application/vnd.ms-excel"), (".xml", "text/xml"), (".xpm", "image/x-xpixmap"), (".xsl", "application/xml"), (".xwd", "image/x-xwindowdump"), (".zip", "application/zip") ] default_common_types = Map.fromList [ (".jpg", "image/jpg"), (".mid", "audio/midi"), (".midi", "audio/midi"), (".pct", "image/pict"), (".pic", "image/pict"), (".pict", "image/pict"), (".rtf", "application/rtf"), (".xul", "text/xul") ] MissingH-1.6.0.1/src/Data/Map/0000755000000000000000000000000007346545000013744 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Map/Utils.hs0000644000000000000000000000530107346545000015377 0ustar0000000000000000{-# LANGUAGE Safe #-} {- Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Map.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with Data.Maps. Written by John Goerzen, jgoerzen\@complete.org -} module Data.Map.Utils (-- * Basic Utilities flipM, flippedLookupM, forceLookupM, -- * Conversions strToM, strFromM ) where import Data.List.Utils (flipAL, strFromAL, strToAL) import qualified Data.Map {- | Converts a String, String Map into a string representation. See 'Data.List.Utils.strFromAL' for more on the similar function for association lists. This implementation is simple: >strFromM = strFromAL . Data.Map.toList This function is designed to work with Map String String objects, but may also work with other objects with simple representations. -} strFromM :: (Show a, Show b, Ord a) => Data.Map.Map a b -> String strFromM = strFromAL . Data.Map.toList {- | Converts a String into a String, String Map. See 'Data.List.Utils.strToAL' for more on the similar function for association lists. This implementation is simple: >strToM = Data.Map.fromList . strToAL This function is designed to work with Map String String objects, but may work with other key\/value combinations if they have simple representations. -} strToM :: (Read a, Read b, Ord a) => String -> Data.Map.Map a b strToM = Data.Map.fromList . strToAL {- | Flips a Map. See 'Data.List.Utils.flipAL' for more on the similar function for lists. -} flipM :: (Ord key, Ord val) => Data.Map.Map key val -> Data.Map.Map val [key] flipM = Data.Map.fromList . flipAL . Data.Map.toList {- | Returns a list of all keys in the Map whose value matches the parameter. If the value does not occur in the Map, the empty list is returned. -} flippedLookupM :: (Ord val, Ord key) => val -> Data.Map.Map key val -> [key] flippedLookupM v fm = case Data.Map.lookup v (flipM fm) of Nothing -> [] Just x -> x {- | Performs a lookup, and raises an exception (with an error message prepended with the given string) if the key could not be found. -} forceLookupM :: (Show key, Ord key) => String -> key -> Data.Map.Map key elt -> elt forceLookupM msg k fm = case Data.Map.lookup k fm of Just x -> x Nothing -> error $ msg ++ ": could not find key " ++ (show k) MissingH-1.6.0.1/src/Data/Maybe/0000755000000000000000000000000007346545000014264 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Maybe/Utils.hs0000644000000000000000000000163107346545000015721 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Maybe utilities Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Maybe.Utils Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Utilities for working with the 'Maybe' data type. -} module Data.Maybe.Utils ( forceMaybe, forceMaybeMsg ) where import Data.Maybe (fromJust) {- | Pulls a 'Just' value out of a 'Maybe' value. If the 'Maybe' value is 'Nothing', raises an exception with error. Alias of 'Data.Maybe.fromJust'. -} forceMaybe :: Maybe a -> a forceMaybe = fromJust {- | Like 'forceMaybe', but lets you customize the error message raised if 'Nothing' is supplied. -} forceMaybeMsg :: String -> Maybe a -> a forceMaybeMsg msg = maybe (error msg) id MissingH-1.6.0.1/src/Data/Progress/0000755000000000000000000000000007346545000015033 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Progress/Meter.hs0000644000000000000000000002210707346545000016445 0ustar0000000000000000{-# LANGUAGE Safe #-} {- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Progress.Meter Copyright : Copyright (C) 2006-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Tool for maintaining a status bar, supporting multiple simultaneous tasks, as a layer atop "Data.Progress.Tracker". Written by John Goerzen, jgoerzen\@complete.org -} module Data.Progress.Meter (-- * Types ProgressMeter, -- * Creation and Configuration simpleNewMeter, newMeter, setComponents, addComponent, removeComponent, setWidth, -- * Rendering and Output renderMeter, displayMeter, clearMeter, writeMeterString, autoDisplayMeter, killAutoDisplayMeter ) where import safe Data.Progress.Tracker ( ProgressStatuses(..), Progress, ProgressStatus(totalUnits, completedUnits, trackerName), getSpeed, getETR ) import safe Control.Concurrent ( modifyMVar_, withMVar, newMVar, MVar, threadDelay, forkIO, myThreadId, yield, ThreadId ) import Control.Monad (when) import Data.String.Utils (join) import System.Time.Utils (renderSecs) import Data.Quantity (renderNums, binaryOpts) import safe System.IO ( Handle, hFlush, hPutStr ) import Control.Monad (filterM) {- | The main data type for the progress meter. -} data ProgressMeterR = ProgressMeterR {masterP :: Progress, -- ^ The master 'Progress' object for overall status components :: [Progress], -- ^ Individual component statuses width :: Int, -- ^ Width of the meter unit :: String, -- ^ Units of display renderer :: [Integer] -> [String], -- ^ Function to render numbers autoDisplayers :: [ThreadId] -- ^ Auto-updating display } type ProgressMeter = MVar ProgressMeterR {- | Set up a new status bar using defaults: * The given tracker * Width 80 * Data.Quantity.renderNums binaryOpts 1 * Unit inticator @"B"@ -} simpleNewMeter :: Progress -> IO ProgressMeter simpleNewMeter pt = newMeter pt "B" 80 (renderNums binaryOpts 1) {- | Set up a new status bar. -} newMeter :: Progress -- ^ The top-level 'Progress' -> String -- ^ Unit indicator string -> Int -- ^ Width of the terminal -- usually 80 -> ([Integer] -> [String])-- ^ A function to render sizes -> IO ProgressMeter newMeter tracker u w rfunc = newMVar $ ProgressMeterR {masterP = tracker, components = [], width = w, renderer = rfunc, autoDisplayers = [], unit = u} {- | Adjust the list of components of this 'ProgressMeter'. -} setComponents :: ProgressMeter -> [Progress] -> IO () setComponents meter componentlist = modifyMVar_ meter (\m -> return $ m {components = componentlist}) {- | Add a new component to the list of components. -} addComponent :: ProgressMeter -> Progress -> IO () addComponent meter component = modifyMVar_ meter (\m -> return $ m {components = component : components m}) {- | Remove a component by name. -} removeComponent :: ProgressMeter -> String -> IO () removeComponent meter componentname = modifyMVar_ meter $ \m -> do newc <- filterM (\x -> withStatus x (\y -> return $ trackerName y /= componentname)) (components m) return $ m {components = newc} {- | Adjusts the width of this 'ProgressMeter'. -} setWidth :: ProgressMeter -> Int -> IO () setWidth meter w = modifyMVar_ meter (\m -> return $ m {width = w}) {- | Like renderMeter, but prints it to the screen instead of returning it. This function will output CR, then the meter. Pass stdout as the handle for regular display to the screen. -} displayMeter :: Handle -> ProgressMeter -> IO () displayMeter h r = withMVar r $ \meter -> do s <- renderMeterR meter hPutStr h ("\r" ++ s) hFlush h -- By placing this whole thing under withMVar, we can effectively -- lock the IO and prevent IO from stomping on each other. {- | Clears the meter -- outputs CR, spaces equal to the width - 1, then another CR. Pass stdout as the handle for regular display to the screen. -} clearMeter :: Handle -> ProgressMeter -> IO () clearMeter h pm = withMVar pm $ \m -> do hPutStr h (clearmeterstr m) hFlush h {- | Clears the meter, writes the given string, then restores the meter. The string is assumed to contain a trailing newline. Pass stdout as the handle for regular display to the screen. -} writeMeterString :: Handle -> ProgressMeter -> String -> IO () writeMeterString h pm msg = withMVar pm $ \meter -> do s <- renderMeterR meter hPutStr h (clearmeterstr meter) hPutStr h msg hPutStr h s hFlush h clearmeterstr :: ProgressMeterR -> String clearmeterstr m = "\r" ++ replicate (width m - 1) ' ' ++ "\r" {- | Starts a thread that updates the meter every n seconds by calling the specified function. Note: @displayMeter stdout@ is an ideal function here. Save this threadID and use it later to call 'stopAutoDisplayMeter'. -} autoDisplayMeter :: ProgressMeter -- ^ The meter to display -> Int -- ^ Update interval in seconds -> (ProgressMeter -> IO ()) -- ^ Function to display it -> IO ThreadId -- ^ Resulting thread id autoDisplayMeter pm delay displayfunc = do thread <- forkIO workerthread modifyMVar_ pm (\p -> return $ p {autoDisplayers = thread : autoDisplayers p}) return thread where workerthread = do tid <- myThreadId -- Help fix a race condition so that the above -- modifyMVar can run before a check ever does yield loop tid loop tid = do displayfunc pm threadDelay (delay * 1000000) c <- doIContinue tid when c (loop tid) doIContinue tid = withMVar pm $ \p -> if tid `elem` autoDisplayers p then return True else return False {- | Stops the specified meter from displaying. You should probably call 'clearMeter' after a call to this. -} killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO () killAutoDisplayMeter pm t = modifyMVar_ pm (\p -> return $ p {autoDisplayers = filter (/= t) (autoDisplayers p)}) {- | Render the current status. -} renderMeter :: ProgressMeter -> IO String renderMeter r = withMVar r $ renderMeterR renderMeterR :: ProgressMeterR -> IO String renderMeterR meter = do overallpct <- renderpct $ masterP meter compnnts <- mapM (rendercomponent $ renderer meter) (components meter) let componentstr = case join " " compnnts of [] -> "" x -> x ++ " " rightpart <- renderoverall (renderer meter) (masterP meter) let leftpart = overallpct ++ " " ++ componentstr let padwidth = (width meter) - 1 - (length leftpart) - (length rightpart) if padwidth < 1 then return $ take (width meter - 1) $ leftpart ++ rightpart else return $ leftpart ++ replicate padwidth ' ' ++ rightpart where u = unit meter renderpct pt = withStatus pt renderpctpts renderpctpts pts = if (totalUnits pts == 0) then return "0%" else return $ show (((completedUnits pts) * 100) `div` (totalUnits pts)) ++ "%" rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String rendercomponent rfunc pt = withStatus pt $ \pts -> do pct <- renderpctpts pts let renders = rfunc [totalUnits pts, completedUnits pts] return $ "[" ++ trackerName pts ++ " " ++ (renders !! 1) ++ u ++ "/" ++ head renders ++ u ++ " " ++ pct ++ "]" renderoverall :: (ProgressStatuses a (IO [Char])) => ([Integer] -> [[Char]]) -> a -> IO [Char] renderoverall rfunc pt = withStatus pt $ \pts -> do etr <- getETR pts speed <- getSpeed pts return $ head (rfunc [floor (speed :: Double)]) ++ u ++ "/s " ++ renderSecs etr MissingH-1.6.0.1/src/Data/Progress/Tracker.hs0000644000000000000000000003661007346545000016770 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Progress.Tracker Copyright : Copyright (C) 2006-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Tools for tracking the status of a long operation. Written by John Goerzen, jgoerzen\@complete.org See also "Data.Progress.Meter" -} module Data.Progress.Tracker ( -- * Introduction -- $introduction -- ** Examples -- $examples -- * Creation and Options newProgress, newProgress', addCallback, addParent, -- * Updating incrP, incrP', setP, setP', incrTotal, setTotal, finishP, -- * Reading and Processing getSpeed, withStatus, getETR, getETA, -- * Types ProgressStatus(..), Progress, ProgressTimeSource, ProgressCallback, ProgressStatuses, -- * Utilities defaultTimeSource ) where import safe Control.Concurrent.MVar ( modifyMVar_, withMVar, newMVar, MVar ) import safe System.Time ( getClockTime ) import safe System.Time.Utils ( clockTimeToEpoch ) import safe Data.Ratio ( (%) ) {- $introduction ProgressTracker is a module for tracking the progress on long-running operations. It can be thought of as the back end engine behind a status bar. ProgressTracker can do things such as track how far along a task is, provide an estimated time of completion, estimated time remaining, current speed, etc. It is designed to be as generic as possible; it can even base its speed calculations on something other than the system clock. ProgressTracker also supports a notion of a parent tracker. This is used when a large task is composed of several individual tasks which may also be long-running. Downloading many large files over the Internet is a common example of this. Any given ProgressTracker can be told about one or more parent trackers. When the child tracker's status is updated, the parent tracker's status is also updated in the same manner. Therefore, the progress on each individual component, as well as the overall progress, can all be kept in sync automatically. Finally, you can register callbacks. Callbacks are functions that are called whenever the status of a tracker changes. They'll be passed the old and new status and are intended to do things like update on-screen status displays. The cousin module 'Data.Progress.Meter' can be used to nicely render these trackers on a console. -} {- $examples Here is an example use: >do prog <- newProgress "mytracker" 1024 > incrP prog 10 > getETR prog >>= print -- prints number of seconds remaining > incrP prog 500 > finishP prog -} ---------------------------------------------------------------------- -- TYPES ---------------------------------------------------------------------- {- | A function that, when called, yields the current time. The default is 'defaultTimeSource'. -} type ProgressTimeSource = IO Integer {- | The type for a callback function for the progress tracker. When given at creation time to 'newProgress\'' or when added via 'addCallback', these functions get called every time the status of the tracker changes. This function is passed two 'ProgressStatus' records: the first reflects the status prior to the update, and the second reflects the status after the update. Please note that the owning 'Progress' object will be locked while the callback is running, so the callback will not be able to make changes to it. -} type ProgressCallback = ProgressStatus -> ProgressStatus -> IO () {- | The main progress status record. -} data ProgressStatus = ProgressStatus {completedUnits :: Integer, totalUnits :: Integer, startTime :: Integer, trackerName :: String, -- ^ An identifying string timeSource :: ProgressTimeSource } data ProgressRecord = ProgressRecord {parents :: [Progress], callbacks :: [ProgressCallback], status :: ProgressStatus} {- | The main Progress object. -} newtype Progress = Progress (MVar ProgressRecord) class ProgressStatuses a b where {- | Lets you examine the 'ProgressStatus' that is contained within a 'Progress' object. You can simply pass a 'Progress' object and a function to 'withStatus', and 'withStatus' will lock the 'Progress' object (blocking any modifications while you are reading it), then pass the object to your function. If you happen to already have a 'ProgressStatus' object, withStatus will also accept it and simply pass it unmodified to the function. -} withStatus :: a -> (ProgressStatus -> b) -> b instance ProgressStatuses Progress (IO b) where withStatus (Progress x) func = withMVar x (\y -> func (status y)) instance ProgressStatuses ProgressStatus b where withStatus x func = func x ---------------------------------------------------------------------- -- Creation ---------------------------------------------------------------------- {- | Create a new 'Progress' object with the given name and number of total units initialized as given. The start time will be initialized with the current time at the present moment according to the system clock. The units completed will be set to 0, the time source will be set to the system clock, and the parents and callbacks will be empty. If you need more control, see 'newProgress\''. Example: > prog <- newProgress "mytracker" 1024 -} newProgress :: String -- ^ Name of this tracker -> Integer -- ^ Total units expected -> IO Progress newProgress name total = do t <- defaultTimeSource newProgress' (ProgressStatus {completedUnits = 0, totalUnits = total, startTime = t, trackerName = name, timeSource = defaultTimeSource}) [] {- | Create a new 'Progress' object initialized with the given status and callbacks. No adjustment to the 'startTime' will be made. If you want to use the system clock, you can initialize 'startTime' with the return value of 'defaultTimeSource' and also pass 'defaultTimeSource' as the timing source. -} newProgress' :: ProgressStatus -> [ProgressCallback] -> IO Progress newProgress' news newcb = do r <- newMVar $ ProgressRecord {parents = [], callbacks = newcb, status = news} return (Progress r) {- | Adds an new callback to an existing 'Progress'. The callback will be called whenever the object's status is updated, except by the call to finishP. Please note that the Progress object will be locked while the callback is running, so the callback will not be able to make any modifications to it. -} addCallback :: Progress -> ProgressCallback -> IO () addCallback (Progress mpo) cb = modifyMVar_ mpo $ \po -> return $ po {callbacks = cb : callbacks po} {- | Adds a new parent to an existing 'Progress'. The parent will automatically have its completed and total counters incremented by the value of those counters in the existing 'Progress'. -} addParent :: Progress -- ^ The child object -> Progress -- ^ The parent to add to this child -> IO () addParent (Progress mcpo) ppo = modifyMVar_ mcpo $ \cpo -> do incrP' ppo (completedUnits . status $ cpo) incrTotal ppo (totalUnits . status $ cpo) return $ cpo {parents = ppo : parents cpo} {- | Call this when you are finished with the object. It is especially important to do this when parent objects are involved. This will simply set the totalUnits to the current completedUnits count, but will not call the callbacks. It will additionally propogate any adjustment in totalUnits to the parents, whose callbacks /will/ be called. This ensures that the total expected counts on the parent are always correct. Without doing this, if, say, a transfer ended earlier than expected, ETA values on the parent would be off since it would be expecting more data than actually arrived. -} finishP :: Progress -> IO () finishP (Progress mp) = modifyMVar_ mp modfunc where modfunc :: ProgressRecord -> IO ProgressRecord modfunc oldpr = do let adjustment = (completedUnits . status $ oldpr) - (totalUnits . status $ oldpr) callParents oldpr (\x -> incrTotal x adjustment) return $ oldpr {status = (status oldpr) {totalUnits = completedUnits . status $ oldpr}} ---------------------------------------------------------------------- -- Updating ---------------------------------------------------------------------- {- | Increment the completed unit count in the 'Progress' object by the amount given. If the value as given exceeds the total, then the total will also be raised to match this value so that the completed count never exceeds the total. You can decrease the completed unit count by supplying a negative number here. -} incrP :: Progress -> Integer -> IO () incrP po count = modStatus po statusfunc where statusfunc s = s {completedUnits = newcu s, totalUnits = if newcu s > totalUnits s then newcu s else totalUnits s} newcu s = completedUnits s + count {- | Like 'incrP', but never modify the total. -} incrP' :: Progress -> Integer -> IO () incrP' po count = modStatus po (\s -> s {completedUnits = completedUnits s + count}) {- | Set the completed unit count in the 'Progress' object to the specified value. Unlike 'incrP', this function sets the count to a specific value, rather than adding to the existing value. If this value exceeds the total, then the total will also be raised to match this value so that the completed count never exceeds teh total. -} setP :: Progress -> Integer -> IO () setP po count = modStatus po statusfunc where statusfunc s = s {completedUnits = count, totalUnits = if count > totalUnits s then count else totalUnits s} {- | Like 'setP', but never modify the total. -} setP' :: Progress -> Integer -> IO () setP' po count = modStatus po (\s -> s {completedUnits = count}) {- | Increment the total unit count in the 'Progress' object by the amount given. This would rarely be needed, but could be needed in some special cases when the total number of units is not known in advance. -} incrTotal :: Progress -> Integer -> IO () incrTotal po count = modStatus po (\s -> s {totalUnits = totalUnits s + count}) {- | Set the total unit count in the 'Progress' object to the specified value. Like 'incrTotal', this would rarely be needed. -} setTotal :: Progress -> Integer -> IO () setTotal po count = modStatus po (\s -> s {totalUnits = count}) ---------------------------------------------------------------------- -- Reading and Processing ---------------------------------------------------------------------- {- | Returns the speed in units processed per time unit. (If you are using the default time source, this would be units processed per second). This obtains the current speed solely from analyzing the 'Progress' object. If no time has elapsed yet, returns 0. You can use this against either a 'Progress' object or a 'ProgressStatus' object. This is in the IO monad because the speed is based on the current time. Example: > getSpeed progressobj >>= print Don't let the type of this function confuse you. It is a fancy way of saying that it can take either a 'Progress' or a 'ProgressStatus' object, and returns a number that is valid as any Fractional type, such as a Double, Float, or Rational. -} getSpeed :: (ProgressStatuses a (IO b), Fractional b) => a -> IO b getSpeed po = withStatus po $ \status -> do t <- timeSource status let elapsed = t - (startTime status) return $ if elapsed == 0 then fromRational 0 else fromRational ((completedUnits status) % elapsed) {- | Returns the estimated time remaining, in standard time units. Returns 0 whenever 'getSpeed' would return 0. See the comments under 'getSpeed' for information about this function's type and result. -} getETR :: (ProgressStatuses a (IO Integer), ProgressStatuses a (IO Rational)) => a -> IO Integer getETR po = do speed <- ((getSpeed po)::IO Rational) if speed == 0 then return 0 else -- FIXME: potential for a race condition here, but it should -- be negligible withStatus po $ \status -> do let remaining = totalUnits status - completedUnits status return $ round $ (toRational remaining) / speed {- | Returns the estimated system clock time of completion, in standard time units. Returns the current time whenever 'getETR' would return 0. See the comments under 'getSpeed' for information about this function's type and result. -} getETA :: (ProgressStatuses a (IO Integer), ProgressStatuses a (IO Rational)) => a -> IO Integer getETA po = do etr <- getETR po -- FIXME: similar race potential here withStatus po $ \status -> do timenow <- timeSource status return $ timenow + etr ---------------------------------------------------------------------- -- Utilities ---------------------------------------------------------------------- {- | The default time source for the system. This is defined as: >getClockTime >>= (return . clockTimeToEpoch) -} defaultTimeSource :: ProgressTimeSource defaultTimeSource = getClockTime >>= (return . clockTimeToEpoch) modStatus :: Progress -> (ProgressStatus -> ProgressStatus) -> IO () -- FIXME/TODO: handle parents modStatus (Progress mp) func = modifyMVar_ mp modfunc where modfunc :: ProgressRecord -> IO ProgressRecord modfunc oldpr = do let newpr = oldpr {status = func (status oldpr)} mapM_ (\x -> x (status oldpr) (status newpr)) (callbacks oldpr) -- Kick it up to the parents. case (completedUnits . status $ newpr) - (completedUnits . status $ oldpr) of 0 -> return () x -> callParents newpr (\y -> incrP' y x) case (totalUnits . status $ newpr) - (totalUnits . status $ oldpr) of 0 -> return () x -> callParents newpr (\y -> incrTotal y x) return newpr callParents :: ProgressRecord -> (Progress -> IO ()) -> IO () callParents pr func = mapM_ func (parents pr) MissingH-1.6.0.1/src/Data/Quantity.hs0000644000000000000000000002051407346545000015403 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.Quantity Copyright : Copyright (C) 2006-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Tools for rendering sizes Written by John Goerzen, jgoerzen\@complete.org -} module Data.Quantity ( renderNum, renderNums, parseNum, parseNumInt, quantifyNum, quantifyNums, SizeOpts(..), binaryOpts, siOpts ) where import safe Data.Char ( toLower ) import safe Data.List (find) import safe Text.Printf ( printf ) {- | The options for 'quantifyNum' and 'renderNum' -} data SizeOpts = SizeOpts { base :: Int, -- ^ The base from which calculations are made powerIncr :: Int, -- ^ The increment to the power for each new suffix firstPower :: Int, -- ^ The first power for which suffixes are given suffixes :: String -- ^ The suffixes themselves } {- | Predefined definitions for byte measurement in groups of 1024, from 0 to 2**80 -} binaryOpts :: SizeOpts binaryOpts = SizeOpts {base = 2, firstPower = 0, suffixes = " KMGTPEZY", powerIncr = 10} {- | Predefined definitions for SI measurement, from 10**-24 to 10**24. -} siOpts :: SizeOpts siOpts = SizeOpts {base = 10, firstPower = -24, suffixes = "yzafpnum kMGTPEZY", powerIncr = 3} {- | Takes a number and returns a new (quantity, suffix) combination. The space character is used as the suffix for items around 0. -} quantifyNum :: (Ord a, Real a, Floating b, Ord b) => SizeOpts -> a -> (b, Char) quantifyNum opts n = (\(x, s) -> (head x, s)) $ quantifyNums opts [n] {- | Like 'quantifyNum', but takes a list of numbers. The first number in the list will be evaluated for the suffix. The same suffix and scale will be used for the remaining items in the list. Please see 'renderNums' for an example of how this works. It is invalid to use this function on an empty list. -} quantifyNums :: (Ord a, Real a, Floating b, Ord b) => SizeOpts -> [a] -> ([b], Char) quantifyNums _ [] = error "Attempt to use quantifyNums on an empty list" quantifyNums opts (headnum:xs) = (map (\n -> procnum n) (headnum:xs), suffix) where number = case fromRational . toRational $ headnum of 0 -> 1 x -> x incrList = map idx2pwr [0..length (suffixes opts) - 1] incrIdxList = zip incrList [0..] idx2pwr i = i * powerIncr opts + firstPower opts finderfunc (x, _) = (fromIntegral $ base opts) ** (fromIntegral x) <= (abs number) -- Find the largest item that does not exceed the number given. -- If the number is larger than the larger item in the list, -- that's fine; we'll just write it in terms of what we have. (usedexp, expidx) = case find finderfunc (reverse incrIdxList) of Just x -> x Nothing -> head incrIdxList -- If not found, it's smaller than the first suffix = (suffixes opts !! (fromIntegral expidx)) procnum n = (fromRational . toRational $ n) / ((fromIntegral (base opts) ** (fromIntegral usedexp))) --(posres, possuf) = quantifyNum opts (headnum * (-1)) {- | Render a number into a string, based on the given quantities. This is useful for displaying quantities in terms of bytes or in SI units. Give this function the 'SizeOpts' for the desired output, and a precision (number of digits to the right of the decimal point), and you get a string output. Here are some examples: > Data.Quantity> renderNum binaryOpts 0 1048576 > "1M" > Data.Quantity> renderNum binaryOpts 2 10485760 > "10.00M" > Data.Quantity> renderNum binaryOpts 3 1048576 > "1.000M" > Data.Quantity> renderNum binaryOpts 3 1500000 > "1.431M" > Data.Quantity> renderNum binaryOpts 2 (1500 ** 3) > "3.14G" > Data.Quantity> renderNum siOpts 2 1024 > "1.02k" > Data.Quantity> renderNum siOpts 2 1048576 > "1.05M" > Data.Quantity> renderNum siOpts 2 0.001 > "1.00m" > Data.Quantity> renderNum siOpts 2 0.0001 > "100.00u" If you want more control over the output, see 'quantifyNum'. -} renderNum :: (Ord a, Real a) => SizeOpts -> Int -- ^ Precision of the result -> a -- ^ The number to examine -> String renderNum opts prec number = (printf ("%." ++ show prec ++ "g") num) ++ [suffix] where (num, suffix) = (quantifyNum opts number)::(Double, Char) {- | Like 'renderNum', but operates on a list of numbers. The first number in the list will be evaluated for the suffix. The same suffix and scale will be used for the remaining items in the list. See 'renderNum' for more examples. Also, unlike 'renderNum', the %f instead of %g printf format is used so that \"scientific\" notation is avoided in the output. Examples: > *Data.Quantity> renderNums binaryOpts 3 [1500000, 10240, 104857600] > ["1.431M","0.010M","100.000M"] > *Data.Quantity> renderNums binaryOpts 3 [1500, 10240, 104857600] > ["1.465K","10.000K","102400.000K"] -} renderNums :: (Ord a, Real a) => SizeOpts -> Int -- ^ Prevision of the result -> [a] -- ^ The numbers to examine -> [String] -- ^ Result renderNums opts prec numbers = map printit convnums where printit num = (printf ("%." ++ show prec ++ "f") num) ++ [suffix] (convnums, suffix) = (quantifyNums opts numbers)::([Double], Char) {- | Parses a String, possibly generated by 'renderNum'. Parses the suffix and applies it to the number, which is read via the Read class. Returns Left "error message" on error, or Right number on successful parse. If you want an Integral result, the convenience function 'parseNumInt' is for you. -} parseNum :: (Read a, Fractional a) => SizeOpts -- ^ Information on how to parse this data -> Bool -- ^ Whether to perform a case-insensitive match -> String -- ^ The string to parse -> Either String a parseNum opts insensitive inp = case reads inp of [] -> Left "Couldn't parse numeric component of input" [(num, "")] -> Right num -- No suffix; pass number unhindered [(num, [suffix])] -> case lookup (caseTransformer suffix) suffixMap of Nothing -> Left $ "Unrecognized suffix " ++ show suffix Just power -> Right $ num * multiplier power [(_, suffix)] -> Left $ "Multi-character suffix " ++ show suffix _ -> Left "Multiple parses for input" where suffixMap = zip (map caseTransformer . suffixes $ opts) (iterate (+ (powerIncr opts)) (firstPower opts)) caseTransformer x | insensitive = toLower x | otherwise = x multiplier :: (Read a, Fractional a) => Int -> a multiplier power = fromRational . toRational $ fromIntegral (base opts) ** fromIntegral power {- | Parse a number as with 'parseNum', but return the result as an 'Integral'. Any type such as Integer, Int, etc. can be used for the result type. This function simply calls 'round' on the result of 'parseNum'. A 'Double' is used internally for the parsing of the numeric component. By using this function, a user can still say something like 1.5M and get an integral result. -} parseNumInt :: (Read a, Integral a) => SizeOpts -- ^ Information on how to parse this data -> Bool -- ^ Whether to perform a case-insensitive match -> String -- ^ The string to parse -> Either String a parseNumInt opts insensitive inp = case (parseNum opts insensitive inp)::Either String Double of Left x -> Left x Right n -> Right (round n) MissingH-1.6.0.1/src/Data/String/0000755000000000000000000000000007346545000014475 5ustar0000000000000000MissingH-1.6.0.1/src/Data/String/Utils.hs0000644000000000000000000000641007346545000016132 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: String utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Data.String.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with strings. Written by John Goerzen, jgoerzen\@complete.org -} module Data.String.Utils (-- * Whitespace Removal strip, lstrip, rstrip, -- * Tests -- | Note: These functions are aliases for functions -- in "Data.List.Utils". startswith, endswith, -- * Conversions -- | Note: Some of these functions are aliases for functions -- in "Data.List.Utils". join, split, splitWs, replace, escapeRe, -- * Reading maybeRead ) where import Data.Char (isAlpha, isAscii, isDigit) import Data.List.Utils (endswith, join, replace, split, startswith) import Data.Maybe (listToMaybe) import Text.Regex (mkRegex, splitRegex) wschars :: String wschars = " \t\r\n" {- | Removes any whitespace characters that are present at the start or end of a string. Does not alter the internal contents of a string. If no whitespace characters are present at the start or end of a string, returns the original string unmodified. Safe to use on any string. Note that this may differ from some other similar functions from other authors in that: 1. If multiple whitespace characters are present all in a row, they are all removed; 2. If no whitespace characters are present, nothing is done. -} strip :: String -> String strip = lstrip . rstrip -- | Same as 'strip', but applies only to the left side of the string. lstrip :: String -> String lstrip s = case s of [] -> [] (x:xs) -> if elem x wschars then lstrip xs else s -- | Same as 'strip', but applies only to the right side of the string. rstrip :: String -> String rstrip = reverse . lstrip . reverse {- | Splits a string around whitespace. Empty elements in the result list are automatically removed. -} splitWs :: String -> [String] splitWs = filter (\x -> x /= []) . splitRegex (mkRegex "[ \t\n\r\v\f]+") {- | Escape all characters in the input pattern that are not alphanumeric. Does not make special allowances for NULL, which isn't valid in a Haskell regular expression pattern. -} escapeRe :: String -> String escapeRe [] = [] escapeRe (x:xs) -- Chars that we never escape | x `elem` ['\'', '`'] = x : escapeRe xs -- General rules for chars we never escape | isDigit x || (isAscii x && isAlpha x) || x `elem` ['<', '>'] = x : escapeRe xs -- Escape everything else | otherwise = '\\' : x : escapeRe xs -- | Attempts to parse a value from the front of the string. maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads MissingH-1.6.0.1/src/Data/Tuple/0000755000000000000000000000000007346545000014320 5ustar0000000000000000MissingH-1.6.0.1/src/Data/Tuple/Utils.hs0000644000000000000000000000211207346545000015750 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Tuple utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE. -} {- | Module : Data.Tuple.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with tuples. Written by Neil Mitchell. -} module Data.Tuple.Utils( -- * Construction dup, triple, -- * Extraction fst3, snd3, thd3 ) where -- | Construct a pair by duplication of a single value -- -- @since 1.4.3.0 dup :: a -> (a,a) dup a = (a,a) -- | Construct a 3-tuple from a single value -- -- @since 1.4.3.0 triple :: a -> (a,a,a) triple a = (a,a,a) -- | Take the first item out of a 3 element tuple fst3 :: (a,b,c) -> a fst3 (a,_,_) = a -- | Take the second item out of a 3 element tuple snd3 :: (a,b,c) -> b snd3 (_,b,_) = b -- | Take the third item out of a 3 element tuple thd3 :: (a,b,c) -> c thd3 (_,_,c) = c MissingH-1.6.0.1/src/Network/Email/0000755000000000000000000000000007346545000015036 5ustar0000000000000000MissingH-1.6.0.1/src/Network/Email/Mailbox.hs0000644000000000000000000000463107346545000016771 0ustar0000000000000000{-# LANGUAGE Safe #-} {- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.Email.Mailbox Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable General support for e-mail mailboxes Written by John Goerzen, jgoerzen\@complete.org -} module Network.Email.Mailbox(Flag(..), Flags, Message, MailboxReader(..), MailboxWriter(..)) where {- | The flags which may be assigned to a message. -} data Flag = SEEN | ANSWERED | FLAGGED | DELETED | DRAFT | FORWARDED | OTHERFLAG String deriving (Eq, Show) {- | Convenience shortcut -} type Flags = [Flag] {- | A Message is represented as a simple String. -} type Message = String {- | Main class for readable mailboxes. The mailbox object /a/ represents zero or more 'Message's. Each message has a unique identifier /b/ in a format specific to each given mailbox. This identifier may or may not be persistent. Functions which return a list are encouraged -- but not guaranteed -- to do so lazily. Implementing classes must provide, at minimum, 'getAll'. -} class (Show a, Show b, Eq b) => MailboxReader a b where {- | Returns a list of all unique identifiers. -} listIDs :: a -> IO [b] {- | Returns a list of all unique identifiers as well as all flags. -} listMessageFlags :: a -> IO [(b, Flags)] {- | Returns a list of all messages, including their content, flags, and unique identifiers. -} getAll :: a -> IO [(b, Flags, Message)] {- | Returns information about specific messages. -} getMessages :: a -> [b] -> IO [(b, Flags, Message)] listIDs mb = listMessageFlags mb >>= return . map fst listMessageFlags mb = getAll mb >>= return . map (\(i, f, _) -> (i, f)) getMessages mb list = do messages <- getAll mb return $ filter (\(x, _, _) -> x `elem` list) messages class (MailboxReader a b) => MailboxWriter a b where appendMessages :: a -> [(Flags, Message)] -> IO [b] deleteMessages :: a -> [b] -> IO () addFlags :: a -> [b] -> Flags -> IO () removeFlags :: a -> [b] -> Flags -> IO () setFlags :: a -> [b] -> Flags -> IO () MissingH-1.6.0.1/src/Network/Email/Sendmail.hs0000644000000000000000000000662407346545000017136 0ustar0000000000000000{-# LANGUAGE CPP #-} {- arch-tag: Sendmail utility Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.Email.Sendmail Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This Haskell module provides an interface to transmitting a mail message. This is not compatible with Windows at this time. Written by John Goerzen, jgoerzen\@complete.org -} #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) module Network.Email.Sendmail where #else module Network.Email.Sendmail(sendmail) where import System.Cmd.Utils ( PipeMode(WriteToPipe), pOpen ) import System.Directory ( doesFileExist, getPermissions, Permissions(executable) ) import System.IO ( hPutStr ) import System.IO.Error () import qualified Control.Exception(try, IOException) sendmails :: [String] sendmails = ["/usr/sbin/sendmail", "/usr/local/sbin/sendmail", "/usr/local/bin/sendmail", "/usr/bin/sendmail", "/etc/sendmail", "/usr/etc/sendmail"] findsendmail :: IO String findsendmail = let worker [] = return "sendmail" worker (this:next) = do e <- doesFileExist this if e then do p <- getPermissions this if executable p then return this else worker next else worker next in worker sendmails {- | Transmits an e-mail message using the system's mail transport agent. This function takes a message, a list of recipients, and an optional sender, and transmits it using the system's MTA, sendmail. If @sendmail@ is on the @PATH@, it will be used; otherwise, a list of system default locations will be searched. A failure will be logged, since this function uses 'System.Cmd.Utils.safeSystem' internally. This function will first try @sendmail@. If it does not exist, an error is logged under @System.Cmd.Utils.pOpen3@ and various default @sendmail@ locations are tried. If that still fails, an error is logged and an exception raised. -} sendmail :: Maybe String -- ^ The envelope from address. If not specified, takes the system's default, which is usually based on the effective userid of the current process. This is not necessarily what you want, so I recommend specifying it. -> [String] -- ^ A list of recipients for your message. An empty list is an error. -> String -- ^ The message itself. -> IO () sendmail _ [] _ = fail "sendmail: no recipients specified" sendmail Nothing recipients msg = sendmail_worker recipients msg sendmail (Just from) recipients msg = sendmail_worker (("-f" ++ from) : recipients) msg sendmail_worker :: [String] -> String -> IO () sendmail_worker args msg = let func h = hPutStr h msg in do --pOpen WriteToPipe "/usr/sbin/sendmail" args func rv <- Control.Exception.try (pOpen WriteToPipe "sendmail" args func) case rv of Right x -> return x Left (_ :: Control.Exception.IOException) -> do sn <- findsendmail r <- pOpen WriteToPipe sn args func return $! r #endif MissingH-1.6.0.1/src/Network/0000755000000000000000000000000007346545000014007 5ustar0000000000000000MissingH-1.6.0.1/src/Network/SocketServer.hs0000644000000000000000000001735007346545000016770 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- arch-tag: Generic Server Support Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.SocketServer Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : experimental Portability: systems with networking This module provides an infrastructure to simplify server design. Written by John Goerzen, jgoerzen\@complete.org Please note: this module is designed to work with TCP, UDP, and Unix domain sockets, but only TCP sockets have been tested to date. This module is presently under-documented. For an example of usage, please see the description of "Network.FTP.Server". -} module Network.SocketServer(-- * Generic Options and Types InetServerOptions(..), simpleTCPOptions, SocketServer(..), HandlerT, -- * TCP server convenient setup serveTCPforever, -- * Lower-Level Processing setupSocketServer, handleOne, serveForever, closeSocketServer, -- * Combinators loggingHandler, threadedHandler, handleHandler ) where import Control.Concurrent ( forkIO ) import Data.Functor (void) import Network.BSD ( getProtocolNumber, Family(AF_INET), HostAddress, PortNumber ) import Network.Socket ( socketToHandle, setSocketOption, accept, bind, getSocketName, listen, socket, close, SocketOption(ReuseAddr), SockAddr(SockAddrInet), Socket, SocketType(Stream) ) import Network.Utils ( showSockAddr ) import System.IO ( Handle, hClose, hSetBuffering, BufferMode(LineBuffering), IOMode(ReadWriteMode) ) import qualified System.Log.Logger {- | Options for your server. -} data InetServerOptions = InetServerOptions {listenQueueSize :: Int, portNumber :: PortNumber, interface :: HostAddress, reuse :: Bool, family :: Family, sockType :: SocketType, protoStr :: String } deriving (Eq, Show) {- | The main handler type. The first parameter is the socket itself. The second is the address of the remote endpoint. The third is the address of the local endpoint. -} type HandlerT = Socket -> SockAddr -> SockAddr -> IO () {- | Get Default options. You can always modify it later. -} simpleTCPOptions :: Int -- ^ Port Number -> InetServerOptions simpleTCPOptions p = InetServerOptions {listenQueueSize = 5, portNumber = (fromIntegral p), interface = 0, reuse = False, family = AF_INET, sockType = Stream, protoStr = "tcp" } data SocketServer = SocketServer {optionsSS :: InetServerOptions, sockSS :: Socket} deriving (Eq, Show) {- | Takes some options and sets up the 'SocketServer'. I will bind and begin listening, but will not accept any connections itself. -} setupSocketServer :: InetServerOptions -> IO SocketServer setupSocketServer opts = do proto <- getProtocolNumber (protoStr opts) s <- socket (family opts) (sockType opts) proto setSocketOption s ReuseAddr (case (reuse opts) of True -> 1 False -> 0) bind s (SockAddrInet (portNumber opts) (interface opts)) listen s (listenQueueSize opts) return $ SocketServer {optionsSS = opts, sockSS = s} {- | Close the socket server. Does not terminate active handlers, if any. -} closeSocketServer :: SocketServer -> IO () closeSocketServer ss = close (sockSS ss) {- | Handle one incoming request from the given 'SocketServer'. -} handleOne :: SocketServer -> HandlerT -> IO () handleOne ss func = do a <- accept (sockSS ss) localaddr <- getSocketName (fst a) func (fst a) (snd a) localaddr {- | Handle all incoming requests from the given 'SocketServer'. -} serveForever :: SocketServer -> HandlerT -> IO () serveForever ss func = sequence_ (repeat (handleOne ss func)) {- | Convenience function to completely set up a TCP 'SocketServer' and handle all incoming requests. This function is literally this: >serveTCPforever options func = > do sockserv <- setupSocketServer options > serveForever sockserv func -} serveTCPforever :: InetServerOptions -- ^ Server options -> HandlerT -- ^ Handler function -> IO () serveTCPforever options func = do sockserv <- setupSocketServer options serveForever sockserv func ---------------------------------------------------------------------- -- Combinators ---------------------------------------------------------------------- {- | Log each incoming connection using the interface in "System.Log.Logger". Log when the incoming connection disconnects. Also, log any failures that may occur in the child handler. -} loggingHandler :: String -- ^ Name of logger to use -> System.Log.Logger.Priority -- ^ Priority of logged messages -> HandlerT -- ^ Handler to call after logging -> HandlerT -- ^ Resulting handler loggingHandler hname prio nexth socket r_sockaddr l_sockaddr = do sockStr <- showSockAddr r_sockaddr System.Log.Logger.logM hname prio ("Received connection from " ++ sockStr) System.Log.Logger.traplogging hname System.Log.Logger.WARNING "" (nexth socket r_sockaddr l_sockaddr) System.Log.Logger.logM hname prio ("Connection " ++ sockStr ++ " disconnected") -- | Handle each incoming connection in its own thread to -- make the server multi-tasking. threadedHandler :: HandlerT -- ^ Handler to call in the new thread -> HandlerT -- ^ Resulting handler threadedHandler nexth socket r_sockaddr l_sockaddr = void $ forkIO (nexth socket r_sockaddr l_sockaddr) {- | Give your handler function a Handle instead of a Socket. The Handle will be opened with ReadWriteMode (you use one handle for both directions of the Socket). Also, it will be initialized with LineBuffering. Unlike other handlers, the handle will be closed when the function returns. Therefore, if you are doing threading, you should to it before you call this handler. -} handleHandler :: (Handle -> SockAddr -> SockAddr -> IO ()) -- ^ Handler to call -> HandlerT handleHandler func socket r_sockaddr l_sockaddr = do h <- socketToHandle socket ReadWriteMode hSetBuffering h LineBuffering func h r_sockaddr l_sockaddr hClose h MissingH-1.6.0.1/src/Network/Utils.hs0000644000000000000000000000572607346545000015455 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {- arch-tag: Network utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Network.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: systems with networking This module provides various helpful utilities for dealing with networking Written by John Goerzen, jgoerzen\@complete.org -} module Network.Utils (niceSocketsDo, connectTCP, connectTCPAddr, listenTCPAddr, showSockAddr) where import Network.BSD ( getHostByName, getProtocolNumber, hostAddress, HostName, Family(AF_INET), PortNumber ) import Network.Socket ( getNameInfo, withSocketsDo, bind, connect, listen, socket, close, NameInfoFlag(NI_NUMERICHOST), SockAddr(..), Socket, SocketType(Stream) ) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import qualified System.Posix.Signals #endif import Control.Exception (bracketOnError) {- | Sets up the system for networking. Similar to the built-in withSocketsDo (and actually, calls it), but also sets the SIGPIPE handler so that signal is ignored. Example: > main = niceSocketsDo $ do { ... } -} -- FIXME integrate with WebCont.Util.UDP niceSocketsDo :: IO a -> IO a niceSocketsDo func = do #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -- No signals on Windows anyway _ <- System.Posix.Signals.installHandler System.Posix.Signals.sigPIPE System.Posix.Signals.Ignore Nothing #endif withSocketsDo func connectTCP :: HostName -> PortNumber -> IO Socket connectTCP host port = do he <- getHostByName host connectTCPAddr (SockAddrInet port (hostAddress he)) connectTCPAddr :: SockAddr -> IO Socket connectTCPAddr addr = do proto <- getProtocolNumber "tcp" bracketOnError (socket AF_INET Stream proto) close (\s -> connect s addr >> return s) listenTCPAddr :: SockAddr -> Int -> IO Socket listenTCPAddr addr queuelen = do proto <- getProtocolNumber "tcp" s <- socket AF_INET Stream proto bind s addr listen s queuelen return s showSockAddr :: SockAddr -> IO String #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) showSockAddr (SockAddrUnix x) = return $ "UNIX socket at " ++ x #endif showSockAddr sa@(SockAddrInet port _host) = do (Just h,_) <- getNameInfo [NI_NUMERICHOST] True False sa return $ "IPv4 host " ++ h ++ ", port " ++ (show port) MissingH-1.6.0.1/src/System/Cmd/0000755000000000000000000000000007346545000014345 5ustar0000000000000000MissingH-1.6.0.1/src/System/Cmd/Utils.hs0000644000000000000000000005103007346545000016000 0ustar0000000000000000-- arch-tag: Command utilities main file {-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {- Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Cmd.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable to platforms with POSIX process\/signal tools Command invocation utilities. Written by John Goerzen, jgoerzen\@complete.org Command lines executed will be logged using "System.Log.Logger" at the DEBUG level. Failure messages will be logged at the WARNING level in addition to being raised as an exception. Both are logged under \"System.Cmd.Utils.funcname\" -- for instance, \"System.Cmd.Utils.safeSystem\". If you wish to suppress these messages globally, you can simply run: > updateGlobalLogger "System.Cmd.Utils.safeSystem" > (setLevel CRITICAL) See also: 'System.Log.Logger.updateGlobalLogger', "System.Log.Logger". It is possible to set up pipelines with these utilities. Example: > (pid1, x1) <- pipeFrom "ls" ["/etc"] > (pid2, x2) <- pipeBoth "grep" ["x"] x1 > putStr x2 > ... the grep output is displayed ... > forceSuccess pid2 > forceSuccess pid1 Remember, when you use the functions that return a String, you must not call 'forceSuccess' until after all data from the String has been consumed. Failure to wait will cause your program to appear to hang. Here is an example of the wrong way to do it: > (pid, x) <- pipeFrom "ls" ["/etc"] > forceSuccess pid -- Hangs; the called program hasn't terminated yet > processTheData x You must instead process the data before calling 'forceSuccess'. When using the hPipe family of functions, this is probably more obvious. Most of this module will be incompatible with Windows. -} module System.Cmd.Utils(-- * High-Level Tools PipeHandle(..), safeSystem, #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) forceSuccess, #ifndef __HUGS__ posixRawSystem, forkRawSystem, -- ** Piping with lazy strings pipeFrom, pipeLinesFrom, pipeTo, pipeBoth, -- ** Piping with handles hPipeFrom, hPipeTo, hPipeBoth, #endif #endif -- * Low-Level Tools PipeMode(..), #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) #ifndef __HUGS__ pOpen, pOpen3, pOpen3Raw #endif #endif ) where -- FIXME - largely obsoleted by 6.4 - convert to wrappers. import System.Exit ( ExitCode(ExitFailure, ExitSuccess) ) import System.Log.Logger ( debugM, warningM ) #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Process (rawSystem) #else import System.Posix.IO ( closeFd, createPipe, dupTo, fdToHandle, stdError, stdInput, stdOutput ) import System.Posix.Process ( executeFile, forkProcess, getProcessStatus, ProcessStatus(..) ) import System.Posix.Signals ( addSignal, blockSignals, emptySignalSet, getSignalMask, installHandler, setSignalMask, sigCHLD, sigINT, sigQUIT, Handler(Ignore), Signal ) #endif import System.Posix.Types ( Fd, ProcessID ) import System.IO ( Handle, hClose, hGetContents, hPutStr ) import Control.Concurrent(forkIO) import Control.Exception(finally) import qualified Control.Exception(try, IOException) data PipeMode = ReadFromPipe | WriteToPipe logbase :: String logbase = "System.Cmd.Utils" {- | Return value from 'pipeFrom', 'pipeLinesFrom', 'pipeTo', or 'pipeBoth'. Contains both a ProcessID and the original command that was executed. If you prefer not to use 'forceSuccess' on the result of one of these pipe calls, you can use (processID ph), assuming ph is your 'PipeHandle', as a parameter to 'System.Posix.Process.getProcessStatus'. -} data PipeHandle = PipeHandle { processID :: ProcessID, phCommand :: FilePath, phArgs :: [String], phCreator :: String -- ^ Function that created it } deriving (Eq, Show) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) #ifndef __HUGS__ {- | Like 'pipeFrom', but returns data in lines instead of just a String. Shortcut for calling lines on the result from 'pipeFrom'. Note: this function logs as pipeFrom. Not available on Windows. -} pipeLinesFrom :: FilePath -> [String] -> IO (PipeHandle, [String]) pipeLinesFrom fp args = do (pid, c) <- pipeFrom fp args return $ (pid, lines c) #endif #endif logRunning :: String -> FilePath -> [String] -> IO () logRunning func fp args = debugM (logbase ++ "." ++ func) (showCmd fp args) warnFail :: [Char] -> FilePath -> [String] -> [Char] -> IO t warnFail funcname fp args msg = let m = showCmd fp args ++ ": " ++ msg in do warningM (logbase ++ "." ++ funcname) m fail m #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Read data from a pipe. Returns a Handle and a 'PipeHandle'. When done, you must hClose the handle, and then use either 'forceSuccess' or getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. This function logs as pipeFrom. Not available on Windows. -} hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle) hPipeFrom fp args = do pipepair <- createPipe logRunning "pipeFrom" fp args let childstuff = do _ <- dupTo (snd pipepair) stdOutput closeFd (fst pipepair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) -- parent pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> warnFail "pipeFrom" fp args $ "Error in fork: " ++ show e closeFd (snd pipepair) h <- fdToHandle (fst pipepair) return (PipeHandle pid fp args "pipeFrom", h) #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Read data from a pipe. Returns a lazy string and a 'PipeHandle'. ONLY AFTER the string has been read completely, You must call either 'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the 'PipeHandle'. Zombies will result otherwise. Not available on Windows. -} pipeFrom :: FilePath -> [String] -> IO (PipeHandle, String) pipeFrom fp args = do (pid, h) <- hPipeFrom fp args c <- hGetContents h return (pid, c) #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Write data to a pipe. Returns a 'PipeHandle' and a new Handle to write to. When done, you must hClose the handle, and then use either 'forceSuccess' or getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. This function logs as pipeTo. Not available on Windows. -} hPipeTo :: FilePath -> [String] -> IO (PipeHandle, Handle) hPipeTo fp args = do pipepair <- createPipe logRunning "pipeTo" fp args let childstuff = do _ <- dupTo (fst pipepair) stdInput closeFd (snd pipepair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) -- parent pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> warnFail "pipeTo" fp args $ "Error in fork: " ++ show e closeFd (fst pipepair) h <- fdToHandle (snd pipepair) return (PipeHandle pid fp args "pipeTo", h) #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Write data to a pipe. Returns a ProcessID. You must call either 'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID. Zombies will result otherwise. Not available on Windows. -} pipeTo :: FilePath -> [String] -> String -> IO PipeHandle pipeTo fp args message = do (pid, h) <- hPipeTo fp args finally (hPutStr h message) (hClose h) return pid #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Like a combination of 'hPipeTo' and 'hPipeFrom'; returns a 3-tuple of ('PipeHandle', Data From Pipe, Data To Pipe). When done, you must hClose both handles, and then use either 'forceSuccess' or getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. Hint: you will usually need to ForkIO a thread to handle one of the Handles; otherwise, deadlock can result. This function logs as pipeBoth. Not available on Windows. -} hPipeBoth :: FilePath -> [String] -> IO (PipeHandle, Handle, Handle) hPipeBoth fp args = do frompair <- createPipe topair <- createPipe logRunning "pipeBoth" fp args let childstuff = do _ <- dupTo (snd frompair) stdOutput closeFd (fst frompair) _ <- dupTo (fst topair) stdInput closeFd (snd topair) executeFile fp True args Nothing p <- Control.Exception.try (forkProcess childstuff) -- parent pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> warnFail "pipeBoth" fp args $ "Error in fork: " ++ show e closeFd (snd frompair) closeFd (fst topair) fromh <- fdToHandle (fst frompair) toh <- fdToHandle (snd topair) return (PipeHandle pid fp args "pipeBoth", fromh, toh) #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Like a combination of 'pipeTo' and 'pipeFrom'; forks an IO thread to send data to the piped program, and simultaneously returns its output stream. The same note about checking the return status applies here as with 'pipeFrom'. Not available on Windows. -} pipeBoth :: FilePath -> [String] -> String -> IO (PipeHandle, String) pipeBoth fp args message = do (pid, fromh, toh) <- hPipeBoth fp args _ <- forkIO $ finally (hPutStr toh message) (hClose toh) c <- hGetContents fromh return (pid, c) #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Uses 'System.Posix.Process.getProcessStatus' to obtain the exit status of the given process ID. If the process terminated normally, does nothing. Otherwise, raises an exception with an appropriate error message. This call will block waiting for the given pid to terminate. Not available on Windows. -} forceSuccess :: PipeHandle -> IO () forceSuccess (PipeHandle pid fp args funcname) = let warnfail = warnFail funcname in do status <- getProcessStatus True False pid case status of Nothing -> warnfail fp args $ "Got no process status" Just (Exited (ExitSuccess)) -> return () Just (Exited (ExitFailure fc)) -> cmdfailed funcname fp args fc #if MIN_VERSION_unix(2,7,0) Just (Terminated sig _) -> #else Just (Terminated sig) -> #endif warnfail fp args $ "Terminated by signal " ++ show sig Just (Stopped sig) -> warnfail fp args $ "Stopped by signal " ++ show sig #endif {- | Invokes the specified command in a subprocess, waiting for the result. If the command terminated successfully, return normally. Otherwise, raises a userError with the problem. Implemented in terms of 'posixRawSystem' where supported, and System.Posix.rawSystem otherwise. -} safeSystem :: FilePath -> [String] -> IO () safeSystem command args = do debugM (logbase ++ ".safeSystem") ("Running: " ++ command ++ " " ++ (show args)) #if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) ec <- rawSystem command args case ec of ExitSuccess -> return () ExitFailure fc -> cmdfailed "safeSystem" command args fc #else ec <- posixRawSystem command args case ec of Exited ExitSuccess -> return () Exited (ExitFailure fc) -> cmdfailed "safeSystem" command args fc #if MIN_VERSION_unix(2,7,0) Terminated s _ -> cmdsignalled "safeSystem" command args s #else Terminated s -> cmdsignalled "safeSystem" command args s #endif Stopped s -> cmdsignalled "safeSystem" command args s #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Invokes the specified command in a subprocess, waiting for the result. Return the result status. Never raises an exception. Only available on POSIX platforms. Like system(3), this command ignores SIGINT and SIGQUIT and blocks SIGCHLD during its execution. Logs as System.Cmd.Utils.posixRawSystem -} posixRawSystem :: FilePath -> [String] -> IO ProcessStatus posixRawSystem program args = do debugM (logbase ++ ".posixRawSystem") ("Running: " ++ program ++ " " ++ (show args)) oldint <- installHandler sigINT Ignore Nothing oldquit <- installHandler sigQUIT Ignore Nothing let sigset = addSignal sigCHLD emptySignalSet oldset <- getSignalMask blockSignals sigset childpid <- forkProcess (childaction oldint oldquit oldset) mps <- getProcessStatus True False childpid restoresignals oldint oldquit oldset let retval = case mps of Just x -> x Nothing -> error "Nothing returned from getProcessStatus" debugM (logbase ++ ".posixRawSystem") (program ++ ": exited with " ++ show retval) return retval where childaction oldint oldquit oldset = do restoresignals oldint oldquit oldset executeFile program True args Nothing restoresignals oldint oldquit oldset = do _ <- installHandler sigINT oldint Nothing _ <- installHandler sigQUIT oldquit Nothing setSignalMask oldset #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Invokes the specified command in a subprocess, without waiting for the result. Returns the PID of the subprocess -- it is YOUR responsibility to use getProcessStatus or getAnyProcessStatus on that at some point. Failure to do so will lead to resource leakage (zombie processes). This function does nothing with signals. That too is up to you. Logs as System.Cmd.Utils.forkRawSystem -} forkRawSystem :: FilePath -> [String] -> IO ProcessID forkRawSystem program args = do debugM (logbase ++ ".forkRawSystem") ("Running: " ++ program ++ " " ++ (show args)) forkProcess childaction where childaction = executeFile program True args Nothing #endif cmdfailed :: String -> FilePath -> [String] -> Int -> IO a cmdfailed funcname command args failcode = do let errormsg = "Command " ++ command ++ " " ++ (show args) ++ " failed; exit code " ++ (show failcode) let e = userError (errormsg) warningM (logbase ++ "." ++ funcname) errormsg ioError e #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) cmdsignalled :: String -> FilePath -> [String] -> Signal -> IO a cmdsignalled funcname command args failcode = do let errormsg = "Command " ++ command ++ " " ++ (show args) ++ " failed due to signal " ++ (show failcode) let e = userError (errormsg) warningM (logbase ++ "." ++ funcname) errormsg ioError e #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Open a pipe to the specified command. Passes the handle on to the specified function. The 'PipeMode' specifies what you will be doing. That is, specifing 'ReadFromPipe' sets up a pipe from stdin, and 'WriteToPipe' sets up a pipe from stdout. Not available on Windows. -} pOpen :: PipeMode -> FilePath -> [String] -> (Handle -> IO a) -> IO a pOpen pm fp args func = do pipepair <- createPipe debugM (logbase ++ ".pOpen") ("Running: " ++ fp ++ " " ++ (show args)) case pm of ReadFromPipe -> do let callfunc _ = do closeFd (snd pipepair) h <- fdToHandle (fst pipepair) x <- func h hClose h return $! x pOpen3 Nothing (Just (snd pipepair)) Nothing fp args callfunc (closeFd (fst pipepair)) WriteToPipe -> do let callfunc _ = do closeFd (fst pipepair) h <- fdToHandle (snd pipepair) x <- func h hClose h return $! x pOpen3 (Just (fst pipepair)) Nothing Nothing fp args callfunc (closeFd (snd pipepair)) #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Runs a command, redirecting things to pipes. Not available on Windows. Note that you may not use the same fd on more than one item. If you want to redirect stdout and stderr, dup it first. -} pOpen3 :: Maybe Fd -- ^ Send stdin to this fd -> Maybe Fd -- ^ Get stdout from this fd -> Maybe Fd -- ^ Get stderr from this fd -> FilePath -- ^ Command to run -> [String] -- ^ Command args -> (ProcessID -> IO a) -- ^ Action to run in parent -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS -> IO a pOpen3 pin pout perr fp args func childfunc = do pid <- pOpen3Raw pin pout perr fp args childfunc retval <- func $! pid let rv = seq retval retval forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3") return rv #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) {- | Runs a command, redirecting things to pipes. Not available on Windows. Returns immediately with the PID of the child. Using 'waitProcess' on it is YOUR responsibility! Note that you may not use the same fd on more than one item. If you want to redirect stdout and stderr, dup it first. -} pOpen3Raw :: Maybe Fd -- ^ Send stdin to this fd -> Maybe Fd -- ^ Get stdout from this fd -> Maybe Fd -- ^ Get stderr from this fd -> FilePath -- ^ Command to run -> [String] -- ^ Command args -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS -> IO ProcessID pOpen3Raw pin pout perr fp args childfunc = let mayberedir Nothing _ = return () mayberedir (Just fromfd) tofd = do _ <- dupTo fromfd tofd closeFd fromfd return () childstuff = do mayberedir pin stdInput mayberedir pout stdOutput mayberedir perr stdError childfunc debugM (logbase ++ ".pOpen3") ("Running: " ++ fp ++ " " ++ (show args)) executeFile fp True args Nothing {- realfunc p = do System.Posix.Signals.installHandler System.Posix.Signals.sigPIPE System.Posix.Signals.Ignore Nothing func p -} in do p <- Control.Exception.try (forkProcess childstuff) pid <- case p of Right x -> return x Left (e :: Control.Exception.IOException) -> fail ("Error in fork: " ++ (show e)) return pid #endif showCmd :: FilePath -> [String] -> String showCmd fp args = fp ++ " " ++ show args MissingH-1.6.0.1/src/System/Console/GetOpt/0000755000000000000000000000000007346545000016446 5ustar0000000000000000MissingH-1.6.0.1/src/System/Console/GetOpt/Utils.hs0000644000000000000000000000573607346545000020115 0ustar0000000000000000{-# LANGUAGE Safe #-} {- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : MissingH.getOpt Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Written by John Goerzen, jgoerzen\@complete.org Utilities for command-line parsing, including wrappers around the standard System.Console.GetOpt module. -} module System.Console.GetOpt.Utils (parseCmdLine, validateCmdLine, StdOption, stdRequired, stdOptional ) where import safe System.Console.GetOpt ( getOpt, usageInfo, ArgOrder, OptDescr ) import safe System.Environment ( getArgs ) {- | Simple command line parser -- a basic wrapper around the system's default getOpt. See the System.Console.GetOpt manual for a description of the first two parameters. The third parameter is a usage information header. The return value consists of the list of parsed flags and a list of non-option arguments. -} parseCmdLine :: ArgOrder a -> [OptDescr a] -> String -> IO ([a], [String]) parseCmdLine order options header = do argv <- getArgs case getOpt order options argv of (o, n, []) -> return (o, n) (_, _, errors) -> ioError (userError (concat errors ++ usageInfo header options)) {- | Similar to 'parseCmdLine', but takes an additional function that validates the post-parse command-line arguments. This is useful, for example, in situations where there are two arguments that are mutually-exclusive and only one may legitimately be given at a time. The return value of the function indicates whether or not it detected an error condition. If it returns Nothing, there is no error. If it returns Just String, there was an error, described by the String. -} validateCmdLine :: ArgOrder a -> [OptDescr a] -> String -> (([a],[String]) -> Maybe String) -> IO ([a], [String]) validateCmdLine order options header func = do res <- parseCmdLine order options header case func res of Nothing -> return res Just errormsg -> ioError (userError (errormsg ++ "\n" ++ usageInfo header options)) {- | A type to standardize some common uses of GetOpt. The first component of the tuple is the long name of the option. The second component is empty if there is no arg, or has the arg otherwise. -} type StdOption = (String, String) {- | Handle a required argument. -} stdRequired :: String -- ^ Name of arg -> String -> StdOption stdRequired name value = (name, value) {- | Handle an optional argument. -} stdOptional :: String -- ^ Name of arg -> Maybe String -> StdOption stdOptional name Nothing = (name, "") stdOptional name (Just x) = (name, x) MissingH-1.6.0.1/src/System/0000755000000000000000000000000007346545000013642 5ustar0000000000000000MissingH-1.6.0.1/src/System/Daemon.hs0000644000000000000000000000472107346545000015405 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Daemon Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable to platforms with POSIX process\/signal tools Tools for writing daemons\/server processes Written by John Goerzen, jgoerzen\@complete.org Messages from this module are logged under @System.Daemon@. See 'System.Log.Logger' for details. This module is not available on Windows. -} module System.Daemon ( #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) detachDaemon #endif ) where #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Directory ( setCurrentDirectory ) import System.Exit ( ExitCode(ExitSuccess) ) import System.Log.Logger ( traplogging, Priority(ERROR) ) import System.Posix.IO ( openFd, closeFd, defaultFileFlags, dupTo, stdError, stdInput, stdOutput, OpenMode(ReadWrite) ) import System.Posix.Process ( createSession, exitImmediately, forkProcess ) trap :: IO a -> IO a trap = traplogging "System.Daemon" ERROR "detachDaemon" {- | Detach the process from a controlling terminal and run it in the background, handling it with standard Unix deamon semantics. After running this, please note the following side-effects: * The PID of the running process will change * stdin, stdout, and stderr will not work (they'll be set to \/dev\/null) * CWD will be changed to \/ I /highly/ suggest running this function before starting any threads. Note that this is not intended for a daemon invoked from inetd(1). -} detachDaemon :: IO () detachDaemon = trap $ do _ <- forkProcess child1 exitImmediately ExitSuccess child1 :: IO () child1 = trap $ do _ <- createSession _ <- forkProcess child2 exitImmediately ExitSuccess child2 :: IO () child2 = trap $ do setCurrentDirectory "/" mapM_ closeFd [stdInput, stdOutput, stdError] nullFd <- openFd "/dev/null" ReadWrite #if !MIN_VERSION_unix(2,8,0) Nothing #endif defaultFileFlags mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] closeFd nullFd #endif MissingH-1.6.0.1/src/System/Debian.hs0000644000000000000000000000476407346545000015373 0ustar0000000000000000{- arch-tag: Debian Package utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Debian Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with Debian files and programs. Written by John Goerzen, jgoerzen\@complete.org -} module System.Debian (-- * Control or Similar File Utilities ControlFile, -- * Version Number Utilities DebVersion, compareDebVersion, checkDebVersion ) where import System.Exit ( ExitCode(ExitFailure, ExitSuccess) ) import System.IO.Unsafe (unsafePerformIO) import System.Process ( rawSystem ) {- | The type representing the contents of a Debian control file, or any control-like file (such as the output from apt-cache show, etc.) -} type ControlFile = [(String, String)] ---------------------------------------------------------------------- -- VERSION NUMBERS ---------------------------------------------------------------------- {- | The type representing a Debian version number. This type is an instance of 'Prelude.Ord', but you can also use 'compareDebVersion' if you prefer. __WARNING__: calls out to @dpkg@ and will throw exceptions if @dpkg@ is missing -} data DebVersion = DebVersion String deriving (Eq) instance Ord DebVersion where compare (DebVersion v1) (DebVersion v2) = {- This is OK since compareDebVersion should always be the same. -} unsafePerformIO $ compareDebVersion v1 v2 {- | Compare the versions of two packages. -} compareDebVersion :: String -> String -> IO Ordering compareDebVersion v1 v2 = let runit op = checkDebVersion v1 op v2 in do islt <- runit "lt" if islt then return LT else do isgt <- runit "gt" if isgt then return GT else return EQ checkDebVersion :: String -- ^ Version 1 -> String -- ^ Operator -> String -- ^ Version 2 -> IO Bool checkDebVersion v1 op v2 = do ec <- rawSystem "dpkg" ["--compare-versions", v1, op, v2] case ec of ExitSuccess -> return True ExitFailure _ -> return False MissingH-1.6.0.1/src/System/Debian/0000755000000000000000000000000007346545000015024 5ustar0000000000000000MissingH-1.6.0.1/src/System/Debian/ControlParser.hs0000644000000000000000000000565107346545000020164 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Parser for Debian control file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Debian.ControlParser Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with Debian files and programs. Written by John Goerzen, jgoerzen\@complete.org -} module System.Debian.ControlParser(control, depPart) where import safe Data.List.Utils ( split ) import safe Text.ParserCombinators.Parsec ( char, noneOf, oneOf, string, many1, manyTill, (), (<|>), many, try, GenParser, CharParser ) eol, extline :: GenParser Char st String eol = (try (string "\r\n")) <|> string "\n" "EOL" extline = try (do _ <- char ' ' content <- many (noneOf "\r\n") _ <- eol return content ) entry :: GenParser Char st (String, String) entry = do key <- many1 (noneOf ":\r\n") _ <- char ':' val <- many (noneOf "\r\n") _ <- eol exts <- many extline return (key, unlines ([val] ++ exts)) {- | Main parser for the control file -} control :: CharParser a [(String, String)] control = do _ <- many header retval <- many entry return retval headerPGP, blankLine, header, headerHash :: GenParser Char st () headerPGP = do _ <- string "-----BEGIN PGP" _ <- manyTill (noneOf "\r\n") eol return () blankLine = do _ <- many (oneOf " \t") _ <- eol return () headerHash = do _ <- string "Hash: " _ <- manyTill (noneOf "\r\n") eol return () header = (try headerPGP) <|> (try blankLine) <|> (try headerHash) {- | Dependency parser. Returns (package name, Maybe version, arch list) version is (operator, operand) -} depPart :: CharParser a (String, (Maybe (String, String)), [String]) depPart = do packagename <- many1 (noneOf " (") _ <- many (char ' ') version <- (do _ <- char '(' op <- many1 (oneOf "<>=") _ <- many (char ' ') vers <- many1 (noneOf ") ") _ <- many (char ' ') _ <- char ')' return $ Just (op, vers) ) <|> return Nothing _ <- many (char ' ') archs <- (do _ <- char '[' t <- many1 (noneOf "]") _ <- many (char ' ') _ <- char ']' return (split " " t) ) <|> return [] return (packagename, version, archs) MissingH-1.6.0.1/src/System/FileArchive/0000755000000000000000000000000007346545000016023 5ustar0000000000000000MissingH-1.6.0.1/src/System/FileArchive/GZip.hs0000644000000000000000000002440307346545000017233 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- arch-tag: GZip file support in Haskell Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.FileArchive.GZip Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable GZip file decompression Copyright (c) 2004 John Goerzen, jgoerzen\@complete.org The GZip format is described in RFC1952. -} module System.FileArchive.GZip ( -- * GZip Files -- $gzipfiles -- * Types Header(..), Section, GZipError(..), Footer(..), -- * Whole-File Processing decompress, hDecompress, read_sections, -- * Section Processing read_header, read_section ) where import Control.Monad.Except (MonadError(..)) import Data.Bits ((.&.)) import Data.Bits.Utils (fromBytes) import Data.Char (ord) import Data.Compression.Inflate (inflate_string_remainder) import Data.Hash.CRC32.GZip (update_crc) import Data.Word (Word32) import System.IO (Handle, hGetContents, hPutStr) data GZipError = CRCError -- ^ CRC-32 check failed | NotGZIPFile -- ^ Couldn't find a GZip header | UnknownMethod -- ^ Compressed with something other than method 8 (deflate) | UnknownError String -- ^ Other problem arose deriving (Eq, Show) -- | First two bytes of file magic :: String magic = "\x1f\x8b" -- | Flags fFHCRC, fFEXTRA, fFNAME, fFCOMMENT :: Int -- fFTEXT = 1 :: Int fFHCRC = 2 fFEXTRA = 4 fFNAME = 8 fFCOMMENT = 16 {- | The data structure representing the GZip header. This occurs at the beginning of each 'Section' on disk. -} data Header = Header { method :: Int, -- ^ Compression method. Only 8 is defined at present. flags :: Int, extra :: Maybe String, filename :: Maybe String, comment :: Maybe String, mtime :: Word32, -- ^ Modification time of the original file xfl :: Int, -- ^ Extra flags os :: Int -- ^ Creating operating system } deriving (Eq, Show) {- | Stored on-disk at the end of each section. -} data Footer = Footer { size :: Word32, -- ^ The size of the original, decompressed data crc32 :: Word32, -- ^ The stored GZip CRC-32 of the original, decompressed data crc32valid :: Bool -- ^ Whether or not the stored CRC-32 matches the calculated CRC-32 of the data } {- | A section represents a compressed component in a GZip file. Every GZip file has at least one. -} type Section = (Header, String, Footer) split1 :: String -> (Char, String) split1 s = (head s, tail s) {- | Read a GZip file, decompressing all sections found. Writes the decompressed data stream to the given output handle. Returns Nothing if the action was successful, or Just GZipError if there was a problem. If there was a problem, the data written to the output handle should be discarded. -} hDecompress :: Handle -- ^ Input handle -> Handle -- ^ Output handle -> IO (Maybe GZipError) hDecompress infd outfd = do inc <- hGetContents infd let (outstr, err) = decompress inc hPutStr outfd outstr return err {- | Read a GZip file, decompressing all sections that are found. Returns a decompresed data stream and Nothing, or an unreliable string and Just (error). If you get anything other than Nothing, the String returned should be discarded. -} decompress :: String -> (String, Maybe GZipError) {- decompress s = do x <- read_header s let rem = snd x return $ inflate_string rem -} decompress s = let procs :: [Section] -> (String, Bool) procs [] = ([], True) procs ((_, content, foot):xs) = let (nexth, nextb) = procs xs in (content ++ nexth, (crc32valid foot) && nextb) in case read_sections s of Left x -> ("", Just x) Right x -> let (decomp, iscrcok) = procs x in (decomp, if iscrcok then Nothing else Just CRCError) {- decompress s = do x <- read_sections s return $ concatMap (\(_, x, _) -> x) x -} -- | Read all sections. read_sections :: String -> Either GZipError [Section] read_sections [] = Right [] read_sections s = do x <- read_section s case x of (sect, remain) -> do next <- read_sections remain return $ sect : next parseword :: String -> Word32 parseword s = fromBytes $ map (fromIntegral . ord) $ reverse s -- | Read one section, returning (ThisSection, Remainder) read_section :: String -> Either GZipError (Section, String) read_section s = do x <- read_header s let headerrem = snd x let (decompressed, crc, remainder) = read_data headerrem let (crc32str, rm) = splitAt 4 remainder let (sizestr, rem2) = splitAt 4 rm let filecrc32 = parseword crc32str let filesize = parseword sizestr return ((fst x, decompressed, Footer {size = filesize, crc32 = filecrc32, crc32valid = filecrc32 == crc}) ,rem2) -- | Read the file's compressed data, returning -- (Decompressed, Calculated CRC32, Remainder) read_data :: String -> (String, Word32, String) read_data x = let (decompressed1, remainder) = inflate_string_remainder x (decompressed, crc32) = read_data_internal decompressed1 0 in (decompressed, crc32, remainder) where read_data_internal [] ck = ([], ck) read_data_internal (y:ys) ck = let newcrc = update_crc ck y n = newcrc `seq` read_data_internal ys newcrc in (y : fst n, snd n) {- | Read the GZip header. Return (Header, Remainder). -} read_header :: String -> Either GZipError (Header, String) read_header s = let ok = Right "ok" in do let (mag, rem1) = splitAt 2 s _ <- if mag /= magic then throwError NotGZIPFile else ok let (method, rem2) = split1 rem1 _ <- if (ord(method) /= 8) then throwError UnknownMethod else ok let (flag_S, rem3) = split1 rem2 let flag = ord flag_S let (mtimea, rem3a) = splitAt 4 rem3 let mtime = parseword mtimea let (xfla, rem3b) = split1 rem3a let xfl = ord xfla let (osa, _) = split1 rem3b let os = ord osa -- skip modtime (4), extraflag (1), and os (1) let rem4 = drop 6 rem3 let (extra, rem5) = if (flag .&. fFEXTRA /= 0) -- Skip past the extra field if we have it. then let (xlen_S, _) = split1 rem4 (xlen2_S, rem4b) = split1 rem4 xlen = (ord xlen_S) + 256 * (ord xlen2_S) (ex, rrem) = splitAt xlen rem4b in (Just ex, rrem) else (Nothing, rem4) let (filename, rem6) = if (flag .&. fFNAME /= 0) -- Skip past the null-terminated filename then let fn = takeWhile (/= '\x00') rem5 in (Just fn, drop ((length fn) + 1) rem5) else (Nothing, rem5) let (comment, rem7) = if (flag .&. fFCOMMENT /= 0) -- Skip past the null-terminated comment then let cm = takeWhile (/= '\x00') rem6 in (Just cm, drop ((length cm) + 1) rem6) else (Nothing, rem6) rem8 <- if (flag .&. fFHCRC /= 0) -- Skip past the header CRC then return $ drop 2 rem7 else return rem7 return (Header {method = ord method, flags = flag, extra = extra, filename = filename, comment = comment, mtime = mtime, xfl = xfl, os = os}, rem8) ---------------------------------------------------------------------- -- Documentation ---------------------------------------------------------------------- {- $gzipfiles GZip files contain one or more 'Section's. Each 'Section', on disk, begins with a GZip 'Header', then stores the compressed data itself, and finally stores a GZip 'Footer'. The 'Header' identifies the file as a GZip file, records the original modification date and time, and, in some cases, also records the original filename and comments. The 'Footer' contains a GZip CRC32 checksum over the decompressed data as well as a 32-bit length of the decompressed data. The module 'Data.Hash.CRC32.GZip' is used to validate stored CRC32 values. The vast majority of GZip files contain only one 'Section'. Standard tools that work with GZip files create single-section files by default. Multi-section files can be created by simply concatenating two existing GZip files together. The standard gunzip and zcat tools will simply concatenate the decompressed data when reading these files back. The 'decompress' function in this module will do the same. When reading data from this module, please use caution regarding how you access it. For instance, if you are wanting to write the decompressed stream to disk and validate its CRC32 value, you could use the 'decompress' function. However, you should process the entire stream before you check the value of the Bool it returns. Otherwise, you will force Haskell to buffer the entire file in memory just so it can check the CRC32. -} MissingH-1.6.0.1/src/System/IO/0000755000000000000000000000000007346545000014151 5ustar0000000000000000MissingH-1.6.0.1/src/System/IO/Binary.hs0000644000000000000000000002726207346545000015742 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {- arch-tag: I/O utilities, binary tools Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.Binary Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable to platforms supporting binary I\/O This module provides various helpful utilities for dealing with binary input and output. You can use this module to deal with binary blocks of data as either Strings or lists of Word8. The BinaryConvertible class provides this abstraction. Wherever you see HVIO, you can transparently substite a regular Handle. This module can work with any HVIO object, however. See "System.IO.HVIO" for more details. Versions of MissingH prior 0.11.6 lacked the 'BinaryConvertible' class and worked only with Strings and Handles. Non-binary functions may be found in "System.IO". See also: "System.IO.BlockIO" Written by John Goerzen, jgoerzen\@complete.org -} module System.IO.Binary( -- * Support for different types of blocks BinaryConvertible(..), -- * Entire File\/Handle Utilities -- ** Opened Handle Data Copying hBlockCopy, blockCopy, -- ** Disk File Data Copying copyFileBlocksToFile, -- * Binary Single-Block I\/O hPutBufStr, putBufStr, hGetBufStr, getBufStr, hFullGetBufStr, fullGetBufStr, -- * Binary Multi-Block I\/O hGetBlocks, getBlocks, hFullGetBlocks, fullGetBlocks, -- * Lazy Interaction readBinaryFile, writeBinaryFile, -- ** Binary Block-based hBlockInteract, blockInteract, hFullBlockInteract, fullBlockInteract ) where import Data.Word (Word8()) import Foreign.C.String (peekCStringLen, withCString) import Foreign.C.Types (CChar()) import Foreign.ForeignPtr ( ForeignPtr, mallocForeignPtrArray, withForeignPtr ) import Foreign.Marshal.Array (peekArray, withArray) import Foreign.Ptr ( Ptr, castPtr ) import System.IO ( stdout, hClose, openBinaryFile, stdin, IOMode(WriteMode, ReadMode) ) import System.IO.HVFS ( SystemFS(SystemFS), HVFSOpenable(vOpenBinaryFile), HVFSOpenEncap(HVFSOpenEncap) ) import System.IO.HVIO ( HVIO(vClose, vGetBuf, vPutBuf, vGetContents, vPutStr) ) import System.IO.Unsafe (unsafeInterleaveIO) {- | Provides support for handling binary blocks with convenient types. This module provides implementations for Strings and for [Word8] (lists of Word8s). -} class (Eq a, Show a) => BinaryConvertible a where toBuf :: [a] -> (Ptr CChar -> IO c) -> IO c fromBuf :: Int -> (Ptr CChar -> IO Int) -> IO [a] instance BinaryConvertible Char where toBuf = withCString fromBuf len func = do fbuf <- mallocForeignPtrArray (len + 1) withForeignPtr fbuf handler where handler ptr = do bytesread <- func ptr peekCStringLen (ptr, bytesread) instance BinaryConvertible Word8 where toBuf hslist func = withArray hslist (\ptr -> func (castPtr ptr)) fromBuf len func = do (fbuf::(ForeignPtr Word8)) <- mallocForeignPtrArray (len + 1) withForeignPtr fbuf handler where handler ptr = do bytesread <- func (castPtr ptr) peekArray bytesread ptr -- ************************************************** -- Binary Files -- ************************************************** {- | As a wrapper around the standard function 'System.IO.hPutBuf', this function takes a standard Haskell 'String' instead of the far less convenient @Ptr a@. The entire contents of the string will be written as a binary buffer using 'hPutBuf'. The length of the output will be the length of the passed String or list. If it helps, you can thing of this function as being of type @Handle -> String -> IO ()@ -} hPutBufStr :: (HVIO a, BinaryConvertible b) => a -> [b] -> IO () hPutBufStr f s = toBuf s (\cs -> vPutBuf f cs (length s)) -- | An alias for 'hPutBufStr' 'stdout' putBufStr :: (BinaryConvertible b) => [b] -> IO () putBufStr = hPutBufStr stdout {- | Acts a wrapper around the standard function 'System.IO.hGetBuf', this function returns a standard Haskell String (or [Word8]) instead of modifying a 'Ptr a' buffer. The length is the maximum length to read and the semantice are the same as with 'hGetBuf'; namely, the empty string is returned with EOF is reached, and any given read may read fewer bytes than the given length. (Actually, it's a wrapper around 'System.IO.HVIO.vGetBuf') -} hGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b] hGetBufStr f count = fromBuf count (\buf -> vGetBuf f buf count) -- | An alias for 'hGetBufStr' 'stdin' getBufStr :: (BinaryConvertible b) => Int -> IO [b] getBufStr = hGetBufStr stdin {- | Like 'hGetBufStr', but guarantees that it will only return fewer than the requested number of bytes when EOF is encountered. -} hFullGetBufStr :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [b] hFullGetBufStr _ 0 = return [] hFullGetBufStr f count = do thisstr <- hGetBufStr f count if thisstr == [] then return [] else do remainder <- hFullGetBufStr f (count - (length thisstr)) return (thisstr ++ remainder) -- | An alias for 'hFullGetBufStr' 'stdin' fullGetBufStr :: BinaryConvertible b => Int -> IO [b] fullGetBufStr = hFullGetBufStr stdin {- | Writes the list of blocks to the given file handle -- a wrapper around 'hPutBufStr'. Think of this function as: >Handle -> [String] -> IO () (You can use it that way) -} hPutBlocks :: (HVIO a, BinaryConvertible b) => a -> [[b]] -> IO () hPutBlocks _ [] = return () hPutBlocks h (x:xs) = do hPutBufStr h x hPutBlocks h xs {- | An alias for 'hPutBlocks' 'stdout' putBlocks :: (BinaryConvertible b) => [[b]] -> IO () putBlocks = hPutBlocks stdout -} {- | Returns a lazily-evaluated list of all blocks in the input file, as read by 'hGetBufStr'. There will be no 0-length block in this list. The list simply ends at EOF. -} hGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]] hGetBlocks = hGetBlocksUtil hGetBufStr -- | An alias for 'hGetBlocks' 'stdin' getBlocks :: BinaryConvertible b => Int -> IO [[b]] getBlocks = hGetBlocks stdin {- | Same as 'hGetBlocks', but using 'hFullGetBufStr' underneath. -} hFullGetBlocks :: (HVIO a, BinaryConvertible b) => a -> Int -> IO [[b]] hFullGetBlocks = hGetBlocksUtil hFullGetBufStr -- | An alias for 'hFullGetBlocks' 'stdin' fullGetBlocks :: BinaryConvertible b => Int -> IO [[b]] fullGetBlocks = hFullGetBlocks stdin hGetBlocksUtil :: (HVIO a, BinaryConvertible b) => (a -> Int -> IO [b]) -> a -> Int -> IO [[b]] hGetBlocksUtil readfunc h count = unsafeInterleaveIO $ do block <- readfunc h count if block == [] then return [] else do remainder <- hGetBlocksUtil readfunc h count return (block : remainder) {- | Binary block-based interaction. This is useful for scenarios that take binary blocks, manipulate them in some way, and then write them out. Take a look at 'hBlockCopy' for an example. The integer argument is the size of input binary blocks. This function uses 'hGetBlocks' internally. -} hBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => Int -> a -> d -> ([[b]] -> [[c]]) -> IO () hBlockInteract = hBlockInteractUtil hGetBlocks -- | An alias for 'hBlockInteract' over 'stdin' and 'stdout' blockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO () blockInteract x = hBlockInteract x stdin stdout {- | Same as 'hBlockInteract', but uses 'hFullGetBlocks' instead of 'hGetBlocks' internally. -} hFullBlockInteract :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => Int -> a -> d -> ([[b]] -> [[c]]) -> IO () hFullBlockInteract = hBlockInteractUtil hFullGetBlocks -- | An alias for 'hFullBlockInteract' over 'stdin' and 'stdout' fullBlockInteract :: (BinaryConvertible b, BinaryConvertible c) => Int -> ([[b]] -> [[c]]) -> IO () fullBlockInteract x = hFullBlockInteract x stdin stdout hBlockInteractUtil :: (HVIO a, HVIO d, BinaryConvertible b, BinaryConvertible c) => (a -> Int -> IO [[b]]) -> Int -> a -> d -> ([[b]] -> [[c]]) -> IO () hBlockInteractUtil blockreader blocksize hin hout func = do blocks <- blockreader hin blocksize hPutBlocks hout (func blocks) {- | Copies everything from the input handle to the output handle using binary blocks of the given size. This was once the following beautiful implementation: > hBlockCopy bs hin hout = hBlockInteract bs hin hout id ('id' is the built-in Haskell function that just returns whatever is given to it) In more recent versions of MissingH, it uses a more optimized routine that avoids ever having to convert the binary buffer at all. -} hBlockCopy :: (HVIO a, HVIO b) => Int -> a -> b -> IO () hBlockCopy bs hin hout = do (fbuf::ForeignPtr CChar) <- mallocForeignPtrArray (bs + 1) withForeignPtr fbuf handler where handler ptr = do bytesread <- vGetBuf hin ptr bs if bytesread > 0 then do vPutBuf hout ptr bytesread handler ptr else return () {- | Copies from 'stdin' to 'stdout' using binary blocks of the given size. An alias for 'hBlockCopy' over 'stdin' and 'stdout' -} blockCopy :: Int -> IO () blockCopy bs = hBlockCopy bs stdin stdout {- | Copies one filename to another in binary mode. Please note that the Unix permission bits on the output file cannot be set due to a limitation of the Haskell 'System.IO.openBinaryFile' function. Therefore, you may need to adjust those bits after the copy yourself. This function is implemented using 'hBlockCopy' internally. -} copyFileBlocksToFile :: Int -> FilePath -> FilePath -> IO () copyFileBlocksToFile bs infn outfn = do hin <- openBinaryFile infn ReadMode hout <- openBinaryFile outfn WriteMode hBlockCopy bs hin hout hClose hin hClose hout return () {- | Like the built-in 'readFile', but opens the file in binary instead of text mode. -} readBinaryFile :: FilePath -> IO String readBinaryFile = vReadBinaryFile SystemFS {- | Same as 'readBinaryFile', but works with HVFS objects. -} vReadBinaryFile :: (HVFSOpenable a) => a -> FilePath -> IO String vReadBinaryFile fs fp = vOpenBinaryFile fs fp ReadMode >>= (\(HVFSOpenEncap h) -> vGetContents h) {- | Like the built-in 'writeFile', but opens the file in binary instead of text mode. -} writeBinaryFile :: FilePath -> String -> IO () writeBinaryFile = vWriteBinaryFile SystemFS {- | Like 'writeBinaryFile', but works on HVFS objects. -} vWriteBinaryFile :: (HVFSOpenable a) => a -> FilePath -> String -> IO () vWriteBinaryFile fs name str = do h <- vOpenBinaryFile fs name WriteMode case h of HVFSOpenEncap x -> do vPutStr x str vClose x MissingH-1.6.0.1/src/System/IO/HVFS.hs0000644000000000000000000003124607346545000015261 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} {- arch-tag: HVFS main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Haskell Virtual FS -- generic support for real or virtual filesystem in Haskell Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org The idea of this module is to provide virtualization of filesystem calls. In addition to the \"real\" system filesystem, you can also provide access to other, virtual, filesystems using the same set of calls. Examples of such virtual filesystems might include a remote FTP server, WebDAV server, a local Hashtable, a ConfigParser object, or any other data structure you can represent as a tree of named nodes containing strings. Each 'HVFS' function takes a 'HVFS' \"handle\" ('HVFS' instance) as its first parameter. If you wish to operate on the standard system filesystem, you can just use 'SystemFS'. The "MissingH.HVFS.IO.InstanceHelpers" module contains some code to help you make your own HVFS instances. The 'HVFSOpenable' class works together with the "System.IO.HVIO" module to provide a complete virtual filesystem and I\/O model that allows you to open up virtual filesystem files and act upon them in a manner similar to standard Handles. -} module System.IO.HVFS(-- * Implementation Classes \/ Types HVFS(..), HVFSStat(..), HVFSOpenable(..), HVFSOpenEncap(..),HVFSStatEncap(..), withStat, withOpen, SystemFS(..), -- * Re-exported types from other modules FilePath, DeviceID, FileID, FileMode, LinkCount, UserID, GroupID, FileOffset, EpochTime, IOMode ) where import qualified Control.Exception (catch, IOException) import System.IO.HVIO ( HVIO(vGetContents, vPutStr, vClose) ) import System.Time.Utils ( epochToClockTime ) import System.IO ( openBinaryFile, openFile, IOMode(ReadMode, WriteMode) ) import System.IO.Error ( IOErrorType, illegalOperationErrorType, mkIOError ) import System.IO.PlafCompat ( DeviceID, EpochTime, FileID, FileMode, FileOffset, GroupID, LinkCount, UserID, #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) createLink, createSymbolicLink, getSymbolicLinkStatus, readSymbolicLink, #endif accessTime, deviceID, fileGroup, fileID, fileMode, fileOwner, fileSize, getFileStatus, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, isSocket, isSymbolicLink, linkCount, modificationTime, specialDeviceID, statusChangeTime, FileStatus ) import System.Time ( ClockTime(..) ) import qualified System.Directory as D #if MIN_VERSION_directory(1,2,0) import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) #endif {- | Encapsulate a 'HVFSStat' result. This is required due to Haskell typing restrictions. You can get at it with: > case encap of > HVFSStatEncap x -> -- now use x -} data HVFSStatEncap = forall a. HVFSStat a => HVFSStatEncap a {- | Convenience function for working with stat -- takes a stat result and a function that uses it, and returns the result. Here is an example from the HVFS source: > vGetModificationTime fs fp = > do s <- vGetFileStatus fs fp > return $ epochToClockTime (withStat s vModificationTime) See 'System.Time.Utils.epochToClockTime' for more information. -} withStat :: forall b. HVFSStatEncap -> (forall a. HVFSStat a => a -> b) -> b withStat s f = case s of HVFSStatEncap x -> f x {- | Similar to 'HVFSStatEncap', but for 'vOpen' result. -} data HVFSOpenEncap = forall a. HVIO a => HVFSOpenEncap a {- | Similar to 'withStat', but for the 'vOpen' result. -} withOpen :: forall b. HVFSOpenEncap -> (forall a. HVIO a => a -> b) -> b withOpen s f = case s of HVFSOpenEncap x -> f x {- | Evaluating types of files and information about them. This corresponds to the System.Posix.Types.FileStatus type, and indeed, that is one instance of this class. Inplementators must, at minimum, implement 'vIsDirectory' and 'vIsRegularFile'. Default implementations of everything else are provided, returning reasonable values. A default implementation of this is not currently present on Windows. -} class (Show a) => HVFSStat a where vDeviceID :: a -> DeviceID vFileID :: a -> FileID {- | Refers to file permissions, NOT the st_mode field from stat(2) -} vFileMode :: a -> FileMode vLinkCount :: a -> LinkCount vFileOwner :: a -> UserID vFileGroup :: a -> GroupID vSpecialDeviceID :: a -> DeviceID vFileSize :: a -> FileOffset vAccessTime :: a -> EpochTime vModificationTime :: a -> EpochTime vStatusChangeTime :: a -> EpochTime vIsBlockDevice :: a -> Bool vIsCharacterDevice :: a -> Bool vIsNamedPipe :: a -> Bool vIsRegularFile :: a -> Bool vIsDirectory :: a -> Bool vIsSymbolicLink :: a -> Bool vIsSocket :: a -> Bool vDeviceID _ = 0 vFileID _ = 0 vFileMode x = if vIsDirectory x then 0x755 else 0o0644 vLinkCount _ = 1 vFileOwner _ = 0 vFileGroup _ = 0 vSpecialDeviceID _ = 0 vFileSize _ = 0 vAccessTime _ = 0 vModificationTime _ = 0 vStatusChangeTime _ = 0 vIsBlockDevice _ = False vIsCharacterDevice _ = False vIsNamedPipe _ = False vIsSymbolicLink _ = False vIsSocket _ = False {- | The main HVFS class. Default implementations of these functions are provided: * 'vGetModificationTime' -- implemented in terms of 'vGetFileStatus' * 'vRaiseError' * 'vDoesFileExist' -- implemented in terms of 'vGetFileStatus' * 'vDoesDirectoryExist' -- implemented in terms of 'vGetFileStatus' * 'vDoesExist' -- implemented in terms of 'vGetSymbolicLinkStatus' * 'vGetSymbolicLinkStatus' -- set to call 'vGetFileStatus'. Default implementations of all other functions will generate an isIllegalOperation error, since they are assumed to be un-implemented. You should always provide at least a 'vGetFileStatus' call, and almost certainly several of the others. Most of these functions correspond to functions in System.Directory or System.Posix.Files. Please see detailed documentation on them there. -} class (Show a) => HVFS a where vGetCurrentDirectory :: a -> IO FilePath vSetCurrentDirectory :: a -> FilePath -> IO () vGetDirectoryContents :: a -> FilePath -> IO [FilePath] vDoesFileExist :: a -> FilePath -> IO Bool vDoesDirectoryExist :: a -> FilePath -> IO Bool {- | True if the file exists, regardless of what type it is. This is even True if the given path is a broken symlink. -} vDoesExist :: a -> FilePath -> IO Bool vCreateDirectory :: a -> FilePath -> IO () vRemoveDirectory :: a -> FilePath -> IO () vRenameDirectory :: a -> FilePath -> FilePath -> IO () vRemoveFile :: a -> FilePath -> IO () vRenameFile :: a -> FilePath -> FilePath -> IO () vGetFileStatus :: a -> FilePath -> IO HVFSStatEncap vGetSymbolicLinkStatus :: a -> FilePath -> IO HVFSStatEncap vGetModificationTime :: a -> FilePath -> IO ClockTime {- | Raise an error relating to actions on this class. -} vRaiseError :: a -> IOErrorType -> String -> Maybe FilePath -> IO c vCreateSymbolicLink :: a -> FilePath -> FilePath -> IO () vReadSymbolicLink :: a -> FilePath -> IO FilePath vCreateLink :: a -> FilePath -> FilePath -> IO () vGetModificationTime fs fp = do s <- vGetFileStatus fs fp return $ epochToClockTime (withStat s vModificationTime) vRaiseError _ et desc mfp = ioError $ mkIOError et desc Nothing mfp vGetCurrentDirectory fs = eh fs "vGetCurrentDirectory" vSetCurrentDirectory fs _ = eh fs "vSetCurrentDirectory" vGetDirectoryContents fs _ = eh fs "vGetDirectoryContents" vDoesFileExist fs fp = Control.Exception.catch (do s <- vGetFileStatus fs fp return $ withStat s vIsRegularFile ) (\(_ :: Control.Exception.IOException) -> return False) vDoesDirectoryExist fs fp = Control.Exception.catch (do s <- vGetFileStatus fs fp return $ withStat s vIsDirectory ) (\(_ :: Control.Exception.IOException) -> return False) vDoesExist fs fp = Control.Exception.catch (do _ <- vGetSymbolicLinkStatus fs fp return True ) (\(_ :: Control.Exception.IOException) -> return False) vCreateDirectory fs _ = eh fs "vCreateDirectory" vRemoveDirectory fs _ = eh fs "vRemoveDirectory" vRemoveFile fs _ = eh fs "vRemoveFile" vRenameFile fs _ _ = eh fs "vRenameFile" vRenameDirectory fs _ _ = eh fs "vRenameDirectory" vCreateSymbolicLink fs _ _ = eh fs "vCreateSymbolicLink" vReadSymbolicLink fs _ = eh fs "vReadSymbolicLink" vCreateLink fs _ _ = eh fs "vCreateLink" vGetSymbolicLinkStatus = vGetFileStatus -- | Error handler helper eh :: HVFS a => a -> String -> IO c eh fs desc = vRaiseError fs illegalOperationErrorType (desc ++ " is not implemented in this HVFS class") Nothing {- | Types that can open a HVIO object should be instances of this class. You need only implement 'vOpen'. -} class HVFS a => HVFSOpenable a where vOpen :: a -> FilePath -> IOMode -> IO HVFSOpenEncap vReadFile :: a -> FilePath -> IO String vWriteFile :: a -> FilePath -> String -> IO () vOpenBinaryFile :: a -> FilePath -> IOMode -> IO HVFSOpenEncap vReadFile h fp = do oe <- vOpen h fp ReadMode withOpen oe (\fh -> vGetContents fh) vWriteFile h fp s = do oe <- vOpen h fp WriteMode withOpen oe (\fh -> do vPutStr fh s vClose fh) -- | Open a file in binary mode. vOpenBinaryFile = vOpen instance Show FileStatus where show _ = "" ---------------------------------------------------------------------- -- Standard implementations ---------------------------------------------------------------------- instance HVFSStat FileStatus where vDeviceID = deviceID vFileID = fileID vFileMode = fileMode vLinkCount = linkCount vFileOwner = fileOwner vFileGroup = fileGroup vSpecialDeviceID = specialDeviceID vFileSize = fileSize vAccessTime = accessTime vModificationTime = modificationTime vStatusChangeTime = statusChangeTime vIsBlockDevice = isBlockDevice vIsCharacterDevice = isCharacterDevice vIsNamedPipe = isNamedPipe vIsRegularFile = isRegularFile vIsDirectory = isDirectory vIsSymbolicLink = isSymbolicLink vIsSocket = isSocket data SystemFS = SystemFS deriving (Eq, Show) instance HVFS SystemFS where vGetCurrentDirectory _ = D.getCurrentDirectory vSetCurrentDirectory _ = D.setCurrentDirectory vGetDirectoryContents _ = D.getDirectoryContents vDoesFileExist _ = D.doesFileExist vDoesDirectoryExist _ = D.doesDirectoryExist vCreateDirectory _ = D.createDirectory vRemoveDirectory _ = D.removeDirectory vRenameDirectory _ = D.renameDirectory vRemoveFile _ = D.removeFile vRenameFile _ = D.renameFile vGetFileStatus _ fp = getFileStatus fp >>= return . HVFSStatEncap #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) vGetSymbolicLinkStatus _ fp = getSymbolicLinkStatus fp >>= return . HVFSStatEncap #else -- No symlinks on Windows; just get the file status directly vGetSymbolicLinkStatus = vGetFileStatus #endif #if MIN_VERSION_directory(1,2,0) vGetModificationTime _ p = D.getModificationTime p >>= (\modUTCTime -> return $ TOD ((toEnum . fromEnum . utcTimeToPOSIXSeconds) modUTCTime) 0) #else vGetModificationTime _ = D.getModificationTime #endif #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) vCreateSymbolicLink _ = createSymbolicLink vReadSymbolicLink _ = readSymbolicLink vCreateLink _ = createLink #else vCreateSymbolicLink _ _ _ = fail "Symbolic link creation not supported by Windows" vReadSymbolicLink _ _ = fail "Symbolic link reading not supported by Widnows" vCreateLink _ _ _ = fail "Hard link creation not supported by Windows" #endif instance HVFSOpenable SystemFS where vOpen _ fp iomode = openFile fp iomode >>= return . HVFSOpenEncap vOpenBinaryFile _ fp iomode = openBinaryFile fp iomode >>= return . HVFSOpenEncap MissingH-1.6.0.1/src/System/IO/HVFS/0000755000000000000000000000000007346545000014717 5ustar0000000000000000MissingH-1.6.0.1/src/System/IO/HVFS/Combinators.hs0000644000000000000000000001700607346545000017537 0ustar0000000000000000{-# LANGUAGE CPP #-} {- arch-tag: HVFS Combinators Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS.Combinators Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Support for combining different HVFS modules together Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org -} module System.IO.HVFS.Combinators ( -- * Restrictions HVFSReadOnly(..), HVFSChroot, newHVFSChroot) where import System.IO ( IOMode(ReadMode) ) import System.IO.Error ( doesNotExistErrorType, permissionErrorType ) import System.IO.HVFS ( HVFSOpenable(vOpen), HVFS(vRemoveFile, vCreateLink, vCreateSymbolicLink, vRenameFile, vRenameDirectory, vRemoveDirectory, vCreateDirectory, vGetCurrentDirectory, vGetDirectoryContents, vDoesFileExist, vGetFileStatus, vGetSymbolicLinkStatus, vGetModificationTime, vReadSymbolicLink, vRaiseError, vDoesDirectoryExist, vSetCurrentDirectory) ) import System.IO.HVFS.InstanceHelpers (getFullPath) import System.FilePath (isPathSeparator, pathSeparator, ()) import System.Path (secureAbsNormPath) import System.Path.NameManip (normalise_path) ---------------------------------------------------------------------- -- Providing read-only access ---------------------------------------------------------------------- {- | Restrict access to the underlying filesystem to be strictly read-only. Any write-type operations will cause an error. No constructor is required; just say @HVFSReadOnly fs@ to make a new read-only wrapper around the 'HVFS' instance @fs@. -} data HVFS a => HVFSReadOnly a = HVFSReadOnly a deriving (Eq, Show) withro :: HVFS a => (a -> b) -> HVFSReadOnly a -> b withro f (HVFSReadOnly x) = f x roerror :: (HVFS a) => HVFSReadOnly a -> IO c roerror h = let err x = vRaiseError x permissionErrorType "Read-only virtual filesystem" Nothing in withro err h instance HVFS a => HVFS (HVFSReadOnly a) where vGetCurrentDirectory = withro vGetCurrentDirectory vSetCurrentDirectory = withro vSetCurrentDirectory vGetDirectoryContents = withro vGetDirectoryContents vDoesFileExist = withro vDoesFileExist vDoesDirectoryExist = withro vDoesDirectoryExist vCreateDirectory h _ = roerror h vRemoveDirectory h _ = roerror h vRenameDirectory h _ _ = roerror h vRenameFile h _ _ = roerror h vGetFileStatus = withro vGetFileStatus vGetSymbolicLinkStatus = withro vGetSymbolicLinkStatus vGetModificationTime = withro vGetModificationTime vRaiseError = withro vRaiseError vCreateSymbolicLink h _ _ = roerror h vReadSymbolicLink = withro vReadSymbolicLink vCreateLink h _ _ = roerror h instance HVFSOpenable a => HVFSOpenable (HVFSReadOnly a) where vOpen fh fp mode = case mode of ReadMode -> withro (\h -> vOpen h fp mode) fh _ -> roerror fh ---------------------------------------------------------------------- -- Restricting to a subdirectory ---------------------------------------------------------------------- {- | Access a subdirectory of a real filesystem as if it was the root of that filesystem. -} data HVFS a => HVFSChroot a = HVFSChroot String a deriving (Eq, Show) {- | Create a new 'HVFSChroot' object. -} newHVFSChroot :: HVFS a => a -- ^ The object to pass requests on to -> FilePath -- ^ The path of the directory to make root -> IO (HVFSChroot a) -- ^ The resulting new object newHVFSChroot fh fp = do full <- getFullPath fh fp isdir <- vDoesDirectoryExist fh full if isdir then do let newobj = (HVFSChroot full fh) vSetCurrentDirectory newobj [pathSeparator] return newobj else vRaiseError fh doesNotExistErrorType ("Attempt to instantiate HVFSChroot over non-directory " ++ full) (Just full) {- | Get the embedded object -} dch :: (HVFS t) => HVFSChroot t -> t dch (HVFSChroot _ a) = a {- | Convert a local (chroot) path to a full path. -} dch2fp, fp2dch :: (HVFS t) => HVFSChroot t -> String -> IO String dch2fp mainh@(HVFSChroot fp h) locfp = do full <- (fp ++) `fmap` if isPathSeparator (head locfp) then return locfp else getFullPath mainh locfp case secureAbsNormPath fp full of Nothing -> vRaiseError h doesNotExistErrorType ("Trouble normalizing path in chroot") (Just (fp ++ "," ++ full)) Just x -> return x {- | Convert a full path to a local (chroot) path. -} fp2dch (HVFSChroot fp h) locfp = do newpath <- case secureAbsNormPath fp locfp of Nothing -> vRaiseError h doesNotExistErrorType ("Unable to securely normalize path") (Just (fp locfp)) Just x -> return x if (take (length fp) newpath /= fp) then vRaiseError h doesNotExistErrorType ("Local path is not subdirectory of parent path") (Just newpath) else let newpath2 = drop (length fp) newpath in return $ normalise_path ([pathSeparator] ++ newpath2) dch2fph :: (HVFS t) => (t -> String -> IO t1) -> HVFSChroot t -> [Char] -> IO t1 dch2fph func fh@(HVFSChroot _ h) locfp = do newfp <- dch2fp fh locfp func h newfp instance HVFS a => HVFS (HVFSChroot a) where vGetCurrentDirectory x = do fp <- vGetCurrentDirectory (dch x) fp2dch x fp vSetCurrentDirectory = dch2fph vSetCurrentDirectory vGetDirectoryContents = dch2fph vGetDirectoryContents vDoesFileExist = dch2fph vDoesFileExist vDoesDirectoryExist = dch2fph vDoesDirectoryExist vCreateDirectory = dch2fph vCreateDirectory vRemoveDirectory = dch2fph vRemoveDirectory vRenameDirectory fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vRenameDirectory (dch fh) old' new' vRemoveFile = dch2fph vRemoveFile vRenameFile fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vRenameFile (dch fh) old' new' vGetFileStatus = dch2fph vGetFileStatus vGetSymbolicLinkStatus = dch2fph vGetSymbolicLinkStatus vGetModificationTime = dch2fph vGetModificationTime -- vRaiseError vCreateSymbolicLink fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vCreateSymbolicLink (dch fh) old' new' vReadSymbolicLink fh fp = do result <- dch2fph vReadSymbolicLink fh fp fp2dch fh result vCreateLink fh old new = do old' <- dch2fp fh old new' <- dch2fp fh new vCreateLink (dch fh) old' new' instance HVFSOpenable a => HVFSOpenable (HVFSChroot a) where vOpen fh fp mode = do newfile <- dch2fp fh fp vOpen (dch fh) newfile mode MissingH-1.6.0.1/src/System/IO/HVFS/InstanceHelpers.hs0000644000000000000000000002117207346545000020345 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- arch-tag: HVFS instance helpers Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS.InstanceHelpers Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Utilities for creating instances of the items defined in "System.IO.HVFS". -} module System.IO.HVFS.InstanceHelpers(-- * HVFSStat objects SimpleStat(..), -- * HVFS objects & types -- ** MemoryVFS MemoryVFS, newMemoryVFS, newMemoryVFSRef, MemoryNode, MemoryEntry(..), -- * Utilities nice_slice, getFullPath, getFullSlice) where import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (genericLength) import System.FilePath (isPathSeparator, pathSeparator, ()) import System.IO ( IOMode(ReadMode) ) import System.IO.Error (doesNotExistErrorType, illegalOperationErrorType, permissionErrorType) import System.IO.HVFS ( FileOffset, HVFSOpenable(vOpen), HVFS(vGetDirectoryContents, vGetFileStatus, vSetCurrentDirectory, vRaiseError, vGetCurrentDirectory), HVFSStat(vIsRegularFile, vFileSize, vIsDirectory), HVFSOpenEncap(HVFSOpenEncap), HVFSStatEncap(HVFSStatEncap) ) import System.IO.HVIO (newStreamReader) import System.Path (absNormPath) import System.Path.NameManip (slice_path) {- | A simple "System.IO.HVFS.HVFSStat" class that assumes that everything is either a file or a directory. -} data SimpleStat = SimpleStat { isFile :: Bool, -- ^ True if file, False if directory fileSize :: FileOffset -- ^ Set to 0 if unknown or a directory } deriving (Show, Eq) instance HVFSStat SimpleStat where vIsRegularFile x = isFile x vIsDirectory x = not (isFile x) vFileSize x = fileSize x ---------------------------------------------------------------------- -- In-Memory Tree Types ---------------------------------------------------------------------- {- | The basic node of a 'MemoryVFS'. The String corresponds to the filename, and the entry to the contents. -} type MemoryNode = (String, MemoryEntry) {- | The content of a file or directory in a 'MemoryVFS'. -} data MemoryEntry = MemoryDirectory [MemoryNode] | MemoryFile String deriving (Eq, Show) {- | An in-memory read\/write filesystem. Think of it as a dynamically resizable ramdisk written in Haskell. -} data MemoryVFS = MemoryVFS { content :: IORef [MemoryNode], cwd :: IORef FilePath } instance Show MemoryVFS where show _ = "" -- | Create a new 'MemoryVFS' object from an existing tree. -- An empty filesystem may be created by using @[]@ for the parameter. newMemoryVFS :: [MemoryNode] -> IO MemoryVFS newMemoryVFS s = do r <- newIORef s newMemoryVFSRef r -- | Create a new 'MemoryVFS' object using an IORef to an -- existing tree. newMemoryVFSRef :: IORef [MemoryNode] -> IO MemoryVFS newMemoryVFSRef r = do c <- newIORef [pathSeparator] return (MemoryVFS {content = r, cwd = c}) {- | Similar to 'System.Path.NameManip' but the first element won't be @\/@. >nice_slice "/" -> [] >nice_slice "/foo/bar" -> ["foo", "bar"] -} nice_slice :: String -> [String] nice_slice path | path == [pathSeparator] = [] | otherwise = let sliced1 = slice_path path h = head sliced1 t = tail sliced1 newh = if isPathSeparator (head h) then tail h else h sliced2 = newh : t in sliced2 {- | Gets a full path, after investigating the cwd. -} getFullPath :: HVFS a => a -> String -> IO String getFullPath fs path = do dir <- vGetCurrentDirectory fs case (absNormPath dir path) of Nothing -> vRaiseError fs doesNotExistErrorType ("Trouble normalizing path " ++ path) (Just (dir path)) Just newpath -> return newpath {- | Gets the full path via 'getFullPath', then splits it via 'nice_slice'. -} getFullSlice :: HVFS a => a -> String -> IO [String] getFullSlice fs fp = do newpath <- getFullPath fs fp return (nice_slice newpath) -- | Find an element on the tree, assuming a normalized path findMelem :: MemoryVFS -> String -> IO MemoryEntry findMelem x path | path == [pathSeparator] = readIORef (content x) >>= return . MemoryDirectory | otherwise = let sliced1 = slice_path path h = head sliced1 t = tail sliced1 newh = if (h /= [pathSeparator]) && isPathSeparator (head h) then tail h else h sliced2 = newh : t -- Walk the tree walk :: MemoryEntry -> [String] -> Either String MemoryEntry -- Empty list -- return the item we have walk y zs | null zs = Right y | zs == [[pathSeparator]] = Right y | otherwise = case y of MemoryFile _ -> Left $ "Attempt to look up name " ++ head zs ++ " in file" MemoryDirectory y -> let newentry = case lookup (head zs) y of Nothing -> Left $ "Couldn't find entry " ++ head zs Just a -> Right a in do newobj <- newentry walk newobj (tail zs) in do c <- readIORef $ content x case walk (MemoryDirectory c) (sliced2) of Left err -> vRaiseError x doesNotExistErrorType err Nothing Right result -> return result -- | Find an element on the tree, normalizing the path first getMelem :: MemoryVFS -> String -> IO MemoryEntry getMelem x s = do base <- readIORef $ cwd x case absNormPath base s of Nothing -> vRaiseError x doesNotExistErrorType ("Trouble normalizing path " ++ s) (Just s) Just newpath -> findMelem x newpath instance HVFS MemoryVFS where vGetCurrentDirectory x = readIORef $ cwd x vSetCurrentDirectory x fp = do curpath <- vGetCurrentDirectory x -- Make sure new dir is valid newdir <- getMelem x fp case newdir of (MemoryFile _) -> vRaiseError x doesNotExistErrorType ("Attempt to cwd to non-directory " ++ fp) (Just fp) (MemoryDirectory _) -> case absNormPath curpath fp of Nothing -> -- should never happen due to above getMelem call vRaiseError x illegalOperationErrorType "Bad internal error" (Just fp) Just y -> writeIORef (cwd x) y vGetFileStatus x fp = getMelem x fp >>= \case (MemoryFile y) -> return $ HVFSStatEncap $ SimpleStat {isFile = True, fileSize = (genericLength y)} (MemoryDirectory _) -> return $ HVFSStatEncap $ SimpleStat {isFile = False, fileSize = 0} vGetDirectoryContents x fp = getMelem x fp >>= \case MemoryFile _ -> vRaiseError x doesNotExistErrorType "Can't list contents of a file" (Just fp) MemoryDirectory c -> return $ map fst c instance HVFSOpenable MemoryVFS where vOpen x fp (ReadMode) = getMelem x fp >>= \case MemoryDirectory _ -> vRaiseError x doesNotExistErrorType "Can't open a directory" (Just fp) MemoryFile y -> newStreamReader y >>= return . HVFSOpenEncap vOpen x fp _ = vRaiseError x permissionErrorType "Only ReadMode is supported with MemoryVFS files" (Just fp) MissingH-1.6.0.1/src/System/IO/HVFS/Utils.hs0000644000000000000000000001466607346545000016370 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- arch-tag: HVFS utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVFS.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing filesystems. Written by John Goerzen, jgoerzen\@complete.org To operate on your system's main filesystem, just pass SystemFS as the first parameter to these functions. -} module System.IO.HVFS.Utils (recurseDir, recurseDirStat, recursiveRemove, lsl, SystemFS(..) ) where import System.FilePath (pathSeparator, ()) import System.IO.HVFS ( SystemFS(..), HVFS(vGetSymbolicLinkStatus, vRemoveDirectory, vRemoveFile, vReadSymbolicLink, vGetDirectoryContents), HVFSStat(vFileSize, vIsDirectory, vIsBlockDevice, vIsCharacterDevice, vIsSocket, vIsNamedPipe, vModificationTime, vIsSymbolicLink, vFileMode, vFileOwner, vFileGroup), HVFSStatEncap(..), withStat ) import System.IO.PlafCompat ( groupExecuteMode, groupReadMode, groupWriteMode, intersectFileModes, otherExecuteMode, otherReadMode, otherWriteMode, ownerExecuteMode, ownerReadMode, ownerWriteMode, setGroupIDMode, setUserIDMode ) import System.IO.Unsafe (unsafeInterleaveIO) import System.Locale ( defaultTimeLocale ) import System.Time ( formatCalendarTime, toCalendarTime ) import System.Time.Utils ( epochToClockTime ) import Text.Printf ( printf ) {- | Obtain a recursive listing of all files\/directories beneath the specified directory. The traversal is depth-first and the original item is always present in the returned list. If the passed value is not a directory, the return value be only that value. The \".\" and \"..\" entries are removed from the data returned. -} recurseDir :: HVFS a => a -> FilePath -> IO [FilePath] recurseDir fs x = recurseDirStat fs x >>= return . map fst {- | Like 'recurseDir', but return the stat() (System.Posix.Files.FileStatus) information with them. This is an optimization if you will be statting files yourself later. The items are returned lazily. WARNING: do not change your current working directory until you have consumed all the items. Doing so could cause strange effects. Alternatively, you may wish to pass an absolute path to this function. -} recurseDirStat :: HVFS a => a -> FilePath -> IO [(FilePath, HVFSStatEncap)] recurseDirStat h fn = do fs <- vGetSymbolicLinkStatus h fn if withStat fs vIsDirectory then do dirc <- vGetDirectoryContents h fn let contents = map ((++) (fn ++ [pathSeparator])) $ filter (\x -> x /= "." && x /= "..") dirc subdirs <- unsafeInterleaveIO $ mapM (recurseDirStat h) contents return $ (concat subdirs) ++ [(fn, fs)] else return [(fn, fs)] {- | Removes a file or a directory. If a directory, also removes all its child files\/directories. -} recursiveRemove :: HVFS a => a -> FilePath -> IO () recursiveRemove h path = recurseDirStat h path >>= (mapM_ $ \(fn, fs) -> if withStat fs vIsDirectory then vRemoveDirectory h fn else vRemoveFile h fn ) {- | Provide a result similar to the command ls -l over a directory. Known bug: setuid bit semantics are inexact compared with standard ls. -} lsl :: HVFS a => a -> FilePath -> IO String lsl fs fp = let showmodes mode = let i m = (intersectFileModes mode m /= 0) in (if i ownerReadMode then 'r' else '-') : (if i ownerWriteMode then 'w' else '-') : (if i setUserIDMode then 's' else if i ownerExecuteMode then 'x' else '-') : (if i groupReadMode then 'r' else '-') : (if i groupWriteMode then 'w' else '-') : (if i setGroupIDMode then 's' else if i groupExecuteMode then 'x' else '-') : (if i otherReadMode then 'r' else '-') : (if i otherWriteMode then 'w' else '-') : (if i otherExecuteMode then 'x' else '-') : [] showentry origdir fh (state, fp) = case state of HVFSStatEncap se -> let typechar = if vIsDirectory se then 'd' else if vIsSymbolicLink se then 'l' else if vIsBlockDevice se then 'b' else if vIsCharacterDevice se then 'c' else if vIsSocket se then 's' else if vIsNamedPipe se then 's' else '-' clocktime = epochToClockTime (vModificationTime se) datestr c= formatCalendarTime defaultTimeLocale "%b %e %Y" c in do c <- toCalendarTime clocktime linkstr <- case vIsSymbolicLink se of False -> return "" True -> do sl <- vReadSymbolicLink fh (origdir fp) return $ " -> " ++ sl return $ printf "%c%s 1 %-8d %-8d %-9d %s %s%s" typechar (showmodes (vFileMode se)) (toInteger $ vFileOwner se) (toInteger $ vFileGroup se) (toInteger $ vFileSize se) (datestr c) fp linkstr in do c <- vGetDirectoryContents fs fp pairs <- mapM (\x -> do ss <- vGetSymbolicLinkStatus fs (fp x) return (ss, x) ) c linedata <- mapM (showentry fp fs) pairs return $ unlines $ ["total 1"] ++ linedata MissingH-1.6.0.1/src/System/IO/HVIO.hs0000644000000000000000000006201507346545000015256 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: HVIO main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.HVIO Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Haskell Virtual I\/O -- a system to increase the flexibility of input and output in Haskell Copyright (c) 2004-2005 John Goerzen, jgoerzen\@complete.org HVIO provides the following general features: * The ability to use a single set of functions on various different types of objects, including standard Handles, in-memory buffers, compressed files, network data streams, etc. * The ability to transparently add filters to the I\/O process. These filters could include things such as character set conversions, compression or decompression of a data stream, and more. * The ability to define new objects that have the properties of I\/O objects and can be used interchangably with them. * Specification compatibility with, and complete support for, existing I\/O on Handles. * Provide easier unit testing capabilities for I\/O actions HVIO defines several basic type classes that you can use. You will mostly be interested in 'HVIO'. It's trivial to adapt old code to work with HVIO. For instance, consider this example of old and new code: >printMsg :: Handle -> String -> IO () >printMsg h msg = hPutStr h ("msg: " ++ msg) And now, the new way: >printMsg :: HVIO h => h -> String -> IO () >printMsg h msg = vPutStr h ("msg: " ++ msg) There are several points to note about this conversion: * The new method can still accept a Handle in exactly the same way as the old method. Changing your functions to use HVIO will require no changes from functions that call them with Handles. * Most \"h\" functions have equivolent \"v\" functions that operate on HVIO classes instead of the more specific Handle. The \"v\" functions behave identically to the \"h\" functions whenever possible. * There is no equivolent of \"openFile\" in any HVIO class. You must create your Handle (or other HVIO object) using normal means. This is because the creation is so different that it cannot be standardized. In addition to Handle, there are several pre-defined classes for your use. 'StreamReader' is a particularly interesting one. At creation time, you pass it a String. Its contents are read lazily whenever a read call is made. It can be used, therefore, to implement filters (simply initialize it with the result from, say, a map over hGetContents from another HVIO object), codecs, and simple I\/O testing. Because it is lazy, it need not hold the entire string in memory. You can create a 'StreamReader' with a call to 'newStreamReader'. 'MemoryBuffer' is a similar class, but with a different purpose. It provides a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter', and 'HVIOSeeker'). However, it maintains an in-memory buffer with the contents of the file, rather than an actual on-disk file. You can access the entire contents of this buffer at any time. This can be quite useful for testing I\/O code, or for cases where existing APIs use I\/O, but you prefer a String representation. You can create a 'MemoryBuffer' with a call to 'newMemoryBuffer'. Finally, there are pipes. These pipes are analogous to the Unix pipes that are available from System.Posix, but don't require Unix and work only in Haskell. When you create a pipe, you actually get two HVIO objects: a 'PipeReader' and a 'PipeWriter'. You must use the 'PipeWriter' in one thread and the 'PipeReader' in another thread. Data that's written to the 'PipeWriter' will then be available for reading with the 'PipeReader'. The pipes are implemented completely with existing Haskell threading primitives, and require no special operating system support. Unlike Unix pipes, these pipes cannot be used across a fork(). Also unlike Unix pipes, these pipes are portable and interact well with Haskell threads. A new pipe can be created with a call to 'newHVIOPipe'. Together with "System.IO.HVFS", this module is part of a complete virtual filesystem solution. -} module System.IO.HVIO(-- * Implementation Classes HVIO(..), -- * Standard HVIO Implementations -- ** Handle -- | Handle is a member of 'HVIO'. -- ** Stream Reader StreamReader, newStreamReader, -- ** Memory Buffer MemoryBuffer, newMemoryBuffer, mbDefaultCloseFunc, getMemoryBuffer, -- ** Haskell Pipe PipeReader, PipeWriter, newHVIOPipe ) where import safe Control.Concurrent.MVar ( newEmptyMVar, putMVar, readMVar, takeMVar, MVar ) import qualified Control.Exception (catch) import safe Data.IORef ( IORef, modifyIORef, newIORef, readIORef ) import safe Foreign.C ( castCharToCChar, peekCStringLen ) import safe Foreign.Ptr ( Ptr, castPtr, plusPtr ) import safe Foreign.Storable ( Storable(poke) ) import safe System.IO ( Handle, hClose, hFlush, hGetBuffering, hIsClosed, hIsEOF, hIsOpen, hIsReadable, hIsSeekable, hIsWritable, hSeek, hSetBuffering, hShow, hTell, hGetBuf, hGetChar, hGetContents, hGetLine, hPutBuf, hPutChar, hPutStr, hPutStrLn, hPrint, hReady, SeekMode(..), BufferMode(NoBuffering) ) import safe System.IO.Error ( IOErrorType, eofErrorType, illegalOperationErrorType, isEOFError, mkIOError ) {- | This is the generic I\/O support class. All objects that are to be used in the HVIO system must provide an instance of 'HVIO'. Functions in this class provide an interface with the same specification as the similar functions in System.IO. Please refer to that documentation for a more complete specification than is provided here. Instances of 'HVIO' must provide 'vClose', 'vIsEOF', and either 'vIsOpen' or 'vIsClosed'. Implementators of readable objects must provide at least 'vGetChar' and 'vIsReadable'. An implementation of 'vGetContents' is also highly suggested, since the default cannot implement proper partial closing semantics. Implementators of writable objects must provide at least 'vPutChar' and 'vIsWritable'. Implementators of seekable objects must provide at least 'vIsSeekable', 'vTell', and 'vSeek'. -} class (Show a) => HVIO a where -- | Close a file vClose :: a -> IO () -- | Test if a file is open vIsOpen :: a -> IO Bool -- | Test if a file is closed vIsClosed :: a -> IO Bool -- | Raise an error if the file is not open. -- This is a new HVIO function and is implemented in terms of -- 'vIsOpen'. vTestOpen :: a -> IO () -- | Whether or not we're at EOF. This may raise on exception -- on some items, most notably write-only Handles such as stdout. -- In general, this is most reliable on items opened for reading. -- vIsEOF implementations must implicitly call vTestOpen. vIsEOF :: a -> IO Bool -- | Detailed show output. vShow :: a -> IO String -- | Make an IOError. vMkIOError :: a -> IOErrorType -> String -> Maybe FilePath -> IOError -- | Throw an IOError. vThrow :: a -> IOErrorType -> IO b -- | Get the filename\/object\/whatever that this corresponds to. -- May be Nothing. vGetFP :: a -> IO (Maybe FilePath) -- | Throw an isEOFError if we're at EOF; returns nothing otherwise. -- If an implementation overrides the default, make sure that it -- calls vTestOpen at some point. The default implementation is -- a wrapper around a call to 'vIsEOF'. vTestEOF :: a -> IO () -- | Read one character vGetChar :: a -> IO Char -- | Read one line vGetLine :: a -> IO String {- | Get the remaining contents. Please note that as a user of this function, the same partial-closing semantics as are used in the standard 'hGetContents' are /encouraged/ from implementators, but are not /required/. That means that, for instance, a 'vGetChar' after a 'vGetContents' may return some undefined result instead of the error you would normally get. You should use caution to make sure your code doesn't fall into that trap, or make sure to test your code with Handle or one of the default instances defined in this module. Also, some implementations may essentially provide a complete close after a call to 'vGetContents'. The bottom line: after a call to 'vGetContents', you should do nothing else with the object save closing it with 'vClose'. For implementators, you are highly encouraged to provide a correct implementation. -} vGetContents :: a -> IO String -- | Indicate whether at least one item is ready for reading. -- This will always be True for a great many implementations. vReady :: a -> IO Bool -- | Indicate whether a particular item is available for reading. vIsReadable :: a -> IO Bool -- | Write one character vPutChar :: a -> Char -> IO () -- | Write a string vPutStr :: a -> String -> IO () -- | Write a string with newline character after it vPutStrLn :: a -> String -> IO () -- | Write a string representation of the argument, plus a newline. vPrint :: Show b => a -> b -> IO () -- | Flush any output buffers. -- Note: implementations should assure that a vFlush is automatically -- performed -- on file close, if necessary to ensure all data sent is written. vFlush :: a -> IO () -- | Indicate whether or not this particular object supports writing. vIsWritable :: a -> IO Bool -- | Seek to a specific location. vSeek :: a -> SeekMode -> Integer -> IO () -- | Get the current position. vTell :: a -> IO Integer -- | Convenience function to reset the file pointer to the beginning -- of the file. A call to @vRewind h@ is the -- same as @'vSeek' h AbsoluteSeek 0@. vRewind :: a -> IO () -- | Indicate whether this instance supports seeking. vIsSeekable :: a -> IO Bool -- | Set buffering; the default action is a no-op. vSetBuffering :: a -> BufferMode -> IO () -- | Get buffering; the default action always returns NoBuffering. vGetBuffering :: a -> IO BufferMode -- | Binary output: write the specified number of octets from the specified -- buffer location. vPutBuf :: a -> Ptr b -> Int -> IO () -- | Binary input: read the specified number of octets from the -- specified buffer location, continuing to read -- until it either consumes that much data or EOF is encountered. -- Returns the number of octets actually read. EOF errors are never -- raised; fewer bytes than requested are returned on EOF. vGetBuf :: a -> Ptr b -> Int -> IO Int vSetBuffering _ _ = return () vGetBuffering _ = return NoBuffering vShow x = return (show x) vMkIOError _ et desc mfp = mkIOError et desc Nothing mfp vGetFP _ = return Nothing vThrow h et = do fp <- vGetFP h ioError (vMkIOError h et "" fp) vTestEOF h = do e <- vIsEOF h if e then vThrow h eofErrorType else return () vIsOpen h = vIsClosed h >>= return . not vIsClosed h = vIsOpen h >>= return . not vTestOpen h = do e <- vIsClosed h if e then vThrow h illegalOperationErrorType else return () vIsReadable _ = return False vGetLine h = let loop accum = let func = do c <- vGetChar h case c of '\n' -> return accum x -> accum `seq` loop (accum ++ [x]) handler e = if isEOFError e then return accum else ioError e in Control.Exception.catch func handler in do firstchar <- vGetChar h case firstchar of '\n' -> return [] x -> loop [x] vGetContents h = let loop = let func = do c <- vGetChar h next <- loop c `seq` return (c : next) handler e = if isEOFError e then return [] else ioError e in Control.Exception.catch func handler in do loop vReady h = do vTestEOF h return True vIsWritable _ = return False vPutStr _ [] = return () vPutStr h (x:xs) = do vPutChar h x vPutStr h xs vPutStrLn h s = vPutStr h (s ++ "\n") vPrint h s = vPutStrLn h (show s) vFlush = vTestOpen vIsSeekable _ = return False vRewind h = vSeek h AbsoluteSeek 0 vPutChar h _ = vThrow h illegalOperationErrorType vSeek h _ _ = vThrow h illegalOperationErrorType vTell h = vThrow h illegalOperationErrorType vGetChar h = vThrow h illegalOperationErrorType vPutBuf h buf len = do str <- peekCStringLen (castPtr buf, len) vPutStr h str vGetBuf h b l = worker b l 0 where worker _ 0 accum = return accum worker buf len accum = do iseof <- vIsEOF h if iseof then return accum else do c <- vGetChar h let cc = castCharToCChar c poke (castPtr buf) cc let newptr = plusPtr buf 1 worker newptr (len - 1) (accum + 1) ---------------------------------------------------------------------- -- Handle instances ---------------------------------------------------------------------- instance HVIO Handle where vClose = hClose vIsEOF = hIsEOF vShow = hShow vMkIOError h et desc mfp = mkIOError et desc (Just h) mfp vGetChar = hGetChar vGetLine = hGetLine vGetContents = hGetContents vReady = hReady vIsReadable = hIsReadable vPutChar = hPutChar vPutStr = hPutStr vPutStrLn = hPutStrLn vPrint = hPrint vFlush = hFlush vIsWritable = hIsWritable vSeek = hSeek vTell = hTell vIsSeekable = hIsSeekable vSetBuffering = hSetBuffering vGetBuffering = hGetBuffering vGetBuf = hGetBuf vPutBuf = hPutBuf vIsOpen = hIsOpen vIsClosed = hIsClosed ---------------------------------------------------------------------- -- VIO Support ---------------------------------------------------------------------- type VIOCloseSupport a = IORef (Bool, a) vioc_isopen :: VIOCloseSupport a -> IO Bool vioc_isopen x = readIORef x >>= return . fst vioc_get :: VIOCloseSupport a -> IO a vioc_get x = readIORef x >>= return . snd vioc_close :: VIOCloseSupport a -> IO () vioc_close x = modifyIORef x (\ (_, dat) -> (False, dat)) vioc_set :: VIOCloseSupport a -> a -> IO () vioc_set x newdat = modifyIORef x (\ (stat, _) -> (stat, newdat)) ---------------------------------------------------------------------- -- Stream Readers ---------------------------------------------------------------------- {- | Simulate I\/O based on a string buffer. When a 'StreamReader' is created, it is initialized based on the contents of a 'String'. Its contents are read lazily whenever a request is made to read something from the 'StreamReader'. It can be used, therefore, to implement filters (simply initialize it with the result from, say, a map over hGetContents from another HVIO object), codecs, and simple I\/O testing. Because it is lazy, it need not hold the entire string in memory. You can create a 'StreamReader' with a call to 'newStreamReader'. -} newtype StreamReader = StreamReader (VIOCloseSupport String) {- | Create a new 'StreamReader' object. -} newStreamReader :: String -- ^ Initial contents of the 'StreamReader' -> IO StreamReader newStreamReader s = do ref <- newIORef (True, s) return (StreamReader ref) srv :: StreamReader -> VIOCloseSupport String srv (StreamReader x) = x instance Show StreamReader where show _ = "" instance HVIO StreamReader where vClose = vioc_close . srv vIsEOF h = do vTestOpen h d <- vioc_get (srv h) return $ case d of [] -> True _ -> False vIsOpen = vioc_isopen . srv vGetChar h = do vTestEOF h c <- vioc_get (srv h) let retval = head c vioc_set (srv h) (tail c) return retval vGetContents h = do vTestEOF h c <- vioc_get (srv h) vClose h return c vIsReadable _ = return True ---------------------------------------------------------------------- -- Buffers ---------------------------------------------------------------------- {- | A 'MemoryBuffer' simulates true I\/O, but uses an in-memory buffer instead of on-disk storage. It provides a full interface like Handle (it implements 'HVIOReader', 'HVIOWriter', and 'HVIOSeeker'). However, it maintains an in-memory buffer with the contents of the file, rather than an actual on-disk file. You can access the entire contents of this buffer at any time. This can be quite useful for testing I\/O code, or for cases where existing APIs use I\/O, but you prefer a String representation. You can create a 'MemoryBuffer' with a call to 'newMemoryBuffer'. The present 'MemoryBuffer' implementation is rather inefficient, particularly when reading towards the end of large files. It's best used for smallish data storage. This problem will be fixed eventually. -} data MemoryBuffer = MemoryBuffer (String -> IO ()) (VIOCloseSupport (Int, String)) {- | Create a new 'MemoryBuffer' instance. The buffer is initialized to the value passed, and the pointer is placed at the beginning of the file. You can put things in it by using the normal 'vPutStr' calls, and reset to the beginning by using the normal 'vRewind' call. The function is called when 'vClose' is called, and is passed the contents of the buffer at close time. You can use 'mbDefaultCloseFunc' if you don't want to do anything. To create an empty buffer, pass the initial value @\"\"@. -} newMemoryBuffer :: String -- ^ Initial Contents -> (String -> IO ()) -- ^ close func -> IO MemoryBuffer newMemoryBuffer initval closefunc = do ref <- newIORef (True, (0, initval)) return (MemoryBuffer closefunc ref) {- | Default (no-op) memory buf close function. -} mbDefaultCloseFunc :: String -> IO () mbDefaultCloseFunc _ = return () vrv :: MemoryBuffer -> VIOCloseSupport (Int, String) vrv (MemoryBuffer _ x) = x {- | Grab the entire contents of the buffer as a string. Unlike 'vGetContents', this has no effect on the open status of the item, the EOF status, or the current position of the file pointer. -} getMemoryBuffer :: MemoryBuffer -> IO String getMemoryBuffer h = do c <- vioc_get (vrv h) return (snd c) instance Show MemoryBuffer where show _ = "" instance HVIO MemoryBuffer where vClose x = do wasopen <- vIsOpen x vioc_close (vrv x) if wasopen then do c <- getMemoryBuffer x case x of MemoryBuffer cf _ -> cf c else return () vIsEOF h = do vTestOpen h c <- vioc_get (vrv h) return ((length (snd c)) == (fst c)) vIsOpen = vioc_isopen . vrv vGetChar h = do vTestEOF h c <- vioc_get (vrv h) let retval = (snd c) !! (fst c) vioc_set (vrv h) (succ (fst c), snd c) return retval vGetContents h = do vTestEOF h v <- vioc_get (vrv h) let retval = drop (fst v) (snd v) vioc_set (vrv h) (-1, "") vClose h return retval vIsReadable _ = return True vPutStr h s = do (pos, buf) <- vioc_get (vrv h) let (pre, post) = splitAt pos buf let newbuf = pre ++ s ++ (drop (length s) post) vioc_set (vrv h) (pos + (length s), newbuf) vPutChar h c = vPutStr h [c] vIsWritable _ = return True vTell h = do v <- vioc_get (vrv h) return . fromIntegral $ (fst v) vSeek h seekmode seekposp = do (pos, buf) <- vioc_get (vrv h) let seekpos = fromInteger seekposp let newpos = case seekmode of AbsoluteSeek -> seekpos RelativeSeek -> pos + seekpos SeekFromEnd -> (length buf) + seekpos let buf2 = buf ++ if newpos > (length buf) then replicate (newpos - (length buf)) '\0' else [] vioc_set (vrv h) (newpos, buf2) vIsSeekable _ = return True ---------------------------------------------------------------------- -- Pipes ---------------------------------------------------------------------- {- | Create a Haskell pipe. These pipes are analogous to the Unix pipes that are available from System.Posix, but don't require Unix and work only in Haskell. When you create a pipe, you actually get two HVIO objects: a 'PipeReader' and a 'PipeWriter'. You must use the 'PipeWriter' in one thread and the 'PipeReader' in another thread. Data that's written to the 'PipeWriter' will then be available for reading with the 'PipeReader'. The pipes are implemented completely with existing Haskell threading primitives, and require no special operating system support. Unlike Unix pipes, these pipes cannot be used across a fork(). Also unlike Unix pipes, these pipes are portable and interact well with Haskell threads. -} newHVIOPipe :: IO (PipeReader, PipeWriter) newHVIOPipe = do mv <- newEmptyMVar readerref <- newIORef (True, mv) let reader = PipeReader readerref writerref <- newIORef (True, reader) return (reader, PipeWriter writerref) data PipeBit = PipeBit Char | PipeEOF deriving (Eq, Show) {- | The reading side of a Haskell pipe. Please see 'newHVIOPipe' for more details. -} newtype PipeReader = PipeReader (VIOCloseSupport (MVar PipeBit)) {- | The writing side of a Haskell pipe. Please see 'newHVIOPipe' for more details. -} newtype PipeWriter = PipeWriter (VIOCloseSupport PipeReader) ------------------------------ -- Pipe Reader ------------------------------ prv :: PipeReader -> VIOCloseSupport (MVar PipeBit) prv (PipeReader x) = x instance Show PipeReader where show _ = "" pr_getc :: PipeReader -> IO PipeBit pr_getc h = do mv <- vioc_get (prv h) takeMVar mv instance HVIO PipeReader where vClose = vioc_close . prv vIsOpen = vioc_isopen . prv vIsEOF h = do vTestOpen h mv <- vioc_get (prv h) dat <- readMVar mv return (dat == PipeEOF) vGetChar h = do vTestEOF h c <- pr_getc h case c of PipeBit x -> return x -- vTestEOF should eliminate this case _ -> fail "Internal error in HVIOReader vGetChar" vGetContents h = let loop = do c <- pr_getc h case c of PipeEOF -> return [] PipeBit x -> do next <- loop return (x : next) in do vTestEOF h loop vIsReadable _ = return True ------------------------------ -- Pipe Writer ------------------------------ pwv :: PipeWriter -> VIOCloseSupport PipeReader pwv (PipeWriter x) = x pwmv :: PipeWriter -> IO (MVar PipeBit) pwmv (PipeWriter x) = do mv1 <- vioc_get x vioc_get (prv mv1) instance Show PipeWriter where show _ = "" instance HVIO PipeWriter where vClose h = do o <- vIsOpen h if o then do mv <- pwmv h putMVar mv PipeEOF vioc_close (pwv h) else return () vIsOpen = vioc_isopen . pwv vIsEOF h = do vTestOpen h return False -- FIXME: race condition below (could be closed after testing) vPutChar h c = do vTestOpen h child <- vioc_get (pwv h) copen <- vIsOpen child if copen then do mv <- pwmv h putMVar mv (PipeBit c) else fail "PipeWriter: Couldn't write to pipe because child end is closed" vIsWritable _ = return True MissingH-1.6.0.1/src/System/IO/PlafCompat.hs0000644000000000000000000000245007346545000016534 0ustar0000000000000000{-# LANGUAGE CPP #-} {- Platform Compatibility Layer Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.PlafCompat Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable On Unix, exports System.Posix.Types and System.Posix.Files. On Windows, exports System.Posix.Types and "System.IO.WindowsCompat". The result should be roughly the same set of defined variables and types. -} module System.IO.PlafCompat (nullFileName, #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) module System.IO.WindowsCompat, #else module System.Posix.Files, #endif module System.Posix.Types) where import System.Posix.Types #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.IO.WindowsCompat #else import System.Posix.Files #endif {- | The name of the null device. NUL: on Windows, \/dev\/null everywhere else. -} nullFileName :: String #if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) nullFileName = "NUL:" #else nullFileName = "/dev/null" #endif MissingH-1.6.0.1/src/System/IO/StatCompat.hs0000644000000000000000000000463007346545000016567 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {- Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.StatCompat Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Provide a stat-like structure for use in MissingH. Especially useful with HVFS and on Windows. See also "System.IO.WindowsCompat". -} module System.IO.StatCompat where import safe System.Posix.Consts ( blockSpecialMode, characterSpecialMode, namedPipeMode, regularFileMode, directoryMode, fileTypeModes, socketMode, symbolicLinkMode ) import safe System.Posix.Types ( DeviceID, EpochTime, FileID, FileMode, FileOffset ) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import safe System.Posix.Types ( LinkCount, UserID, GroupID ) import safe System.Posix.Files ( intersectFileModes ) #else import safe Data.Bits ( (.&.) ) type LinkCount = Int type UserID = Int type GroupID = Int intersectFileModes :: FileMode -> FileMode -> FileMode intersectFileModes m1 m2 = m1 .&. m2 #endif data FileStatusCompat = FileStatusCompat {deviceID :: DeviceID, fileID :: FileID, fileMode :: FileMode, linkCount :: LinkCount, fileOwner :: UserID, fileGroup :: GroupID, specialDeviceID :: DeviceID, fileSize :: FileOffset, accessTime :: EpochTime, modificationTime :: EpochTime, statusChangeTime :: EpochTime } sc_helper :: FileMode -> FileStatusCompat -> Bool sc_helper comp stat = (fileMode stat `intersectFileModes` fileTypeModes) == comp isBlockDevice,isCharacterDevice,isNamedPipe,isRegularFile,isDirectory,isSymbolicLink,isSocket :: FileStatusCompat -> Bool isBlockDevice = sc_helper blockSpecialMode isCharacterDevice = sc_helper characterSpecialMode isNamedPipe = sc_helper namedPipeMode isRegularFile = sc_helper regularFileMode isDirectory = sc_helper directoryMode isSymbolicLink = sc_helper symbolicLinkMode isSocket = sc_helper socketMode MissingH-1.6.0.1/src/System/IO/Utils.hs0000644000000000000000000001714707346545000015617 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {- Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable -} module System.IO.Utils(-- * Entire File Handle Utilities -- ** Opened Handle Data Copying hCopy, hCopyProgress, hLineCopy, lineCopy, -- ** Disk File Data Copying copyFileLinesToFile, -- * Line Processing Utilities hPutStrLns, hGetLines, -- * Lazy Interaction -- ** Character-based hInteract, -- ** Line-based hLineInteract, lineInteract, -- ** Misc. Lazy lazyMapM, -- * Optimizations optimizeForBatch, optimizeForInteraction ) where import Data.List (genericLength) import System.IO (BufferMode (BlockBuffering, LineBuffering), IOMode (ReadMode, WriteMode), hClose, hSetBuffering, openFile, stdin, stdout) import System.IO.HVIO (HVIO (vGetContents, vGetLine, vIsEOF, vPutStr, vPutStrLn)) import System.IO.Unsafe (unsafeInterleaveIO) {- | Given a list of strings, output a line containing each item, adding newlines as appropriate. The list is not expected to have newlines already. -} hPutStrLns :: HVIO a => a -> [String] -> IO () hPutStrLns h = mapM_ $ vPutStrLn h {- | Given a handle, returns a list of all the lines in that handle. Thanks to lazy evaluation, this list does not have to be read all at once. Combined with 'hPutStrLns', this can make a powerful way to develop filters. See the 'lineInteract' function for more on that concept. Example: > main = do > l <- hGetLines stdin > hPutStrLns stdout $ filter (startswith "1") l -} -- FIXME: does hGetContents h >>= return . lines not work? hGetLines :: HVIO a => a -> IO [String] hGetLines h = unsafeInterleaveIO (do ieof <- vIsEOF h if (ieof) then return [] else do line <- vGetLine h remainder <- hGetLines h return (line : remainder)) {- | This is similar to the built-in 'System.IO.interact', but works on any handle, not just stdin and stdout. In other words: > interact = hInteract stdin stdout -} hInteract :: (HVIO a, HVIO b) => a -> b -> (String -> String) -> IO () hInteract finput foutput func = do content <- vGetContents finput vPutStr foutput (func content) {- | Line-based interaction. This is similar to wrapping your interact functions with 'lines' and 'unlines'. This equality holds: > lineInteract = hLineInteract stdin stdout Here's an example: > main = lineInteract (filter (startswith "1")) This will act as a simple version of grep -- all lines that start with 1 will be displayed; all others will be ignored. -} lineInteract :: ([String] -> [String]) -> IO () lineInteract = hLineInteract stdin stdout {- | Line-based interaction over arbitrary handles. This is similar to wrapping hInteract with 'lines' and 'unlines'. One could view this function like this: > hLineInteract finput foutput func = > let newf = unlines . func . lines in > hInteract finput foutput newf Though the actual implementation is this for efficiency: > hLineInteract finput foutput func = > do > lines <- hGetLines finput > hPutStrLns foutput (func lines) -} hLineInteract :: (HVIO a, HVIO b) => a -> b -> ([String] -> [String]) -> IO () hLineInteract finput foutput func = do ls <- hGetLines finput hPutStrLns foutput (func ls) {- | Copies from one handle to another in raw mode (using hGetContents). -} hCopy :: (HVIO a, HVIO b) => a -> b -> IO () hCopy hin hout = do c <- vGetContents hin vPutStr hout c {- | Copies from one handle to another in raw mode (using hGetContents). Takes a function to provide progress updates to the user. -} hCopyProgress :: (HVIO b, HVIO c, Integral a) => b -- ^ Input handle -> c -- ^ Output handle -> (Maybe a -> Integer -> Bool -> IO ()) -- ^ Progress function -- the bool is always False unless this is the final call -> Int -- Block size -> Maybe a -- Estimated file size (passed to func) -> IO Integer -- Number of bytes copied hCopyProgress hin hout func bsize estsize = let copyFunc :: String -> Integer -> IO Integer copyFunc [] count = return count copyFunc indata count = let block = take bsize indata remainder = drop bsize indata newcount = count + (genericLength block) in do vPutStr hout block func estsize count False copyFunc remainder newcount in do c <- vGetContents hin bytes <- copyFunc c 0 func estsize bytes True return bytes {- | Copies from one handle to another in text mode (with lines). Like 'hBlockCopy', this implementation is nice: > hLineCopy hin hout = hLineInteract hin hout id -} hLineCopy :: (HVIO a, HVIO b) => a -> b -> IO() hLineCopy hin hout = hLineInteract hin hout id {- | Copies from 'stdin' to 'stdout' using lines. An alias for 'hLineCopy' over 'stdin' and 'stdout'. -} lineCopy :: IO () lineCopy = hLineCopy stdin stdout {- | Copies one filename to another in text mode. Please note that the Unix permission bits are set at a default; you may need to adjust them after the copy yourself. This function is implemented using 'hLineCopy' internally. -} copyFileLinesToFile :: FilePath -> FilePath -> IO () copyFileLinesToFile infn outfn = do hin <- openFile infn ReadMode hout <- openFile outfn WriteMode hLineCopy hin hout hClose hin hClose hout return () {- | Sets stdin and stdout to be block-buffered. This can save a huge amount of system resources since far fewer syscalls are made, and can make programs run much faster. -} optimizeForBatch :: IO () optimizeForBatch = do hSetBuffering stdin (BlockBuffering (Just 4096)) hSetBuffering stdout (BlockBuffering (Just 4096)) {- | Sets stdin and stdout to be line-buffered. This saves resources on stdout, but not many on stdin, since it it still looking for newlines. -} optimizeForInteraction :: IO () optimizeForInteraction = do hSetBuffering stdin LineBuffering hSetBuffering stdout LineBuffering {- | Applies a given function to every item in a list, and returns the new list. Unlike the system\'s mapM, items are evaluated lazily. -} lazyMapM :: (a -> IO b) -> [a] -> IO [b] lazyMapM _ [] = return [] lazyMapM conv (x:xs) = do this <- conv x next <- unsafeInterleaveIO $ lazyMapM conv xs return (this:next) MissingH-1.6.0.1/src/System/IO/WindowsCompat.hs0000644000000000000000000000762307346545000017313 0ustar0000000000000000{-# LANGUAGE CPP #-} {- Windows compatibility layer Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.IO.WindowsCompat Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Provides some types and related items on Windows to be compatible with the System.Posix.* libraries See also "System.IO.StatCompat", which this module re-exports. On non-Windows platforms, this module does nothing. On Windows, it re-exports "System.IO.StatCompat". It also provides various file type information modes that are otherwise in "System.Posix.Types" or "System.Posix.Files". It also provides a rudimentary implemention of getFileStatus that emulates the Posix call to stat(2). Common usage might be like this: >import System.Posix.Types >#if (defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) >import System.IO.WindowsCompat >#else >import System.Posix.Files >#endif Or, to avoid having to use CPP and make things even easier, just import "System.IO.PlafCompat", which essentially does the above. -} module System.IO.WindowsCompat #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) where #else (module System.IO.StatCompat, module System.IO.WindowsCompat) where import System.Posix.Types import Data.Bits import System.IO.StatCompat import System.Posix.Consts import System.Time.Utils import System.Directory import Data.Time import Data.Time.Clock.POSIX -- these types aren't defined here nullFileMode :: FileMode nullFileMode = 0 ownerReadMode :: FileMode ownerReadMode = 0o00400 ownerWriteMode :: FileMode ownerWriteMode = 0o00200 ownerExecuteMode :: FileMode ownerExecuteMode = 0o00100 groupReadMode :: FileMode groupReadMode = 0o00040 groupWriteMode :: FileMode groupWriteMode = 0o00020 groupExecuteMode :: FileMode groupExecuteMode = 0o00010 otherReadMode :: FileMode otherReadMode = 0o00004 otherWriteMode :: FileMode otherWriteMode = 0o00002 otherExecuteMode :: FileMode otherExecuteMode = 0o00001 setUserIDMode :: FileMode setUserIDMode = 0o0004000 setGroupIDMode :: FileMode setGroupIDMode = 0o0002000 stdFileMode :: FileMode stdFileMode = ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. groupWriteMode .|. otherReadMode .|. otherWriteMode ownerModes :: FileMode ownerModes = 0o00700 groupModes :: FileMode groupModes = 0o00070 otherModes :: FileMode otherModes = 0o00007 accessModes :: FileMode accessModes = ownerModes .|. groupModes .|. otherModes utcTimeToSeconds :: Num a => UTCTime -> a utcTimeToSeconds = fromInteger . floor . utcTimeToPOSIXSeconds ----------- stat type FileStatus = FileStatusCompat getFileStatus :: FilePath -> IO FileStatus getFileStatus fp = do isfile <- doesFileExist fp isdir <- doesDirectoryExist fp perms <- getPermissions fp modct <- getModificationTime fp #if MIN_VERSION_directory(1,2,0) let epochtime = utcTimeToSeconds modct #else let epochtime = clockTimeToEpoch modct #endif return $ FileStatusCompat {deviceID = -1, fileID = -1, fileMode = if isfile then regularFileMode else directoryMode, linkCount = 1, fileOwner = 0, fileGroup = 0, specialDeviceID = -1, fileSize = 0, -- fixme: hFileSize? accessTime = fromInteger epochtime, modificationTime = fromInteger epochtime, statusChangeTime = fromInteger epochtime } #endif MissingH-1.6.0.1/src/System/Path.hs0000644000000000000000000001247507346545000015103 0ustar0000000000000000{-# LANGUAGE CPP #-} {- arch-tag: Path utilities main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Path Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various helpful utilities for dealing with path and file names, directories, and related support. Written by John Goerzen, jgoerzen\@complete.org -} module System.Path(-- * Name processing splitExt, absNormPath, secureAbsNormPath, -- * Directory Processing recurseDir, recurseDirStat, recursiveRemove, bracketCWD, -- * Temporary Directories mktmpdir, brackettmpdir, brackettmpdirCWD ) where import Data.List.Utils ( startswith, alwaysElemRIndex ) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Directory ( getCurrentDirectory, removeFile, setCurrentDirectory ) import System.Posix.Directory ( createDirectory ) import System.Posix.Temp ( mkstemp ) #else import System.Directory import System.IO ( openTempFile ) #endif import Control.Exception ( finally ) import System.FilePath ( pathSeparator ) import System.IO ( hClose ) import System.IO.HVFS.Utils ( SystemFS(SystemFS), recurseDir, recurseDirStat, recursiveRemove ) import System.Path.NameManip ( normalise_path, absolute_path_by, guess_dotdot ) {- | Splits a pathname into a tuple representing the root of the name and the extension. The extension is considered to be all characters from the last dot after the last slash to the end. Either returned string may be empty. -} -- FIXME: See 6.4 API when released. splitExt :: String -> (String, String) splitExt path = let dotindex = alwaysElemRIndex '.' path slashindex = alwaysElemRIndex pathSeparator path in if dotindex <= slashindex then (path, "") else ((take dotindex path), (drop dotindex path)) {- | Make an absolute, normalized version of a path with all double slashes, dot, and dotdot entries removed. The first parameter is the base for the absolut calculation; in many cases, it would correspond to the current working directory. The second parameter is the pathname to transform. If it is already absolute, the first parameter is ignored. Nothing may be returned if there's an error; for instance, too many @..@ entries for the given path. -} absNormPath :: String -- ^ Absolute path for use with starting directory -> String -- ^ The path name to make absolute -> Maybe String -- ^ Result absNormPath base thepath = let path = absolute_path_by base thepath in case guess_dotdot (normalise_path path) of Just "." -> Just [pathSeparator] x -> x {- | Like absNormPath, but returns Nothing if the generated result is not the passed base path or a subdirectory thereof. -} secureAbsNormPath :: String -- ^ Absolute path for use with starting directory -> String -- ^ The path to make absolute -> Maybe String secureAbsNormPath base s = do p <- absNormPath base s if startswith base p then return p else fail "" {- | Creates a temporary directory for your use. The passed string should be a template suitable for mkstemp; that is, end with @\"XXXXXX\"@. Your string should probably start with the value returned from System.Directory.getTemporaryDirectory. The name of the directory created will be returned. -} mktmpdir :: String -> IO String #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) mktmpdir x = do y <- mkstemp x let (dirname, h) = y hClose h removeFile dirname createDirectory dirname 0o700 return dirname #else mktmpdir x = do (fp, h) <- openTempFile "" x hClose h removeFile fp createDirectory fp return fp #endif {- | Creates a temporary directory for your use via 'mktmpdir', runs the specified action (passing in the directory name), then removes the directory and all its contents when the action completes (or raises an exception. -} brackettmpdir :: String -> (String -> IO a) -> IO a brackettmpdir x action = do tmpdir <- mktmpdir x finally (action tmpdir) (recursiveRemove SystemFS tmpdir) {- | Changes the current working directory to the given path, executes the given I\/O action, then changes back to the original directory, even if the I\/O action raised an exception. -} bracketCWD :: FilePath -> IO a -> IO a bracketCWD fp action = do oldcwd <- getCurrentDirectory setCurrentDirectory fp finally action (setCurrentDirectory oldcwd) {- | Runs the given I\/O action with the CWD set to the given tmp dir, removing the tmp dir and changing CWD back afterwards, even if there was an exception. -} brackettmpdirCWD :: String -> IO a -> IO a brackettmpdirCWD template action = brackettmpdir template (\newdir -> bracketCWD newdir action) MissingH-1.6.0.1/src/System/Path/0000755000000000000000000000000007346545000014536 5ustar0000000000000000MissingH-1.6.0.1/src/System/Path/Glob.hs0000644000000000000000000001020407346545000015752 0ustar0000000000000000{- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Path.Glob Copyright : Copyright (C) 2006-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Functions for expanding wildcards, filenames, and pathnames. For information on the metacharacters recognized, please see the notes in "System.Path.WildMatch". -} module System.Path.Glob (glob, vGlob) where import Control.Exception (tryJust) import Data.List (isSuffixOf) import Data.List.Utils (hasAny) import System.FilePath (pathSeparator, splitFileName, ()) import System.IO.HVFS (HVFS (vDoesDirectoryExist, vDoesExist, vGetDirectoryContents), SystemFS (SystemFS)) import System.Path.WildMatch (wildCheckCase) hasWild :: String -> Bool hasWild = hasAny "*?[" {- | Takes a pattern. Returns a list of names that match that pattern. The pattern is evaluated by "System.Path.WildMatch". This function does not perform tilde or environment variable expansion. Filenames that begin with a dot are not included in the result set unless that component of the pattern also begins with a dot. In MissingH, this function is defined as: >glob = vGlob SystemFS -} glob :: FilePath -> IO [FilePath] glob = vGlob SystemFS {- | Like 'glob', but works on both the system ("real") and HVFS virtual filesystems. -} vGlob :: HVFS a => a -> FilePath -> IO [FilePath] vGlob fs fn = if not (hasWild fn) -- Don't try globbing if there are no wilds then do de <- vDoesExist fs fn if de then return [fn] else return [] else expandGlob fs fn -- It's there expandGlob :: HVFS a => a -> FilePath -> IO [FilePath] expandGlob fs fn | dirnameslash == '.':pathSeparator:[] = runGlob fs "." basename | dirnameslash == [pathSeparator] = do rgs <- runGlob fs [pathSeparator] basename return $ map (pathSeparator :) rgs | otherwise = do dirlist <- if hasWild dirname then expandGlob fs dirname else return [dirname] if hasWild basename then concat `fmap` mapM expandWildBase dirlist else concat `fmap` mapM expandNormalBase dirlist where (dirnameslash, basename) = splitFileName fn dirname = if dirnameslash == [pathSeparator] then [pathSeparator] else if isSuffixOf [pathSeparator] dirnameslash then init dirnameslash else dirnameslash expandWildBase :: FilePath -> IO [FilePath] expandWildBase dname = do dirglobs <- runGlob fs dname basename return $ map withD dirglobs where withD = case dname of "" -> id _ -> \globfn -> dname ++ [pathSeparator] ++ globfn expandNormalBase :: FilePath -> IO [FilePath] expandNormalBase dname = do isdir <- vDoesDirectoryExist fs dname let newname = dname basename isexists <- vDoesExist fs newname if isexists && ((basename /= "." && basename /= "") || isdir) then return [dname basename] else return [] runGlob :: HVFS a => a -> FilePath -> FilePath -> IO [FilePath] runGlob fs "" patt = runGlob fs "." patt runGlob fs dirname patt = do r <- tryJust ioErrors (vGetDirectoryContents fs dirname) case r of Left _ -> return [] Right names -> let matches = filter (wildCheckCase patt) $ names in if head patt == '.' then return matches else return $ filter (\x -> head x /= '.') matches where ioErrors :: IOError -> Maybe IOError ioErrors e = Just e MissingH-1.6.0.1/src/System/Path/NameManip.hs0000644000000000000000000003726707346545000016756 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {- | Module : System.Path.NameManip Copyright : Copyright (C) 2004 Volker Wysk SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Low-level path name manipulations. Written by Volker Wysk -} module System.Path.NameManip where import Data.List (intercalate, unfoldr) import System.Directory (getCurrentDirectory) import System.FilePath (isPathSeparator, pathSeparator, ()) {- | Split a path in components. Repeated \"@\/@\" characters don\'t lead to empty components. \"@.@\" path components are removed. If the path is absolute, the first component will start with \"@\/@\". \"@..@\" components are left intact. They can't be simply removed, because the preceding component might be a symlink. In this case, 'realpath' is probably what you need. The case that the path is empty, is probably an error. However, it is treated like \"@.@\", yielding an empty path components list. Examples: >slice_path "/" = ["/"] >slice_path "/foo/bar" = ["/foo","bar"] >slice_path "..//./" = [".."] >slice_path "." = [] See 'unslice_path', 'realpath', 'realpath_s'. -} slice_path :: String -- ^ The path to be broken to components. -> [String] -- ^ List of path components. slice_path "" = [] slice_path (c:cs) = if isPathSeparator c then case slice_path' cs of [] -> [[c]] (p:ps) -> (c:p):ps else slice_path' (c:cs) where slice_path' o = filter (\c -> c /= "" && c /= ".") (split o) split xs = unfoldr f xs where f "" = Nothing f xs = Just $ fmap tail' $ break isPathSeparator xs tail' [] = [] tail' xs = tail xs {- | Form a path from path components. This isn't the inverse of 'slice_path', since @'unslice_path' . 'slice_path'@ normalises the path. See 'slice_path'. -} unslice_path :: [String] -- ^ List of path components -> String -- ^ The path which consists of the supplied path components unslice_path [] = "." unslice_path cs = intercalate [pathSeparator] cs {- | Normalise a path. This is done by reducing repeated @\/@ characters to one, and removing @.@ path components. @..@ path components are left intact, because of possible symlinks. @'normalise_path' = 'unslice_path' . 'slice_path'@ -} normalise_path :: String -- ^ Path to be normalised -> String -- ^ Path in normalised form normalise_path = unslice_path . slice_path {- | Split a file name in components. This are the base file name and the suffixes, which are separated by dots. If the name starts with a dot, it is regarded as part of the base name. The result is a list of file name components. The filename may be a path. In this case, everything up to the last path component will be returned as part of the base file name. The path gets normalised thereby. No empty suffixes are returned. If the file name contains several consecutive dots, they are regared as part of the preceding file name component. Concateneting the name components and adding dots, reproduces the original name, with a normalised path: @concat . intersperse \".\" . 'slice_filename' == 'normalise'@. Note that the last path component might be \"@..@\". Then it is not possible to deduce the refered directory's name from the path. An IO action for getting the real path is then necessary. Examples: @ 'slice_filename' \"a.b\/\/.\/.foo.tar.gz\" == [\"a.b\/.foo\",\"tar\",\"gz\"] 'slice_filename' \".x..y.\" == [\".x.\", \"y.\"] @ See 'unslice_filename', @slice_filename\'@. -} slice_filename :: String -- ^ Path -> [String] -- ^ List of components the file name is made up of slice_filename path = let comps = slice_path path in if comps == [] then [] else -- slice_filename' result not empty, because comps not empty let (base:suffixes) = slice_filename' (last comps) in (unslice_path (init comps ++ [base]) : suffixes) {- | This is a variant of 'slice_filename'. It is like 'slice_filename', except for being more efficient, and the filename must not contain any preceding path, since this case isn't considered. See 'slice_filename', 'unslice_filename'. -} slice_filename' :: String -- ^ File name without path -> [String] -- ^ List of components the file name is made up of slice_filename' = \case ('.':filename') -> case slice_filename'' filename' of [] -> ["."] (t:ts) -> ('.':t) : ts filename -> slice_filename'' filename where slice_filename'' :: String -> [String] slice_filename'' "" = [] slice_filename'' fn = let (beg,rest) = split1 fn in (beg : slice_filename'' rest) split1 :: String -> (String, String) split1 (x:y:r) = if x == '.' && y /= '.' then ("", y:r) else let (beg,rest) = split1 (y:r) in (x:beg,rest) split1 str = (str, "") {- | Form file name from file name components, interspersing dots. This is the inverse of 'slice_filename', except for normalisation of any path. > unslice_filename = concat . intersperse "." See 'slice_filename'. -} unslice_filename :: [String] -- ^ List of file name components -> String -- ^ Name of the file which consists of the supplied components unslice_filename = intercalate "." {- | Split a path in directory and file name. Only in the case that the supplied path is empty, both parts are empty strings. Otherwise, @\".\"@ is filled in for the corresponding part, if necessary. Unless the path is empty, concatenating the returned path and file name components with a slash in between, makes a valid path to the file. @split_path@ splits off the last path component. This isn't the same as the text after the last @\/@. Note that the last path component might be @\"..\"@. Then it is not possible to deduce the refered directory's name from the path. Then an IO action for getting the real path is necessary. Examples: >split_path "/a/b/c" == ("/a/b", "c") >split_path "foo" == (".", "foo") >split_path "foo/bar" == ("foo", "bar") >split_path "foo/.." == ("foo", "..") >split_path "." == (".", ".") >split_path "" == ("", "") >split_path "/foo" == ("/", "foo") >split_path "foo/" == (".", "foo") >split_path "foo/." == (".", "foo") >split_path "foo///./bar" == ("foo", "bar") See 'slice_path'. -} split_path :: String -- ^ Path to be split -> (String, String) -- ^ Directory and file name components of the path. The directory path is normalized. split_path "" = ("","") split_path path = case slice_path path of [] -> (".", ".") [""] -> (".", "") [f:fs] -> if isPathSeparator f then ([pathSeparator], fs) else (".", f:fs) parts -> ( unslice_path (init parts) , last parts ) {- | Get the directory part of a path. >dir_part = fst . split_path See 'split_path'. -} dir_part :: String -> String dir_part = fst . split_path {- | Get the last path component of a path. >filename_part = snd . split_path Examples: >filename_part "foo/bar" == "bar" >filename_part "." == "." See 'split_path'. -} filename_part :: String -> String filename_part = snd . split_path {- | Inverse of 'split_path', except for normalisation. This concatenates two paths, and takes care of @\".\"@ and empty paths. When the two components are the result of @split_path@, then @unsplit_path@ creates a normalised path. It is best documented by its definition: >unsplit_path (".", "") = "." >unsplit_path ("", ".") = "." >unsplit_path (".", q) = q >unsplit_path ("", q) = q >unsplit_path (p, "") = p >unsplit_path (p, ".") = p >unsplit_path (p, q) = p ++ "/" ++ q Examples: >unsplit_path ("", "") == "" >unsplit_path (".", "") == "." >unsplit_path (".", ".") == "." >unsplit_path ("foo", ".") == "foo" See 'split_path'. -} unsplit_path :: ( String, String ) -- ^ Directory and file name -> String -- ^ Path formed from the directory and file name parts unsplit_path (".", "") = "." unsplit_path ("", ".") = "." unsplit_path (".", q) = q unsplit_path ("", q) = q unsplit_path (p, "") = p unsplit_path (p, ".") = p unsplit_path (p, q) = p q {- | Split a file name in prefix and suffix. If there isn't any suffix in the file name, then return an empty suffix. A dot at the beginning or at the end is not regarded as introducing a suffix. The last path component is what is being split. This isn't the same as splitting the string at the last dot. For instance, if the file name doesn't contain any dot, dots in previous path component's aren't mistaken as introducing suffixes. The path part is returned in normalised form. This means, @\".\"@ components are removed, and multiple \"@\/@\"s are reduced to one. Note that there isn't any plausibility check performed on the suffix. If the file name doesn't have a suffix, but happens to contain a dot, then this dot is mistaken as introducing a suffix. Examples: >split_filename "path/to/foo.bar" = ("path/to/foo","bar") >split_filename "path/to/foo" = ("path/to/foo","") >split_filename "/path.to/foo" = ("/path.to/foo","") >split_filename "a///./x" = ("a/x","") >split_filename "dir.suffix/./" = ("dir","suffix") >split_filename "Photographie, Das 20. Jahrhundert (300 dpi)" = ("Photographie, Das 20", " Jahrhundert (300 dpi)") See 'slice_path', 'split_filename\'' -} split_filename :: String -- ^ Path including the file name to be split -> (String, String) -- ^ The normalised path with the file prefix, and the file suffix. split_filename "" = ("", "") split_filename path = case slice_path path of [] -> (".","") comps -> let (pref_fn, suff_fn) = split_filename' (last comps) in ( intercalate [pathSeparator] (init comps ++ [pref_fn]) , suff_fn ) {- | Variant of 'split_filename'. This is a more efficient version of 'split_filename', for the case that you know the string is is a pure file name without any slashes. See 'split_filename'. -} split_filename' :: String -- ^ Filename to be split -> (String, String) -- ^ Base name and the last suffix split_filename' "" = ("", "") split_filename' fn = let parts = slice_filename' fn in case parts of [] -> (".", "") [base] -> (base, "") p -> (unslice_filename (init p), last p) {- | Inverse of 'split_filename'. Concatenate prefix and suffix, adding a dot in between, iff the suffix is not empty. The path part of the prefix is normalised. See 'split_filename'. -} unsplit_filename :: (String, String) -- ^ File name prefix and suffix -> String -- ^ Path unsplit_filename (prefix, suffix) = if suffix == "" then prefix else prefix ++ "." ++ suffix {- | Split a path in directory, base file name and suffix. -} split3 :: String -- ^ Path to split -> (String, String, String) -- ^ Directory part, base file name part and suffix part split3 "" = ("","","") split3 path = let comps = slice_path path (base, suffix) = split_filename' (last comps) in (unslice_path (init comps), base, suffix) {- | Form path from directory, base file name and suffix parts. -} unsplit3 :: (String, String, String) -- ^ Directory part, base file name part and suffix part -> String -- ^ Path consisting of dir, base and suffix unsplit3 (dir, base, suffix) = unsplit_path (dir, (unsplit_filename (base,suffix))) {- | Test a path for a specific suffix and split it off. If the path ends with the suffix, then the result is @Just prefix@, where @prefix@ is the normalised path without the suffix. Otherwise it's @Nothing@. -} test_suffix :: String -- ^ Suffix to split off -> String -- ^ Path to test -> Maybe String -- ^ Prefix without the suffix or @Nothing@ test_suffix suffix path = let (prefix, suff) = split_filename path in if suff == suffix then Just prefix else Nothing {- | Make a path absolute, using the current working directory. This makes a relative path absolute with respect to the current working directory. An absolute path is returned unmodified. The current working directory is determined with @getCurrentDirectory@ which means that symbolic links in it are expanded and the path is normalised. This is different from @pwd@. -} absolute_path :: String -- ^ The path to be made absolute -> IO String -- ^ Absulte path absolute_path path = fmap (absolute_path' path) getCurrentDirectory {- | Make a path absolute. This makes a relative path absolute with respect to a specified directory. An absolute path is returned unmodified. -} absolute_path_by :: String -- ^ The directory relative to which the path is made absolute -> String -- ^ The path to be made absolute -> String -- ^ Absolute path absolute_path_by = () {- | Make a path absolute. This makes a relative path absolute with respect to a specified directory. An absolute path is returned unmodified. The order of the arguments can be confusing. You should rather use 'absolute_path_by'. @absolute_path\'@ is included for backwards compatibility. -} absolute_path' :: String -- ^ The path to be made absolute -> String -- ^ The directory relative to which the path is made absolute -> String -- ^ Absolute path absolute_path' = flip absolute_path_by {- | Guess the @\"..\"@-component free form of a path, specified as a list of path components, by syntactically removing them, along with the preceding path components. This will produce erroneous results when the path contains symlinks. If the path contains leading @\"..\"@ components, or more @\"..\"@ components than preceeding normal components, then the @\"..\"@ components can't be normalised away. In this case, the result is @Nothing@. -} guess_dotdot_comps :: [String] -- ^ List of path components -> Maybe [String] -- ^ In case the path could be transformed, the @\"..\"@-component free list of path components. guess_dotdot_comps = guess_dotdot_comps' [] where guess_dotdot_comps' schon [] = Just schon guess_dotdot_comps' [] ("..":_) = Nothing guess_dotdot_comps' schon ("..":teile) = guess_dotdot_comps' (reverse . tail . reverse $ schon) teile guess_dotdot_comps' schon (teil:teile) = guess_dotdot_comps' (schon ++ [teil]) teile {- | Guess the @\"..\"@-component free, normalised form of a path. The transformation is purely syntactic. @\"..\"@ path components will be removed, along with their preceding path components. This will produce erroneous results when the path contains symlinks. If the path contains leading @\"..\"@ components, or more @\"..\"@ components than preceeding normal components, then the @\"..\"@ components can't be normalised away. In this case, the result is @Nothing@. >guess_dotdot = fmap unslice_path . guess_dotdot_comps . slice_path -} guess_dotdot :: String -- ^ Path to be normalised -> Maybe String -- ^ In case the path could be transformed, the normalised, @\"..\"@-component free form of the path. guess_dotdot = fmap unslice_path . guess_dotdot_comps . slice_path MissingH-1.6.0.1/src/System/Path/WildMatch.hs0000644000000000000000000000573207346545000016755 0ustar0000000000000000{-# LANGUAGE Safe #-} {- Copyright (c) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Path.WildMatch Copyright : Copyright (C) 2006-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Matching filenames with wildcards. See also "System.Path.Glob" for support for generating lists of files based on wildcards. Inspired by fnmatch.py, part of the Python standard library. Written by John Goerzen, jgoerzen\@complete.org The input wildcard for functions in this module is expected to be in the standard style of Posix shells. That is: >? matches exactly one character >\* matches zero or more characters >[list] matches any character in list >[!list] matches any character not in the list The returned regular expression will always end in \$ but never begins with ^, making it suitable for appending to the end of paths. If you want to match a given filename directly, you should prepend the ^ character to the returned value from this function. Please note: * Neither the path separator (the slash or backslash) nor the period carry any special meaning for the functions in this module. That is, @*@ will match @\/@ in a filename. If this is not the behavior you want, you probably want "System.Path.Glob" instead of this module. * Unlike the Unix shell, filenames that begin with a period are not ignored by this module. That is, @*.txt@ will match @.test.txt@. * This module does not current permit escaping of special characters. -} module System.Path.WildMatch (-- * Wildcard matching wildCheckCase, wildToRegex) where import Data.String.Utils ( escapeRe ) import Text.Regex ( matchRegex, mkRegex ) {- | Convert a wildcard to an (uncompiled) regular expression. -} wildToRegex :: String -> String wildToRegex i = convwild i ++ "$" {- | Check the given name against the given pattern, being case-sensitive. The given pattern is forced to match the given name starting at the beginning. -} wildCheckCase :: String -- ^ The wildcard pattern to use as the base -> String -- ^ The filename to check against it -> Bool -- ^ Result wildCheckCase patt name = case matchRegex (mkRegex $ "^" ++ wildToRegex patt) name of Nothing -> False Just _ -> True -- This is SO MUCH CLEANER than the python implementation! convwild :: String -> String convwild [] = [] convwild ('*':xs) = ".*" ++ convwild xs convwild ('?':xs) = "." ++ convwild xs convwild ('[':'!':xs) = "[^" ++ convpat xs convwild ('[':xs) = '[' : convpat xs convwild ('.':xs) = "\\." ++ convwild xs convwild (x:xs) = escapeRe [x] ++ convwild xs convpat :: String -> String convpat ('\\':xs) = "\\\\" ++ convpat xs convpat (']':xs) = ']' : convwild xs convpat (x:xs) = x : convpat xs convpat [] = [] MissingH-1.6.0.1/src/System/Posix/0000755000000000000000000000000007346545000014744 5ustar0000000000000000MissingH-1.6.0.1/src/System/Posix/Consts.hs0000644000000000000000000000177107346545000016557 0ustar0000000000000000{-# LANGUAGE Safe #-} {- Posix consts not included with Haskell Copyright (c) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Posix.Consts Copyright : Copyright (C) 2005-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Exports some POSIX constants and functions that are not exported in fptools by default. -} module System.Posix.Consts where import safe System.Posix.Types ( FileMode ) blockSpecialMode :: FileMode blockSpecialMode = 0o0060000 characterSpecialMode :: FileMode characterSpecialMode = 0o0020000 namedPipeMode :: FileMode namedPipeMode = 0o0010000 regularFileMode :: FileMode regularFileMode = 0o0100000 directoryMode :: FileMode directoryMode = 0o0040000 fileTypeModes :: FileMode fileTypeModes = 0o00170000 socketMode :: FileMode socketMode = 0o0140000 symbolicLinkMode :: FileMode symbolicLinkMode = 0o0120000 MissingH-1.6.0.1/src/System/Time/0000755000000000000000000000000007346545000014540 5ustar0000000000000000MissingH-1.6.0.1/src/System/Time/Utils.hs0000644000000000000000000001153307346545000016177 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Time utilities main file Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : System.Time.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable This module provides various Haskell utilities for dealing with times and dates. Written by John Goerzen, jgoerzen\@complete.org -} module System.Time.Utils( timelocal, timegm, timeDiffToSecs, epoch, epochToClockTime, clockTimeToEpoch, renderSecs, renderTD ) where import safe Data.Ratio ( (%) ) import safe System.Time ( diffClockTimes, normalizeTimeDiff, toCalendarTime, toClockTime, CalendarTime(..), ClockTime(..), Day(Thursday), Month(January), TimeDiff(TimeDiff, tdSec, tdMin, tdHour, tdDay, tdMonth, tdYear) ) {- | January 1, 1970, midnight, UTC, represented as a CalendarTime. -} epoch :: CalendarTime epoch = CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 1, ctHour = 0, ctMin = 0, ctSec = 0, ctPicosec = 0, ctWDay = Thursday, ctYDay = 0, ctTZName = "UTC", ctTZ = 0, ctIsDST = False} {- | Converts the specified CalendarTime (see System.Time) to seconds-since-epoch time. This conversion does respect the timezone specified on the input object. If you want a conversion from UTC, specify ctTZ = 0 and ctIsDST = False. When called like that, the behavior is equivolent to the GNU C function timegm(). Unlike the C library, Haskell's CalendarTime supports timezone information, so if such information is specified, it will impact the result. -} timegm :: CalendarTime -> Integer timegm ct = timeDiffToSecs (diffClockTimes (toClockTime ct) (toClockTime epoch)) {- | Converts the specified CalendarTime (see System.Time) to seconds-since-epoch format. The input CalendarTime is assumed to be the time as given in your local timezone. All timezone and DST fields in the object are ignored. This behavior is equivolent to the timelocal() and mktime() functions that C programmers are accustomed to. Please note that the behavior for this function during the hour immediately before or after a DST switchover may produce a result with a different hour than you expect. -} timelocal :: CalendarTime -> IO Integer timelocal ct = do guessct <- toCalendarTime guesscl let newct = ct {ctTZ = ctTZ guessct} return $ timegm newct where guesscl = toClockTime ct {- | Converts the given timeDiff to the number of seconds it represents. Uses the same algorithm as normalizeTimeDiff in GHC. -} timeDiffToSecs :: TimeDiff -> Integer timeDiffToSecs td = (fromIntegral $ tdSec td) + 60 * ((fromIntegral $ tdMin td) + 60 * ((fromIntegral $ tdHour td) + 24 * ((fromIntegral $ tdDay td) + 30 * ((fromIntegral $ tdMonth td) + 365 * (fromIntegral $ tdYear td))))) {- | Converts an Epoch time represented with an arbitrary Real to a ClockTime. This input could be a CTime from Foreign.C.Types or an EpochTime from System.Posix.Types. -} epochToClockTime :: Real a => a -> ClockTime epochToClockTime x = TOD seconds secfrac where ratval = toRational x seconds = floor ratval secfrac = floor $ (ratval - (seconds % 1) ) * picosecondfactor picosecondfactor = 10 ^ (12 :: Integer) {- | Converts a ClockTime to something represented with an arbitrary Real. The result could be treated as a CTime from Foreign.C.Types or EpochTime from System.Posix.Types. The inverse of 'epochToClockTime'. Fractions of a second are not preserved by this function. -} clockTimeToEpoch :: Num a => ClockTime -> a clockTimeToEpoch (TOD sec _) = fromInteger sec {- | Render a number of seconds as a human-readable amount. Shows the two most significant places. For instance: >renderSecs 121 = "2m1s" See also 'renderTD' for a function that works on a TimeDiff. -} renderSecs :: Integer -> String renderSecs i = renderTD $ diffClockTimes (TOD i 0) (TOD 0 0) {- | Like 'renderSecs', but takes a TimeDiff instead of an integer second count. -} renderTD :: TimeDiff -> String renderTD itd = case workinglist of [] -> "0s" _ -> concat . map (\(q, s) -> show q ++ [s]) $ workinglist where td = normalizeTimeDiff itd suffixlist = "yMdhms" quantlist = (\(TimeDiff y mo d h m s _) -> [y, mo, d, h, m, s]) td zippedlist = zip quantlist suffixlist -- Drop all leading elements that are 0, then take at most 2 workinglist = take 2 . dropWhile (\(q, _) -> q == 0) $ zippedlist MissingH-1.6.0.1/src/Text/ParserCombinators/Parsec/0000755000000000000000000000000007346545000020154 5ustar0000000000000000MissingH-1.6.0.1/src/Text/ParserCombinators/Parsec/Utils.hs0000644000000000000000000000712107346545000021611 0ustar0000000000000000{-# LANGUAGE Safe #-} {- arch-tag: Parsec utilities Copyright (c) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {- | Module : Text.ParserCombinators.Parsec.Utils Copyright : Copyright (C) 2004-2011 John Goerzen SPDX-License-Identifier: BSD-3-Clause Stability : stable Portability: portable Written by John Goerzen, jgoerzen\@complete.org -} module Text.ParserCombinators.Parsec.Utils(-- * Generalized Utilities -- | These functions are generalized versions of -- ones you might see in the Char parser. GeneralizedToken, GeneralizedTokenParser, togtok, tokeng, satisfyg, oneOfg, noneOfg, specificg, allg, -- * Other Utilities notMatching ) where import safe Text.ParserCombinators.Parsec ( (), (<|>), getPosition, many, token, unexpected, try, SourcePos, GenParser ) type GeneralizedToken a = (SourcePos, a) type GeneralizedTokenParser a st b = GenParser (GeneralizedToken a) st b {- | Generate (return) a 'GeneralizedToken'. -} togtok :: a -> GenParser b st (GeneralizedToken a) togtok tok = do x <- getPosition return (x, tok) {- | Retrieve the next token from a 'GeneralizedToken' stream. The given function should return the value to use, or Nothing to cause an error. -} tokeng :: (Show a) => (a -> Maybe b) -> GeneralizedTokenParser a st b tokeng test = token (show . snd) (fst) (test . snd) {- | A shortcut to 'tokeng'; the test here is just a function that returns a Bool. If the result is true; return that value -- otherwise, an error. -} satisfyg :: (Show a) => (a -> Bool) -> GeneralizedTokenParser a st a satisfyg test = tokeng (\t -> if test t then Just t else Nothing) {- | Matches one item in a list and returns it. -} oneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a oneOfg i = satisfyg (\x -> elem x i) {- | Matches all items and returns them -} allg :: (Show a) => GeneralizedTokenParser a st [a] allg = many $ satisfyg (\_ -> True) {- | Matches one item not in a list and returns it. -} noneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a noneOfg l = satisfyg (\x -> not (elem x l)) {- | Matches one specific token and returns it. -} specificg :: (Eq a, Show a) => a -> GeneralizedTokenParser a st a specificg i = satisfyg (== i) show i {- Matches a list of tokens and returns it. -} {- listg :: (Eq a, Show a) => [GeneralizedToken a] -> GeneralizedTokenParser a st [GeneralizedToken a] listg l = tokens (show . map fst) nextpos l where tokpos = fst nextpos nextposs _ _ (tok:toks) = tokpos tok nextposs _ tok [] = tokpos tok nextpos pos x = nextposs pos [x] -} {- | Running @notMatching p msg@ will try to apply parser p. If it fails, returns (). If it succeds, cause a failure and raise the given error message. It will not consume input in either case. -} notMatching :: GenParser a b c -> String -> GenParser a b () notMatching p errormsg = let maybeRead = try (do x <- p return (Just x) ) <|> return Nothing workerFunc = do x <- maybeRead case x of Nothing -> return () Just _ -> unexpected errormsg in try workerFunc MissingH-1.6.0.1/testsrc/0000755000000000000000000000000007346545000013256 5ustar0000000000000000MissingH-1.6.0.1/testsrc/Bitstest.hs0000644000000000000000000000214007346545000015410 0ustar0000000000000000{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Bitstest(tests) where import Test.HUnit import Data.Bits.Utils import Data.Word test_fromBytes = let f :: [Word32] -> Word32 -> Test f inp exp = TestCase $ exp @=? fromBytes inp in [ f [] 0 ,f [0] 0 ,f [1] 1 ,f [0xff, 0] 0xff00 ,f [0x0, 0xff] 0xff ,f [0x12, 0x34, 0x56, 0x78] 0x12345678 ,f [0xff, 0xff, 0xff, 0xff] 0xffffffff ,f [0xff, 0, 0, 0] 0xff000000 ] test_getBytes = let f :: Word32 -> [Word32] -> Test f inp exp = TestCase $ exp @=? getBytes inp in [ f 0 [0, 0, 0, 0] ,f 0x1200 [0, 0, 0x12, 0] ,f 0x0012 [0, 0, 0, 0x12] ,f 0xffffffff [0xff, 0xff, 0xff, 0xff] ,f 0x12345678 [0x12, 0x34, 0x56, 0x78] ,f 0xf0000000 [0xf0, 0, 0, 0] ] tests = TestList [TestLabel "getBytes" (TestList test_getBytes), TestLabel "fromBytes" (TestList test_fromBytes) ] MissingH-1.6.0.1/testsrc/CRC32GZIPtest.hs0000644000000000000000000000130407346545000015756 0ustar0000000000000000{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module CRC32GZIPtest(tests) where import Test.HUnit import Data.Hash.CRC32.GZip test_crcgzip = let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp (calc_crc32 inp) in [f "Simple" "Test 1" 0x9927f819 ,f "Empty" "" 0x0 --f "Empty" "" 4294967295, --f "1" "1" 433426081, --f "some numbers" "153141341309874102987412" 2083856642, --f "Some text" "This is a test of the crc32 thing\n" 2449124888 ] tests = TestList [TestLabel "crcgzip" (TestList test_crcgzip) ] MissingH-1.6.0.1/testsrc/Eithertest.hs0000644000000000000000000000260507346545000015735 0ustar0000000000000000{- arch-tag: Data.Either.Utils tests Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} {-# LANGUAGE CPP #-} module Eithertest(tests) where import Control.Exception #if !MIN_VERSION_base(4,7,0) import Control.Exception.ErrorCall.EqInstance #endif import Data.Either.Utils import Test.HUnit import TestUtils test_maybeToEither = let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp inp in [ f "Nothing" (maybeToEither "error" (Nothing::Maybe String)) (Left "error"), f "Nothing diff types" (maybeToEither "error" (Nothing::Maybe Int)) (Left "error"), f "Just" (maybeToEither "error" (Just "good")) (Right "good"), f "Diff types" (maybeToEither "error" (Just (5::Int))) (Right (5::Int)) ] test_forceEither = let f msg inp exp = TestLabel msg $ TestCase $ assertEqual "" exp inp in [ f "Right" (forceEither ((Right "foo")::Either Int String)) "foo", TestLabel "Left" $ TestCase $ assertRaises ((== "\"wrong\"") . errorCallMsg) ("" @=? forceEither (Left "wrong")) ] tests = TestList [TestLabel "test_maybeToEither" (TestList test_maybeToEither), TestLabel "test_forceEither" (TestList test_forceEither) ] MissingH-1.6.0.1/testsrc/GZiptest.hs0000644000000000000000000000551607346545000015372 0ustar0000000000000000{- arch-tag: Tests for GZip module Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module GZiptest(tests) where import Test.HUnit import System.FileArchive.GZip import System.FilePath import Data.Compression.Inflate import System.IO.Binary import System.IO import Data.Either.Utils import Data.List mf fn exp conf = TestLabel fn $ TestCase $ do c <- readBinaryFile $ joinPath ["testsrc", "gzfiles", fn] assertEqual "" exp (conf c) {- import System.FileArchive.GZip import System.IO import Data.Either.Utils main = do c <- hGetContents stdin let x = snd . forceEither . read_header $ c putStr x test_bunches = let f fn exp conv = mf fn exp (conv . snd . forceEither . read_header) f2 c = let fn = "t/z" ++ (show c) ++ ".gz" in f fn c (length . inflate_string) in map f2 [0..1000] -} test_inflate = let f fn exp conv = mf fn exp (conv . snd . forceEither . read_header) in [ f "t1.gz" "Test 1" inflate_string ,f "t1.gz" 6 (length . inflate_string) ,f "t1.gz" ("Test 1", "\x19\xf8\x27\x99\x06\x00\x00\x00") inflate_string_remainder ,f "empty.gz" "" inflate_string --,f "zeros.gz" 10485760 (length . inflate_string) -- BAD BAD ,f "zeros.gz" (replicate (10 * 1048576) '\0') inflate_string -- This line tests Igloo's code: --,f "zeros.gz" True (\x -> (replicate 10485760 '\0') == inflate_string x) ] test_header = let f fn exp = mf fn exp (fst . forceEither . read_header) in [ f "t1.gz" Header {method = 8, flags = 0, extra = Nothing, filename = Nothing, comment = Nothing, mtime = 1102111446, xfl = 2, os = 3} ,f "empty.gz" Header {method = 8, flags = 8, extra = Nothing, filename = Just "empty", comment = Nothing, mtime = 1102127257, xfl = 0, os = 3} ] test_gunzip = let f fn exp = mf fn exp decompress in [ f "t1.gz" ("Test 1", Nothing) ,f "t1bad.gz" ("Test 1", Just CRCError) ,f "t2.gz" ("Test 1Test 2", Nothing) -- The following tests my code {- ,mf "zeros.gz" True (\x -> case decompress x of (y, _) -> y == replicate 10485760 '\0' ) -} ] tests = TestList [TestLabel "inflate" (TestList test_inflate), TestLabel "header" (TestList test_header), -- TestLabel "bunches" (TestList test_bunches), TestLabel "gunzip" (TestList test_gunzip) ] MissingH-1.6.0.1/testsrc/Globtest.hs0000644000000000000000000000722107346545000015377 0ustar0000000000000000{-# LANGUAGE CPP #-} {- Copyright (C) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Globtest(tests) where import Test.HUnit import System.Path.Glob import System.Path import TestUtils import System.IO.HVFS import System.Directory(createDirectory) #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) import System.Posix.Directory hiding (createDirectory) import System.Posix.Files #endif import Control.Exception import Data.List import System.FilePath (pathSeparator) sep = map (\c -> if c == '/' then pathSeparator else c) bp = "testtmp" touch x = writeFile (sep x) "" globtest thetest = bracket_ (setupfs) (recursiveRemove SystemFS bp) thetest where setupfs = do mapM_ (\x -> createDirectory (sep x)) [bp, bp ++ "/a", bp ++ "/aab", bp ++ "/aaa", bp ++ "/ZZZ", bp ++ "/a/bcd", bp ++ "/a/bcd/efg"] mapM_ touch [bp ++ "/a/D", bp ++ "/aab/F", bp ++ "/aaa/zzzF", bp ++ "/a/bcd/EF", bp ++ "/a/bcd/efg/ha", bp ++ "/a/foo", bp ++ "/a/afoo", bp ++ "/a/a-foo", bp ++ "/a/a.foo"] #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) createSymbolicLink (preppath "broken") (preppath "sym1") createSymbolicLink (preppath "broken") (preppath "sym2") #endif eq msg exp res = assertEqual msg (sort exp) (sort res) mf msg func = TestLabel msg $ TestCase $ globtest func f func = TestCase $ globtest func preppath x = sep (bp ++ "/" ++ x) test_literal = map f [glob (preppath "a") >>= eq "" [preppath "a"] ,glob (preppath "a/D") >>= eq "" [preppath "a/D"] ,glob (preppath "aab") >>= eq "" [preppath "aab"] ,glob (preppath "nonexistant") >>= eq "empty" [] ] test_one_dir = map f [glob (preppath "a*") >>= eq "a*" (map preppath ["a", "aab", "aaa"]), glob (preppath "*a") >>= eq "*a" (map preppath ["a", "aaa"]), glob (preppath "aa?") >>= eq "aa?" (map preppath ["aaa", "aab"]), glob (preppath "aa[ab]") >>= eq "aa[ab]" (map preppath ["aaa", "aab"]), glob (preppath "*q") >>= eq "*q" [] ] test_nested_dir = map f [glob (preppath "a/bcd/E*") >>= eq "a/bcd/E*" [preppath "a/bcd/EF"], glob (preppath "a/bcd/*g") >>= eq "a/bcd/*g" [preppath "a/bcd/efg"], glob (preppath "a/*.foo") >>= eq "a/*.foo" [preppath "a/a.foo"] ] test_dirnames = map f [glob (preppath "*/D") >>= eq "*/D" [preppath "a/D"], glob (preppath "*/*a") >>= eq "*/*a" [], glob (preppath "a/*/*/*a") >>= eq "a/*/*/*a" [preppath "a/bcd/efg/ha"], glob (preppath "?a?/*F") >>= eq "?a?/*F" (map preppath ["aaa/zzzF", "aab/F"]) ] test_brokensymlinks = #if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) map f [glob (preppath "sym*") >>= eq "sym*" (map preppath ["sym1", "sym2"]), glob (preppath "sym1") >>= eq "sym1" [preppath "sym1"], glob (preppath "sym2") >>= eq "sym2" [preppath "sym2"] ] #else [] #endif tests = TestList [TestLabel "test_literal" (TestList test_literal), TestLabel "test_one_dir" (TestList test_one_dir), TestLabel "test_nested_dir" (TestList test_nested_dir), TestLabel "test_dirnames" (TestList test_dirnames), TestLabel "test_brokensymlinks" (TestList test_brokensymlinks)] MissingH-1.6.0.1/testsrc/HVFStest.hs0000644000000000000000000001076407346545000015270 0ustar0000000000000000{- arch-tag: HVFS tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module HVFStest(tests) where import Test.HUnit import System.IO.HVIO import System.IO.HVFS import System.IO.HVFS.InstanceHelpers import System.IO.HVFS.Combinators import TestUtils import System.IO import System.IO.Error import Control.Exception import System.FilePath (pathSeparator) sep = map (\c -> if c == '/' then pathSeparator else c) ioeq :: (Show a, Eq a) => a -> IO a -> Assertion ioeq exp inp = do x <- inp exp @=? x testTree = [("test.txt", MemoryFile "line1\nline2\n"), ("file2.txt", MemoryFile "line3\nline4\n"), ("emptydir", MemoryDirectory []), ("dir1", MemoryDirectory [("file3.txt", MemoryFile "line5\n"), ("test.txt", MemoryFile "subdir test"), ("dir2", MemoryDirectory []) ] ) ] test_nice_slice = let f exp fp' = TestLabel fp $ TestCase $ exp @=? nice_slice fp where fp = sep fp' in [ f [] "/" ,f ["foo", "bar"] "/foo/bar" --,f [] "." ] test_content = let f exp fp' = TestLabel fp $ TestCase $ do x <- newMemoryVFS testTree h <- vOpen x fp ReadMode case h of HVFSOpenEncap h2 -> exp `ioeq` vGetContents h2 where fp = sep fp' in [ f "line1\nline2\n" "test.txt", f "line1\nline2\n" "/test.txt", f "line5\n" "dir1/file3.txt", f "subdir test" "/dir1/test.txt" ] test_chroot = let f msg testfunc = TestLabel msg $ TestCase $ do x <- newMemoryVFS testTree vSetCurrentDirectory x (sep "/emptydir") y <- newHVFSChroot x (sep "/dir1") testfunc y in [ f "root" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x (sep "/")) ,f "cwd" (\x -> sep "/" `ioeq` vGetCurrentDirectory x) ,f "dir2" (\x -> [] `ioeq` vGetDirectoryContents x (sep "/dir2")) ,f "dot" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x ".") ,f "cwd tests" $ (\x -> do a <- vGetDirectoryContents x (sep "/") ["file3.txt", "test.txt", "dir2"] @=? a vSetCurrentDirectory x (sep "/dir2") cwd <- vGetCurrentDirectory x sep "/dir2" @=? cwd y <- vGetDirectoryContents x "." [] @=? y vSetCurrentDirectory x ".." sep "/" `ioeq` vGetCurrentDirectory x --vSetCurrentDirectory x ".." --"/" `ioeq` vGetCurrentDirectory x ) --,f "test.txt" (\x -> "subdir test" `ioeq` -- (vOpen x "/test.txt" ReadMode >>= vGetContents)) ] test_structure = let f msg testfunc = TestLabel msg $ TestCase $ do x <- newMemoryVFS testTree testfunc x in [ f "root" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"] `ioeq` vGetDirectoryContents x (sep ("/"))) ,f "dot" (\x -> ["test.txt", "file2.txt", "emptydir", "dir1"] `ioeq` vGetDirectoryContents x ".") ,f "dot2" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` do vSetCurrentDirectory x (sep "./dir1") vGetDirectoryContents x ".") ,f "emptydir" (\x -> [] `ioeq` vGetDirectoryContents x (sep "/emptydir")) ,f "dir1" (\x -> ["file3.txt", "test.txt", "dir2"] `ioeq` vGetDirectoryContents x "/dir1") ,f (sep "dir1/dir2") (\x -> [] `ioeq` vGetDirectoryContents x (sep "/dir1/dir2")) ,f "relative tests" (\x -> do vSetCurrentDirectory x "dir1" [] `ioeq` vGetDirectoryContents x "dir2" ) ] tests = TestList [TestLabel "nice_slice" (TestList test_nice_slice) ,TestLabel "structure" (TestList test_structure) ,TestLabel "content" (TestList test_content) ,TestLabel "chroot" (TestList test_chroot) ] MissingH-1.6.0.1/testsrc/HVIOtest.hs0000644000000000000000000000625707346545000015271 0ustar0000000000000000{- arch-tag: HVIO tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module HVIOtest(tests) where import Control.Exception import System.IO import System.IO.Error import System.IO.HVIO import Test.HUnit import TestUtils ioeq :: (Show a, Eq a) => a -> IO a -> Assertion ioeq exp inp = do x <- inp exp @=? x test_MemoryBuffer = let f inp testfunc = TestLabel inp $ TestCase $ do x <- newMemoryBuffer inp mbDefaultCloseFunc testfunc x in [ f "" (\x -> do True `ioeq` vIsOpen x assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) vPutStrLn x "Line1" vPutStrLn x "Line2" vRewind x "Line1" `ioeq` vGetLine x "Line2" `ioeq` vGetLine x 12 `ioeq` vTell x vSeek x AbsoluteSeek 1 "ine1" `ioeq` vGetLine x vSeek x RelativeSeek (-3) "e1" `ioeq` vGetLine x vSeek x SeekFromEnd (-3) "e2" `ioeq` vGetLine x vSeek x AbsoluteSeek 1 vPutStr x "IN" vRewind x "LINe1" `ioeq` vGetLine x "Line2" `ioeq` vGetLine x vSeek x SeekFromEnd 0 vPutChar x 'c' assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) vRewind x "LINe1\nLine2\nc" `ioeq` vGetContents x ) ] test_StreamReader = let f inp testfunc = TestLabel inp $ TestCase $ do x <- newStreamReader inp testfunc x in [ f "" (\x -> do True `ioeq` vIsEOF x True `ioeq` vIsOpen x assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetChar x) vClose x False `ioeq` vIsOpen x ) ,f "abcd" (\x -> do False `ioeq` vIsEOF x True `ioeq` vIsOpen x 'a' `ioeq` vGetChar x "bcd" `ioeq` vGetContents x vClose x ) ,f "line1\nline2\n\n\nline5\nlastline" (\x -> do False `ioeq` vIsEOF x "line1" `ioeq` vGetLine x "line2" `ioeq` vGetLine x "" `ioeq` vGetLine x "" `ioeq` vGetLine x "line5" `ioeq` vGetLine x "lastline" `ioeq` vGetLine x assertRaises (== mkIOError eofErrorType "" Nothing Nothing) (vGetLine x) ) ] tests = TestList [TestLabel "streamReader" (TestList test_StreamReader), TestLabel "MemoryBuffer" (TestList test_MemoryBuffer) ] MissingH-1.6.0.1/testsrc/IOtest.hs0000644000000000000000000000034307346545000015021 0ustar0000000000000000{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module IOtest() where import Test.HUnit import System.IO import TestUtils MissingH-1.6.0.1/testsrc/Listtest.hs0000644000000000000000000002021207346545000015422 0ustar0000000000000000{- arch-tag: List tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Listtest(tests) where import Data.List import Data.List.Utils import Test.HUnit import Test.HUnit -- import Test.QuickCheck as QC test_delFromAL = let f :: [(String, Int)] -> [(String, Int)] -> Test f inp exp = TestCase $ exp @=? (delFromAL inp "testkey") in [ f [] [] ,f [("one", 1)] [("one", 1)] ,f [("1", 1), ("2", 2), ("testkey", 3)] [("1", 1), ("2", 2)] ,f [("testkey", 1)] [] ,f [("testkey", 1), ("testkey", 2)] [] ,f [("testkey", 1), ("2", 2), ("3", 3)] [("2", 2), ("3", 3)] ,f [("testkey", 1), ("2", 2), ("testkey", 3), ("4", 4)] [("2", 2), ("4", 4)] ] test_addToAL = let f :: [(String, Int)] -> [(String, Int)] -> Test f inp exp = TestCase $ exp @=? (addToAL inp "testkey" 101) in [ f [] [("testkey", 101)] ,f [("testkey", 5)] [("testkey", 101)] ,f [("testkey", 5), ("testkey", 6)] [("testkey", 101)] ] test_split = let f delim inp exp = TestCase $ exp @=? split delim inp in [ f "," "foo,bar,,baz," ["foo", "bar", "", "baz", ""] ,f "ba" ",foo,bar,,baz," [",foo,","r,,","z,"] ,f "," "" [] ,f "," "," ["", ""] ] test_join = let f :: (Eq a, Show a) => [a] -> [[a]] -> [a] -> Test f delim inp exp = TestCase $ exp @=? join delim inp in [ f "|" ["foo", "bar", "baz"] "foo|bar|baz" ,f "|" [] "" ,f "|" ["foo"] "foo" -- f 5 [[1, 2], [3, 4]] [1, 2, 5, 3, 4] ] test_replace = let f old new inp exp = TestCase $ exp @=? replace old new inp in [ f "" "" "" "" ,f "foo" "bar" "" "" ,f "foo" "bar" "foo" "bar" ,f "foo" "bar" "footestfoothisisabarfoo" "bartestbarthisisabarbar" ,f "," ", " "1,2,3,4" "1, 2, 3, 4" ,f "," "." "1,2,3,4" "1.2.3.4" ] test_genericJoin = let f delim inp exp = TestCase $ exp @=? genericJoin delim inp in [ f ", " [1, 2, 3, 4] "1, 2, 3, 4" ,f ", " ([] :: [Int]) "" ,f "|" ["foo", "bar", "baz"] "\"foo\"|\"bar\"|\"baz\"" ,f ", " [5] "5" ] test_flipAL = let f inp exp = TestCase $ exp @=? flipAL inp in [ f ([]::[(Int,Int)]) ([]::[(Int,[Int])]) ,f [("a", "b")] [("b", ["a"])] ,f [("a", "b"), ("c", "b"), ("d", "e"), ("b", "b")] [("b", ["b", "c", "a"]), ("e", ["d"])] ] test_uniq = let f inp exp = TestCase $ exp @=? uniq inp in [f ([]::[Int]) [], f "asdf" "asdf", f "aabbcc" "abc", f "abcabc" "abc", f "aaaaaa" "a", f "aaaaaab" "ab", f "111111111111111" "1", f "baaaaaaaaa" "ba", f "baaaaaaaaab" "ba", f "aaacccdbbbefff" "acdbef", f "foo" "fo", f "15553344409" "153409", f "Mississippi" "Misp"] test_trunc = let f len inp exp = TestCase $ exp @=? take len inp in [ f 2 "Hello" "He" ,f 1 "Hello" "H" ,f 0 "Hello" "" ,f 2 "H" "H" ,f 2 "" "" ,f 2 [1, 2, 3, 4, 5] [1, 2] ,f 10 "Hello" "Hello" ,f 0 "" "" ] test_contains = let f msg sub testlist exp = TestCase $ assertEqual msg exp (contains sub testlist) in [ f "t1" "Haskell" "I really like Haskell." True ,f "t2" "" "Foo" True ,f "t3" "" "" True ,f "t4" "Hello" "" False ,f "t5" "Haskell" "Haskell" True ,f "t6" "Haskell" "1Haskell" True ,f "t7" "Haskell" "Haskell1" True ,f "t8" "Haskell" "Ocaml" False ,f "t9" "Haskell" "OCamlasfasfasdfasfd" False ,f "t10" "a" "Hello" False ,f "t11" "e" "Hello" True ] test_elemRIndex = let f item inp exp = TestCase $ exp @=? elemRIndex item inp in [ f "foo" [] Nothing ,f "foo" ["bar", "baz"] Nothing ,f "foo" ["foo"] (Just 0) ,f "foo" ["foo", "bar"] (Just 0) ,f "foo" ["bar", "foo"] (Just 1) ,f "foo" ["foo", "bar", "foo", "bar", "foo"] (Just 4) ,f 'f' ['f', 'b', 'f', 'f', 'b'] (Just 3) ,f 'f' ['b', 'b', 'f'] (Just 2) ] test_alwaysElemRIndex = let f item inp exp = TestCase $ exp @=? alwaysElemRIndex item inp in [ f "foo" [] (-1) ,f 'f' ['b', 'q'] (-1) ,f 'f' ['f', 'b', 'f', 'f', 'b'] 3 ] test_subIndex = let f item inp exp = TestCase $ exp @=? subIndex item inp in [f "foo" "asdfoobar" (Just 3) ,f "foo" [] (Nothing) ,f "" [] (Just 0) ,f "" "asdf" (Just 0) ,f "test" "asdftestbartest" (Just 4) ,f [(1::Int), 2] [0, 5, 3, 2, 1, 2, 4] (Just 4) ] test_fixedWidth = let f inplen inplist exp = TestLabel ((show inplen) ++ ", " ++ (show inplist)) $ TestCase $ wholeMap (fixedWidth inplen) inplist @=? exp in [ f [] ([]::[Int]) ([]::[[Int]]) ,f [1] [5] [[5]] ,f [1] [3, 4, 5, 6] [[3], [4, 5, 6]] ,f [1] ([]::[Int]) ([]::[[Int]]) ,f [2] [3] [[3]] ,f [2] [3, 4, 5, 6] [[3, 4], [5, 6]] ,f [2] [3, 4, 5] [[3, 4], [5]] ,f [1, 2, 3] "1234567890" ["1","23","456","7890"] ,f (repeat 2) "123456789" ["12","34","56","78","9"] ,f [] "123456789" ["123456789"] ,f [5, 3, 6, 1] "Hello, This is a test." ["Hello",", T","his is"," ","a test."] ] test_strToAL = let f inp exp = TestLabel (show inp) $ TestCase $ do let r = strFromAL inp exp @=? r inp @=? strToAL r in [ f ([]::[(String, String)]) "" ,f [("foo", "bar")] "\"foo\",\"bar\"\n" ,f [("foo", "bar"), ("baz", "quux")] "\"foo\",\"bar\"\n\"baz\",\"quux\"\n" ,f [(1::Int, 2::Int), (3, 4)] "1,2\n3,4\n" ,f [(1::Int, "one"), (2, "two")] "1,\"one\"\n2,\"two\"\n" ,f [("one", 1::Double), ("n\nl", 2::Double)] "\"one\",1.0\n\"n\\nl\",2.0\n" ] test_spanList = let f func inp exp = TestLabel (show inp) $ TestCase $ exp @=? spanList func inp in [f (contains "foo") "Testfoobar" ("Testf", "oobar"), f (\_ -> True) "Testasdf" ("Testasdf", ""), f (\_ -> False) "Testasdf" ("", "Testasdf"), f (contains "foo") "" ("", ""), f (contains "foo") "foo" ("f", "oo")] -- test_merge = -- qctest "prop_merge" prop_merge prop_merge xs ys = merge (sort xs) (sort ys) == sort (xs ++ ys) where types = xs :: [Int] -- test_mergeBy = -- qctest "test_mergeBy" prop_mergeBy prop_mergeBy xs ys = mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys) where types = xs :: [Int] cmp = compare tests = TestList [-- test_merge, -- test_mergeBy, TestLabel "delFromAL" (TestList test_delFromAL), TestLabel "uniq" (TestList test_uniq), TestLabel "addToAL" (TestList test_addToAL), TestLabel "split" (TestList test_split), TestLabel "join" (TestList test_join), TestLabel "genericJoin" (TestList test_genericJoin), TestLabel "trunc" (TestList test_trunc), TestLabel "flipAL" (TestList test_flipAL), TestLabel "elemRIndex" (TestList test_elemRIndex), TestLabel "alwaysElemRIndex" (TestList test_alwaysElemRIndex), TestLabel "replace" (TestList test_replace), TestLabel "contains" (TestList test_contains), TestLabel "strFromAL & strToAL" (TestList test_strToAL), TestLabel "fixedWidth" (TestList test_fixedWidth), TestLabel "subIndex" (TestList test_subIndex), TestLabel "spanList" (TestList test_spanList)] MissingH-1.6.0.1/testsrc/MIMETypestest.hs0000644000000000000000000000536307346545000016275 0ustar0000000000000000{- arch-tag: MIMETypes tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module MIMETypestest(tests) where import Test.HUnit import Data.List import Data.MIME.Types test_readMIMETypes = let omtd = readMIMETypes defaultmtd True "testsrc/mime.types.test" f = \strict inp exp -> TestCase $ do mtd <- omtd exp @=? guessType mtd strict inp fe = \strict inp exp -> TestCase $ do mtd <- omtd (sort exp) @=? sort (guessAllExtensions mtd strict inp) in [ f True "foo.bar.baz" (Nothing, Nothing) ,f True "" (Nothing, Nothing) ,f True "foo.ez" (Just "application/andrew-inset", Nothing) ,fe True "application/andrew-inset" [".ez"] ,f True "foo.dv" (Just "video/x-dv", Nothing) ,fe True "video/x-dv" [".dif", ".dv"] ,f True "test.h++" (Just "text/x-c++hdr", Nothing) ,fe True "text/x-c++hdr" [".h++", ".hpp", ".hxx", ".hh"] ,f True "foo.tgz" (Just "application/x-tar", Just "gzip") ] test_guessAllExtensions = let f strict inp exp = TestCase $ (sort exp) @=? sort (guessAllExtensions defaultmtd strict inp) in [ f True "" [] ,f True "foo" [] ,f True "application/octet-stream" [".obj", ".so", ".bin", ".a", ".dll", ".exe", ".o"] ,f True "text/plain" [".pl", ".ksh", ".bat", ".c", ".h", ".txt"] ,f True "application/rtf" [] ,f False "application/rtf" [".rtf"] ] test_guessType = let f strict inp exp = TestCase $ exp @=? guessType defaultmtd strict inp in [ f True "" (Nothing, Nothing) ,f True "foo" (Nothing, Nothing) ,f True "foo.txt" (Just "text/plain", Nothing) ,f True "foo.txt.gz" (Just "text/plain", Just "gzip") ,f True "foo.txt.blah" (Nothing, Nothing) ,f True "foo.tar" (Just "application/x-tar", Nothing) ,f True "foo.tar.gz" (Just "application/x-tar", Just "gzip") ,f True "foo.tgz" (Just "application/x-tar", Just "gzip") ,f True "http://foo/test.dir/blah.rtf" (Nothing, Nothing) ,f False "http://foo/test.dir/blah.rtf" (Just "application/rtf", Nothing) ,f True "foo.pict" (Nothing, Nothing) ,f False "foo.pict" (Just "image/pict", Nothing) ] tests = TestList [TestLabel "guessType" (TestList test_guessType), TestLabel "guessAllExtensions" (TestList test_guessAllExtensions), TestLabel "readMIMETypes" (TestList test_readMIMETypes) ] MissingH-1.6.0.1/testsrc/Maptest.hs0000644000000000000000000000211207346545000015223 0ustar0000000000000000{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Maptest(tests) where import Test.HUnit import Data.Map.Utils import Data.Map as M test_flipM = let f inp exp = TestCase $ (M.fromList exp) @=? flipM (M.fromList inp) in [ f ([]::[(Int,Int)]) ([]::[(Int,[Int])]) ,f [("a", "b")] [("b", ["a"])] ,f [("a", "b"), ("c", "b"), ("d", "e"), ("b", "b")] [("b", ["c", "b", "a"]), ("e", ["d"])] ] test_flippedLookupM = let f item inp exp = TestCase $ exp @=? flippedLookupM item (M.fromList inp) in [ f 'a' ([]::[(Char, Char)]) [] ,f 'a' [("Test1", 'a'), ("Test2", 'b')] ["Test1"] ,f 'a' [("Test1", 'b'), ("Test2", 'b')] [] ,f 'a' [("Test1", 'a'), ("Test2", 'a')] ["Test2", "Test1"] ] tests = TestList [TestLabel "flipM" (TestList test_flipM), TestLabel "flippedLookupM" (TestList test_flippedLookupM) ] MissingH-1.6.0.1/testsrc/Pathtest.hs0000644000000000000000000000542107346545000015410 0ustar0000000000000000{- arch-tag: Path tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Pathtest(tests) where import Test.HUnit import System.Path import System.FilePath (pathSeparator) sep = map (\c -> if c == '/' then pathSeparator else c) test_absNormPath = let f base' p' exp' = TestLabel (show (base, p)) $ TestCase $ exp @=? absNormPath base p where base = sep base' p = sep p' exp = fmap sep exp' f2 = f "/usr/1/2" in [ f "/" "" (Just "/") ,f "/usr/test" "" (Just "/usr/test") ,f "/usr/test" ".." (Just "/usr") ,f "/usr/1/2" "/foo/bar" (Just "/foo/bar") ,f2 "jack/./.." (Just "/usr/1/2") ,f2 "jack///../foo" (Just "/usr/1/2/foo") ,f2 "../bar" (Just "/usr/1/bar") ,f2 "../" (Just "/usr/1") ,f2 "../.." (Just "/usr") ,f2 "../../" (Just "/usr") ,f2 "../../.." (Just "/") ,f2 "../../../" (Just "/") ,f2 "../../../.." Nothing ] test_secureAbsNormPath = let f base' p' exp' = TestLabel (show (base, p)) $ TestCase $ exp @=? secureAbsNormPath base p where base = sep base' p = sep p' exp = fmap sep exp' f2 = f "/usr/1/2" in [ f "/" "" (Just "/") ,f "/usr/test" "" (Just "/usr/test") ,f "/usr/test" ".." Nothing ,f "/usr/1/2" "/foo/bar" Nothing ,f "/usr/1/2" "/usr/1/2" (Just "/usr/1/2") ,f "/usr/1/2" "/usr/1/2/foo/bar" (Just "/usr/1/2/foo/bar") ,f2 "jack/./.." (Just "/usr/1/2") ,f2 "jack///../foo" (Just "/usr/1/2/foo") ,f2 "../bar" Nothing ,f2 "../" Nothing ,f2 "../.." Nothing ,f2 "../../" Nothing ,f2 "../../.." Nothing ,f2 "../../../" Nothing ,f2 "../../../.." Nothing ] test_splitExt = let f inp' exp' = TestCase $ exp @=? splitExt inp where inp = sep inp' exp = (\(x,y) -> (sep x, y)) exp' in [ f "" ("", "") ,f "/usr/local" ("/usr/local", "") ,f "../foo.txt" ("../foo", ".txt") ,f "../bar.txt.gz" ("../bar.txt", ".gz") ,f "foo.txt/bar" ("foo.txt/bar", "") ,f "foo.txt/bar.bz" ("foo.txt/bar", ".bz") ] tests = TestList [TestLabel "splitExt" (TestList test_splitExt) ,TestLabel "absNormPath" (TestList test_absNormPath) ,TestLabel "secureAbsNormPath" (TestList test_secureAbsNormPath) ] MissingH-1.6.0.1/testsrc/ProgressTrackertest.hs0000644000000000000000000001024007346545000017627 0ustar0000000000000000{- Copyright (C) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module ProgressTrackertest(tests) where import Data.Progress.Tracker import Test.HUnit import Control.Concurrent.MVar setup = do timem <- newMVar 0 let timesource = readMVar timem po <- newProgress' (ProgressStatus 0 100 0 "" timesource) [] return (po, timem) settime timem newval = swapMVar timem newval >> return () test_incrP = do (po, timem) <- setup incrP po 5 withStatus po $ \s -> do assertEqual "completedUnits" 5 (completedUnits s) assertEqual "totalUnits" 100 (totalUnits s) incrP po 95 withStatus po $ \s -> do assertEqual "completedUnits" 100 (completedUnits s) assertEqual "totalUnits" 100 (totalUnits s) incrP po 5 withStatus po $ \s -> do assertEqual "completedUnits" 105 (completedUnits s) assertEqual "totalUnits" 105 (totalUnits s) incrP' po 5 withStatus po $ \s -> do assertEqual "completedUnits" 110 (completedUnits s) assertEqual "totalUnits" 105 (totalUnits s) incrTotal po 10 withStatus po $ \s -> do 110 @=? completedUnits s 115 @=? totalUnits s test_setP = do (po, timem) <- setup setP po 5 withStatus po $ \s -> do 5 @=? completedUnits s 100 @=? totalUnits s setP po 100 withStatus po $ \s -> do 100 @=? completedUnits s 100 @=? totalUnits s setP po 105 withStatus po $ \s -> do 105 @=? completedUnits s 105 @=? totalUnits s setP' po 110 withStatus po $ \s -> do 110 @=? completedUnits s 105 @=? totalUnits s setTotal po 115 withStatus po $ \s -> do 110 @=? completedUnits s 115 @=? totalUnits s test_speed = do (po, timem) <- setup getSpeed po >>= assertEqual "initial speed" 0 getETR po >>= assertEqual "initial ETR" 0 getETA po >>= assertEqual "initial ETA" 0 incrP po 10 getSpeed po >>= assertEqual "speed after incr" 0 getETR po >>= assertEqual "ETR after incr" 0 getETA po >>= assertEqual "ETA after incr" 0 settime timem 5 getSpeed po >>= assertEqual "first speed" 2.0 getETR po >>= assertEqual "first ETR" 45 getETA po >>= assertEqual "first ETA" 50 incrP po 90 getSpeed po >>= assertEqual "speed 2" 20.0 getETR po >>= assertEqual "etr 2" 0 getETA po >>= assertEqual "eta 2" 5 settime timem 400 setP po 90 getSpeed po >>= assertEqual "speed 3" 0.225 getETR po >>= assertEqual "etr 2" 44 getETA po >>= assertEqual "eta 2" 444 test_callback = do (po, _) <- setup mcounter <- newMVar (0::Int) mcounter1 <- newMVar (0::Int) mcounter2 <- newMVar (0::Int) (po2, _) <- setup (po3, _) <- setup addCallback po (minc mcounter) addParent po po2 incrP po 5 readMVar mcounter >>= assertEqual "cb1" 1 withStatus po (\x -> 5 @=? completedUnits x) withStatus po2 (\x -> do 5 @=? completedUnits x 200 @=? totalUnits x) addCallback po2 (minc mcounter2) incrP po 100 readMVar mcounter2 >>= (\x -> assertBool "cb2" (0 /= x)) withStatus po2 (\x -> do 105 @=? completedUnits x 205 @=? totalUnits x) incrP' po 5 withStatus po2 (\x -> do 110 @=? completedUnits x 205 @=? totalUnits x) finishP po withStatus po2 (\x -> do 110 @=? completedUnits x 210 @=? totalUnits x) where minc mv _ _ = modifyMVar_ mv (\x -> return $ x + 1) tests = TestList [TestLabel "incrP" (TestCase test_incrP), TestLabel "setP" (TestCase test_setP), TestLabel "speed" (TestCase test_speed), TestLabel "test_callback" (TestCase test_callback)] MissingH-1.6.0.1/testsrc/Str/0000755000000000000000000000000007346545000014026 5ustar0000000000000000MissingH-1.6.0.1/testsrc/Str/CSVtest.hs0000644000000000000000000000201107346545000015707 0ustar0000000000000000{- arch-tag: CSV tests main file Copyright (C) 2005-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Str.CSVtest(tests) where import Test.HUnit import Data.CSV import Text.ParserCombinators.Parsec test_csv = let f inp exp = TestLabel inp $ TestCase $ exp @=? case parse csvFile "" inp of Right x -> Right x Left y -> Left (show y) in [ f "" (Right []), f "\n" (Right [[""]]), f "1,2,3\n" (Right [["1", "2", "3"]]), f "This is a,Test,Really\n" (Right [["This is a", "Test", "Really"]]), f "l1\nl2\n" (Right [["l1"], ["l2"]]), f "NQ,\"Quoted\"\n" (Right [["NQ", "Quoted"]]), f "1Q,\"\"\"\"\n" (Right [["1Q", "\""]]), f ",\"\"\n" (Right [["", ""]]), f "\"Embedded\"\"Quote\"\n" (Right [["Embedded\"Quote"]]) ] tests = TestList [TestLabel "csv" (TestList test_csv)] MissingH-1.6.0.1/testsrc/Strtest.hs0000644000000000000000000000422307346545000015263 0ustar0000000000000000{- arch-tag: Str tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Strtest(tests) where import Test.HUnit import Data.String.Utils import TestUtils import Text.Regex import Data.Char test_lstrip = mapassertEqual "lstrip" lstrip [("", ""), ("a", "a"), (" a ", "a "), (" abas", "abas"), ("\n\t fdsa", "fdsa"), ("abc def", "abc def")] test_rstrip = mapassertEqual "rstrip" rstrip [("", ""), ("a", "a"), (" a ", " a"), ("abas ", "abas"), ("fdsa \n\t", "fdsa"), ("abc def", "abc def")] test_strip = mapassertEqual "strip" strip [("", ""), ("a", "a"), (" a ", "a"), ("abas ", "abas"), (" abas", "abas"), ("asdf\n\t ", "asdf"), ("\nbas", "bas"), ("abc def", "abc def")] test_splitWs = let f exp inp = TestCase $ exp @=? splitWs inp in [ f [] " ", f [] "", f ["asdf"] " asdf\n", f ["one", "two", "three"] " one\ntwo \tthree \n" ] test_escapeRe = map (\i -> TestLabel (show $ chr i) $ TestCase $ assertEqual [chr i] (Just []) (matchRegex (mkRegex $ escapeRe $ [chr i]) [chr i])) [1..127] ++ [TestCase $ assertEqual "big string" (Just ([], teststr, [], [])) (matchRegexAll (mkRegex $ escapeRe teststr) teststr) ] where teststr = map chr [1..127] tests = TestList [TestLabel "lstrip" (TestList test_lstrip), TestLabel "rstrip" $ TestList test_rstrip, TestLabel "strip" $ TestList test_strip, TestLabel "splitWs" $ TestList test_splitWs, TestLabel "escapeRe" $ TestList test_escapeRe ] MissingH-1.6.0.1/testsrc/TestUtils.hs0000644000000000000000000000235107346545000015553 0ustar0000000000000000{-# LANGUAGE CPP #-} module TestUtils (mapassertEqual, assertRaises, errorCallMsg) where import Control.Exception (ErrorCall (..), Exception, Handler (Handler), SomeException, catches) import Test.HUnit (Assertion, Test (TestCase), assertEqual, assertFailure) mapassertEqual :: (Show b, Eq b) => String -> (a -> b) -> [(a, b)] -> [Test] mapassertEqual label f xs = [ TestCase $ assertEqual label result (f inp) | (inp,result) <- xs ] assertRaises :: (Exception e, Show e) => (e -> Bool) -> IO a -> Assertion assertRaises check act = do res <- go `catches` [ Handler check', Handler anyEx ] res where go = act >> return (assertFailure "action completed without exception") check' ex | check ex = return (return ()) | otherwise = return (assertFailure ("got exception of expected type *but* wrong value: " ++ show ex)) anyEx :: SomeException -> IO (Assertion) anyEx ex = return (assertFailure ("got unexpected exception type: " ++ show ex)) errorCallMsg :: ErrorCall -> String errorCallMsg (ErrorCall msg) = msg #if MIN_VERSION_base(4,9,0) errorCallMsg (ErrorCallWithLocation msg _) = msg #endif MissingH-1.6.0.1/testsrc/Tests.hs0000644000000000000000000000314507346545000014717 0ustar0000000000000000{- arch-tag: Tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Tests(tests) where import Test.HUnit import qualified MIMETypestest import qualified Listtest import qualified Maptest import qualified Pathtest import qualified Strtest import qualified IOtest import qualified Bitstest import qualified Eithertest import qualified CRC32GZIPtest import qualified GZiptest import qualified HVIOtest import qualified HVFStest import qualified Timetest import qualified Str.CSVtest import qualified WildMatchtest import qualified Globtest import qualified ProgressTrackertest test1 = TestCase ("x" @=? "x") tests = TestList [TestLabel "test1" test1, TestLabel "List" Listtest.tests, TestLabel "Str" Strtest.tests, TestLabel "CSV" Str.CSVtest.tests, TestLabel "Time" Timetest.tests, TestLabel "Map" Maptest.tests, TestLabel "ProgressTracker" ProgressTrackertest.tests, TestLabel "Path" Pathtest.tests, TestLabel "WildMatch" WildMatchtest.tests, TestLabel "HVIO" HVIOtest.tests, TestLabel "HVFS" HVFStest.tests, TestLabel "Glob" Globtest.tests, TestLabel "MIMETypes" MIMETypestest.tests, TestLabel "Bitstest" Bitstest.tests, TestLabel "Eithertest" Eithertest.tests, TestLabel "CRC32GZIPtest" CRC32GZIPtest.tests, TestLabel "GZiptest" GZiptest.tests] MissingH-1.6.0.1/testsrc/Timetest.hs0000644000000000000000000000270407346545000015413 0ustar0000000000000000{- arch-tag: Time tests main file Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Timetest(tests) where import Test.HUnit import System.Time.Utils import System.Time base =CalendarTime {ctYear = 2005, ctMonth = January, ctDay = 21, ctHour = 1, ctMin = 1, ctSec = 20, ctPicosec = 0, ctWDay = Sunday, ctYDay = 0, ctTZName = "", ctTZ = 0, ctIsDST = False} test_ctu2e = let f base exp = TestLabel (show base) $ TestCase $ exp @=? timegm base in [ f (base {ctYear = 2005, ctMonth = January, ctDay = 21, ctHour = 1, ctMin = 1, ctSec = 20}) 1106269280 ,f (base {ctYear = 2004, ctMonth = July, ctDay = 1, ctHour = 17, ctMin = 0, ctSec = 0}) 1088701200 ] test_ct2e = let f base exp = TestLabel (show base) $ TestCase $ do r <- timelocal base exp @=? r in [ f (base {ctYear = 2005, ctMonth = January, ctDay = 20, ctHour = 19, ctMin = 1, ctSec = 20}) 1106269280 ,f (base {ctYear = 2004, ctMonth = July, ctDay = 1, ctHour = 12, ctMin = 0, ctSec = 0}) 1088701200 ] tests = TestList [TestLabel "ctu2e" (TestList test_ctu2e)] MissingH-1.6.0.1/testsrc/WildMatchtest.hs0000644000000000000000000000172507346545000016373 0ustar0000000000000000{- Copyright (C) 2006-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module WildMatchtest(tests) where import Test.HUnit import System.Path.WildMatch import TestUtils test_wildCheckCase = let f patt name = TestCase $ assertBool (patt ++ "," ++ name ++ " was false") (wildCheckCase patt name) f0 patt name = TestCase $ assertBool (patt ++ "," ++ name ++ " was true") (not $ wildCheckCase patt name) in [f "asdf" "asdf", f "?*?" "abc", f "???*" "asd", f "*???" "asd", f "???" "asd", f "*" "asd", f "ab[cd]" "abc", f "ab[!de]" "abc", f0 "ab[de]" "abc", f0 "??" "a", f0 "a" "b", f "[\\]" "\\", f "[!\\]" "a", f0 "[!\\]" "\\", f0 "*.deb" "thedebianthing", f0 "a/*.foo" "testtmp/a/D"] tests = TestList [TestLabel "wildCheckCase" (TestList test_wildCheckCase)] MissingH-1.6.0.1/testsrc/gzfiles/0000755000000000000000000000000007346545000014721 5ustar0000000000000000MissingH-1.6.0.1/testsrc/gzfiles/empty.gz0000644000000000000000000000003207346545000016414 0ustar0000000000000000 AemptyMissingH-1.6.0.1/testsrc/gzfiles/t1.gz0000644000000000000000000000003207346545000015602 0ustar0000000000000000A I-.Q0'MissingH-1.6.0.1/testsrc/gzfiles/t1bad.gz0000644000000000000000000000003207346545000016251 0ustar0000000000000000A I-.Q0'MissingH-1.6.0.1/testsrc/gzfiles/t2.gz0000644000000000000000000000006707346545000015613 0ustar0000000000000000A I-.Q0'AAt2 I-.Q0.MissingH-1.6.0.1/testsrc/gzfiles/zeros.gz0000644000000000000000000002374607346545000016441 0ustar0000000000000000#Azeros ۃCA_; *ʞMissingH-1.6.0.1/testsrc/mime.types.test0000644000000000000000000000071707346545000016256 0ustar0000000000000000# arch-tag: test file for MIMETypes # Here are some comments # ## # and some fun blank lines # Some types with nothing application/activemessage application/applefile application/atomicmail # comment here # Some lines with real stuff application/andrew-inset ez # blah # Some lines with multiple things video/x-dv dif dv text/x-c++hdr h++ hpp hxx hh # foo MissingH-1.6.0.1/testsrc/runtests.hs0000644000000000000000000000034307346545000015501 0ustar0000000000000000{- Copyright (C) 2004-2011 John Goerzen All rights reserved. For license and copyright information, see the file LICENSE -} module Main where import Test.HUnit import Tests main = runTestTT tests