diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,504 @@ + 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! + + diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,24 @@ +CFLAGS = -XScopedTypeVariables + +default :: lib + +lib :: + cabal configure + cabal build + cabal haddock + cabal install + +dist/build/libHShsshellscript-3.0.0.a :: + cabal build + +dist :: + cabal sdist + +install-manual :: + mkdir -p /usr/local/share/hsshellscript/manual + cp -rv manual/* /usr/local/share/hsshellscript/manual + rm -f /usr/local/share/hsshellscript/manual/*~ + +uninstall-manual :: + rm -rf /usr/local/share/hsshellscript/manual + rmdir --ignore-fail-on-non-empty /usr/local/share/hsshellscript diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,13 @@ +This is HsShellScript, a library which enables you to use Haskell for tasks which +are typically done by shell scripts. It requires the Glasgow Haskell Compiler. + +The installation instructions are in the user manual. It is located in the "manual" +subdirectory. + +HsShellScript is released under the terms of the GNU Lesser General Public License +(LGPL), version 2.1, or any later version. A copy of the license in included in +the user manual. + +The homepage is at http://www.volker-wysk.de/hsshellscript. + +Volker Wysk diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsshellscript.cabal b/hsshellscript.cabal new file mode 100644 --- /dev/null +++ b/hsshellscript.cabal @@ -0,0 +1,48 @@ +Name: hsshellscript +Version: 3.1.0 +Synopsis: Haskell for Unix shell scripting tasks +Description: A Haskell-library for tasks which are usually done in + shell scripts. This includes parsing command line + arguments; dealing with paths; some commands for dealing + with files; calling external programs and subroutines as + separate processes; pipes and redirection of input and + output; and error handling. +Homepage: http://www.volker-wysk.de/hsshellscript/ +License: LGPL +License-file: LICENSE +Author: Volker Wysk +Maintainer: hsss@volker-wysk.de +Copyright: (c)2004-2011 by Volker Wysk +Category: System +Build-type: Simple +Extra-source-files: README, manual/*.html, manual/LICENSE, Makefile + +cabal-version: >= 1.6 + + +Library + Exposed-Modules: HsShellScript, + HsShellScript.Args + HsShellScript.Commands + HsShellScript.GetOpt + HsShellScript.Misc + HsShellScript.Paths + HsShellScript.ProcErr + HsShellScript.Shell + Extensions: DeriveDataTypeable, + ForeignFunctionInterface, + RecordWildCards, + ScopedTypeVariables, + NamedFieldPuns + Build-depends: base >= 3 && < 6, + unix >= 2.3.2, + directory, + parsec >= 2.1.0.1, + random + hs-source-dirs: src + C-Sources: src/cbits/hsshellscript.c + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + Build-tools: c2hs >= 0.15.1 + + diff --git a/manual/LICENSE b/manual/LICENSE new file mode 100644 --- /dev/null +++ b/manual/LICENSE @@ -0,0 +1,504 @@ + 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! + + diff --git a/manual/features.html b/manual/features.html new file mode 100644 --- /dev/null +++ b/manual/features.html @@ -0,0 +1,51 @@ + + + + + + + + + + +

HsShellScript Features

+ +

Command Line Argument Parser

+ HsShellScript has facilities for managing command line arguments, which are + easier to use than the GHC library GetOpt. Command line + arguments are specified as lists of properties. HsShellScript builds on top + of GHC's GetOpt, but hides it completely. Command line arguments handling + has been added because GetOpt was found to be too cumbersome.

+

Easy Interface to External Programs

+ Calling programs and recognizing errors (via exitcode or exception) is made more easy. There are front end functions for common programs, such as + /bin/mv or /bin/chmod.

+

Analyzing Paths

+ Dealing with paths is not as trivial as it sounds. Take, for example + ../foo.bar//./../baz/ (and split off the extension of the file + name...). HsShellScript solves this thoroughly and provides functions for such + tasks as splitting a path in directory and file name parts, splitting a path + into path components, or syntactically normalising paths.

+

Redirecting Input and Output

+ HsShellScript defines operators like ->- and ->>- which work like + redirection operators in shells.

+

Building Pipes

+ Reading the output of an external program, or piping the output of one + program into the input of another, is almost as easy as in shells. + HsShellScript provides corresponding operators.

+

Error Handling

+ Error handling is one thing which is done more thoroughly in + HsShellScript than in shells. Failed programs won't be silently ignored. + Exceptions are used for error handling. Non zero exit codes + are thrown as exceptions.

+

Quoting of Strings and Building Commands for Shells

+ Taking care of shell metacharacters usually isn't done right. HsShellScript + provides functions for doing it safely.

+

Non-broken, Secure Functions for Creating Temporary Files and Directories

+ The standard C library has mkstemp, mktemp, tempnam, tmpfile and tmpnam, which are all broken, + non-portable or unsuitable in some way.

+ + +

+HsShellScript User Manual main page

+ + diff --git a/manual/imports.html b/manual/imports.html new file mode 100644 --- /dev/null +++ b/manual/imports.html @@ -0,0 +1,27 @@ + + + + + + + +

GHC-Libraries needed for HsShellScript

+ +

In order to use HsShellScript's exception handling, you'll have to import +some and restrict some GHC-libraries (all of which are included in GHC). The +following source code will to the trick: + + +
+
import Prelude hiding (catch) +
import IO hiding (catch) +
import Control.Exception +
import HsShellScript + + + +

+HsShellScript User Manual main page

+ + + diff --git a/manual/index.html b/manual/index.html new file mode 100644 --- /dev/null +++ b/manual/index.html @@ -0,0 +1,28 @@ + + + + + HsShellScript User Manual + + +

HsShellScript User Manual

+ +

This is the user manual for the HsShellScript +Haskell shell scripting library, version 3.1.0. It has been released 2012-04-02. The API +documentation is in a separate document.

+

HsShellScript is a library which makes things easy to program in +Haskell, which are typically done by shell scripts on Unix-like +systems. You can use Haskell for writing your shell scripts.

+

Of course your Haskell scripts can grow to become real programs. It's all ready. + +

Features +
Requirements +
Installation +
Usage +
Necessary import declarations +
License

+ +

+Last changed 2012-04-02

+ + diff --git a/manual/install.html b/manual/install.html new file mode 100644 --- /dev/null +++ b/manual/install.html @@ -0,0 +1,41 @@ + + + + + + + + + + +

Building and Installing HsShellScript

+ +

HsShellScript is cabalized, which means that building and installing is a + matter of some calls to cabal. However, it also provides a + Makefile, which further simplifies the installation. + +

In order to install, unpack the source distribution somewhere. Go to the + directory, and call make. This will compile and install the library, + locally, as a user package. The location of the API documentation + is ~/.cabal/share/doc/hsshellscript-3.1.0/html/index.html. + +

Cabal's Simple Build Infrastructure doesn't provide any means to add extra + documenation to a project. Therefore the user manual isn't installed by default. + If you need it, you can just copy the "manual" directory anywhere you like, + but the Makefile privides + the make target install-manual, which copies the files to + /usr/local/share/hsshellscript/manual. + "make" must be run as root. + + +

Further information about the Cabal can be found here: +The Haskell Cabal + + +

HsShellScript User Manual main + page

+ + diff --git a/manual/requirements.html b/manual/requirements.html new file mode 100644 --- /dev/null +++ b/manual/requirements.html @@ -0,0 +1,38 @@ + + + + + + + + + + + +

Requirements

+ +

Requirements for using and for building +

    +

  • The Glasgow Haskell + Compiler. It works with GHC-7.4.1, and + should also work with later versions. It might work with GHC-7.2, but does + not work with GHC-7.0.4 or older. +

  • A Unix like system. HsShellScript is being developed and tested on Linux.

    +
+ +

Requirements only for building +

    +

  • GNU make

    +

  • The interface generator C2HS

    +

  • Haddock for the API documentation

    +
+

GHC and Haddock are included in + the The Haskell Platform, + c2hs isn't. + + +

+HsShellScript User Manual main page

+ + + diff --git a/manual/usage.html b/manual/usage.html new file mode 100644 --- /dev/null +++ b/manual/usage.html @@ -0,0 +1,26 @@ + + + + + + + + + + + +

Usage

+ +

HsShellScript registers itself in GHC's package management system during installation. Therefore all you need is to add +"-package hsshellscript" to the command line when compiling and linking.

+ +

+HsShellScript User Manual main page

+ + + diff --git a/src/HsShellScript.hs b/src/HsShellScript.hs new file mode 100644 --- /dev/null +++ b/src/HsShellScript.hs @@ -0,0 +1,302 @@ +-- HsShellScript main module +module HsShellScript ( + -- * Command Line Arguments + -- Command line arguments are handled by the module "HsShellScript.Args", which is reexported by "HsShellScript". + module HsShellScript.Args, + + -- * Paths and Directories + mkdir, rmdir, pwd, cd, realpath, realpath_s, path_exists, path_exists', is_file, is_dir, with_wd, + -- ** Parsing and Composing Paths + module HsShellScript.Paths, + + -- * Symbolic Links + is_symlink, symlink, readlink, readlink', + + -- * Manipulating Files + rm, chmod, chown, cp, mv, + HsShellScript.Commands.rename, rename_mv, force_rename, force_mv, force_rename_mv, force_cmd, force_writeable, force_writeable2, + getFileStatus', fileAccess', setFileMode', + + -- * Interfaces to Some Specific External Commands + mt_status, fdupes, du, + + -- * Calling External Programs + + -- ** Running a Subroutine in a Separate Process + -- $subr + + -- ** About the @exec@ Functions + -- $exec + + -- ** Functions for Forking Child Processes and Calling External Programs + subproc, + spawn, + runprog, RunError(..), show_runerror, to_ioe, as_ioe, + exec, execp, exece, execpe, + echo, silently, + system_runprog, system_throw, execute_file, + child, + explain_processstatus, + call, run, + + -- * Redirecting Input and Output + (->-), (->>-), (=>-), (=>>-), (-<-), + (-&>-), (-&>>-), + err_to_out, out_to_err, + + -- * Pipes + + -- ** File Descriptors in Pipes + -- $fdpipes + + -- ** Pipe Creation Functions + (-|-), (=|-), (-|=), (=|=), + redirect, + pipe_to, h_pipe_to, + pipe_from, lazy_pipe_from, h_pipe_from, + pipe_from2, lazy_pipe_from2, h_pipe_from2, + pipes, + + -- * Shell-like Quoting + module HsShellScript.Shell, + + -- * Creating temporary files and directories + tmp_file, tmp_dir, temp_file, temp_dir, temp_path, with_tmp_file, with_tmp_dir, with_temp_file, with_temp_dir, + + -- * Reading mount information + Mntent(..), read_mounts, read_mtab, read_fstab, + + -- * Output to the standard stream, colorful logging and error reporting + outm, outm_, logm, logm_, errm, errm_, + isatty, + + -- * Miscellaneous + zeros, chomp, lazy_contents, contents, glob, + + -- * Error Handling + mainwrapper, errno, + strerror, + perror', + perror, + {-abort, _exit,-} + HsShellScript.ProcErr.failIO, + exitcode, + throwErrno', + show_ioerror, + fill_in_filename, fill_in_location, add_location + ) +where + +-- import IO +-- import List +-- import Maybe +-- import Monad +-- import Random +-- import System +import Control.Exception +import GHC.IO +import HsShellScript.Args +import HsShellScript.Commands +import HsShellScript.Misc +import HsShellScript.Paths +import HsShellScript.ProcErr +import HsShellScript.Shell +import Prelude hiding (catch) +import System.Console.GetOpt +import System.Directory +import System.Exit +import System.Posix + + +{- | Error reporting wrapper for the @main@ function. This catches any + HsShellScript generated exceptions, and @IOError@s, prints + an error message and exits with @exitFailure@. The @main@ function + typically looks like this: + + >main = mainwrapper $ do ... + + The exceptions caught are 'ArgError', 'RunError', 'ProcessStatus' and @IOError@. +-} +mainwrapper :: IO a -- ^ Should be @main@ + -> IO a -- ^ Wrapped @main@ +mainwrapper io = + io + `catches` [ Handler $ \(argerror :: ArgError) -> + do errm (argerror_message argerror) + putStrLn $ "\n" ++ (argerror_usageinfo argerror) + exitFailure + , Handler $ \(processstatus :: ProcessStatus) -> + do errm $ "Process error. process status = " ++ show ( processstatus :: ProcessStatus ) + exitFailure + , Handler $ \(runerror :: RunError) -> + do errm (show_runerror runerror) + exitFailure + , Handler $ \(ioe :: IOError) -> + do errm (show_ioerror ioe) + exitFailure + ] + +{- $fdpipes + #fdpipes# + + With HsShellScript, you build pipes from IO actions, which can replace + themselves with an external program via a variant of @exec@. It's mostly + transparent whether some part of the pipe is a subroutine of the main + program, or an external program. + + But actually, there are two cases. When the forked process is a subroutine, + the child's @stdin@ handle is connected to the parent. On the other hand, + when the forked process consists of calling an @exec@ variant, that program's + file descriptor 0 is to be connected to the parent process. + + Normally, @stdin@ connects exactly to file descriptor 0, but this isn't + necessarily the case. For instance, when @stdin@ has been closed, the file + descriptor will be reused on the next occasion. When it is reopened again + by calling @GHC.Handle.hDuplicateTo h stdin@, then the new @stdin@ + will be using a different file descriptor, and file descriptor 0 will be in + use by another handle. Thus, when forking a subroutine, we're connected via + @stdin@, but we can't expect to be connected via file descriptor 0. + + In case the child process is to be replaced with another program, we need to + make sure that right file descriptor connects to the parent process. This is + accomplished by the @exec@ functions. They replace the standard file + descriptors with the ones that the standard handles currently use. See + "HsShellScript#exec" for details. + + These two examples work as expected. + + Example 1: + +>-- This closes stdin. +>c <- contents "-" +> +>pipe_to something +> ( -- execp arranges for "something" to go to foo's file descriptor 0 +> execp "foo" [] +> +> -|- (do -- Read foo's standard output from new stdin handle +> c' <- lazy_contents "-" +> ... +> ) +> ) + + Example 2: + +>-- Call wc to count the number of lines in txt +>count <- fmap (read . chomp) $ +> pipe_from (putStr txt -|= execp "wc" ["-l"]) + +-} + + +{- $subr + #subr# + + It can by very useful to fork a child process, which executes a subroutine of + the main program. In the following example, paths are piped to the @recode@ + program in order to convert them from ISO 8859-1 to UTF-8. Its output is read + by a subroutine of the main program, which can use it to rename the files. + +>main = mainwrapper $ do +> paths <- contents "-" +> pipe_to paths $ +> ( execp "recode" ["-f", "latin1..utf8"] +> -|= (do paths_utf8 <- lazy_contents "-" +> mapM_ (\(path, path_utf8) -> +> ... +> ) +> (zip (lines paths) (lines paths_utf8)) +> ) +> ) + + The same could be achieved this way: + +>main = mainwrapper $ do +> paths <- contents "-" +> paths_utf8 <- +> pipe_from ( putStr paths +> -|= execp "recode" ["-f", "latin1..utf8"] +> ) +> mapM_ (\(path, path_utf8) -> +> ... +> ) +> (zip (lines paths) (lines paths_utf8)) + + Most of the time, it's intuitive. But sometimes, the forked subroutine + interferes with the parent process. + + When the process clones itself by calling @fork(2)@, everything gets + duplicated - open files, database connections, window system connections... + This becomes an issue when the child process uses any of it. For instance, + any buffered, not yet written data associated with a file handle gets + duplicated. When the child process uses that handle, that data gets written + twice. + + The functions which fork a child process ('call', 'spawn', 'silently', + 'pipe_to' etc.) flush @stdout@ and @stderr@ (should be unbuffered) before the + fork. So the child process can use them. The pipe functions also take care of + @stdin@, which is used to read from the pipe. But they don't know about any + other handles. + + What happens when the subroutine finishes? The control flow would escape into + the main program, doing unexpected things. Therefore the functions which fork + an IO action terminate the child process when the subroutine finishes. They + do so by calling '_exit', circumventing normal program shutdown. Normal + shutdown would flush cloned file handles, shut down database connections now + shared with the parent process etc. Only the @stdout@ and @stderr@ are + flushed before. If the child process requires any more cleanup on + termination, such as flushing new file handles created in the child process, + it's the responsibility of the programmer to do so before the subroutine + exits. + + When the subroutine throws an exception, the control flow isn't allowed to + escape into the main program either. Any exception is caught, an error + message is printed, and the child process is terminated with @_exit 1@. + + The subroutine /must not/ terminate the child process normally, by calling + @exitWith@ or @exitFailure@. It should terminate with '_exit'. Don't forget + to flush @stdout@ before, which won't be line buffered when not connected to + a terminal. It can also just leave the subroutine. The functions which fork + child processes intercept any attempt of normal program shutdown in the child + process (it's an @ExitException@, see the GHC library documentation). A + warning message is printed, and the child is terminated with @_exit@, with + the same exit code which it would have been. +-} + + +{- $exec + #exec# + + There are five @exec@ variants: 'exec', 'execp', 'exece', 'execpe' and + 'execute_file'. The first four are frontends to @execute_file@. They + differ in whether the @PATH@ is searched, and in whether a new environment is + installed. The latter is a replacement for + @System.Posix.Process.executeFile@. They are designed to work intuitively in + conjunction with the functions which fork a child process, such as 'run', + 'call', 'spawn', 'pipe_to' etc. + + Before replacing the process, @stdout@ and @stderr@ are flushed, so no yet + unwritten data is lost. Then the file descriptors of the process are prepared + for the exec, such that everything works as expected. The standard file + descriptors 0-2 are made to correspond to the standard handles again (this + might have changed, see "HsShellScript#exec"). They are also reset to + blocking mode. All others are closed when the exec succeeds. + + /You can't use/ @executeFile@ /directly, unless you take care of the things + outlined at/ "HsShellScript#exec" /and/ 'execute_file' /by yourself./ + + If replacing the process fails (for instance, because the program wasn't + found), then everything is restored to original state, and an @IOError@ is + thrown, and the process continues with normal error handling. Normally, the + @exec@ functions are used in conjunction with some of the functions which + fork a child process. They also handle errors, so the forked action doesn't + need to cope with failure of @exec@. The error handling and + termination is done via the 'child' function. + + Sometimes you want to pass an open file descriptor to the program. In this + case, you can't use the @exec@ variants. You need to call @executeFile@ + directly, and take care of the outlined matters by yourself. In this + case, take a look at the source code of @execute_file@. + + For full details, see the documentation of 'execute_file'. +-} diff --git a/src/HsShellScript/Args.hs b/src/HsShellScript/Args.hs new file mode 100644 --- /dev/null +++ b/src/HsShellScript/Args.hs @@ -0,0 +1,978 @@ +-- | +-- This module provides a more convient way of parsing command line +-- arguments than the GHC GetOpt package. It makes use of GetOpt, but hides +-- it from the user. It is reexported from module HsShellScript. +-- +-- For each command line argument, a description is to be created with +-- @argdesc@. Then the command line arguments are evaluated with +-- one of the @getargs@... functions. In case of an error, this will cause a +-- exception, which provides an expressive error message to be +-- printed. Then the @arg@... functions are used to extract the +-- values contained in the arguments, with the right type. The typical use +-- of HsShellScript.Args looks something like this: +-- +-- >import HsShellScript +-- > +-- >main = +-- > do let a_onevalue = argdesc [ desc_at_most_once, ... ] +-- > a_values = argdesc [ desc_direct, ... ] +-- > a_switch = argdesc [ ... ] +-- > ... +-- > header = "mclapep - My Command Line Argument Parser Example Program, version 1.0.0" +-- > +-- > args <- getargs header [a_onevalue, a_values, a_switch, ...] +-- > +-- > val <- optarg_req a_onevalue args -- val :: Maybe String +-- > vals <- args_req a_values args -- vals :: [String] +-- > doit <- arg_switch a_switch args -- doit :: Bool +-- > ... +-- > `catch` +-- > (\argerror -> do +-- > hPutStrLn stderr $ (argerror_message argerror) ++ "\n\n" ++ (argerror_usageinfo argerror) +-- > exitFailure +-- > ) +-- +-- Errors in the argument descriptions are regarded as bugs, and handled +-- by aborting the program with a message which is meaningful to the +-- programmer. It is assumed that the argument description is a constant for +-- a given program. +-- +-- Errors in the arguments are reported using HsShellScript's error handling +-- scheme. An error description +-- value is generated, and either returned via an @Either@ +-- value, or thrown as an exception. + +module HsShellScript.Args ( -- ** Argument Properties + ArgumentProperty + , ArgumentDescription (..) + , ArgumentValueSpec (..) + , Argtester + , argdesc + , desc_short + , desc_long + , desc_direct + , desc_value_required + , desc_value_optional + , desc_times + , desc_once + , desc_at_least_once + , desc_at_most_once + , desc_any_times + , desc_at_least + , desc_at_most + , desc_argname + , desc_description + , desc_tester + , desc_integer + , desc_nonneg_integer + , readtester + -- ** Evaluating the Command Line + , Arguments + , getargs + , getargs_ordered + , getargs' + , getargs_ordered' + , unsafe_getargs + , unsafe_getargs_ordered + -- ** Extracting the Argument Values + , arg_switch + , arg_times + , args_opt + , args_req + , reqarg_opt + , reqarg_req + , optarg_opt + , optarg_req + , arg_occurs + -- ** Placing additional Constraints on the Arguments + , args_none + , args_all + , args_one + , args_at_most_one + , args_at_least_one + , arg_conflicts + -- ** Argument Error Reporting + , ArgError (..) + , usage_info + , argname + , argname_a + ) where + +-- We use a fixed copy of GHC's GetOpt implementation. This is to work around a bug. +-- import System.Console.GetOpt +import HsShellScript.GetOpt + +import Control.Monad +import Control.Exception +import Prelude hiding (catch) +import Data.Maybe +import System.Environment +import Data.List +import GHC.IO +import System.IO +import HsShellScript.Shell +import Data.Char +import Debug.Trace +import Data.Typeable + + + + +-- | Does the command line argument take an value? +data ArgumentValueSpec = ArgumentValue_none -- ^ No value + | ArgumentValue_required -- ^ Value required + | ArgumentValue_optional -- ^ Value optional + deriving (Eq, Show, Ord) + + +-- | Argument value tester function. This tests the format of an argument's value for errors. The tester function is specified by +-- 'desc_tester' or such, as part of the argument description. +-- +-- The tester is passed the argument value. If the format is correct, then it returns @Nothing@. If there is an error, then it returns @Just msgf@, +-- with @msgf@ being an error message generation function. This function gets passed the argument description, and produces the error +-- message. The argument description typically is used to extract a descriptive name of the argument (using 'argname' or 'argname_a') to be included +-- in the error message. +type Argtester = String -- Argument value to be tested + -> Maybe (ArgumentDescription -- Argument description for message generation + -> String -- Error message + ) + + +-- | Description of one command line argument. These are generated by +-- @argdesc@ from a list of argument properties, and subsequently used by one of the +-- @getargs@... functions. This type is abstract. +data ArgumentDescription = ArgumentDescription { + argdesc_short_args :: [Char], -- ^ Short option names + argdesc_long_args :: [String], -- ^ Long option names + argdesc_argarg :: ArgumentValueSpec, -- ^ What about a possible value of the argument? + argdesc_times :: Maybe (Int,Int), -- ^ Minimum and maximum of number of occurences allowed + argdesc_argargname :: Maybe String, -- ^ Name for argument's value, for message generation + argdesc_argarg_description :: Maybe String, -- ^ Descrition of the argument, for message generation + argdesc_argarg_tester :: Maybe Argtester -- ^ Argument value tester + } + +-- excluding tester +ad_tup ad = + (argdesc_short_args ad, argdesc_long_args ad, argdesc_argarg ad, argdesc_times ad, argdesc_argargname ad, argdesc_argarg_description ad) + +instance Eq ArgumentDescription where + d == e = ad_tup d == ad_tup e + +instance Ord ArgumentDescription where + compare d e = compare (ad_tup d) (ad_tup e) + +-- value for maximum number of times +unlimited = -1 + +-- Whether two argument descriptions describe the same argument. +-- Every short or long argument name occurs in only one argument +-- descriptor (this is checked). Every argument has a short or a long +-- name (short = [], long = [""] for direct arguments). +same_arg :: ArgumentDescription -> ArgumentDescription -> Bool +same_arg arg1 arg2 = + case (argdesc_short_args arg1, argdesc_short_args arg2) of + (a:_, b:_) -> a == b + ([], []) -> case (argdesc_long_args arg1, argdesc_long_args arg2) of + ([],_) -> unnamed + (_,[]) -> unnamed + (l1,l2) -> head l1 == head l2 + _ -> False + where unnamed = error "Bug in argument description: nameless, non-direct argument. desc_short or desc_long must be specified." + +-- | A property of a command line argument. These are generated by the +-- @desc_@... functions, and condensed to argument +-- descriptions of type @ArgumentDescription@ by @argdesc@. This type is abstract. +newtype ArgumentProperty = + ArgumentProperty { argumentproperty :: ArgumentDescription -> ArgumentDescription } +-- An argument property is a function which fills in part of an argument descriptor. + + +-- starting value for argument descriptor +nulldesc :: ArgumentDescription +nulldesc = + ArgumentDescription { + argdesc_short_args = [], + argdesc_long_args = [], + argdesc_argarg = ArgumentValue_none, + argdesc_times = Nothing, -- default = (0,1) + argdesc_argargname = Nothing, + argdesc_argarg_description = Nothing, + argdesc_argarg_tester = Nothing + } + +-- default number of times an argument may occur +times_default = (0,1) + + +-- | This represents the parsed contents of the command line. It is returned +-- by the @getargs@... functions, and passed on to the +-- value extraction functions by the user. +-- +-- See 'getargs', 'getargs_ordered', 'getargs\'', 'getargs_ordered\''. +newtype Arguments = + Arguments ( [ ( ArgumentDescription -- argument descriptor + , [Maybe String] -- arguments matching this descriptor + ) + ] + , String -- usage information + ) + +argvalues :: Arguments -> ArgumentDescription -> [Maybe String] +argvalues (Arguments (l,_)) desc = + argvalues' l + where + argvalues' ((d,v):r) = if same_arg desc d then v else argvalues' r + argvalues' [] = abort "Bug using HsShellScript: Value of unknown argument queried (add it to getarg's list)" desc + +-- used internally to represent one occurence of a specific argument +type ArgOcc = (ArgumentDescription, Maybe String) + + +-- | Error thrown when there is an error in the +-- command line arguments. +data ArgError = ArgError { + -- | Error message generated by HsShellScript.Args. + argerror_message :: String, + -- | Usage information derived from the argument descriptions. + argerror_usageinfo :: String + } + deriving (Typeable) + + +-- | +-- Make @ArgError@ an instance of @Exception@, so we can throw and catch it, using GHC-6.10\'s new exception library. +instance Exception ArgError + + +--- +-- Printing an @ArgError@ will produce the error message. The usage +-- information must be printed separately, using @usage_info@. +instance Show ArgError where + show argerror = argerror_message argerror + + +-- Whether it is the description for direct arguments. Direct arguments are +-- the ones without introducing "-" or "--". +is_direct :: ArgumentDescription -> Bool +is_direct desc = + argdesc_short_args desc == [] && argdesc_long_args desc == [""] + + +-- | +-- Short name of the argument. This specifies a character for a +-- one letter style argument, like @-x@. There can be specified +-- several for the same argument. Each argument needs at least +-- either a short or a long name. +desc_short :: Char -- ^ The character to name the argument. + -> ArgumentProperty -- ^ The corresponding argument property. +desc_short c = ArgumentProperty + (\desc -> + if (c `elem` (argdesc_short_args desc)) + then abort ("Bug in HsShellScript argument description: Duplicate short argument " ++ show c ++ " specified") desc + else if ("" `elem` argdesc_long_args desc) + then abort_conflict "" desc + else desc { argdesc_short_args = c : argdesc_short_args desc } + ) + +-- | +-- Long name of the argument. This specifies a GNU style long +-- name for the argument, like @--arg@ or @--arg=...@. There can be specified +-- several names for the same argument. Each argument needs at least +-- either a short or a long name. +desc_long :: String -- ^ The long name of the argument. + -> ArgumentProperty -- ^ The corresponding argument property. +desc_long str = ArgumentProperty + (\desc -> + if (str `elem` (argdesc_long_args desc)) + then abort ("Bug in HsShellScript argument description: Duplicate long argument " ++ show str ++ " specified") desc + else if ("" `elem` argdesc_long_args desc) + then abort_conflict "" desc + else desc { argdesc_long_args = str : argdesc_long_args desc } + ) + +-- | +-- Signal that this is the description of direct arguments. Direct arguments +-- are the ones not introduced by any short or long argument names (like +-- @-x@ or @--arg@), or which occur after the special +-- argument @--@. The presence of @desc_direct@ in the argument properties list +-- signals @argdesc@ that this is the description of the direct +-- arguments. There may be at most one such description. +desc_direct :: ArgumentProperty +desc_direct = ArgumentProperty + (\desc -> + if argdesc_long_args desc == [] && argdesc_short_args desc == [] && argdesc_argarg desc == ArgumentValue_none + then desc { argdesc_long_args = [""], argdesc_argarg = ArgumentValue_required, argdesc_argargname = Just "" } + else abort_conflict "desc_direct conflicts desc_long, desc_short, desc_value_required and desc_value_optional." desc + ) + +-- | +-- Signal that the argument requires a value. +desc_value_required :: ArgumentProperty +desc_value_required = ArgumentProperty + (\desc -> + if argdesc_argarg desc == ArgumentValue_none + then desc { argdesc_argarg = ArgumentValue_required } + else abort_conflict "desc_value_required repeated or conflicting desc_value_optional" desc + ) + +-- | +-- Signal that the argument optionally has a value. The user may or may +-- not specify a value to this argument. +desc_value_optional :: ArgumentProperty +desc_value_optional = ArgumentProperty + (\desc -> + if argdesc_argarg desc == ArgumentValue_none + then desc { argdesc_argarg = ArgumentValue_optional } + else abort_conflict "desc_value_optional repeated or conflicting desc_value_required" desc + ) + +-- | +-- Specify lower and upper bound on the number of times an argument may +-- occur. +desc_times :: Int -- ^ Lower bound of the allowed number of argdesc_times. + -> Int -- ^ Upper bound of the allowed number of argdesc_times. + -> ArgumentProperty -- ^ The corresponding argument property. +desc_times n m = ArgumentProperty + (\desc -> + if argdesc_times desc == Nothing + then desc { argdesc_times = Just (n,m) } + else abort_conflict "desc_times conflicting previous number of occurences specification" desc + ) + +-- | +-- Signal that the argument must be present exactly once. This is +-- meaningful only for arguments which can take a value. +desc_once :: ArgumentProperty -- ^ The corresponding argument property. +desc_once = desc_times 1 1 + +-- | +-- Signal that the argument must occur at least one time. +desc_at_least_once :: ArgumentProperty -- ^ The corresponding argument property. +desc_at_least_once = desc_times 1 unlimited + +-- | +-- Signal that the argument must occur at most one time. +desc_at_most_once :: ArgumentProperty -- ^ The corresponding argument property. +desc_at_most_once = desc_times 0 1 + +-- | +-- Signal that the argument must have at least the specified number of +-- occurences, and has no upper limit of occurences. +desc_at_least :: Int -- ^ Number of times. + -> ArgumentProperty -- ^ The corresponding argument property. +desc_at_least n = desc_times n unlimited + +-- | +-- Signal that the argument may occur any number of times. +desc_any_times :: ArgumentProperty -- ^ The corresponding argument property. +desc_any_times = desc_times 0 unlimited + +-- | +-- Signal that the argument does not need to be present, and may occur at most +-- the specified number of times. +desc_at_most :: Int -- ^ Number of times. + -> ArgumentProperty -- ^ The corresponding argument property. +desc_at_most n = desc_times 0 n + +-- | +-- Specify the descriptive name for command line argument's value. Used for the +-- generation of the usage message. The name should be very short. +desc_argname :: String -- ^ Name of the argument's value. + -> ArgumentProperty -- ^ The corresponding argument property. +desc_argname name = ArgumentProperty + (\desc -> + if argdesc_argargname desc == Nothing + then desc { argdesc_argargname = Just name } + else abort "Bug in HsShellScript argument description: Multiple names specified" desc + ) + +-- | +-- Specify a short description of what the argument does. Used for the +-- generation of the usage message. This is to fit on one line, after the +-- short and long argument names. It should be 40 characters long or so. +desc_description :: String -- ^ Short description of the argument. + -> ArgumentProperty -- ^ The corresponding argument property. +desc_description expl = ArgumentProperty + (\desc -> + if argdesc_argarg_description desc == Nothing + then desc { argdesc_argarg_description = Just expl } + else abort "Bug in HsShellScript argument description: Multiple explanations specified" desc + ) + +-- | Specify a tester for this argument. The tester is a function which tests the argument value for format errors. Typically, it tests whether the +-- value can be parsed to some target type. If the test fails, the tester produces an error message. When parsing the command line arguments (which +-- @getargs@ or related), all the testers are applied to the respective argument values, and an 'ArgError' is thrown in case of failure. By using a +-- tester, it can be ensured that the argument values abide a specific format when extracting them, such that they can be parsed without errors, e.g. +-- @myarg = read (reqarg_req args d_myarg)@. +-- +-- An argument tester is a function of type 'Argtester'. +-- +-- See 'readtester', 'desc_integer', 'desc_nonneg_integer', 'Argtester'. +desc_tester :: Argtester -- ^ Argument tester to apply to this argument + -> ArgumentProperty -- ^ The corresponding argument property. +desc_tester t = ArgumentProperty + (\desc -> + case argdesc_argarg_tester desc of + Nothing -> desc { argdesc_argarg_tester = Just t } + Just _ -> abort "Bug in HsShellScript argument description: Multiple argument value testers specified" desc + ) + + +-- | +-- Build an argument tester from a @reads@ like function. Typically, a specialisation of the standard prelude function @read@ is used. +-- Example: @readtester \"Integer expected.\" (reads :: ReadS Int)@ +readtester :: ReadS a -- Reader function, like the standard prelude function @reads@ + -> String -- Additional message + -> Argtester -- Argument tester to be passed to 'desc_tester' +readtester reader msg val = + case filter ((== "") . snd) $ reader val of + [(_,"")] -> Nothing + [] -> Just (\arg -> "Format error in the value of the " ++ argname_a arg ++ ". " ++ msg ++ "\nValue: " ++ quote val) + _ -> Just (\arg -> "Ambigious value of the " ++ argname_a arg ++ ". " ++ msg ++ "\nValue: " ++ quote val) + + +{- | Specify that the value of this argument, if present, is a positive integer. This will cause an error when the command line is parsed, and the + argument's value doesn't specify an integer. + +>desc_integer = desc_tester (readtester (reads :: ReadS Int) "Integer expected.") + + See 'desc_tester'. +-} +desc_integer :: ArgumentProperty +desc_integer = desc_tester (readtester (reads :: ReadS Int) "Integer expected.") + + +{- | Specify that the value of this argument, if present, is a non-negative integer. This will cause an error when the command line is parsed, and the + value doesn't specify a non-negative integer. + +>desc_nonneg_integer = desc_tester (readtester ((filter (\(a,_) -> a >= 0) . reads) :: ReadS Int) "Non-negative integer expected." ) + + See 'desc_tester'. +-} +desc_nonneg_integer :: ArgumentProperty +desc_nonneg_integer = desc_tester (readtester ((filter (\(a,_) -> a >= 0) . reads) :: ReadS Int) "Non-negative integer expected." ) + + +abort_conflict msg = abort ("Conflicting properties in argument description. " ++ msg) +abort msg desc = error (msg ++ "\nargument (so far): " ++ argname desc) + +-- | Generate a descriptive argument name from an argument description, suitable for use in error messages. This uses the long and short argument names +-- (as specified by 'desc_short' and 'desc_long') and generates descriptive names of the argument like \"-f\", \"-myflag\", \"-f\/--myflag\", etc. All the +-- argument names are included. In case of direct arguments (see 'desc_direct'), the descriptive name is \"@(direct argument)@\". +argname :: ArgumentDescription -> String +argname desc = + if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "(direct argument)" + else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument" + else concat (intersperse "/" ( map (\s -> "-"++[s]) (argdesc_short_args desc) ++ map ("--" ++) (argdesc_long_args desc) )) + +-- | Generate a descriptive argument name from an argument description, beginning with \"argument\". This uses the long and short argument names (as +-- specified by 'desc_short' and 'desc_long') and generates descriptive names of the argument like \"argument -f\", \"argument -myflag\", \"argument +-- -f\/--myflag\", etc. All the argument names are included. In case of direct arguments (see 'desc_direct'), the descriptive name is \"direct argument\". +argname_a :: ArgumentDescription -> String +argname_a desc = + if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "direct argument" + else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument" + else "argument " ++ concat (intersperse "/" ( map (\s -> "-"++[s]) (argdesc_short_args desc) ++ map ("--" ++) (argdesc_long_args desc) )) + +up1 "" = "" +up1 (x:xs) = toUpper x : xs + +-- complete generation of argument description +prop_final :: ArgumentProperty +prop_final = ArgumentProperty + (\desc -> + seq (if argdesc_argarg desc /= ArgumentValue_none && argdesc_argargname desc == Nothing + then error $ "Bug in description of " ++ argname_a desc ++ ": Argument's value must be given a name using desc_argname." + else if argdesc_argarg desc == ArgumentValue_none && argdesc_argargname desc /= Nothing + then error $ "Bug in description of " ++ argname_a desc + ++ ": Argument doesn't take a sub argument, but a name for it is specified." + else () + ) $ + desc { argdesc_times = Just (fromMaybe times_default (argdesc_times desc)) + , argdesc_argarg_description = Just (fromMaybe "" (argdesc_argarg_description desc)) + } + ) + +-- | +-- Make an argument description from a list of argument properties. This +-- condenses the list to an argument description, +-- which can be uses by the @getargs@... functions and the +-- argument value extraction functions. +argdesc :: [ArgumentProperty] -- ^ List of properties, which describe the command line argument. + -> ArgumentDescription -- ^ The corresponding argument description. +argdesc propl = + foldr (.) id (map argumentproperty (prop_final:propl)) nulldesc + + +-- Parse command line arguments. +getargs0 :: String -> ArgOrder ArgOcc -> [String] -> [ArgumentDescription] -> Either ArgError Arguments +getargs0 header ordering cmdlargs descs = + let ( descs_direct -- direct arguments (without argument name) + , descs_regular -- regular arguments (with long or short argument name) + ) = partition is_direct descs + + nonunique :: Eq a => [a] -> Maybe a + nonunique (a:b:r) = if (a == b) then (Just a) else nonunique (b:r) + nonunique _ = Nothing + + test_unique :: (Show a, Ord a) => (ArgumentDescription -> [a]) -> String -> b -> b + test_unique extr what x = + case nonunique (sort (concat (map extr descs))) of + Just y -> error ("Bug: Several occurences of " ++ what ++ " " ++ show y ++ " in command line argument specifications") + Nothing -> x + + optdescr = map make_optdescr descs_regular + + make_optdescr :: ArgumentDescription -> OptDescr ArgOcc + make_optdescr desc = + Option (argdesc_short_args desc) + (argdesc_long_args desc) + (case argdesc_argarg desc of + ArgumentValue_none -> NoArg (desc, Nothing) + ArgumentValue_required -> ReqArg (\arg -> (desc, Just arg)) + (fromJust (argdesc_argargname desc)) + ArgumentValue_optional -> OptArg (\arg -> (desc, arg)) + (fromJust (argdesc_argargname desc)) + ) + (fromJust (argdesc_argarg_description desc)) + + -- Postprocessing after successful call to getOpt + getopt_post :: [ArgOcc] -> [String] -> Either ArgError Arguments + getopt_post pars{-getOpt recognized arguments-} rest{-direct arguments-} = + case (rest, descs_direct) of + ([],[]) -> + -- no direct arguments allowed and none provided + getopt_post' pars + (r, [d]) -> + -- direct arguments allowed and expected + getopt_post' (pars ++ zip (repeat d) (map Just r)) + ((x:xs), []) -> + -- direct arguments provided, but not allowed + Left (ArgError "Surplus arguments." usageinfo) + _ -> + -- several descriptions for direct arguments + error "Bug in argument descriptions: Several descriptions for direct arguments (desc_direct) specified." + + add :: (ArgumentDescription, Maybe String) -> [(ArgumentDescription, [Maybe String])] -> [(ArgumentDescription, [Maybe String])] + add (a,str) [] = [(a,[str])] + add (b,str) ((a,l):r) = + if same_arg a b then (a,str:l) : r + else (a,l) : add (b,str) r + + getopt_post' :: [ArgOcc] -> Either ArgError Arguments + getopt_post' pars{-all arguments-} = + let pars' = foldr add (map (\d -> (d,[])) descs) pars + + -- Check the number of argument occurences + check_num :: [(ArgumentDescription, [Maybe String])] -> Maybe ArgError + check_num [] = Nothing + check_num ((desc,args):rest) = + let (min,max) = fromJust (argdesc_times desc) + number = length args + wrong_number_msg = + (if is_direct desc then fst else snd) $ + if number == 0 && min == 1 then + ( "Missing argument." + , "Missing " ++ argname_a desc ++ "." + ) + else if number < min then + ( "Too few arguments. " ++ show min ++ " required." + , "Too few instances of " ++ argname_a desc ++ ". "++ show min ++ " required." + ) + else if number > max && max == 1 then + ( "Only one argument may be specified." + , "Repeated " ++ argname_a desc ++ "." + ) + else if number > max && max /= unlimited then + ( "Too many arguments." + , "Too many instances of " ++ argname_a desc ++ "." + ) + else error "bug in HsShellScript.Args.hs" + in if number >= min && (number <= max || max == unlimited) + then check_num rest + else Just (ArgError wrong_number_msg usageinfo) + + -- Apply any argument testers + check_testers :: [(ArgumentDescription, [Maybe String])] -> Maybe ArgError + check_testers [] = Nothing + check_testers ((desc,args):rest) = + case argdesc_argarg_tester desc of + Just argdesc_argarg_tester -> + if argdesc_argarg desc == ArgumentValue_none + then abort "Bug in HsShellScript argument descriptions: Argument value tester specified,\n\ + \but no argument value has been allowed. Add desc_value_optional or\n\ + \desc_value_required." + desc + else case filter isJust (map (argdesc_argarg_tester . fromJust) (filter isJust args)) of + [] -> check_testers rest + (Just msgf : _) -> Just (ArgError (msgf desc) usageinfo) + Nothing -> check_testers rest + + in case check_testers pars' of + Nothing -> case check_num pars' of + Nothing -> Right (Arguments (pars',usageinfo)) + Just err -> Left err + Just err -> Left err + + -- usage information generated by GetOpt + usageinfo = usageInfo header optdescr + + in test_unique argdesc_short_args "short argument" $ + test_unique argdesc_long_args "long argument" $ + case getOpt ordering optdescr cmdlargs of + (pars, rest, []) -> + getopt_post pars rest + (_,_,f) -> + throw (ArgError (unlines (map chomp f)) (usageInfo header optdescr)) + where + -- duplicated here in order to break cyclic module dependency + chomp "" = "" + chomp "\n" = "" + chomp [x] = [x] + chomp (x:xs) = let xs' = chomp xs + in if xs' == "" && x == '\n' then "" else x:xs' + + +-- | +-- Parse command line arguments. The arguments are taken from a call to +-- @getArgs@ and parsed. Any error is thrown as a +-- @ArgError@ exception. The result is a value from which the +-- information in the command line can be extracted by the @arg@..., +-- @reqarg@... and @optarg@... functions. +-- +-- Named arguments (like @-x@ or @--arg@) and direct +-- arguments may occur in any order. +getargs :: String -- ^ Header to be used in the usage info. + -> [ArgumentDescription] -- ^ The argument descriptions. + -> IO Arguments -- ^ The contents of the command line. +getargs header descs = do + args <- getArgs + let res = getargs0 header Permute args descs + either throw + return + res + +-- | +-- Parse command line arguments. The arguments are taken from a call to +-- @getArgs@ and parsed. Any error is thrown as a +-- @ArgError@ exception. The result is a value from which the +-- information in the command line can be extracted by the @arg@..., +-- @reqarg@... and @optarg@... functions. +-- +-- All arguments after the first direct argument are regarded as direct +-- arguments. This means that argument names introduced by @-@ +-- or @--@ no longer take effect. +getargs_ordered :: String -- ^ Header to be used in the usage info. + -> [ArgumentDescription] -- ^ Descriptions of the arguments. + -> IO Arguments -- ^ The contents of the command line. +getargs_ordered header descs = do + args <- getArgs + either throw + return + (getargs0 header RequireOrder args descs) + +-- | +-- Parse the specified command line. Any error is returned as @Left +-- argerror@. In case of success, the result is returned as +-- @Right res@. From the result, the information in the command +-- line can be extracted by the @arg@..., @reqarg@... +-- and @optarg@... functions. +-- +-- Named arguments (like @-x@ or @--arg@) and direct +-- arguments may occur in any order. +getargs' :: String -- ^ Header to be used in the usage info. + -> [String] -- ^ Command line to be parsed. + -> [ArgumentDescription] -- ^ The argument descriptions. + -> Either ArgError Arguments -- ^ The contents of the command line. +getargs' header args descs = getargs0 header Permute args descs + +-- | +-- Parse the specified command line. Any error is returned as @Left +-- argerror@. In case of success, the result is returned as +-- @Right res@. From the result, the information in the command +-- line can be extracted by the @arg@..., @reqarg@... +-- and @optarg@... functions. +-- +-- All arguments after the first direct argument are regarded as direct +-- arguments. This means that argument names introduced by @-@ +-- or @--@ no longer take effect. +getargs_ordered' :: String -- ^ Header to be used in the usage info. + -> [String] -- ^ Command line to be parsed. + -> [ArgumentDescription] -- ^ The argument descriptions. + -> Either ArgError Arguments -- ^ The contents of the command line. +getargs_ordered' header args descs = getargs0 header RequireOrder args descs + + +test_desc :: ArgumentDescription -> Bool -> String -> b -> b +test_desc desc ok msg x = + if ok then x + else abort msg desc + +maybe_head :: [a] -> Maybe a +maybe_head [] = Nothing +maybe_head [a] = Just a + +-- | +-- Query whether a certain switch is specified on the command line. A switch is an +-- argument which is allowed zero or one time, and has no value. +arg_switch :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Argument description of the switch. + -> Bool -- ^ Whether the switch is present in the command line. +arg_switch args desc = + test_desc desc (argdesc_argarg desc == ArgumentValue_none && argdesc_times desc == Just (0,1)) + "bug: querying argument with is not a switch with arg_switch" $ + case argvalues args desc of + [] -> False + [Nothing] -> True + +-- | +-- Query the number of occurences of an argument. +arg_times :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the argument. + -> Int -- ^ Number of times the argument occurs. +arg_times args desc = + length (argvalues args desc) + +-- | +-- Query the values of an argument with optional value. This is for +-- arguments which take an optional value, and may occur several times. The +-- occurences with value are represented as @Just value@, the occurences +-- without are represented as @Nothing@. +args_opt :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the argument. + -> [Maybe String] -- ^ The occurences of the argument. +args_opt args desc = + test_desc desc (argdesc_argarg desc == ArgumentValue_optional && snd (fromJust (argdesc_times desc)) /= 1) + "Bug: Querying argument which doesn't take an optional value, or may not occur several times, with args_opt." + $ argvalues args desc + +-- | +-- Query the values of an argument with required value. This is for +-- arguments which require a value, and may occur several times. +args_req :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the argument. + -> [String] -- ^ The values of the argument. +args_req args desc = + test_desc desc (argdesc_argarg desc == ArgumentValue_required && snd (fromJust (argdesc_times desc)) /= 1) + "Bug: Querying argument which doesn't require a value, or may not occur several times, with args_req." $ + map fromJust (argvalues args desc) + +-- | +-- Query the optional value of a required argument. This is for arguments +-- which must occur once, and may have a value. If the argument is +-- specified, its value is returned as @Just value@. If it isn't, the result +-- is @Nothing@. +reqarg_opt :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the argument. + -> Maybe String -- ^ The value of the argument, if it occurs. +reqarg_opt args desc = + test_desc desc (argdesc_argarg desc == ArgumentValue_optional && argdesc_times desc == Just (1,1)) + "Bug: Querying argument which doesn't take an optional value, or which must not occur exactly once, with reqarg_opt." $ + head (argvalues args desc) + +-- | +-- Query the value of a required argument. This is for arguments which must +-- occur exactly once, and require a value. +reqarg_req :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the argument. + -> String -- ^ The value of the argument. +reqarg_req args desc = + test_desc desc (argdesc_argarg desc == ArgumentValue_required && argdesc_times desc == Just (1,1)) + "Bug: Querying argument with non-required value, or which doesn't occur exactly once, with reqarg_req." $ + fromJust (head (argvalues args desc)) + +-- | +-- Query the optional value of an optional argument. This is for arguments +-- which may occur zero or one time, and which may or may not have a value. +-- If the argument doesn't occur, the result is @Nothing@. If it does occur, +-- but has no value, then the result is @Just Nothing@. If it does occur with +-- value, the result is @Just (Just value)@. +optarg_opt :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the argument. + -> Maybe (Maybe String) -- ^ The occurence of the argument and its value (see above). +optarg_opt args desc = + test_desc desc (argdesc_argarg desc == ArgumentValue_optional) "Bug: Querying argument with non-optional value with optarg_opt." $ + test_desc desc (fst (fromJust (argdesc_times desc)) == 0) "Bug: Querying argument which isn't optional with optarg_opt." $ + test_desc desc (snd (fromJust (argdesc_times desc)) == 1) "Bug: Querying argument which may occur several times optarg_opt." $ + maybe_head (argvalues args desc) + +-- | +-- Query the value of an optional argument. This is for optional arguments +-- which require a value, and may occur at most once. The result is +-- @Just value@ if the argument occurs, and @Nothing@ +-- if it doesn't occur. +optarg_req :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the argument. + -> Maybe String -- ^ The value of the argument, if it occurs. +optarg_req args desc = + test_desc desc (argdesc_argarg desc == ArgumentValue_required) "Bug: Querying argument with non-required value with optarg_req." + $ test_desc desc (fst (fromJust (argdesc_times desc)) == 0) "Bug: Querying argument which isn't optional with optarg_req." + $ test_desc desc (snd (fromJust (argdesc_times desc)) == 1) "Bug: Querying argument which may occur several times optarg_req." + $ fmap fromJust (maybe_head (argvalues args desc)) + + +-- | +-- None of the specifed arguments may be present. +-- +-- Throws an ArgError if any of the arguments are present. +args_none :: [ArgumentDescription] -- ^ List of the arguments which must not be present. + -> Arguments -- ^ Command line parse result. + -> IO () +args_none descs args@(Arguments (argl,usageinfo)) = + mapM_ (\desc -> + when (arg_times args desc /= 0) $ + throw (ArgError (up1 (argname_a desc) ++ " is not allowed.\n") usageinfo) + ) + descs + +-- | +-- All of the specified arguments must be present. +-- +-- Throws an ArgError if any is missing. +args_all :: [ArgumentDescription] -- ^ List of the arguments which must be present. + -> Arguments -- ^ Command line parse result. + -> IO () +args_all descs args@(Arguments (argl,usageinfo)) = + mapM_ (\desc -> + when (arg_times args desc == 0) $ + throw (ArgError ("Missing " ++ argname_a desc ++ "\n") usageinfo) + ) + descs + +-- | +-- Exactly one of the specified arguments must be present. +-- +-- Otherwise throw an ArgError. +args_one :: [ArgumentDescription] -- ^ List of the arguments, of which exactly one must be present. + -> Arguments -- ^ Command line parse result. + -> IO () +args_one descs args@(Arguments (argl,usageinfo)) = + when (occuring descs args /= 1) $ + throw (ArgError ("Exactly one of the following arguments must be present.\n" + ++ concat (intersperse ", " (map argname descs)) ++ "\n") + usageinfo) + + +-- | +-- At most one of the specified arguments may be present. +-- +-- Otherwise throw an ArgError. +args_at_most_one :: [ArgumentDescription] -- ^ List of the arguments, of which at most one may be present. + -> Arguments -- ^ Command line parse result. + -> IO () +args_at_most_one descs args@(Arguments (argl,usageinfo)) = + when (occuring descs args > 1) $ + throw (ArgError ("Only one of the following arguments may be present.\n" + ++ concat (intersperse ", " (map argname descs)) ++ "\n") + usageinfo) + + +-- | +-- At least one of the specified arguments must be present. +-- +-- Otherwise throw an ArgError. +args_at_least_one :: [ArgumentDescription] -- ^ List of the arguments, of which at least one must be present. + -> Arguments -- ^ Command line parse result. + -> IO () +args_at_least_one descs args@(Arguments (argl,usageinfo)) = + when (occuring descs args == 0) $ + throw (ArgError ("One of the following arguments must be present.\n" + ++ concat (intersperse ", " (map argname descs)) ++ "\n") + usageinfo) + + +-- | +-- When the specified argument is present, then none of the other arguments may be present. +-- +-- Otherwise throw an ArgError. +arg_conflicts :: ArgumentDescription -- ^ Argument which doesn't tolerate the other arguments + -> [ArgumentDescription] -- ^ Arguments which aren't tolerated by the specified argument + -> Arguments -- ^ Command line parse result. + -> IO () +arg_conflicts desc descs args@(Arguments (argl,usageinfo)) = + when (arg_occurs args desc && occuring descs args > 1) $ + throw (ArgError ("When " ++ argname desc ++ " is present, none of the following arguments may be present.\n" + ++ concat (intersperse ", " (map argname descs)) ++ "\n") + usageinfo) + + +-- How many of the specified arguments do occur? Multiple occurences of the same argument count as one. +occuring :: [ArgumentDescription] -> Arguments -> Int +occuring descs args = + sum (map (\desc -> if arg_times args desc == 0 then 0 else 1) descs) + + +{- | Whether the specified argument occurs in the command line. +-} +arg_occurs :: Arguments -- ^ Command line parse result. + -> ArgumentDescription -- ^ Description of the respective argument. + -> Bool -- ^ Whether the specified argument occurs in the command line. +arg_occurs args desc = + occuring [desc] args == 1 + + +-- | +-- Get the usage information from the parsed arguments. The usage info +-- contains the header specified to the corresponding @getargs...@ +-- function, and descriptions of the command line arguments. +usage_info :: Arguments -> String +usage_info (Arguments (_,ui)) = ui + + +{- +instance Show (OptDescr a) where + show (Option short long argdescr expl) = + "Option short:" ++ showList short " long:" ++ show long ++ " argdescr:" ++ show argdescr ++ " expl:" ++ showList expl "" + +instance Show (ArgDescr a) where + show (NoArg _) = "NoArg" + show (ReqArg _ _) = "ReqArg ..." + show (OptArg _ _) = "OptArg ..." +-} + + +{- | @getargs@ as a pure function, instead of an IO action. This allows to make evaluated command line arguments global values. This calls @getargs@ + to parse the command line arguments. @GHC.IO.unsafePerformIO@ is used to take the result out of the IO monad. + + >unsafe_getargs header descs = GHC.IO.unsafePerformIO $ getargs header descs + + The @getargs@ action is performed on demand, when the parse result is evaluated. It may result in an 'ArgError' being thrown. In order to avoid + this happening at unexpected times, the @main@ function should, start with the line @seq args (return ())@, where @args@ is the result of + @unsafe_getargs@,. This will trigger any command line argument errors at the beginning of the program. (See section 6.2 of the Hakell Report for the + definition of @seq@). + + A typical use of @unsafe_getargs@ looks like this: + +>header = "..." +>descs = [ d_myflag, ... ] +> +>d_myflag = argdesc [ ... ] +> +>args = unsafe_getargs header descs +>myflag = arg_switch args d_myflag +> +>main = mainwrapper $ do +> seq args (return ()) +> ... + + See 'getargs', 'unsafe_getargs_ordered'. +-} +unsafe_getargs :: String -- ^ The header used in the usage information + -> [ArgumentDescription] -- ^ The argument descriptions + -> Arguments -- ^ The parsed command line arguments +unsafe_getargs header descs = + GHC.IO.unsafePerformIO $ getargs header descs + + +{- | @getargs_ordered@ as a pure function, instead of an IO action. This is exactly like @unsafe_getargs@, but using @getargs_ordered@ instead of + @getargs@. + + >unsafe_getargs_ordered = GHC.IO.unsafePerformIO $ getargs_ordered header descs + + See 'unsafe_getargs'. +-} +unsafe_getargs_ordered :: String -- ^ The header used in the usage information + -> [ArgumentDescription] -- ^ The argument descriptions + -> Arguments -- ^ The parsed command line arguments +unsafe_getargs_ordered header descs = + GHC.IO.unsafePerformIO $ getargs_ordered header descs diff --git a/src/HsShellScript/Commands.chs b/src/HsShellScript/Commands.chs new file mode 100644 --- /dev/null +++ b/src/HsShellScript/Commands.chs @@ -0,0 +1,545 @@ +-- #hide +module HsShellScript.Commands where + + +import Prelude hiding (catch) +import Control.Exception +import Data.Bits +-- import Directory +import Foreign.C +import Foreign.C.Error +import Foreign.Ptr +import GHC.IO +import GHC.IO.Exception -- InvalidArgument, UnsupportedOperation +import HsShellScript.Misc +import HsShellScript.Misc +import HsShellScript.Paths +import HsShellScript.ProcErr +import HsShellScript.Shell +import System.IO.Error hiding (catch) +import Data.List +import Data.Maybe +import Control.Monad +import Text.ParserCombinators.Parsec as Parsec +import System.Posix hiding (rename, createDirectory, removeDirectory) +import System.Posix.Env +import System.Random +import System.Directory + +-- | +-- Do a call to the @realpath(3)@ system library function. This makes the path absolute, normalizes it and expands all symbolic links. In case of an +-- error, an @IOError@ is thrown. +realpath :: String -- ^ path + -> IO String -- ^ noramlized, absolute path, with symbolic links expanded +realpath path = + withCString path $ \cpath -> do + res <- {#call hsshellscript_get_realpath#} cpath + if res == nullPtr + then throwErrno' "realpath" Nothing (Just path) + else peekCString res + +-- | Determine the target of a symbolic link. This uses the @readlink(2)@ system call. The result is a path which is either absolute, or relative to +-- the directory which the symlink is in. In case of an error, an @IOError@ is thrown. The path is included and can be accessed with +-- @IO.ioeGetFileName@. Note that, if the path to the symlink ends with a slash, this path denotes the directory pointed to, /not/ the symlink. In +-- this case the call to will fail because of \"Invalid argument\". +readlink :: String -- ^ Path of the symbolic link + -> IO String -- ^ The link target - where the symbolic link points to +readlink path = + withCString path $ \cpath -> do + res <- {#call hsshellscript_get_readlink#} cpath + if res == nullPtr + then throwErrno' "readlink" Nothing (Just path) + else peekCString res + +-- | Determine the target of a symbolic link. This uses the @readlink(2)@ system call. The target is converted, such that it is relative to the +-- current working directory, if it isn't absolute. Note that, if the path to the symlink ends with a slash, this path denotes the directory pointed +-- to, /not/ the symlink. In this case the call to @readlink@ will fail with an @IOError@ because of \"Invalid argument\". In case of any error, a +-- proper @IOError@ is thrown. +readlink' :: String -- ^ path of the symbolic link + -> IO String -- ^ target; where the symbolic link points to +readlink' symlink = do + target <- readlink symlink + return (absolute_path' target (fst (split_path symlink))) + + +-- | Determine whether a path is a symbolic link. The result for a dangling symlink is @True@. The path must exist in the file system. In case of an +-- error, a proper @IOError@ is thrown. +is_symlink :: String -- ^ path + -> IO Bool -- ^ Whether the path is a symbolic link. +is_symlink path = + do fill_in_location "is_symlink" $ readlink path + return True + `catch` + (\(ioe::IOError) -> if (ioeGetErrorType ioe == InvalidArgument) then return False else ioError ioe) + + +-- | Return the normalised, absolute version of a specified path. The path is made absolute with the current working directory, and is syntactically +-- normalised afterwards. This is the same as what the @realpath@ program reports with the @-s@ option. It's almost the same as what it reports when +-- called from a shell. The difference lies in the shell's idea of the current working directory. See 'cd' for details. +-- +-- See 'cd', 'normalise_path'. +realpath_s :: String -- ^ path + -> IO String -- ^ noramlized, absolute path, with symbolic links not expanded +realpath_s pfad = + do cwd <- getCurrentDirectory + return (normalise_path (absolute_path_by cwd pfad)) + + +-- | +-- Make a symbolic link. This is the @symlink(2)@ function. Any error results in an @IOError@ thrown. The path of the intended symlink is included in +-- the @IOError@ and +-- can be accessed with @ioeGetFileName@ from the Haskell standard library @IO@. +symlink :: String -- ^ contents of the symlink (/from/) + -> String -- ^ path of the symlink (/to/) + -> IO () +symlink oldpath newpath = do + o <- newCString oldpath + n <- newCString newpath + res <- {#call symlink as foreign_symlink#} o n + when (res == -1) $ throwErrno' ("symlink " ++ shell_quote oldpath ++ " to " ++ shell_quote newpath) Nothing (Just newpath) + + +-- | +-- Call the @du@ program. See du(1). +du :: (Integral int, Read int, Show int) + => int -- ^ block size, this is the @--block-size@ option. + -> String -- ^ path of the file or directory to determine the size of + -> IO int -- ^ size in blocks +du block_gr pfad = + let par = ["--summarize", "--block-size=" ++ show block_gr, pfad] + parsen ausg = + case reads ausg of + [(groesse, _)] -> return groesse + _ -> errm ("Can't parse the output of the \"du\" program: \n" ++ quote ausg ++ "\nShell command: " ++ shell_command "du" par) + >> fail ("Parse error: " ++ ausg) + in pipe_from (exec "/usr/bin/du" par) >>= parsen + + + +-- | +-- Create directory. This is a shorthand to @System.Directory.createDirectory@ from the Haskell standard +-- library. In case of an error, the path is included in the @IOError@, which GHC's implementation neglects to do. +mkdir :: String -- ^ path + -> IO () +mkdir path = + createDirectory path + `catch` (\(ioe::IOError) -> ioError (ioe { ioe_filename = Just path })) + + +-- | +-- Remove directory. This is +-- @Directory.removeDirectory@ from the Haskell standard +-- library. In case of an error, the path is included in the @IOError@, which GHC's implementation neglects to do. +rmdir :: String -- ^ path + -> IO () +rmdir path = + removeDirectory path + `catch` (\(ioe::IOError) -> ioError (ioe { ioe_filename = Just path })) + + +-- | Remove file. This is @Directory.removeFile@ from the Haskell standard library, which is a direct frontend to the @unlink(2)@ system call in GHC. +rm :: String -- ^ path + -> IO () +rm = removeFile + + +{- | Change directory. This is an alias for @Directory.setCurrentDirectory@ from the Haskell standard + library. In case of an error, the path is included in the @IOError@, which GHC's implementation neglects to do. + + Note that this command is subtly different from the shell's @cd@ command. It changes the process' working directory. This is always a realpath. + Symlinks are expanded. The shell, on the other hand, keeps track of the current working directory separately, in a different way: symlinks are + /not/ expanded. The shell's idea of the working directory is different from the working directory which a process has. + + This means that the same sequence of @cd@ commands, when done in a real shell script, will lead into the same directory. But the working directory + as reported by the shell's @pwd@ command may differ from the corresponding one, reported by @getCurrentDirectory@. + + (When talking about the \"shell\", I'm talking about bash, regardless of whether started as @\/bin\/bash@ or in compatibility mode, as @\/bin\/sh@. I + presume it's the standard behavior for the POSIX standard shell.) + + See 'pwd'. +-} +cd :: String -- ^ path + -> IO () +cd path = + setCurrentDirectory path + `catch` (\(ioe::IOError) -> ioError (ioe { ioe_filename = Just path })) + + +-- | +-- Get program start working directory. This is the @PWD@ environent +-- variable, which is kept by the shell (bash, at least). It records the +-- directory path in which the program has been started. Symbolic links in +-- this path aren't expanded. In this way, it differs from +-- @getCurrentDirectory@ from the Haskell standard library. +pwd :: IO String +pwd = fmap (fromMaybe "") (System.Posix.Env.getEnv "PWD") + + +{- | Execute @\/bin\/chmod@ + +>chmod = run "/bin/chmod" +-} +chmod :: [String] -- ^ Command line arguments + -> IO () +chmod = run "/bin/chmod" + + +{- | Execute @\/bin\/chown@ + +>chown = run "/bin/chown" +-} +chown :: [String] -- ^ Command line arguments + -> IO () +chown = run "/bin/chown" + + +-- | +-- Execute the cp program +cp :: String -- ^ source + -> String -- ^ destination + -> IO () +cp from to = + run "cp" [from, to] + + +-- | +-- Execute the mv program +mv :: String -- ^ source + -> String -- ^ destination + -> IO () +mv from to = run "mv" ["--", from, to] + + +number :: Parser Int +number = do sgn <- ( (char '-' >> return (-1)) + <|> return 1 + ) + ds <- many1 digit + return (sgn * read ds) + "number" + +-- Parser for the output of the "mt status" command. +parse_mt_status :: Parser ( Int -- file number + , Int -- block number + ) +parse_mt_status = + do (fn,bn) <- parse_mt_status' (Nothing, Nothing) + return (fromJust fn, fromJust bn) + where + try = Parsec.try + + parse_mt_status' :: (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int) + parse_mt_status' st = do + st' <- parse_mt_status1' st + ( parse_mt_status' st' <|> return st' ) + + parse_mt_status1' :: (Maybe Int, Maybe Int) -> Parser (Maybe Int, Maybe Int) + parse_mt_status1' st@(fn,bn) = + try (do string "file number = " + nr <- number + newline + return (Just nr, bn) + ) + <|> try (do string "block number = " + nr <- number + newline + return (fn, Just nr) + ) + <|> (manyTill anyChar newline >> return st) + +-- | +-- Run the command @mt status@ for querying the tape drive status, and +-- parse its output. +mt_status :: IO (Int, Int) -- ^ file and block number +mt_status = do + out <- pipe_from (exec "/bin/mt" ["status"]) + case (parse parse_mt_status "" out) of + Left err -> ioError (userError ("parse error at " ++ show err)) + Right x -> return x + + + +-- | +-- The @rename(2)@ system call to rename and\/or move a file. The @renameFile@ action from the Haskell standard library doesn\'t do it, because +-- the two paths may not refer to directories. Failure results in an @IOError@ thrown. The /new/ path is included in +-- the @IOError@ and +-- can be accessed with @IO.ioeGetFileName@. +rename :: String -- ^ Old path + -> String -- ^ New path + -> IO () +rename oldpath newpath = do + withCString oldpath $ \coldpath -> + withCString newpath $ \cnewpath -> do + res <- {#call rename as foreign_rename#} coldpath cnewpath + when (res == -1) $ throwErrno' ("rename " ++ shell_quote oldpath ++ " to " ++ shell_quote newpath) Nothing (Just newpath) + + + +-- | +-- Rename a file. This first tries 'rename', which is most efficient. If it fails, because source and target path point to different file systems +-- (as indicated by the @errno@ value @EXDEV@), then @\/bin\/mv@ is called. +-- +-- See 'rename', 'mv'. +rename_mv :: FilePath -- ^ Old path + -> FilePath -- ^ New path + -> IO () +rename_mv old new = + HsShellScript.Commands.rename old new + `catch` (\(ioe::IOError) -> + if ioeGetErrorType ioe == UnsupportedOperation + then do errno <- getErrno + -- Foreign.C.Error.errnoToIOError matches many errno values to UnsupportedOperation. In order to determine + -- if it is the right one, the errno is taken again. This relies on no system calls in between. + if (errno == eXDEV) + then run "/bin/mv" ["--", old, new] + else ioError ioe + else ioError ioe + ) + + +{- | Rename a file or directory, and cope with read only issues. + +This renames a file or directory, using @rename@, sets the necessary write permissions beforehand, and restores them afterwards. This is more +efficient than @force_mv@, because no external program needs to be called, but it can rename files only inside the same file system. See @force_cmd@ +for a detailed description. + +The new path may be an existing directory. In this case, it is assumed that the old file is to be moved into this directory (like with @mv@). The +new path is then completed with the file name component of the old path. You won't get an \"already exists\" error. + +>force_rename = force_cmd rename + +See 'force_cmd', 'rename'. +-} +force_rename :: String -- ^ Old path + -> String -- ^ New path + -> IO () +force_rename = force_cmd HsShellScript.Commands.rename + + +{- | Move a file or directory, and cope with read only issues. + +This moves a file or directory, using the external command @mv@, sets the necessary write permissions beforehand, and restores them afterwards. +This is less efficient than @force_rename@, because the external program @mv@ needs to be called, but it can move files between file systems. See +@force_cmd@ for a detailed description. + +>force_mv src tgt = fill_in_location "force_mv" $ force_cmd (\src tgt -> run "/bin/mv" ["--", src, tgt]) src tgt + +See 'force_cmd', 'force_mv'. +-} +force_mv :: String -- ^ Old path + -> String -- ^ New path or target directory + -> IO () +force_mv src tgt = + fill_in_location "force_mv" $ + force_cmd (\src tgt -> run "/bin/mv" ["--", src, tgt]) src tgt + + +{- | Rename a file with 'rename', or when necessary with 'mv', and cope with read only issues. + +The necessary write permissions are set, then the file is renamed, then the permissions are restored. + +First, the 'rename' system call is tried, which is most efficient. If it fails, because source and target path point to different file systems +(as indicated by the @errno@ value @EXDEV@), then @\/bin\/mv@ is called. + +>force_rename_mv old new = fill_in_location "force_rename_mv" $ force_cmd rename_mv old new + +See 'rename_mv', 'rename', 'mv', 'force_cmd'. +-} +force_rename_mv :: FilePath -- ^ Old path + -> FilePath -- ^ New path + -> IO () +force_rename_mv old new = + fill_in_location "force_rename_mv" $ + force_cmd rename_mv old new + + +{- | Call a command which moves a file or directory, and cope with read only issues. + +This function is for calling a command, which renames files. Beforehand, write permissions are set in order to enable the +operation, and afterwards the permissions are restored. The command is meant to be something like @rename@ or @run \"\/bin\/mv\"@. + +In order to change the name of a file or dirctory, but leave it in the super directory +it is in, the super directory must be writeable. In order to move a file or directory to a different super directory, both super directories and +the file\/directory to be moved must be writeable. I don't know what this behaviour is supposed to be good for. + +This function copes with the case that the file\/directory to be moved or renamed, or the super directories are read only. It makes the necessary +places writeable, calls the command, and makes them read only again, if they were before. The user needs the necessary permissions for changing the +corresponding write permissions. If an error occurs (such as file not found, or insufficient permissions), then the write permissions are restored +to the state before, before the exception is passed through to the caller. + +The command must take two arguments, the old path and the new path. It is expected to create the new path in the file system, such that the correct +write permissions of the new path can be set by @force_cmd@ after executing it. + +The new path may be an existing directory. In this case, it is assumed that the old file is to be moved into this directory (like with @mv@). The +new path is completed with the file name component of the old path, before it is passed to the command, such that the command is supplied the +complete new path. + +Examples: + +>force_cmd rename from to +>force_cmd (\from to -> run "/bin/mv" ["-i", "-v", "--", from, to]) from to + +See 'force_rename', 'force_mv', 'rename'. +-} +force_cmd :: (String -> String -> IO ()) -- ^ Command to execute after preparing the permissions + -> String -- ^ Old path + -> String -- ^ New path or target directory + -> IO () +force_cmd cmd oldpath newpath0 = + do isdir <- is_dir newpath0 + let newpath = if isdir then newpath0 ++ "/" ++ snd (split_path oldpath) else newpath0 + + old_abs <- absolute_path oldpath + new_abs <- absolute_path newpath + let (olddir, _) = split_path old_abs + (newdir, _) = split_path new_abs + if olddir == newdir + then -- Don't need to make the file/directory writeable. + force_writeable olddir (cmd oldpath newpath) + else -- Need to make both the file/dirctory and both super directories writeable. + let cmd' = do res <- cmd oldpath newpath + return (newpath, res) + in force_writeable olddir (force_writeable newdir (force_writeable2 oldpath cmd')) + `catch` + (\(ioe::IOError) -> + ioError (if ioe_location ioe == "" || ioe_location ioe == "force_writeable" + then ioe { ioe_location = "force_cmd" } + else ioe)) + + + +{- | Make a file or directory writeable for the user, perform an action, and restore its writeable status. An IOError is raised when the user doesn't + have permission to make the file or directory writeable. + +>force_writeable path io = force_writeable2 path (io >>= \res -> return (path, res)) + +Example: + +>-- Need to create a new directory in /foo/bar, even if that's write protected +>force_writeable "/foo/bar" $ mkdir "/foo/bar/baz" + +See 'force_cmd', 'force_writeable2'. +-} +force_writeable :: String -- ^ File or directory to make writeable + -> IO a -- ^ Action to perform + -> IO a -- ^ Returns the return value of the action +force_writeable path io = + add_location "force_writeable" $ + force_writeable2 path (io >>= \res -> return (path, res)) + + +{- | Make a file or directory writeable for the user, perform an action, and restore its writeable status. The action may change the name of the file + or directory. Therefore it returns the new name, along with another return value, which is passed to the caller. + + The writeable status is only changed back if it has been changed by @force_writeable2@ before. An IOError is raised when the user doesn'h have + permission to make the file or directory writeable, or when the new path doesn't exist. + + See 'force_cmd', 'force_writeable'. +-} +force_writeable2 :: String -- ^ File or directory to make writeable + -> IO (String, a) -- ^ Action to perform + -> IO a +force_writeable2 path_before io = + add_location "force_writeable2" $ + do writeable <- fileAccess' path_before False True False + when (not writeable) $ set_user_writeable path_before + (path_after, res) <- + catch + io + (\(e::SomeException) -> + do when (not writeable) $ + catch (set_user_readonly path_before) + ignore -- Don't let failure to restore the status make us loose the actual exception + throwIO e + ) + when (not writeable) $ set_user_readonly path_after + return res + + where + ignore :: SomeException -> IO () + ignore _ = return () + + set_user_writeable path = do + filemode <- fmap fileMode (getFileStatus' path) + fill_in_filename path $ setFileMode' path (filemode .|. ownerWriteMode) + + set_user_readonly path = do + filemode <- fmap fileMode (getFileStatus' path) + fill_in_filename path $ setFileMode' path (filemode .&. (complement ownerWriteMode)) + + +-- | +-- Call the @fdupes@ program in order to find identical files. It outputs a +-- list of groups of file names, such that the files in each group are +-- identical. Each of these groups is further analysed by the @fdupes@ +-- action. It is split to a list of lists of paths, such that each list +-- of paths corresponds to one of the directories which have been searched +-- by the @fdupes@ program. If you just want groups of identical files, then apply @map concat@ to the result. +-- +-- /The/ @fdupes@ /program doesn\'t handle multiple occurences of the same directory, or in recursive mode one specified directory containing another, +-- properly. The same file may get reported multiple times, and identical files may not get reported./ +-- +-- The paths are normalised (using 'normalise_path'). +fdupes :: [String] -- ^ Options for the fdupes program + -> [String] -- ^ Directories with files to compare + -> IO [[[String]]] -- ^ For each set of identical files, and each of the specified directories, the paths of the identical files in this + -- directory. +fdupes opts paths = do + let paths' = map normalise_path paths + paths'' = map (++"/") paths' + out <- fmap lines $ pipe_from (run "/usr/bin/fdupes" (opts ++ ["--"] ++ paths')) + let grps = groups out + return (map (sortgrp paths'') grps) + where + groups [] = [] + groups l = + let l' = dropWhile (== "") l + (g,rest) = span (/= "") l' + in if g == [] then [] else (g : groups rest) + + split p [] = ([], []) + split p (x:xs) = + let (yes, no) = split p xs + in if p x then (x:yes, no) + else (yes, x:no) + + -- result: ( , ) + path1 grp dir = split (isPrefixOf dir) grp + + -- super directories -> Group of identical files -> list of lists of files in each directory + sortgrp dirs [] = map (const []) dirs + sortgrp [] grp = error ("Bug: found paths which don't belong to any of the directories:\n" ++ show grp) + sortgrp (dir:dirs) grp = let (paths1, grp_rest) = path1 grp dir + in (paths1 : sortgrp dirs grp_rest) + + +replace_location :: String + -> String + -> IO a + -> IO a +replace_location was wodurch io = + catch io + (\(ioe::IOError) -> + if ioe_location ioe == was + then ioError (ioe { ioe_location = wodurch }) + else ioError ioe + ) + + +#c +/* +#include +#include +#include +#include +#include +*/ +int symlink(const char *oldpath, const char *newpath); +int rename(const char *oldpath, const char *newpath); + +char* hsshellscript_get_realpath(char* path); +char* hsshellscript_get_readlink(char* path); +#endc + + + diff --git a/src/HsShellScript/GetOpt.hs b/src/HsShellScript/GetOpt.hs new file mode 100644 --- /dev/null +++ b/src/HsShellScript/GetOpt.hs @@ -0,0 +1,266 @@ +-- #hide +{- This ist GetOpt from GHC 6.2.2. GHC 6.4's GetOpt is buggy - the "--" argument + is no longer recognized. Therefore I include the old GetOpt here. + HsShellScript.Args uses it. +-} + +module HsShellScript.GetOpt ( + -- * GetOpt + getOpt, + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Example + + -- $example + ) where + +import Prelude +import Data.List ( isPrefixOf ) + +-- |What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + | ReturnInOrder (String -> a) -- ^ wrap non-options into options + +{-| +Each 'OptDescr' describes a single option. + +The arguments to 'Option' are: + +* list of short option characters + +* list of long option strings (without \"--\") + +* argument descriptor + +* explanation of option for user +-} +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +-- |Describes whether an option takes an argument or not, and if so +-- how the argument is injected into a value of type @a@. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> a) String -- ^ option requires argument + | OptArg (Maybe String -> a) String -- ^ optional argument + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = (unzip3 . map fmtOpt) optDescr + table = zipWith3 paste (sameLen ss) (sameLen ls) ds + paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z + sameLen xs = flushLeft ((maximum . map length) xs) xs + flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] + +fmtOpt :: OptDescr a -> (String,String,String) +fmtOpt (Option sos los ad descr) = (sepBy ',' (map (fmtShort ad) sos), + sepBy ',' (map (fmtLong ad) los), + descr) + where sepBy _ [] = "" + sepBy _ [x] = x + sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad +fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'System.Environment.getArgs'). + +'getOpt' returns a triple, consisting of the argument values, a list +of options that didn\'t match, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the commandline arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt _ _ [] = ([],[],[]) +getOpt ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[]) + procNextOpt EndOfOpts Permute = ([],rest,[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[]) + procNextOpt (OptErr e) _ = (os,xs,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,es) = getOpt ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + getWith p = [ o | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `p` l ] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (errUnrec optStr,rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt x xs rest optDescr = short ads xs rest + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[x] + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) + short (ReqArg f _:_) xs rest = (Opt (f xs),rest) + short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) + short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short [] [] rest = (errUnrec optStr,rest) + short [] xs rest = (errUnrec optStr,('-':xs):rest) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> OptKind a +errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n") + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} + +{- $example + +To hopefully illuminate the role of the different data +structures, here\'s the command-line options for a (very simple) +compiler: + +> module Opts where +> +> import System.Console.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String +> deriving Show +> +> options :: [OptDescr Flag] +> options = +> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" +> , Option ['V','?'] ["version"] (NoArg Version) "show version number" +> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" +> , Option ['c'] [] (OptArg inp "FILE") "input FILE" +> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" +> ] +> +> inp,outp :: Maybe String -> Flag +> outp = Output . fromMaybe "stdout" +> inp = Input . fromMaybe "stdout" +> +> compilerOpts :: [String] -> IO ([Flag], [String]) +> compilerOpts argv = +> case (getOpt Permute options argv) of +> (o,n,[] ) -> return (o,n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +-} diff --git a/src/HsShellScript/Misc.chs b/src/HsShellScript/Misc.chs new file mode 100644 --- /dev/null +++ b/src/HsShellScript/Misc.chs @@ -0,0 +1,511 @@ +-- #hide +module HsShellScript.Misc where + +import Control.Exception +import Control.Monad +import Data.Bits +import Data.Typeable +import Foreign +import Foreign.C +import Foreign.C.Error +import Foreign.C.String +import Foreign.Ptr +import GHC.IO hiding (finally, bracket) +import GHC.IO.Exception +import HsShellScript.ProcErr +import Prelude hiding (catch) +import System.Directory +import System.IO +import System.IO.Error hiding (catch) +import System.Posix hiding (removeDirectory) +import System.Random + + + +-- | +-- Format an @Int@ with leading zeros. If the string representation of the @Inŧ@ is longer than the number of characters to fill up, this produces as +-- many characters as needed. +zeros :: Int -- ^ How many characters to fill up + -> Int -- ^ Value to represent as a string + -> String -- ^ String representation of the value, using the specified number of characters +zeros stellen z = + let txt = show z + auff = stellen - length txt + n = take (if auff >= 0 then auff else 0) (repeat '0') + in n ++ txt + + +-- | +-- Remove trailing newlines. This is silimar to perl's @chomp@ procedure. +chomp :: String -- ^ String to be chomped + -> String -- ^ Same string, except for no newline characters at the end +chomp "" = "" +chomp "\n" = "" +chomp [x] = [x] +chomp (x:xs) = let xs' = chomp xs + in if xs' == "" && x == '\n' then "" else x:xs' + + +{- | Get contents of a file or of @stdin@. This is a simple frontend to +@hGetContents@. A file name of @\"-\"@ designates stdin. The contents are read +lazily as the string is evaluated. + +(The handle which we read from will be in semi-closed state. Once all input +has read, it is closed automatically (Haskell Library Report 11.2.1). +Therefore we don't need to return it). + +>lazy_contents path = do +> h <- if path == "-" then return stdin else openFile path ReadMode +> hGetContents h +-} +lazy_contents :: String -- ^ Either the name of a file, or @\"-\"@ + -> IO String -- ^ The lazily read contents of the file or @stdin@. +lazy_contents path = do + h <- if path == "-" then return stdin else openFile path ReadMode + hGetContents h + +-- | +-- Get contents of a file or of @stdin@ eagerly. This is the +-- same as @lazy_contents@, except for the contents being +-- read immediately. +contents :: String -- ^ either the name of a file, or @\"-\"@ for @stdin@ + -> IO String -- ^ the contents of the file or of standard input +contents pfad = do + txt <- lazy_contents pfad + seq (length txt) (return ()) + return txt + + +-- | +-- Test for the existence of a path. This is the disjunction of +-- @Directory.doesDirectoryExist@ and @Directory.doesFileExist@. For an dangling symlink, this will return @False@. +path_exists :: String -- ^ Path + -> IO Bool -- ^ Whether the path exists in the file system +path_exists pfad = do + de <- doesDirectoryExist pfad + fe <- doesFileExist pfad + return (de || fe) + + +-- | +-- Test for the existence of a path. This uses @System.Posix.Files.getFileStatus@ to determine whether the path exists in any form in the file system. +-- For a dangling symlink, the result is @True@. +path_exists' :: String -- ^ Path + -> IO Bool -- ^ Whether the path exists in the file system +path_exists' path = + catch (do getSymbolicLinkStatus path + return True) + (\(ioe :: IOError) -> + if isDoesNotExistError ioe then return False + else ioError ioe) + + +-- | +-- Test if path points to a directory. This will return @True@ for a symlink pointing to a directory. It's a shortcut for +-- @Directory.doesDirectoryExist@. +is_dir :: String -- ^ Path + -> IO Bool -- ^ Whether the path exists and points to a directory. +is_dir = doesDirectoryExist + + +-- | +-- Test if path points to a file. This is a shortcut for +-- @Directory.doesFileExist@. +is_file :: String -- ^ Path + -> IO Bool -- ^ Whether the path exists and points to a file. +is_file = doesFileExist + + +-- | +-- This is the @System.Posix.Files.getFileStatus@ function from the GHC libraries, with improved error reporting. The GHC function doesn't include the +-- file name in the @IOError@ when the call fails, making error messages much less useful. @getFileStatus\'@ rectifies this. +-- +-- See 'System.Posix.Files.getFileStatus'. +getFileStatus' :: FilePath -- ^ Path of the file, whose status is to be queried + -> IO FileStatus -- ^ Status of the file +getFileStatus' path = + getFileStatus path + `catch` (\ioe -> ioError (ioe { ioe_filename = Just path })) + + +-- | +-- This is the @System.Posix.Files.fileAccess@ function from the GHC libraries, with improved error reporting. The GHC function doesn't include the +-- file name in the @IOError@ when the call fails, making error messages much less useful. @fileAccess\'@ rectifies this. +-- +-- See 'System.Posix.Files.fileAccess'. +fileAccess' :: FilePath -> Bool -> Bool -> Bool -> IO Bool +fileAccess' p b c d = + fileAccess p b c d + `catch` (\ioe -> ioError (ioe { ioe_filename = Just p })) + + +-- | +-- Create a temporary file. This will create a new, empty file, with a path which did not previously exist in the file system. The path consists +-- of the specified prefix, a sequence of random characters (digits and letters), and the specified suffix. The file is created with read-write +-- permissions for the user, and no permissons for the group and others. The ownership is set to the effective user ID of the process. The group +-- ownership is set either to the effective group ID of the process or to the group ID of the parent directory (depending on filesystem type and mount +-- options on Linux - see @open(2)@ for details). +-- +-- See 'tmp_file', 'temp_dir', 'with_temp_file'. +temp_file :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't already + -- exist. + -> String -- ^ Prefix for the path to generate. + -> String -- ^ Suffix for the path to generate. + -> IO FilePath -- ^ Path of the created file. +temp_file nr prefix suffix = do + (fd, path) <- untilIO (do path <- temp_path nr prefix suffix + fd <- withCString path $ \cpath -> + {#call hsshellscript_open_nonvariadic#} cpath (o_CREAT .|. o_EXCL) 0o600 + return (fd, path) + ) + (\(fd, path) -> + if fd == -1 then do errno <- getErrno + when (errno /= eEXIST) $ + throwErrno' "temp_file" Nothing (Just path) + return False + else return True + ) + res <- {# call close as c_close #} fd + when (res == -1) $ throwErrno' "temp_file" Nothing (Just path) + return path + +-- | +-- Create a temporary directory. This will create a new directory, with a path which did not previously exist in the file system. The path consists +-- of the specified prefix, a sequence of random characters (digits and letters), and the specified suffix. The directory is normally created with +-- read-write-execute permissions for the user, and no permissons for the group and others. But this may be further restricted by the process's umask +-- in the usual way. +-- +-- The newly created directory will be owned by the effective uid of the process. If the directory containing the it has the set group +-- id bit set, or if the filesystem is mounted with BSD group semantics, the new directory will inherit the group ownership from its parent; +-- otherwise it will be owned by the effective gid of the process. (See @mkdir(2)@) +-- +-- See 'tmp_dir', 'temp_file', 'with_temp_dir'. +temp_dir :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't already + -- exist. + -> String -- ^ Prefix for the path to generate. + -> String -- ^ Suffix for the path to generate. + -> IO FilePath -- ^ Generated path. +temp_dir nr prefix suffix = do + (_, path) <- untilIO (do path <- temp_path nr prefix suffix + ret <- withCString path $ \cpath -> {#call mkdir as c_mkdir#} cpath 0o700 + return (ret, path) + ) + (\(ret, path) -> + if ret == -1 then do errno <- getErrno + when (errno /= eEXIST) $ + throwErrno' "temp_dir" Nothing (Just path) + return False + else return True + ) + return path + +-- | +-- Create a temporary file. This will create a new, empty file, with read-write permissions for the user, and no permissons for the group and others. +-- The path consists of the specified prefix, a dot, and six random characters (digits and letters). +-- +-- @tmp_file prefix = temp_file 6 (prefix ++ \".\") \"\"@ +-- +-- See 'temp_file', 'tmp_dir', 'with_tmp_file'. +tmp_file :: String -- ^ Prefix for the path to generate. + -> IO FilePath -- ^ Path of the created file. +tmp_file prefix = temp_file 6 (prefix ++ ".") "" + + +-- | +-- Create a temporary directory. This will create a new directory, with read-write-execute permissions for the user (unless further restricted by the +-- process's umask), and no permissons for the group and others. +-- The path consists of the specified prefix, a dot, and six random characters (digits and letters). +-- +-- @tmp_dir prefix = temp_dir 6 (prefix ++ \".\") \"\"@ +-- +-- See 'temp_dir', 'tmp_file', 'with_tmp_dir'. +tmp_dir :: String -- ^ Prefix for the path to generate. + -> IO FilePath -- ^ Path of the created directory. +tmp_dir prefix = temp_dir 6 (prefix ++ ".") "" + + +-- | +-- Create and open a temporary file, perform some action with it, and delete it afterwards. This is a front end to the 'temp_file' function. The file +-- and its path are created in the same way. The IO action is passed a handle of the new file. When it finishes - normally or with an exception - +-- the file is deleted. +-- +-- See 'temp_file', 'with_tmp_file', 'with_temp_dir'. +with_temp_file :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't + -- already exist. + -> String -- ^ Prefix for the path to generate. + -> String -- ^ Suffix for the path to generate. + -> (Handle -> IO a) -- ^ Action to perform. + -> IO a -- ^ Returns the value returned by the action. +with_temp_file nr prefix suffix io = + bracket (do path <- temp_file nr prefix suffix + h <- openFile path ReadWriteMode + return (path, h) + ) + (\(path,h) -> do + hClose h + removeFile path + ) + (\(path,h) -> + io h + ) + + + +-- | +-- Create a temporary directory, perform some action with it, and delete it afterwards. This is a front end to the 'temp_dir' function. The directory +-- and its path are created in the same way. The IO action is passed the path of the new directory. When it finishes - normally or with an exception - +-- the directory is deleted. +-- +-- The action must clean up any files it creates inside the directory by itself. @with_temp_dir@ doesn't delete any files inside, so the directory +-- could be removed. If the directory isn't empty, an @IOError@ results (with the path filled in). When the action throws an exception, and the +-- temporary directory cannot be removed, then the exception is passed through, rather than replacing it with the IOError. (This is because it's +-- probably exactly because of that exception that the directory isn't empty and can't be removed). +-- +-- See 'temp_dir', 'with_tmp_dir', 'with_temp_file'. +with_temp_dir :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't + -- already exist. + -> String -- ^ Prefix for the path to generate. + -> String -- ^ Suffix for the path to generate. + -> (FilePath -> IO a) -- ^ Action to perform. + -> IO a -- ^ Returns the value returned by the action. +with_temp_dir nr prefix suffix io = + do path <- temp_dir nr prefix suffix + a <- catch (io path) + (\e -> do remove path `catch` (\(e::SomeException) -> return ()) + throw (e :: SomeException) + ) + remove path + return a + where + remove path = removeDirectory path + `catch` (\ioe -> ioError (ioe { ioe_filename = Just path })) + + +-- | +-- Create and open a temporary file, perform some action with it, and delete it afterwards. This is a front end to the 'tmp_file' function. The file +-- and its path are created in the same way. The IO action is passed a handle of the new file. When it finishes - normally or with an exception - +-- the file is deleted. +-- +-- See 'tmp_file', 'with_temp_file', 'with_tmp_dir'. +with_tmp_file :: String -- ^ Prefix for the path to generate. + -> (Handle -> IO a) -- ^ Action to perform. + -> IO a -- ^ Returns the value returned by the action. +with_tmp_file prefix io = + bracket (do path <- tmp_file prefix + h <- openFile path ReadWriteMode + return (path, h) + ) + (\(path,h) -> do + hClose h + removeFile path + ) + (\(path,h) -> do + e <- io h + return e + ) + +-- | +-- Create a temporary directory, perform some action with it, and delete it afterwards. This is a front end to the 'tmp_dir' function. The directory +-- and its path are created in the same way. The IO action is passed the path of the new directory. When it finishes - normally or with an exception - +-- the directory is deleted. +-- +-- The action must clean up any files it creates inside the directory by itself. @with_temp_dir@ doesn't delete any files inside, so the directory +-- could be removed. If the directory isn't empty, an @IOError@ results (with the path filled in). When the action throws an exception, and the +-- temporary directory cannot be removed, then the exception is passed through, rather than replacing it with the IOError. (This is because it's +-- probably exactly because of that exception that the directory isn't empty and can't be removed). +-- +-- >with_tmp_dir prefix io = with_temp_dir 6 (prefix ++ ".") "" io +-- +-- See 'tmp_dir', 'with_temp_dir', 'with_tmp_file'. +with_tmp_dir :: String -- ^ Prefix for the path to generate. + -> (FilePath -> IO a) -- ^ Action to perform. + -> IO a -- ^ Returns the value returned by the action. +with_tmp_dir prefix io = with_temp_dir 6 (prefix ++ ".") "" io + + +-- | +-- Create a temporary path. This will generate a path which does not yet exist in the file system. It consists of the specified prefix, a +-- sequence of random characters (digits and letters), and the specified suffix. +-- +-- /Avoid relying on the generated path not to exist in the file system./ Or else you'll get a potential race condition, since some other process might +-- create the path after @temp_path@, before you use it. This is a security risk. The global random number generator (@Random.randomRIO@) is used to +-- generate the random characters. These might not be that random after all, and could potentially be guessed. Rather use @temp_file@ or @temp_dir@. +-- +-- See 'temp_file', 'temp_dir'. +temp_path :: Int -- ^ Number of random characters to intersperse. Must be large enough, such that most combinations can't already + -- exist. + -> String -- ^ Prefix for the path to generate. + -> String -- ^ Suffix for the path to generate. + -> IO FilePath -- ^ Generated path. +temp_path nr prefix suffix = do + untilIO (do rand <- sequence (take nr (repeat (fmap char (randomRIO (0, 10+2*26 - 1))))) + return (prefix ++ rand ++ suffix) + ) + (\path -> fmap not (path_exists' path)) + + where char nr = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" !! nr + + +-- Execute action until condition is met. +untilIO io cond = do + res <- io + u <- cond res + if u then return res + else untilIO io cond + + +{- | One entry of mount information. This is the same as @struct mntent@ from @\@. +A list of these is returned by the functions which read mount information. + +See 'read_mounts', 'read_mtab', 'read_fstab'. +-} +data Mntent = Mntent { mnt_fsname :: String -- ^ Device file (\"name of mounted file system\") + , mnt_dir :: String -- ^ Mount point + , mnt_type :: String -- ^ Which kind of file system (\"see mntent.h\") + , mnt_opts :: String -- ^ Mount options (\"see mntent.h\") + , mnt_freq :: Int -- ^ Dump frequency in days + , mnt_passno :: Int -- ^ \"Pass number on parallel fsck\" + } + deriving (Read, Show, Typeable, Eq) + +{- | Read mount information. This is a front end to the @setmntent(3)@, @getmntent(3)@, @endmntent(3)@ system library functions. + +When the @setmntent@ call fails, the @errno@ value is converted to an @IOError@ and thrown. + +See 'read_mtab', 'read_fstab'. +-} +read_mounts :: String -- ^ File to read (typically @\/etc\/mtab@ or @\/etc\/fstab@) + -> IO [Mntent] -- ^ Mount information in that file +read_mounts path = do + h <- withCString path $ \cpath -> + withCString "r" $ \r -> + {#call setmntent#} cpath r + when (h == nullPtr) $ + throwErrno' "setmntent(3) in read_mounts" Nothing (Just path) + mntent <- getmntent h [] + {#call endmntent#} h + return mntent + + where + getmntent h l = do + ptr <- {#call getmntent as c_getmntent#} h + if (ptr == nullPtr) then return l + else do mnt_fsname_str <- {#get mntent.mnt_fsname#} ptr >>= peekCString + mnt_dir_str <- {#get mntent.mnt_dir#} ptr >>= peekCString + mnt_type_str <- {#get mntent.mnt_type#} ptr >>= peekCString + mnt_opts_str <- {#get mntent.mnt_opts#} ptr >>= peekCString + mnt_freq_int <- fmap fromEnum $ {#get mntent.mnt_freq#} ptr + mnt_passno_int <- fmap fromEnum $ {#get mntent.mnt_passno#} ptr + getmntent h (l ++ [Mntent { mnt_fsname = mnt_fsname_str + , mnt_dir = mnt_dir_str + , mnt_type = mnt_type_str + , mnt_opts = mnt_opts_str + , mnt_freq = mnt_freq_int + , mnt_passno = mnt_passno_int + }]) + +{- | Get the currently mounted file systems. + +>read_mtab = read_mounts "/etc/mtab" + +See 'read_mounts'. +-} +read_mtab :: IO [Mntent] +read_mtab = read_mounts "/etc/mtab" + + +{- | Get the system wide file system table. + +>read_fstab = read_mounts "/etc/fstab" + +See 'read_mounts'. +-} +read_fstab :: IO [Mntent] +read_fstab = read_mounts "/etc/fstab" + + +-- Taken from the source code of the GHC 6 libraries (in System.Posix.Internals). It isn't exported from there. "HsBase.h" belongs to the files which +-- are visible to users of GHC, but it isn't documented. The comment at the beginning says "Definitions for package `base' which are visible in +-- Haskell land.". +foreign import ccall unsafe "HsBase.h __hscore_o_creat" o_CREAT :: CInt +foreign import ccall unsafe "HsBase.h __hscore_o_excl" o_EXCL :: CInt + + +-- | Change the working directory temporarily. This executes the specified IO action with a new working directory, and restores it afterwards +-- (exception-safely). +with_wd :: FilePath -- ^ New working directory + -> IO a -- ^ Action to run + -> IO a +with_wd wd io = + bracket (do cwd <- getCurrentDirectory + setCurrentDirectory wd + return cwd) + (\cwd -> setCurrentDirectory cwd) + (const io) + + +-- | This is an interface to the POSIX @glob@ function, which does wildcard expansion +-- in paths. The list of matched paths is returned. It's empty +-- for no match (rather than the original pattern). In case anything goes wrong +-- (such as permission denied), an IOError is thrown. +-- +-- This does /not/ do tilde expansion, which is done (among many unwanted other +-- things) by @wordexp@. The only flag used for the call to @glob@ is @GLOB_ERR@. +-- +-- The behaviour in case of non-existing path components is inconsistent in the +-- GNU version of the underlying @glob@ function. @glob "\/doesnt_exist\/foo"@ will return +-- the empty list, whereas @glob "\/doesnt_exist\/*"@ causes a "No such file or directory" +-- IOError. +-- +-- See man pages @glob(3)@ and @wordexp(3)@. +glob :: String -- ^ Pattern + -> IO [String] -- ^ Sorted list of matching paths +glob pattern = do + withCString pattern $ \pattern_ptr -> + allocaBytes {#sizeof glob_t#} $ \buf_ptr -> + do res <- {#call do_glob#} buf_ptr pattern_ptr + case res of + 0 -> -- success + do pptr <- {#get glob_t->gl_pathv#} buf_ptr + len <- lengthArray0 nullPtr pptr + cstrs <- peekArray len pptr + mapM peekCString cstrs + 1 -> -- GLOB_ABORTED + throwErrno' "glob" Nothing (Just pattern) + 2 -> -- GLOB_NOSPACE + ioError (ioeSetErrorString (mkIOError ResourceExhausted "glob" Nothing (Just pattern)) + "Out of memory") + 3 -> -- GLOB_NOMATCH + return [] + `finally` + (do pptr <- {#get glob_t->gl_pathv#} buf_ptr + when (pptr /= nullPtr) $ + {#call globfree#} buf_ptr + ) + + + +#c +/* +#include +#include +#include +#include +#include +*/ +#include +#include +#include + +int close(int fd); + + +/* open(2) is defined in fcntl.h as "extern int open (__const char *__file, int __oflag, ...)", with variable number of arguments, which isn's + supported by the FFI. +*/ +int hsshellscript_open_nonvariadic(const char *pathname, int flags, mode_t mode); + +int do_glob(void* buf, const char* pattern); + + +#endc diff --git a/src/HsShellScript/Paths.hs b/src/HsShellScript/Paths.hs new file mode 100644 --- /dev/null +++ b/src/HsShellScript/Paths.hs @@ -0,0 +1,464 @@ +-- Path parsing and composing + +-- #hide +module HsShellScript.Paths where + +import Data.List +import System.Directory + +{- | 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 treated like \"@.@\", yielding an empty path components list. + +Examples: + +>slice_path "/" = ["/"] +>slice_path "/foo/bar" = ["/foo","bar"] +>slice_path "..//./" = [".."] +>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 p = + case p of + ('/':p') -> case slice_path' p' of + [] -> ["/"] + (c:cs) -> (('/':c):cs) + _ -> slice_path' p + where + slice_path' p = filter (\c -> c /= "" && c /= ".") (split p) + + split "" = [] + split ('/':p) = "" : split p + split (x:xs) = case split xs of + [] -> [[x]] + (y:ys) -> ((x:y):ys) + +{- | Form a path from path components. This isn't the inverse +of 'slice_path', since @'unslice_path' . 'slice_path'@ +normalises the path. + +>unslice_path [] = "." +>unslice_path cs = concat (intersperse "/" cs) + +See 'slice_path', 'unsplit_parts'. +-} +unslice_path :: [String] -- ^ List of path components + -> String -- ^ The path which consists of the supplied path components +unslice_path [] = "." +unslice_path cs = concat (intersperse "/" 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. + + Note that the normalised path isn't 100% equivalent to the original one. Any trailing slash is removed. When the last path component is a symbolic + link, then both paths denote the same thing, except for in the context of the 'readlink' call. It will fail when the trailing slash is present + (because then the path denotes the directory which the link points to), but it will succeed when it is absent. + + >normalise_path = unslice_path . slice_path + + See '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' filename = + case filename of + ('.':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 = concat . intersperse "." + + +{- | 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") +>split_path "/" == ("/", ".") + +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 + [] -> (".",".") + ["/"] -> ("/", ".") + ['/':p] -> ("/", p) + [fn] -> (".", fn) + 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 forms a path from two parts, and takes care of @\".\"@ and empty parts. When the two components are in normalised form, then @unsplit_path@ +creates a normalised path. + +The definition: + +>unsplit_path ("", "") = "" +>unsplit_path (p, q) = unsplit_parts [p, q] + +Examples: + +>unsplit_path ("", "") == "" +>unsplit_path (".", "") == "." +>unsplit_path (".", ".") == "." +>unsplit_path ("foo", ".") == "foo" + +See 'split_path', 'slice_path', 'unsplit_parts'. +-} +unsplit_path :: ( String, String ) -- ^ Directory and file name + -> String -- ^ Path formed from the directory and file name parts +unsplit_path ("", "") = "" +unsplit_path (p, q) = unsplit_parts [p, q] + +{- old 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 +-} + + +{- | Concatenate a list of path parts. The idea is that you can throw in reasonably formed parts, and get a reasonably +formed version of the concatenated path out. + +@\".\"@ parts are removed. Empty parts are treated as @\".\"@ parts. One leading slash in each of any but the first part is removed. The result is +then interspersed with slashes and string wise concatenated. The interior of the parts isn't examined. @\"..\"@ components aren't treated specially. + +Examples: + +>unsplit_parts [] == "." +>unsplit_parts [""] == "." +>unsplit_parts ["/"] == "/" +>unsplit_parts ["/", "foo"] == "/foo" +>unsplit_parts ["", "/foo"] == "foo" +>unsplit_parts ["/foo", "bar"] == "/foo/bar" +>unsplit_parts ["/foo", "/bar"] == "/foo/bar" +>unsplit_parts ["foo/", "bar"] == "foo//bar" +>unsplit_parts ["foo", "", ".", "bar"] == "foo/bar" +>unsplit_parts ["foo", "bar//./baz/"] == "foo/bar//./baz/" + +See 'unsplit_path', 'unslice_path', 'split_path'. +-} +unsplit_parts :: [String] -- ^ List of path parts to concatenate. + -> String -- ^ Formed path, which concatenates the parts. +unsplit_parts [] = "." +unsplit_parts parts = + let abs = case parts of + ('/':p1):rest -> "/" + _ -> "" + parts' = map (\part -> case part of + '/':rest -> rest + _ -> part + ) + parts + in case (abs ++ (concat $ intersperse "/" $ filter (\part -> part /= "" && part /= ".") parts')) + of "" -> "." + path -> path + + +{- | 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 ( concat (intersperse "/" (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@('/':p) = return path +absolute_path path = do + cwd <- getCurrentDirectory + return (cwd ++ "/" ++ path) + + +{- | 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 dir path@('/':p) = path +absolute_path_by dir path = dir ++ "/" ++ path + + +{- | 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' path@('/':p) dir = path +absolute_path' path dir = dir ++ "/" ++ path + + +{- | 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 diff --git a/src/HsShellScript/ProcErr.chs b/src/HsShellScript/ProcErr.chs new file mode 100644 --- /dev/null +++ b/src/HsShellScript/ProcErr.chs @@ -0,0 +1,1949 @@ +-- Ausnahme in child, Exception +-- #hide +module HsShellScript.ProcErr where + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Data.IORef as IORef +import Data.Int +import Data.List +import Data.Maybe +import Data.Typeable +import Foreign +import Foreign.C +import Foreign.C.Error +import GHC.Conc +import GHC.IO hiding (finally, bracket) +import GHC.IO.Exception -- SystemError, ioe_* +import GHC.IO.Handle +import GHC.IO.Handle.Internals -- withHandle', do_operation +import GHC.IO.Handle.Types hiding (close) +import HsShellScript.Args +import HsShellScript.Shell +import Prelude hiding (catch) +import System.Directory +import System.Environment +import System.Exit +import System.IO +import System.IO.Error hiding (catch) +import System.Posix +import System.Posix.IO +import System.Posix.Process (forkProcess) +import System.Posix.Types -- Fd +import qualified GHC.IO.FD as FD +import qualified System.IO.Error -- mkIOError + +infixr 2 -|- -- left handed, stdout +infixr 2 =|- -- left handed, stderr +infixl 2 -|= -- right handed, stdout +infixl 2 =|= -- right handed, stderr +infixl 3 ->- -- write stdout to file +infixl 3 =>- -- write stderr to file +infixl 3 ->>- -- append stdout to file +infixl 3 =>>- -- append stderr to file +infixl 3 -<- -- read stdin from file or string +infixl 3 -&>- -- write stdout and stderr to file +infixl 3 -&>>- -- append stdout and stderr to file + + + +{- | Improved version of @System.Posix.Files.setFileMode@, which sets the file name in the @IOError@ which is thrown in case of an error. The + implementation in GHC 6.2.2 neglects to do this. + +>setFileMode' path mode = +> fill_in_filename path $ +> setFileMode path mode +-} +setFileMode' :: FilePath -> FileMode -> IO () +setFileMode' path mode = + fill_in_filename path $ + setFileMode path mode + + +-- | +-- Execute an IO action as a separate process, and wait for it to finish. +-- Report errors as exceptions. +-- +-- The program forks a child process and performs the specified action. +-- Then it waits for the child process to finish. If it exits in any way +-- which indicates an error, the @ProcessStatus@ is thrown as an +-- exception. +-- +-- When the action throws an @IOError@, it is transmitted to the parent. +-- It is then raised there, as if it happened locally. The child then aborts +-- quietly with an exit code of 0. +-- +-- When used in conjunction with an @exec@ variant, this means that the parent +-- process can tell the difference between failure of the @exec@ call itself, +-- and failure of the program being executed. You get the @IOError@, which +-- happened in the child when calling @executeFile@ (GHC hierarchical +-- libraries). Of course, the action can prevent this form happening, by +-- itself catching @IOError@s. +-- +-- The parent process waits for the child process, if it has been stopped by a +-- signal. +-- +-- See "HsShellScript#subr" for further details. +-- +-- +-- Examples: +-- +-- Run a program with the environment replaced: +-- +-- >subproc (execpe "foobar" ["1","2","3"] new_env) +-- +-- This results in a @ProcessStatus@ exception: +-- +-- >subproc (exec "/bin/false" []) +-- +-- This results in an @IOError@ (unless you actually have @\/frooble@): +-- +-- >subproc (exec "/frooble" []) +-- +-- See 'runprog', 'spawn', 'exec', 'execp', 'exece', 'execpe'. +subproc :: IO a -- ^ Action to execute in a child process + -> IO () +subproc io = do + + -- Make new error channel + (readend, writeend) <- createPipe + + -- Set it to "close on exec" + {#call c_close_on_exec#} (fromIntegral writeend) + + -- Fork child process + flush_outerr + pid <- forkProcess (do -- Child process + closeFd readend + + -- Do it. In case some part of the child hands over an IOError to + -- be transmitted to the parent, do that and abort quietly. + child $ + catch (io >> return ()) + (\(ioe::IOError) -> do + send_ioerror writeend ioe + flush_outerr + _exit 0 + ) + ) + + -- Parent process + closeFd writeend + + -- Read the complete contents of the error channel as an encoding + -- of a possible IOError (until closed on the other side). + -- + -- The write end in the child stays open, until either + -- - exec in the child + -- - child terminates (not merely stops) + -- - child sends ioerror and closes the channel + mioe <- receive_ioerror readend + + -- Waits for the child to finish. The process status is "Exited + -- ExitSuccess" in case the child transmitted an error. + (Just ps) <- getProcessStatus True False (fromIntegral pid) + if ps == Exited ExitSuccess + then return () + else throw ps + + -- In case an IOError has been received, throw it locally + case mioe of + Just ioe -> ioError ioe + Nothing -> return () + + +-- | +-- Execute an IO action as a separate process, and wait for it to finish. +-- Report errors as exceptions. +-- +-- /This function is included only for backwards compatibility. New code should/ +-- /use/ 'subproc' instead/, which has better error handling./ +-- +-- The program forks a child process and performs the specified action. +-- Then it waits for the child process to finish. If it exits in any way +-- which indicates an error, the @ProcessStatus@ is thrown. +-- +-- The parent process waits for the child processes, which have been stopped by +-- a signal. +-- +-- See "HsShellScript#subr" for further details. +-- +-- See 'subproc', 'spawn'. +call :: IO a -- ^ action to execute as a child process + -> IO () +call io = do + pid <- spawn_loc "call" io + (Just ps) <- getProcessStatus True False pid + if ps == Exited ExitSuccess + then return () + else throw ps + + +-- | +-- Execute an IO action as a separate process, and continue without waiting +-- for it to finish. +-- +-- The program forks a child process, which performs the specified action and terminates. +-- The child's process ID is returned. +-- +-- See "HsShellScript#subr" for further details. +-- +-- See 'subproc'. +spawn :: IO a -- ^ Action to execute as a child process. + -> IO ProcessID -- ^ Process ID of the new process. +spawn = spawn_loc "spawn" + +spawn_loc :: String -> IO a -> IO ProcessID +spawn_loc loc io = do + flush_outerr + pid <- forkProcess (child io) + return pid + + +-- | +-- Run an external program. This starts a program as a child +-- process, and waits for it to finish. The executable is searched via the +-- @PATH@. +-- +-- /This function is included for backwards compatibility only. New code should/ +-- /use/ 'runprog'/, which has much better error handling./ +-- +-- When the specified program can't be executed, an error message is printed, and the main process +-- gets a @ProcessStatus@ thrown, with the value @Exited +-- (ExitFailure 1)@. This means that the main program can't distinguish between +-- failure of calling the program and the program exiting with an exit code of +-- 1. However, an error message \"Error calling ...\", including the description in the IOError produced +-- by the failed @execp@ call, is printed on @stderr@. +-- +-- @run prog par@ is essentially @call (execp prog par)@. +-- +-- Example: +-- +-- >run "/usr/bin/foobar" ["some", "args"] +-- > `catch` (\ps -> do -- oops... +-- > ) +-- +-- See 'runprog', 'subproc', 'spawn'. +run :: FilePath -- ^ Name of the executable to run + -> [String] -- ^ Command line arguments + -> IO () +run prog par = + call (child $ execp prog par) + + + +{- | An error which occured when calling an external program via 'runprog'. + The fields specifiy the details of the call. + + See 'show_runerror', 'to_ioe', 'as_ioe', @System.Posix.ProcessStatus@. +-} +data RunError = RunError + { re_prog :: String -- ^ Program name + , re_pars :: [String] -- ^ Program arguments + , re_env :: [(String,String)] -- ^ The environment in use when the call was done + , re_wd :: String -- ^ The working directory when the call was done + , re_ps :: ProcessStatus -- ^ The process status of the failure + , re_errno :: Maybe CInt -- ^ The error (errno) code + } + deriving (Show, Typeable, Eq) + +instance Exception RunError + + + +-- | Make a readable error message. This includes all the +-- fields of @RunError@ except for the environment. +-- +-- See 'RunError'. +show_runerror :: RunError -> String +show_runerror re = + "The following program failed:\n\ + \ " ++ shell_command (re_prog re) (re_pars re) ++ "\n" ++ + explain_processstatus (re_ps re) ++ "\n\ + \The working directory was " ++ quote (re_wd re) ++ "." + + +-- | Generate a human-readable description of a @ProcessStatus@. +-- +-- See 'exec', 'runprog' and @System.Posix.ProcessStatus@ in the GHC hierarchical +-- library documentation. +explain_processstatus :: ProcessStatus -> String +explain_processstatus ps = + case ps of + Exited (ExitFailure ec) -> "The program exited abnormally with an exit code of " ++ show ec ++ "." + Exited ExitSuccess -> "The program finished normally." + Terminated sig -> "The process was terminated by signal " ++ showsig sig ++ "." + Stopped sig -> "The process was stopped by signal " ++ showsig sig ++ "." + where + showsig sig = show sig ++ + case lookup sig signals of + Just name -> " (" ++ name ++ ")" + Nothing -> "" + + signals = [(sigABRT, "SIGABRT"), (sigALRM, "SIGALRM"), (sigBUS, "SIGBUS"), (sigCHLD, "SIGCHLD"), (sigCONT, "SIGCONT"), (sigFPE, "SIGFPE"), + (sigHUP, "SIGHUP"), (sigILL, "SIGILL"), (sigINT, "SIGINT"), (sigKILL, "SIGKILL"), (sigPIPE, "SIGPIPE"), (sigQUIT, "SIGQUIT"), + (sigSEGV, "SIGSEGV"), (sigSTOP, "SIGSTOP"), (sigTERM, "SIGTERM"), (sigTSTP, "SIGTSTP"), (sigTTIN, "SIGTTIN"), (sigTTOU, "SIGTTOU"), + (sigUSR1, "SIGUSR1"), (sigUSR2, "SIGUSR2"), (sigPOLL, "SIGPOLL"), (sigPROF, "SIGPROF"), (sigSYS, "SIGSYS"), (sigTRAP, "SIGTRAP"), + (sigURG, "SIGURG"), (sigVTALRM, "SIGVTALRM"), (sigXCPU, "SIGXCPU"), (sigXFSZ, "SIGXFSZ")] + + +-- | Convert a @RunError@ to an @IOError@. +-- +-- The @IOError@ type isn't capable of holding all the information which is +-- contained in a @RunError@. The environment is left out, and most of the other +-- fields are included only informally, in the description. +-- +-- The fields of the generated @IOError@ are: +-- +-- * The handle (@ioeGetHandle@): @Nothing@ +-- +-- * The error type (@ioeGetErrorType@): @GHC.IO.Exception.SystemError@ +-- +-- * @ioe_location@: @\"runprog\"@ +-- +-- * @ioe_description@: The error message, as procuded by @show_runerror@. +-- +-- * @ioe_filename@: This is @Just (shell_command /prog/ /pars/)@, with /prog/ +-- and /pars/ being the program and its arguments. +-- +-- See 'as_ioe', 'runprog', 'show_runerror'. +to_ioe :: RunError -> IOError +to_ioe re = + GHC.IO.Exception.IOError { ioe_handle = Nothing, + ioe_type = GHC.IO.Exception.SystemError, + ioe_location = "runprog", + ioe_description = show_runerror re, + ioe_filename = Just (shell_command (re_prog re) (re_pars re)), + ioe_errno = re_errno re + } + + +-- | Call the specified IO action (which is expected to contain calls of +-- @runprog@) and convert any @RunError@ exceptions to @IOError@s. +-- +-- The conversion is done by @to_ioe@. +-- +-- See 'to_ioe', 'runprog'. +as_ioe :: IO a -> IO a +as_ioe io = + io + `catch` (\(re::RunError) -> ioError (to_ioe re)) + + +-- | +-- Run an external program, and report errors as exceptions. The executable is +-- searched via the @PATH@. +-- +-- In case the program exits in an way which indicates an error, or is +-- terminated by a signal, a @RunError@ is thrown. It +-- contains the details of the call. The @runprog@ action can also be converted +-- to throw @IOError@s instaed, by applying @as_ioe@ to it. Either can be used +-- to generate an informative error message. +-- +-- In case of starting the program itself failed, an @IOError@ is thrown. +-- +-- @runprog prog par@ is essentially @subproc (execp prog par)@. +-- +-- Example 1: +-- +-- >do runprog "foo" ["some", "args"] +-- > ... +-- >`catch` (\re -> do errm (show_runerror re) +-- > ... +-- > ) +-- +-- Example 2: +-- +-- >do as_ioe $ runprog "foo" ["some", "args"] +-- > ... +-- >`catch` (\ioe -> do errm (show_ioerror ioe) +-- > ... +-- > ) +-- +-- See 'subproc', 'spawn', 'RunError', 'show_runerror', 'to_ioe', 'as_ioe'. +runprog :: FilePath -- ^ Name of the executable to run + -> [String] -- ^ Command line arguments + -> IO () +runprog prog pars = + subproc (execp prog pars) + + `catch` + -- Convert ProcessStatus error to RunError + (\(ps::ProcessStatus) -> + do env <- System.Environment.getEnvironment + wd <- getCurrentDirectory + (Errno c_errno) <- getErrno + throw (RunError { re_prog = prog + , re_pars = pars + , re_env = env + , re_wd = wd + , re_ps = ps + , re_errno = if c_errno /= (0::CInt) then Just c_errno + else Nothing + })) + + + +-- | Print an action as a shell command, then perform it. +-- +-- This is used with actions such as 'runprog', 'exec' or 'subproc'. For instance, +-- @echo runprog prog args@ is a variant of @runprog prog args@, which prints what +-- is being done before doing it. +-- +-- See 'runprog', 'subproc', 'exec'. +echo :: ( FilePath -> [String] -> IO () ) -- ^ Action to perform + -> FilePath -- ^ Name or path of the executable to run + -> [String] -- ^ Command line arguments + -> IO () +echo action path args = do + putStrLn (shell_command path args) + action path args + + +-- | Execute an external program. This replaces the running process. The path isn't searched, the environment isn't changed. In case of failure, +-- an IOError is thrown. +-- +-- >exec path args = +-- > execute_file path False args Nothing +-- +-- See 'execute_file', "HsShellScript#exec". +exec :: String -- ^ Full path to the executable + -> [String] -- ^ Command line arguments + -> IO a -- ^ Never returns +exec path args = + execute_file path False args Nothing + + +-- | Execute an external program. This replaces the running process. The path is searched, the environment isn't changed. In case of failure, +-- an IOError is thrown. +-- +-- >execp prog args = +-- > execute_file prog True args Nothing +-- +-- See 'execute_file', "HsShellScript#exec". +execp :: String -- ^ Name or path of the executable + -> [String] -- ^ Command line arguments + -> IO a -- ^ Never returns +execp prog args = + execute_file prog True args Nothing + + +-- | Execute an external program. This replaces the running process. The path isn't searched, the environment of the program is set as specified. In +-- case of failure, an IOError is thrown. +-- +-- >exece path args env = +-- > execute_file path False args (Just env) +-- +-- See 'execute_file', "HsShellScript#exec". +exece :: String -- ^ Full path to the executable + -> [String] -- ^ Command line arguments + -> [(String,String)] -- ^ New environment + -> IO a -- ^ Never returns +exece path args env = + execute_file path False args (Just env) + + +-- | Execute an external program. This replaces the running process. The path is searched, the environment of the program is set as specified. In +-- case of failure, an IOError is thrown. +-- +-- >execpe prog args env = +-- > execute_file prog True args (Just env) +-- +-- See 'execute_file', "HsShellScript#exec". +execpe :: String -- ^ Name or path of the executable + -> [String] -- ^ Command line arguments + -> [(String,String)] -- ^ New environment + -> IO a -- ^ Never returns +execpe prog args env = + execute_file prog True args (Just env) + + +{- | Build left handed pipe of stdout. + + \"@p -|- q@\" builds an IO action from the two IO actions @p@ and @q@. + @q@ is executed in an external process. The standard output of @p@ is sent + to the standard input of @q@ through a pipe. The result action consists + of forking off @q@ (connected with a pipe), and @p@. + + The result action does /not/ run @p@ in a separate process. So, the pipe + itself can be seen as a modified action @p@, forking a connected @q@. The + pipe is called \"left handed\", because @p@ remains unforked, and not @q@. + + /The exit code of q is silently ignored./ The process ID of the forked + copy of @q@ isn't returned to the caller, so it's lost. + + See "HsShellScript#subr" and + "HsShellScript#exec" for further details. + + Examples: + + >call (exec "/usr/bin/foo" [] -|- exec "/usr/bin/bar" []) + + >call ( execp "foo" ["..."] + > -|= ( -- Do something with foo's output + > do cnt <- lazy_contents "-" + > ... + > ) + > ) + + See 'subproc', '(=|-)', '(-|=)'. +-} +(-|-) :: IO a -- ^ Action which won't be forked + -> IO b -- ^ Action which will be forked and connected with a pipe + -> IO a -- ^ Result action +p -|- q = do + (Just h, _, _, _) <- pipe_fork_dup q True False False + res <- redirect stdout h p + hClose h + return res + + +{- | Build left handed pipe of stderr. + + \"@p =|- q@\" builds an IO action from the two IO actions @p@ and @q@. + @q@ is executed in an external process. The standard error output of @p@ is sent + to the standard input of @q@ through a pipe. The result action consists + of forking off @q@ (connected with a pipe), and @p@. + + The result action does /not/ run @p@ in a separate process. So, the pipe + itself can be seen as a modified action @p@, forking a connected @q@. The + pipe is called \"left handed\", because @p@ has this property, and not @q@. + + /The exit code of q is silently ignored./ The process ID of the forked + copy of @q@ isn't returned to the caller, so it's lost. + + See "HsShellScript#subr" and + "HsShellScript#exec" for further details. + + Example: + +>call (exec "/usr/bin/foo" [] =|- exec "/usr/bin/bar" []) + + See 'subproc', '(-|-)', '(-|=)'. +-} +(=|-) :: IO a -- ^ Action which won't be forked + -> IO b -- ^ Action which will be forked and connected with a pipe + -> IO a -- ^ Result action +p =|- q = do + (Just h, _, _, _) <- pipe_fork_dup q True False False + res <- redirect stderr h p + hClose h + return res + + +{- | Build right handed pipe of stdout. + + \"@p -|= q@\" builds an IO action from the two IO actions @p@ and @q@. + @p@ is executed in an external process. The standard output of @p@ is sent + to the standard input of @q@ through a pipe. The result action consists + of forking off @p@ (connected with a pipe), and @q@. + + The result action does /not/ run @q@ in a separate process. So, the pipe + itself can be seen as a modified action @q@, forking a connected @p@. + The pipe is called \"right + handed\", because @q@ has this property, and not @p@. + + /The exit code of p is silently ignored./ The process ID of the forked + copy of @q@ isn't returned to the caller, so it's lost. + + See "HsShellScript#subr" and + "HsShellScript#exec" for further details. + + Example: + + >@call (exec \"\/usr\/bin\/foo\" [] -|= exec \"\/usr\/bin\/bar\" [])@ + + See 'subproc', '(=|-)', '(=|=)'. +-} +(-|=) :: IO a -- ^ Action which will be forked and connected with a pipe + -> IO b -- ^ Action which won't be forked + -> IO b -- ^ Result action +p -|= q = do + (_, Just h, _, _) <- pipe_fork_dup p False True False + res <- redirect stdin h q + hClose h + return res + +{- | Build right handed pipe of stderr. + + \"@p =|= q@\" builds an IO action from the two IO actions @p@ and @q@. + @p@ is executed in an external process. The standard error output of @p@ is sent + to the standard input of @q@ through a pipe. The result action consists + of forking off @p@ (connected with a pipe), and @q@. + + The result action does /not/ run @q@ in a separate process. So, the pipe + itself can be seen as a modified action @q@, forking a connected @p@. + The pipe is called \"right + handed\", because @q@ has this property, and not @p@. + + /The exit code of p is silently ignored./ The process ID of the forked + copy of @q@ isn't returned to the caller, so it's lost. + + See "HsShellScript#subr" and + "HsShellScript#exec" for further details. + + Example: + + > call (exec "/usr/bin/foo" [] =|= exec "/usr/bin/bar" []) + + See 'subproc', '=|-', '-|='. +-} +(=|=) :: IO a -- ^ Action which will be forked and connected with a pipe + -> IO b -- ^ Action which won't be forked + -> IO b -- ^ Result action +p =|= q = do + (_, _, Just h, _) <- pipe_fork_dup p False False True + res <- redirect stdin h q + hClose h + return res + + +-- | Temporarily replace a handle. This makes a backup copy of the original handle (typically a standard handle), overwrites it with the specified one, +-- runs the specified action, and restores the handle from the backup. +-- +-- Example: +-- +-- > h <- openFile "/tmp/log" WriteMode +-- > redirect stdout h io +-- > hClose h +-- +-- This is the same as +-- +-- > io ->- "/tmp/log" +-- +-- See '-|-', '=|-'. +redirect :: Handle -- ^ Handle to replace + -> Handle -- ^ Handle to replace it with + -> IO a -- ^ Action + -> IO a +redirect handle replacement io = + bracket (do bak <- hDuplicate handle + hDuplicateTo replacement handle + return bak + ) + (\bak -> do hDuplicateTo bak handle + hClose bak + ) + (\_ -> io) + + +redirect_helper stdh mode io path = do + h <- openFile path mode + res <- redirect stdh h io + hClose h + return res + + +{- | Redirect the standard output of the specified IO action to a file. The file will be overwritten, if it already exists. + +What's actually modified is the @stdout@ handle, not the file descriptor 1. The +@exec@ functions know about this. See "HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +Example: + +>run "/some/program" [] ->- "/tmp/output" + +Note: You can't redirect to @\"\/dev\/null\"@ this way, because GHC 6.4's @openFile@ throws an \"invalid argument\" +IOError. (This may be a bug in the GHC 6.4 libraries). Use @->>-@ instead. + +See 'subproc', 'runprog', '->>-', '=>-'. +-} +(->-) :: IO a -- ^ Action, whose output will be redirected + -> FilePath -- ^ File to redirect the output to + -> IO a -- ^ Result action +(->-) = + redirect_helper stdout WriteMode + + +{- | Redirect the standard output of the specified IO action to a file. If the file already exists, the output will be appended. + +What's actually modified is the @stdout@ handle, not the file descriptor 1. The +@exec@ functions know about this. See "HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +Example: + +>run "/some/noisy/program" [] ->>- "/dev/null" + +See 'subproc', 'runprog', '(->-)', '(=>>-)'. +-} +(->>-) :: IO a -- ^ Action, whose output will be redirected + -> FilePath -- ^ File to redirect the output to + -> IO a -- ^ Result action +(->>-) = + redirect_helper stdout AppendMode + + +{- | Redirect the standard error output of the specified IO action to a file. If the file already exists, it will be overwritten. + +What's actually modified is the @stderr@ handle, not the file descriptor 2. The +@exec@ functions know about this. See "HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +Note: You can't redirect to @\"\/dev\/null\"@ this way, because GHC 6.4's @openFile@ throws an \"invalid argument\" +IOError. (This may be a bug in the GHC 6.4 libraries). Use @=>>-@ instead. + +Example: + +>run "/path/to/foo" [] =>- "/tmp/errlog" + +See 'subproc', 'runprog', '(->-)', '(=>>-)'. +-} +(=>-) :: IO a -- ^ Action, whose error output will be redirected + -> FilePath -- ^ File to redirect the error output to + -> IO a -- ^ Result action +(=>-) = + redirect_helper stderr WriteMode + + +{- | Redirect the standard error output of the specified IO action to a file. If the file already exists, the output will be appended. + +What's actually modified is the @stderr@ handle, not the file descriptor 2. The +@exec@ functions know about this. See "HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +Example: + +>run "/some/program" [] =>>- "/dev/null" + +See 'subproc', 'runprog', '(->>-)', '(=>-)'. +-} +(=>>-) :: IO a -- ^ Action, whose error output will be redirected + -> FilePath -- ^ File to redirect the error output to + -> IO a -- ^ Result action +(=>>-) = + redirect_helper stderr AppendMode + + +{- | Redirect both stdout and stderr to a file. This is equivalent to the +shell's @&>@ operator. If the file already exists, it will be overwritten. + +What's actually modified are the @stdout@ and @stderr@ handles, not the file +descriptors 1 and 2. The @exec@ functions know about this. See +"HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +Note: You can't redirect to @\"\/dev\/null\"@ this way, because GHC 6.4's @openFile@ throws an \"invalid argument\" +IOError. (This may be a bug in the GHC 6.4 libraries). Use @-&>>-@ instead. + +>(-&>-) io path = err_to_out io ->- path + +Example: + +@call (exec \"\/path\/to\/foo\" [] -&\>- \"log\")@ + +See '(-&>>-)', 'err_to_out'. +-} +(-&>-) :: IO a -- ^ Action, whose output and error output will be redirected + -> FilePath -- ^ File to redirect to + -> IO a -- ^ Result action +(-&>-) io path = err_to_out io ->- path + + +{- | Redirect both stdout and stderr to a file. If the file already exists, the + output will be appended. + +What's actually modified are the @stdout@ and @stderr@ handles, not the file +descriptors 1 and 2. The @exec@ functions know about this. See +"HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +>(-&>>-) io path = (err_to_out >> io) ->>- path + +Example: + +>run "/some/noisy/program" [] -&>>- "/dev/null" + +See '(-&>-)', 'out_to_err'. +-} +(-&>>-) :: IO a -- ^ Action, whose output and error output will be redirected + -> FilePath -- ^ File to redirect to + -> IO a -- ^ Result action +(-&>>-) io path = + err_to_out io ->>- path + + +{- | Redirect stdin from a file. This modifies the specified action, such +that the standard input is read from a file. + + What's actually modified is the @stdin@ handle, not the file + descriptor 0. The @exec@ functions know about this. See + "HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +Example: + +@call (exec \"\/path\/to\/foo\" [] -\<- \"bar\")@ + +See 'exec', 'runprog', '(->-)', '(=>-)'. +-} +(-<-) :: IO a + -> FilePath + -> IO a +(-<-) = redirect_helper stdin ReadMode + + +{- | Send the error output of the specified action to its standard output. + +What's actually modified is the @stdout@ handle, not the file descriptor 1. The +@exec@ functions know about this. See "HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +>err_to_out = redirect stderr stdout + +See 'redirect'. +-} +err_to_out :: IO a -> IO a +err_to_out = redirect stderr stdout + + +{- | Send the output of the specified action to its standard error output. + +What's actually modified is the @stderr@ handle, not the file descriptor 2. The +@exec@ functions know about this. See "HsShellScript#fdpipes" and +"HsShellScript#exec" for details. + +>redirect stdout stderr + +See 'redirect'. +-} +out_to_err :: IO a -> IO a +out_to_err = redirect stdout stderr + + +-- Run an IO action as a new process, and optionally connect its +-- stdin, stdout and stderr via pipes. +pipe_fork_dup :: IO a -- Action to run in a new process. + -> Bool -- make stdin pipe? + -> Bool -- make stdout pipe? + -> Bool -- make stderr pipe? + -> IO ( Maybe Handle -- Handle to the new process's stdin, if applicable. + , Maybe Handle -- Handle to the new process's stdout, if applicable. + , Maybe Handle -- Handle to the new process's stderr, if applicable. + , ProcessID + ) +pipe_fork_dup io fd0 fd1 fd2 = do + flush_outerr + + pipe0 <- pipe_if fd0 + pipe1 <- pipe_if fd1 + pipe2 <- pipe_if fd2 + + pid <- forkProcess (do -- child + dup_close pipe0 stdin True + dup_close pipe1 stdout False + dup_close pipe2 stderr False + child io + ) + -- parent + h0 <- finish_pipe pipe0 True + h1 <- finish_pipe pipe1 False + h2 <- finish_pipe pipe2 False + return (h0, h1, h2, pid) + + where + -- Make a pipe, if applicable. + pipe_if False = return Nothing + --pipe_if True = fmap Just $ createPipe -- Just (read,write) + pipe_if True = do + (read, write) <- createPipe + return (Just (read,write)) + + -- Child work after fork: connect a fd of the new process to the pipe. + dup_close :: Maybe (Fd, Fd) -- maybe the pipe + -> Handle -- which handle descriptor to connect to the pipe + -> Bool -- whether the child reads from this pipe + -> IO () + dup_close Nothing _ _ = + return () + dup_close m@(Just (readend,writeend)) dest True = + do + h <- System.Posix.fdToHandle readend + hDuplicateTo h dest + hClose h + closeFd writeend + dup_close m@(Just (readend,writeend)) dest False = + do h <- System.Posix.fdToHandle writeend + hDuplicateTo h dest + hClose h + closeFd readend + + -- Parent work after fork: close surplus end of the pipe and make a handle from the other end. + finish_pipe :: Maybe (Fd, Fd) -- maybe the pipe + -> Bool -- whether the fd is for reading + -> IO (Maybe Handle) + finish_pipe Nothing _ = + return Nothing + finish_pipe (Just (readend,writeend)) read = + do closeFd (if read then readend else writeend) + let fd = if read then writeend else readend + h <- System.Posix.fdToHandle fd + return (Just h) + + +-- | Run an IO action as a separate process, and pipe some text to its @stdin@. +-- Then close the pipe and wait for the child process to finish. If it +-- exits in a way which indicates an error, the @ProcessStatus@ is thrown. +-- +-- Example: @pipe_to \"blah\" $ exec \"\/usr\/bin\/foo\" [\"bar\"]@ +-- +-- See 'subproc', 'runprog', '-<-', 'h_pipe_to'. See "HsShellScript#fdpipes" for more details. +pipe_to :: String -- ^ Text to pipe + -> IO a -- ^ Action to run as a separate process, and to pipe to + -> IO () +pipe_to str io = do + (h, pid) <- h_pipe_to io + hPutStr h str + hClose h + (Just ps) <- getProcessStatus True False pid + if ps == Exited ExitSuccess + then return () + else throw ps + + +-- | Run an IO action as a separate process, and connect to its @stdin@ +-- with a pipe. +-- +-- Example: @h \<- h_pipe_to $ exec \"\/usr\/bin\/foo\" [\"bar\"]@ +-- +-- See '-<-', 'pipe_to', 'pipe_from', 'pipe_from2'. See "HsShellScript#fdpipes" for more details. +h_pipe_to :: IO a -- ^ Action to run as a separate process, and to pipe to + -> IO (Handle, ProcessID) -- ^ Returns handle connected to the standard input of the child process, and the child's process ID +h_pipe_to io = do + (Just h, _, _, pid) <- pipe_fork_dup io True False False + return (h, pid) + + +-- | Run an IO action as a separate process, and read its @stdout@ +-- strictly. Then wait for the child process to finish. This is like the +-- backquote feature of shells. +-- +-- If the child process exits with a non-zero exit code, the +-- @ProcessStatus@ is thrown. +-- +-- The whole output is returned, no trailing newline character is removed, like the shell does with backquotes. You may want to apply @chomp@ +-- to the result. +-- +-- Example: +-- +-- >output <- pipe_from $ exec "/bin/foo" ["bar"] +-- +-- See 'exec', 'pipe_to', 'pipe_from2', 'h_pipe_from', 'lazy_pipe_from', 'chomp', 'silently'. See "HsShellScript#fdpipes" for more details. +pipe_from :: IO a -- ^ Action to run as a separate process + -> IO String -- ^ The called program's standard output +pipe_from io = do + (h, pid) <- h_pipe_from io + txt <- hGetContents h + seq (length txt) (hClose h) + (Just ps) <- getProcessStatus True False pid + if ps == Exited ExitSuccess + then return txt + else throw ps + + +-- | Run an IO action as a separate process, and read its @stderr@ +-- strictly. Then wait for the child process to finish, and return the text +-- along with its exit code. +-- +-- Example: +-- +-- >(errmsg, ec) <- pipe_from2 $ exec "/bin/foo" ["bar"] ->- "/dev/null" +-- > +-- >when (ec /= Exited ExitSuccess) $ do +-- > errm errmsg +-- > ... +-- +-- See 'exec', 'pipe_to', 'pipe_from', 'h_pipe_from2', 'lazy_pipe_from2', 'silently'. See "HsShellScript#fdpipes" for more details. +pipe_from2 :: IO a -- ^ Action to run as a separate process + -> IO (String, ProcessStatus) -- ^ The called program's standard output +pipe_from2 io = do + (h, pid) <- h_pipe_from2 io + txt <- hGetContents h + seq (length txt) (hClose h) + (Just ps) <- getProcessStatus True False pid + return (txt, ps) + + +-- | Run an IO action as a separate process, and connect to its @stdout@ +-- with a pipe. +-- +-- A handle connected to the child process, and the process ID +-- of the child are returned. The process ID can be used with +-- @System.Posix.getProcessStatus@ to get the child's exit code. You must either +-- ensure that all data has been read, or close the handle, before calling +-- @getProcessStatus@ blockingly. Otherwise you'll get a deadlock. When you +-- close the handle before all data has been read, then the child gets a +-- @SIGPIPE@ signal. +-- +-- Example: +-- +-- >h <- h_pipe_from $ exec "/usr/bin/foo" ["bar"] +-- +-- See 'exec', 'pipe_to', 'h_pipe_from2', 'pipe_from', 'lazy_pipe_from', 'chomp', 'silently'. See "HsShellScript#fdpipes" for more details. +h_pipe_from :: IO a -- ^ Action to run as a separate process, and to pipe from + -> IO (Handle, ProcessID) -- ^ Returns handle connected to the standard output of the child process, and the child's process ID +h_pipe_from io = do + (_, Just h, _, pid) <- pipe_fork_dup io False True False + return (h, pid) + + +-- | Run an IO action as a separate process, and connect to its @stderr@ +-- with a pipe. +-- +-- A handle connected to the child process' standard error output, and the process ID +-- of the child are returned. The process ID can be used with +-- @System.Posix.getProcessStatus@ to get the child's exit code. You must either +-- ensure that all data has been read, or close the handle, before calling +-- @getProcessStatus@ blockingly. Otherwise you'll get a deadlock. When you +-- close the handle before all data has been read, then the child gets a +-- @SIGPIPE@ signal. Of course, you can also use the process ID to kill the +-- child process. +-- +-- Example: +-- +-- >h <- h_pipe_from2 $ exec "/usr/bin/foo" ["bar"] +-- +-- See 'exec', 'pipe_to', 'h_pipe_from', 'pipe_from2', 'lazy_pipe_from2', 'chomp', 'silently'. See "HsShellScript#fdpipes" for more details. +h_pipe_from2 :: IO a -- ^ Action to run as a separate process, and to pipe from + -> IO (Handle, ProcessID) -- ^ Returns handle connected to the standard output of the child process, and the child's process ID +h_pipe_from2 io = do + (_, _, Just h, pid) <- pipe_fork_dup io False False True + return (h, pid) + + +-- | Run an IO action as a separate process, and read its @stdout@, +-- This is like the backquote feature of shells. The output is read +-- lazily, as the returned string is evaluated. +-- +-- The child's output along with its process ID are returned. The process ID can +-- be used with @System.Posix.getProcessStatus@ to get the child process' exit +-- code. Be aware that you must evaluate the whole string, before calling +-- @getProcessStatus@ blockingly, or you'll get a deadlock. +-- +-- The whole output is returned, no trailing newline character is removed, like +-- the shell does with backquotes. You'll possibly want to apply 'chomp' to the +-- result. +-- +-- Example: +-- +-- >(txt, pid) <- lazy_pipe_from $ exec "/usr/bin/foo" ["bar"] +-- >... +-- >-- Done, but must read the rest of the output +-- >seq (length txt) (return ()) +-- >(Just ps) <- getProcessStatus True False pid +-- +-- See 'exec', 'pipe_to', 'pipe_from', 'h_pipe_from', 'lazy_pipe_from2', 'silently'. See "HsShellScript#fdpipes" for more details. +lazy_pipe_from :: IO a -- ^ Action to run as a separate process + -> IO (String, ProcessID) -- ^ The action's lazy output and the process ID of the child process +lazy_pipe_from io = do + (_, Just h, _, pid) <- pipe_fork_dup io False True False + txt <- hGetContents h + return (txt, pid) + + +-- | Run an IO action as a separate process, and read its @stderr@. The output +-- is read lazily, as the returned string is evaluated. +-- +-- The child's error output along with its process ID are returned. The process +-- ID can be used with @System.Posix.getProcessStatus@ to get the child process' +-- exit code. Be aware that you must evaluate the whole string, before calling +-- @getProcessStatus@ blockingly, or you'll get a deadlock. +-- +-- Example: +-- +-- >(errmsg, pid) <- lazy_pipe_from2 $ exec "/usr/bin/foo" ["bar"] ->- "/dev/null" +-- >... +-- >-- Read enough error messages, terminate the child. +-- >signalProcess killProcess pid +-- > +-- >-- Make sure the file descriptor gets closed, or you may run out of file descriptors. +-- >seq (length errmsg) (return ()) +-- +-- See 'exec', 'pipe_to', 'pipe_from2', 'h_pipe_from2', 'lazy_pipe_from', 'silently'. See "HsShellScript#fdpipes" for more details. +lazy_pipe_from2 :: IO a -- ^ Action to run as a separate process + -> IO (String, ProcessID) -- ^ The action's lazy output and the process ID of the child process +lazy_pipe_from2 io = do + (_, Just h, _, pid) <- pipe_fork_dup io False True False + txt <- hGetContents h + return (txt, pid) + + +-- | Run an IO action as a separate process, and optionally connect to its +-- @stdin@, its @stdout@ and its @stderr@ output with +-- pipes. +-- +-- See 'pipe_from', 'pipe_from2', 'pipe_to'. +pipes :: IO a -- ^ Action to run in a new process + -> Bool -- ^ Whether to make stdin pipe + -> Bool -- ^ Whether to make stdout pipe + -> Bool -- ^ Whether to make stderr pipe + -> IO ( Maybe Handle + , Maybe Handle + , Maybe Handle + , ProcessID + ) -- ^ Pipes to the new process's @stdin@, @stdout@ and @stderr@, if applicable; and its process id. +pipes = pipe_fork_dup + + +-- {- | Execute the supplied action. In case of an error, exit with an error +-- message. +-- +-- > Noch nicht auf neue Exception-Bibliothek portiert. < +-- +-- An error is an exception, thrown using @throw@ as a type which is +-- instance of @Typeable@. The type err is supposed to be a specific type used +-- for specific errors. The program is terminated with @exitFailure@. +-- -} +-- abort :: Exception err +-- => (err -> String) -- ^ Error message generation function +-- -> IO a -- ^ IO action to monitor +-- -> IO a -- ^ Same action, but abort with error message in case of user exception +-- abort msgf io = +-- io +-- `catch` (\se -> hPutStrLn stderr (msgf errval) >> exitFailure) + + +{- | Forcibly terminate the program, circumventing normal program shutdown. + +This is the @_exit(2)@ system call. No cleanup actions installed with @bracket@ +are performed, no data buffered by file handles is written out, etc. +-} +_exit :: Int -- ^ Exit code + -> IO a -- ^ Never returns +_exit ec = do + {#call _exit as _exit_prim#} (fromIntegral ec) + error "Impossible error" -- never reached, only for the type checker + + + +-- | Generate an error message from an @errno@ value. This is the POSIX +-- @strerror@ system library function. +-- +-- See the man page @strerror(3)@. +strerror :: Errno -- ^ @errno@ value + -> IO String -- ^ Corresponding error message +strerror (Errno errno) = do + peekCString ({#call pure strerror as foreign_strerror#} errno) + + +-- | Read the global system error number. This is the POSIX @errno@ value. This +-- function is redundant. Use @Foreign.C.Error.getErrno@ instead. +errno :: IO Errno -- ^ @errno@ value +errno = getErrno + + +-- | Print error message corresponding to the specified @errno@ error +-- number. This is similar to the POSIX system library function @perror@. +-- +-- See the man page @perror(3)@. +perror' :: Errno -- ^ @errno@ error number + -> String -- ^ Text to precede the message, separated by \"@: @\" + -> IO () +perror' errno txt = do + str <- strerror errno + hPutStrLn stderr ((if txt == "" then "" else txt ++ ": ") ++ str) + + +-- | Print error message corresponding to the global @errno@ error +-- number. This is the same as the POSIX system library function @perror@. +-- +-- See the man page @perror(3)@. +perror :: String -- ^ Text to precede the message, separated by \"@: @\" + -> IO () +perror txt = do + eno <- getErrno + perror' eno txt + + +-- | Print a message to @stderr@ and exit with an exit code +-- indicating an error. +-- +-- >failIO msg = hPutStrLn stderr msg >> exitFailure +failIO :: String -> IO a +failIO meld = + hPutStrLn stderr meld >> exitFailure + + +-- | Modify an IO action to return the exit code of a failed program call, +-- instead of throwing an exception. +-- +-- This is used to modify the error reporting behaviour of an IO action which +-- uses 'run'/'runprog' or 'call'/'subproc'. When an external program exits with +-- an exit code which indicates an error, normally an exception is thrown. After +-- @exitcode@ has been applied, the exit code is retruned instead. +-- +-- The caught exceptions are 'RunError' and 'ProcessStatus'. Termination by a +-- signal is still reported by an exception, which is passed through. +-- +-- Example: @ec \<- exitcode $ runprog \"foo\" [\"bar\"]@ +-- +-- See 'runprog', 'subproc', 'run', 'call'. +exitcode :: IO () -- ^ Action to modify + -> IO ExitCode -- ^ Modified action +exitcode io = + do io + return ExitSuccess + `catch` + (\processstatus -> + case processstatus of + (Exited ec) -> return ec + ps -> throw ps) + `catch` + (\re -> + case re_ps re of + (Exited ec) -> return ec + ps -> throw re) + + +-- |Create and throw an @IOError@ from the current @errno@ value, an optional handle and an optional file name. +-- +-- This is an extended version of the @Foreign.C.Error.throwErrno@ function +-- from the GHC libraries, which additionally allows to specify a handle and a file +-- name to include in the @IOError@ thrown. +-- +-- See @Foreign.C.Error.throwErrno@, @Foreign.C.Error.errnoToIOError@. +throwErrno' :: String -- ^ Description of the location where the error occurs in the program + -> Maybe Handle -- ^ Optional handle + -> Maybe FilePath -- ^ Optional file name (for failing operations on files) + -> IO a +throwErrno' loc maybe_handle maybe_filename = + do + errno <- getErrno + ioError (errnoToIOError loc errno maybe_handle maybe_filename) + + +-- |Convert an @IOError@ to a string. +-- +-- There is an instance declaration of @IOError@ in @Show@ in the @GHC.IO@ library, but @show_ioerror@ produces a more readable, and more +-- complete, message. +show_ioerror :: IOError -> String +show_ioerror ioe = + "IO-Error\n\ + \ Error type: " ++ show (ioeGetErrorType ioe) ++ "\n\ + \ Location: " ++ none (indent (ioe_location ioe)) ++ "\n\ + \ Description: " ++ none (indent (ioe_description ioe)) ++ "\n\ + \ " ++ fn (ioeGetFileName ioe) + where fn (Just n) = "File name: " ++ quote n + fn Nothing = "File name: (none)" + none "" = "(none)" + none msg = msg + indent txt = concat (intersperse ("\n ") (lines txt)) + + +{- | + Call the shell to execute a command. In case of an error, throw the @ProcessStatus@ (such as @(Exited (ExitFailure ec))@) as an exception. + This is like the Haskell standard library function @system@, except that error handling is brought in accordance with HsShellScript\'s scheme. + + @exitcode . system_throw@ is the same as the @system@ function, except that when the called shell is terminated or stopped by a signal, this still + lead to the @ProcessStatus@ being thrown. The Haskell library report says nothing about what happens in this case, when using the + @system@ function. + +>system_throw cmd = run "/bin/sh" ["-c", "--", cmd] + + This function is deprecated. You should rather use 'system_runprog', which provides for much better error reporting. +-} +-- This function should go to HsShellScript.Shell, but this would introduce a circular dependency. +system_throw :: String -> IO () +system_throw cmd = + run "/bin/sh" ["-c", "--", cmd] + + + + +{- | + Call the shell to execute a command. In case of an error, a @RunError@ ist thrown. + This is like the Haskell standard library function @system@, except that error handling is brought in accordance with HsShellScript's scheme. (It is + /not/ a front end to @system@.) + +>system_runprog cmd = runprog "/bin/sh" ["-c", "--", cmd] + + Example: Call \"foo\" and report Errors as @IOError@s, rather than @RunError@s. + +>as_ioe $ system_runprog "foo" ["bar", "baz"] + + See 'RunError', 'as_ioe' +-} +-- This function should go to HsShellScript.Shell, but this would introduce a circular dependency. +system_runprog :: String -> IO () +system_runprog cmd = + runprog "/bin/sh" ["-c", "--", cmd] + + + +{- | Run a subroutine as a child process, but don't let it produce any messages. +Read its @stdout@ and @stderr@ instead, and append it to the contents of a +mutable variable. The idea is that you can run some commands silently, and +report them and their messages to the user only when something goes wrong. + +If the child process terminates in a way which indicates an error, then the +process status is thrown, in the same way as 'runprog' does. If the subroutine +throws an @(Exited ec)@ exception (of type @ProcessStatus@), such as thrown by +'runprog', then the child process exits with the same exit code, such that the +parent process reports it to the caller, again as a @ProcessStatus@ exception. + +When the subroutine finishes, the child process is terminated with @'_exit' 0@. +When it throws an exception, an error message is printed and it is terminated +with @'_exit' 1@. See "HsShellScript#subr" for details. + +The standard output (and the standard error output) of the parent process are +flushed before the fork, such that no output appears twice. + +Example: + +>let handler :: IORef String -> ProcessStatus -> IO () +> handler msgref ps = do hPutStrLn stderr ("Command failed with " ++ show ps ++ ". Actions so far: ") +> msg <- readIORef msgref +> hPutStrLn stderr msg +> exitWith (ExitFailure 1) +> +>msgref <- newIORef "" +>do silently msgref $ do putStrLn "Now doing foobar:" +> echo exec "/foo/bar" ["arguments"] +> silently msgref $ echo exec "/bar/baz" ["arguments"] +>`catch` (handler msgref) + +See 'lazy_pipe_from', 'subproc', 'runprog', Data.IORef. +-} +silently :: IORef.IORef String -- ^ A mutable variable, which gets the output (stdout and stderr) of the action appended. + -> IO () -- ^ The IO action to run. + -> IO () +silently ref io = do + (msg, pid) <- lazy_pipe_from (err_to_out (child io)) + seq (length msg) (return ()) + + msgs <- readIORef ref + writeIORef ref (msgs ++ msg) + + (Just ps) <- getProcessStatus True False pid + case ps of + Exited ExitSuccess -> return () + ps -> throw ps + + +{- | Modify a subroutine action in order to make it suitable to run as a child + process. + + This is used by functions like 'call', 'silently', 'pipe_to' etc. The action + is executed. When it returns, the (child) process is terminated with @'_exit' 0@ + (after flushing @stdout@), circumventing normal program shutdown. When it + throws an exception, an error message is printed and the (child) process is + terminated with @'_exit' 1@. +-} +child :: IO a -- Action to modify + -> IO b -- Never returns +child io = do + (io `finally` flush_outerr) + `catches` + [ Handler $ (\argerror -> do + errm $ "In child process:\n" ++ argerror_message argerror + _exit 1 + ) + , Handler $ (\processstatus -> do + errm $ "Process error in child process. Process status = " ++ show ( processstatus :: ProcessStatus ) + _exit 1 + ) + , Handler $ (\(ioe::IOError) -> do + errm ("In child process:\n " ++ show_ioerror ioe) + _exit 1 + ) + , Handler $ (\(e::ExitCode) -> do + -- Child process is a subroutine that has terminated normally. + errm "Warning! Child process tries to shut down normally. This is a bug. It should\n\ + \terminate with _exit (or catch the ExitException yourself). See section\n\"\ + \Running a Subroutine in a Separate Process\" in the HsShellScript API\n\ + \documentation. Terminating with _exit 0 now." + _exit (case e of + ExitSuccess -> 0 + ExitFailure ec' -> ec' + )) + , Handler $ (\(e::SomeException) -> do + errm ("Child process quit with unexpected exception:\n" ++ show e) + _exit 1 + ) + ] + + _exit 0 + + +{- | Print text to @stdout@. + + This is a shorthand for @putStrLn@, except for @stderr@ being flushed + beforehand. This way normal output and error output appear in + order, even when they aren't buffered as by default. + + An additional newline is printed at the end. + + >outm msg = do + > hFlush stderr + > putStrLn msg +-} +outm :: String -- ^ Message to print + -> IO () +outm msg = do + hFlush stderr + putStrLn msg + + +{- | Print text to @stdout@. + + This is a shorthand for @putStr@, except for @stderr@ being flushed + beforehand. This way normal output and error output appear in + order, even when they aren't buffered as by default. + + No newline is printed at the end. + + >outm_ msg = do + > hFlush stderr + > putStr msg +-} +outm_ :: String -- ^ Message to print + -> IO () +outm_ msg = do + hFlush stderr + putStr msg + + +{- | Colorful log message to @stderr@. + + This prints a message to @stderr@. When @stderr@ is connected to a terminal + (as determined by @isatty(3)@), additional escape sequences are printed, + which make the message appear in cyan. Additionally, a newline character is + output at the end. + + @stdout@ is flushed beforehand. So normal output and error output appear in + order, even when they aren't buffered as by default. + + See 'logm_', 'errm', 'errm_'. +-} +logm :: String -- ^ Message to print + -> IO () +logm msg = + do hFlush stdout + tty <- isatty stderr + if tty + then hPutStrLn stderr $ "\ESC[36m" ++ msg ++ "\ESC[00m" + else hPutStrLn stderr msg + + +{- | Colorful log message to @stderr@. + + This prints a message to @stderr@. When @stderr@ is connected to a terminal + (as determined by @isatty(3)@), additional escape sequences are printed, + which make the message appear in cyan. No a newline character is output at the end. + + @stdout@ is flushed beforehand. So normal output and error output appear in + order, even when they aren't buffered as by default. + + See 'logm', 'errm', 'errm_'. +-} +logm_ :: String -> IO () +logm_ msg = do + do hFlush stdout + tty <- isatty stderr + if tty + then hPutStr stderr $ "\ESC[36m" ++ msg ++ "\ESC[00m" + else hPutStr stderr msg + + +{- | Colorful error message to @stderr@. + + This prints a message to @stderr@. When @stderr@ is connected to a terminal + (as determined by @isatty(3)@), additional escape sequences are printed, + which make the message appear in red. Additionally, a newline character is + output at the end. + + @stdout@ is flushed beforehand. So normal output and error output appear in + order, even when they aren't buffered as by default. + + See 'logm', 'logm_', 'errm_'. +-} +errm :: String -> IO () +errm msg = do + do hFlush stdout + tty <- isatty stderr + if tty + then hPutStrLn stderr $ "\ESC[01;31m" ++ msg ++ "\ESC[00m" + else hPutStrLn stderr msg + + +{- | Colorful error message to @stderr@. + + This prints a message to @stderr@. When @stderr@ is connected to a terminal + (as determined by @isatty(3)@), additional escape sequences are printed, + which make the message appear in red. No a newline character is output at the end. + + @stdout@ is flushed beforehand. So normal output and error output appear in + order, even when they aren't buffered as by default. + + See 'logm', 'logm_', 'errm'. +-} +errm_ :: String -> IO () +errm_ msg = do + do hFlush stdout + tty <- isatty stderr + if tty + then hPutStr stderr $ "\ESC[01;31m" ++ msg ++ "\ESC[00m" + else hPutStr stderr msg + + +{- | In case the specified action throws an IOError, fill in its filename field. This way, more useful error messages can be produced. + +Example: + +>-- Oh, the GHC libraries neglect to fill in the file name +>executeFile' prog a b c = +> fill_in_filename prog $ executeFile prog a b c + +See 'fill_in_location', 'add_location'. +-} +fill_in_filename :: String -- ^ File name to fill in + -> IO a -- ^ IO action to modify + -> IO a -- ^ Modified IO action +fill_in_filename filename io = + io `catch` (\ioe -> ioError (ioeSetFileName ioe filename)) + + +{- | In case the specified action throws an IOError, fill in its location field. This way, more useful error messages can be produced. + +Example: + +>my_fun a b c = do +> -- ... +> fill_in_location "my_fun" $ -- Give the caller a more useful location information in case of failure +> rename "foo" "bar" +> -- ... + +See 'fill_in_filename'. +-} +fill_in_location :: String -- ^ Location name to fill in + -> IO a -- ^ IO action to modify + -> IO a -- ^ Modified IO action +fill_in_location location io = + io `catch` (\ioe -> ioError (ioeSetLocation ioe location)) + + +{- | In case the specified action throws an IOError, add a line to its location field. This way, more useful error messages can be produced. The + specified string is prepended to the old location, separating it with a newline from the previous location, if any. When using this thoroughly, you + get a reverse call stack in IOErrors. + +Example: + +>my_fun = +> add_location "my_fun" $ do +> -- ... + +See 'fill_in_filename', 'fill_in_location'. +-} +add_location :: String -- ^ Location name to add + -> IO a -- ^ IO action to modify + -> IO a -- ^ Modified IO action +add_location location io = + io `catch` (\ioe -> let loc = case ioe_location ioe of + "" -> location + loc0 -> location ++ "\n" ++ loc0 + in ioError (ioe { ioe_location = loc }) + ) + + +{- | This is a replacement for @System.Posix.Process.executeFile@. It does + additional preparations, then calls @executeFile@. @executeFile@ /can't normally/ + /be used directly, because it doesn't do the things which are/ + /outlined here./ + + This are the differences to @executeFile@: + + 1. @stdout@ and @stderr@ are flushed. + + 2. The standard file descriptors 0-2 are made copies of the file descriptors + which the standard handles currently use. This is necessary because they + might no longer use the standard handles. See "HsShellScript#fdpipes". + + If the standard handles @stdin@, @stdout@, @stderr@ aren't in closed state, + and they aren't already connected to the respective standard file + descriptors, their file descriptors are copied to the respective standard + file descriptors (with @dup2@). Backup copies are made of the file + descriptors which are overwritten. If some of the standard handles are closed, + the corresponding standard file descriptors are closed as well. + + 3. All file descriptors, except for the standard ones, are set to close-on-exec + (see @fcntl(2)@), and will be closed on successful replacement of + the process. Before that, the old file descriptor flags are saved. + + 4. The standard file descriptors are set to blocking mode, since GHC 6.2.2 + sets file descriptors to non-blocking (except 0-2, which may get + overwritten by a non-blocking one in step 2). The called program + doesn't expect that. + + 5. In case replacing the process fails, the file descriptors are reset to + the original state. The file descriptors flags are restored, and the file + descriptors 0-2 are overwritten again, with their backup copies. Then an + IOError is thrown. + + 6. In any IOError, the program is filled in as the file name (@executeFile@ + neglects this). + + 7. The return type is a generic @a@, rather than @()@. + + Also see "HsShellScript#exec". +-} +execute_file :: FilePath -- ^ Program to call + -> Bool -- ^ Search @PATH@? + -> [String] -- ^ Arguments + -> Maybe [(String, String)] -- ^ Optionally new environment + -> IO a -- ^ Never returns +execute_file path search args menv = + fill_in_filename path $ fill_in_location "execute_file" $ do + bracket + (do -- Flush stdout and stderr, if open + flush_outerr + + -- Make fds 0-2 copies of the things which the standard handles refer to. + recover0 <- restore stdin 0 + recover1 <- restore stdout 1 + recover2 <- restore stderr 2 + + -- Save the flags of all file descriptors + fdflags <- {# call c_save_fdflags #} + + -- Prepare all fds for subsequent exec. Fds 0-2 are set to blocking (because GHC sets new fds to non-blocking). All + -- others are set to close-on-exec. + {# call c_prepare_fd_flags_for_exec #} + + return (recover0, recover1, recover2, fdflags) + ) + (\(recover0, recover1, recover2, fdflags) -> + do -- Failure of the exec. Restore the file descriptor flags + {# call c_restore_fdflags #} fdflags + + -- Restore the standard handles + recover0 + recover1 + recover2 + ) + (const $ do + -- The exec. Throws an IOError in case replacing the process failed. + executeFile path search args menv + + -- Never reached, only for the type checker + error "Impossible error" + ) + + where + handleToFd_noclose :: Handle -> IO Fd + handleToFd_noclose h = + unsafeWithHandleFd h (\fd -> return fd) + + restore h@(FileHandle _ mvar) fd = do + -- The fd used by the handle. This is in GHC.IO.Handle.FD + -- handleToFd_noclose: Fehlerhaft, aus hssh-2.9 + -- handle_fd: der file descriptor, den der Handle mitbringt. Weicht möglicherweise von 0-2 ab. + handle_fd <- fmap fromIntegral (handleToFd_noclose h) + + -- Get the fd which the handle h uses. This locks the handle. + (h__ :: Handle__) <- takeMVar mvar + + -- Make a copy of the fd which is about to be overwritten. Returns -1 for invalid (closed) fd. + -- Mache Sicherheitskopie des Standard-file descriptor (0-2) in einem neu zu belegenden f.d. (ab 3). + -- fd: Standard-file descritor, 0-2. + -- Bewegt den Standardfiledescriptor aus dem Weg. + fd_backup <- {# call c_fcntl_dupfd #} fd 3 + -- Liefert den neuen file descriptor, oder -1 (bei Fehler), wenn der filedescriptor geschlossen ist + + + -- Is the handle closed? + let closed = case haType h__ of + ClosedHandle -> True + SemiClosedHandle -> True + otherwise -> False + + -- If the handle is open, make the fd a copy of the fd which the handle uses. Otherwise, close the fd as well. + if closed + then {# call close #} fd >> return () + else when (fd /= handle_fd) $ + -- Den f.d., den der Standard-Handle benutzt, auf die Standardposition in 0-2 kopieren. + {# call dup2 #} handle_fd fd >> return () + + + -- Return recovery action which undoes everything. + return (do -- Restore the fd + if fd_backup /= -1 then do -- Den Inhalt des 0-2-file descriptors wiederherstellen + {# call dup2 #} fd_backup fd + -- Die Sicherheitskopie wieder freigeben + {# call close #} fd_backup + + return () + else do -- Wenn der 0-2-filedescriptor nicht kopiert werden konnte, dann liegt das (?) daran, daß er + -- geschlossen war. Ihn dann wieder schließen. + {# call close #} fd + return () + -- Unlock the handle + putMVar mvar h__ + return () + ) + + -- Silly: The standard handle has been overwritten with a duplex. + restore h fd = do + -- Make a copy of the fd which is about to be closed. Returns -1 for already closed fd. + fd_backup <- {# call c_fcntl_dupfd #} fd 3 + + -- Close the fd + {# call close #} fd + + -- Return recovery action, which restores the fd. + return (if fd_backup /= -1 then do {# call dup2 #} fd_backup fd + {# call close #} fd_backup + return () + else do {# call close #} fd + return () + ) + + + +{- About Bas van Dijk's unsafeWithHandleFd: + + This function is broken. It blocks when called like this: + + -- Blocks + unsafeWithHandleFd stdout $ \fd -> + putStrLn ("stdout: fd = " ++ show fd) + + The job of unsafeWithHandleFd's job is, to keep a reference to + the handle, so it won't be garbage collected, while the action is still + running. Garbage collecting the handle would close it, as well as the + underlying file descriptor, while the latter is still in use by the action. + This can't happen as long as use of the file descriptor is encapsulated in the + action. + + This encapsulation can be circumvented by returning the file descriptor, and + that's what I do in execute_file. This should usually not be done. + + However, I want to use it on stdin, stdout and stderr, only. These three + should never be garbage collected. Under this circumstances, it should be + safe to use unsafeWithHandleFd this way. +-} + +unsafeWithHandleFd :: Handle -> (Fd -> IO a) -> IO a +unsafeWithHandleFd h@(FileHandle _ m) f = unsafeWithHandleFd' h m f +-- unsafeWithHandleFd h@(DuplexHandle _ _ w) f = unsafeWithHandleFd' h w f + +unsafeWithHandleFd' :: Handle -> MVar Handle__ -> (Fd -> IO a) -> IO a +unsafeWithHandleFd' h m f = + withHandle' "unsafeWithHandleFd" h m $ \h_@Handle__{haDevice} -> + case cast haDevice of + Nothing -> ioError (System.IO.Error.ioeSetErrorString (System.IO.Error.mkIOError IllegalOperation "unsafeWithHandleFd" (Just h) Nothing) + "handle is not a file descriptor") + Just fd -> do + x <- f (Fd (FD.fdFD fd)) + return (h_, x) + + +------------------------------------------------------------------------------------------------------------------------------------------------------ + + + +{- | Check if a handle is connected to a terminal. + + This is a front end to the @isatty(3)@ function (see man page). It is useful, + for instance, to determine if color escape sequences should be + generated. +-} + +isatty :: Handle -- ^ Handle to check + -> IO Bool -- ^ Whether the handle is connected to a terminal +isatty h = + unsafeWithHandleFd h $ \fd -> do + isterm <- {# call isatty as hssh_c_isatty #} ((fromIntegral fd) :: CInt) + return (isterm /= (0::CInt)) + + +-- Flush stdout and stderr (which should not be necessary). Discard Illegal Operation IOError which arises when they are closed. +flush_outerr = do + flush stdout + flush stderr + where + flush h = hFlush h `catch` (\ioe -> if isIllegalOperation ioe then return () else ioError ioe) + + +-- ProcessStatus doesn't derive Typeable. +{- +data ProcessStatus = Exited ExitCode + | Terminated Signal + | Stopped Signal + deriving (Eq, Ord, Show) +-} +instance Typeable ProcessStatus where + typeOf = const tyCon_ProcessStatus + +-- GHC 6.4 +tyCon_ProcessStatus = mkTyConApp (mkTyCon3 "hsshellscript" + "HsShellScript.ProcErr" + "Posix.ProcessStatus") [] + + +-- | The GHC libraries don't declare @Foreign.C.Error.Errno@ as instance of +-- Show. This makes it up. +instance Show Foreign.C.Error.Errno where + show (Errno e) = show e + + + + +------------------------------------------------------------------------------------------------------------------------------------------------------ +-- Transmission of at most one IOError through a pipe (as far as that's possible). +-- This is used by execute_file to send the IOError of a failed exec...-call to the parent process. +-- +-- Can't be transmitted: +-- - the handle field (of course...) +-- - IOErrors of the type DynIOError. They carry a dynamic value, with no provisions for serialization. +-- +-- See base.GHC.IO.lhs + + +-- Read a single possible IOError from a file descriptor. The stream must be +-- closed on the other side after writing either nothing or a single IOError to +-- it. +receive_ioerror :: Fd -> IO (Maybe IOError) +receive_ioerror fd = do + h <- System.Posix.fdToHandle fd + txt <- hGetContents h + seq (length txt) (return ()) + hClose h + return (decode_ioerror txt) + + +-- Write a single IOError to a file descriptor, and close it. +send_ioerror fd ioe = do + h <- System.Posix.fdToHandle fd + Foreign.C.Error.getErrno + hPutStr h (encode_ioerror ioe) + hClose h + + +encode_ioerror :: IOError -> String +encode_ioerror ioe = + show (ioetype_num ioe, ioe_location ioe, ioe_description ioe, ioe_filename ioe, ioe_errno ioe) + + +decode_ioerror :: String -> Maybe IOError +decode_ioerror txt = + case txt of + "" -> Nothing + _ -> let (type_nr, location, description, filename, errno) = read txt + in (Just (IOError { ioe_handle = Nothing, + ioe_type = num_ioetype type_nr, + ioe_location = location, + ioe_description = description, + ioe_filename = filename, + ioe_errno = errno + })) + +-- All IOError types in GHC 6.4, taken from the source code of GHC.IO. +-- Used only for serializing IOErrors which are thrown by executeFile, so this should never go out of date. +ioe_types = [(AlreadyExists, 1), (NoSuchThing, 2), (ResourceBusy, 3), (ResourceExhausted, 4), (EOF, 5), (IllegalOperation, 6), (PermissionDenied, 7), + (UserError, 8), (UnsatisfiedConstraints, 9), (SystemError, 10), (ProtocolError, 11), (OtherError, 12), (InvalidArgument, 13), + (InappropriateType, 14), (HardwareFault, 15), (UnsupportedOperation, 16), (TimeExpired, 17), (ResourceVanished, 18), (Interrupted, 19)] + +-- IOError type as a number +ioetype_num ioe = + case ioeGetErrorType ioe of + ioetype -> case lookup ioetype ioe_types of + Just num -> num + Nothing -> error "Bug in HsShellScript: Unknown IOError type, can't serialize it." + +-- IOError type from the number +num_ioetype num = + case lookup num (map (\(a,b) -> (b,a)) ioe_types) of + Just ioetype -> ioetype + Nothing -> error ("Bug in HsShellScript: Unknown IOError type number " ++ show num) + + +instance Exception ProcessStatus + + + +{- ALT: + +------------------------------------------------------------------------------------------------------------------------------------------------------ +-- Getting the file descriptor which is encapsulated inside a handle + + +-- This is a modified version of System.Posix.IO.handleToFd. The original function has the side effect of closing the handle. From the GHC +-- documentation: +-- +-- "converting a Handle into an Fd effectively means +-- letting go of the Handle; it is put into a closed +-- state as a result." +-- +-- The modified version does the same, but doesn't close the handle. + +handleToFd_noclose :: Handle -- Handle, must be a @FileHandle@. Throws an @IOError@ when the handle is a @DuplexHandle@, or when the + -- handle doesn't incapsulate a file descriptor. + -> IO Fd -- The file descriptor inside of the handle. + +handleToFd_noclose h@(FileHandle _ m) = do + withHandle' "handleToFd_noclose" h m $ + handleToFd'_noclose h + +handleToFd_noclose h@(DuplexHandle _ r w) = + ioError (System.IO.Error.ioeSetErrorString + (System.IO.Error.mkIOError IllegalOperation "handleToFd_noclose" (Just h) Nothing) + "handle is a Duplex") + + +handleToFd'_noclose :: Handle -> Handle__ -> IO (Handle__, Fd) + +handleToFd'_noclose h h_@Handle__{haType=_, ..} = do + case cast haDevice of + Nothing -> ioError (System.IO.Error.ioeSetErrorString + (System.IO.Error.mkIOError IllegalOperation "handleToFd_noclose" (Just h) Nothing) + "handle is not a file descriptor") + Just fd -> do + -- Removed code (2 lines) which would close the handle. + return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd)) +-} + + + + + +------------------------------------------------------------------------------------------------------------------------------------------------------ + +#c +/* +c2hs-0.14.5 chokes on the following includes. +#include +#include +#include +#include +#include +#include +*/ +char *strerror(int errnum); +int fork(void); +void _exit(int status); +int isatty(int desc); +int close(int fd); +int dup2(int oldfd, int newfd); + + + +/* Save all file descriptor flags in an array */ +int* c_save_fdflags(void); + +/* Restore all file descriptor flags from the array, and free it */ +void c_restore_fdflags(int* flags); + +/* Duplicate a file descriptor, allocating the new one at min or above */ +int c_fcntl_dupfd(int fd, int min); + +/* Prepare all file descriptors for a subsequent exec */ +void c_prepare_fd_flags_for_exec(void); + +/* Set a file descriptor to "close on exec" mode. Returns the old flags. */ +int c_close_on_exec(int fd); + +/* Set the flags of a file descriptor. Returns the old flags. */ +int c_set_flags(int fd, int new_flags); +#endc diff --git a/src/HsShellScript/Shell.hs b/src/HsShellScript/Shell.hs new file mode 100644 --- /dev/null +++ b/src/HsShellScript/Shell.hs @@ -0,0 +1,86 @@ +-- #hide +module HsShellScript.Shell where + +import Data.List +-- import System + +-- | +-- Generate command (for a shell) which corresponds to the specified program +-- name and argument list. The program name and arguments are the usual +-- parameters for calling an external program, like when using +-- @runProcess@ or @run@. The generated shell command +-- would achieve the same effect. The name and the arguments are properly +-- quoted, using 'shell_quote'. +-- +-- Note: The quoted strings are correctly recognized in shell scripts. But the shell bash has an annoying history expansion \"feature\", which causes +-- it to choke on exclamation marks, when in interactive mode, even when quoted with double quotes. You can turn it off with @set +o histexpand@. +shell_command :: String -- ^ name or path of the executable + -> [String] -- ^ command line arguments + -> String -- ^ shell command +shell_command k par = + concat (intersperse " " (map shell_quote (k:par))) + + +-- | +-- Quote shell metacharacters. +-- +-- This function quotes strings, such that they are not misinterpreted by +-- the shell. It tries to be friendly to a human reader - when special +-- characters are present, then the string is quoted with double quotes. If +-- not, it is left unchanged. +-- +-- The list of exacly which characters need to be quoted has been taken +-- from the bash source code. Bash in turn, implements POSIX 1003.2. So the +-- result produced should be correct. From the bash info pages: +-- \"... the rules for evaluation and quoting are taken from the POSIX +-- 1003.2 specification for the `standard' Unix shell.\" +-- +-- Note: The quoted strings are correctly recognized in shell scripts. But the shell bash has an annoying history expansion \"feature\", which causes +-- it to choke on exclamation marks, when in interactive mode, even when quoted with double quotes. You can turn it off with @set +o histexpand@. +-- +-- See 'quote'. +shell_quote :: String -> String +shell_quote "" = "\"\"" +shell_quote txt = + let need_to_quote c = c `elem` "' \t\n\"\\|&;()<>!{}*[?]^$`#" + in if any need_to_quote txt + then '"' : quote0' txt + else txt + where + quote0' :: String -> String + quote0' (z:zs) = + if (z `elem` "\"$`\\") then ('\\':(z:(quote0' zs))) + else (z:(quote0' zs)) + quote0' "" = "\"" + +-- | +-- Quote special characters inside a string for the shell +-- +-- This quotes special characters inside a string, such that it is +-- recognized as one string by the shell when enclosed in double quotes. +-- Doesn't add the double quotes. +-- +-- Note: The quoted strings are correctly recognized in shell scripts. But the shell bash has an annoying history expansion \"feature\", which causes +-- it to choke on exclamation marks, when in interactive mode, even when quoted with double quotes. You can turn it off with @set +o histexpand@. +-- +-- See 'quote', 'shell_quote'. +quote0 :: String -> String +quote0 (z:zs) = + if (z `elem` "\"$`\\") then ('\\':(z:(quote0 zs))) + else (z:(quote0 zs)) +quote0 "" = "" + +-- | +-- Quote a string for the shell +-- +-- This encloses a string in double quotes and quotes any special +-- characters inside, such that it will be recognized as one string by a +-- shell. The double quotes are added even when they aren't needed for this +-- purpose. +-- +-- Note: The quoted strings are correctly recognized in shell scripts. But the shell bash has an annoying history expansion \"feature\", which causes +-- it to choke on exclamation marks, when in interactive mode, even when quoted with double quotes. You can turn it off with @set +o histexpand@. +-- +-- See 'quote0', 'shell_quote'. +quote :: String -> String +quote str = "\"" ++ quote0 str ++ "\"" diff --git a/src/cbits/hsshellscript.c b/src/cbits/hsshellscript.c new file mode 100644 --- /dev/null +++ b/src/cbits/hsshellscript.c @@ -0,0 +1,136 @@ +/* Common place for the C parts of HsShellScript. */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/*#include "HsShellScript/Commands.chs.h" +#include "HsShellScript/ProcErr.chs.h" +#include "HsShellScript/Misc.chs.h" +*/ + +/* Commands.chs */ + +char* hsshellscript_get_realpath(char* path) +{ + static char tmp[PATH_MAX+1]; + return realpath(path, tmp); +} + +char* hsshellscript_get_readlink(char* path) +{ + static char tmp[PATH_MAX+1]; + int count = readlink(path, tmp, PATH_MAX); + if (count == -1) return 0; + tmp[count] = 0; + return tmp; +} + + +/* Misc.chs */ + +int hsshellscript_open_nonvariadic(const char *pathname, int flags, mode_t mode) +{ + open(pathname, flags, mode); +} + +int do_glob(void* buf0, const char* pattern) +{ + glob_t* buf = (glob_t*) buf0; + int ret; + buf->gl_pathv = 0; + + printf("pattern = >%s<\n", pattern); /***/ + + ret = glob(pattern, GLOB_ERR, 0, buf); + + switch (ret) { + case 0: return 0; + case GLOB_ABORTED: return 1; + case GLOB_NOSPACE: return 2; + case GLOB_NOMATCH: return 3; + } +} + + +/* ProcErr.chs */ + + +/* Save all file descriptor flags in an array */ +int* c_save_fdflags(void) +{ + int maxfds = sysconf(_SC_OPEN_MAX); + int* flags = calloc(maxfds, sizeof(int)); + int fd; + + for (fd = 0; fd < maxfds; fd++) + /* Saves -1 for invalid fds */ + flags[fd] = fcntl(fd, F_GETFL); + + return flags; +} + +/* Restore all file descriptor flags from the array, and free it */ +void c_restore_fdflags(int* flags) +{ + int maxfds = sysconf(_SC_OPEN_MAX); + int fd; + + for (fd = 0; fd < maxfds; fd++) + if (flags[fd] != -1) + fcntl(fd, F_SETFL, flags[fd]); + + free(flags); +} + +/* Duplicate a file descriptor, allocating the new one at min or above */ +int c_fcntl_dupfd(int fd, int min) +{ + return fcntl(fd, F_DUPFD, min); +} + +/* Prepare all file descriptors for a subsequent exec */ +void c_prepare_fd_flags_for_exec(void) +{ + int maxfds = sysconf(_SC_OPEN_MAX); + int fd, flags; + + /* Set fds 0-2 to blocking mode */ + for (fd = 0; fd < 3; fd++) { + flags = fcntl(fd, F_GETFL); + fcntl(fd, F_SETFL, flags & ~O_NONBLOCK); + } + + /* Set all other fds to close-on-exec */ + for (fd = 3; fd < maxfds; fd++) { + flags = fcntl(fd, F_GETFL); + fcntl(fd, F_SETFL, flags | FD_CLOEXEC); + } +} + +/* Set a file descriptor to "close on exec" mode. Returns the old flags. */ +int c_close_on_exec(int fd) +{ + int old_flags; + old_flags = fcntl(fd, F_GETFL); + fcntl(fd, F_SETFL, old_flags | FD_CLOEXEC); + return old_flags; +} + +/* Set the flags of a file descriptor. Returns the old flags. */ +int c_set_flags(int fd, int new_flags) +{ + int old_flags; + old_flags = fcntl(fd, F_GETFL); + fcntl(fd, F_SETFL, new_flags); + return old_flags; +} +