packages feed

propellor (empty) → 0.1

raw patch · 39 files changed

+3265/−0 lines, 39 filesdep +IfElsedep +MissingHdep +ansi-terminalsetup-changed

Dependencies added: IfElse, MissingH, ansi-terminal, base, bytestring, containers, directory, filepath, hslogger, process, unix, unix-compat

Files

+ GPL view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Makefile view
@@ -0,0 +1,28 @@+run: pull build+	./propellor++devel: build tags++pull:+	git pull++build: deps dist/setup-config+	cabal build || (cabal configure; cabal build)+	ln -sf dist/build/propellor/propellor++deps:+	@if [ $$(whoami) = root ]; then apt-get install ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev; fi || true++dist/setup-config: propellor.cabal+	cabal configure++clean:+	rm -rf dist Setup tags propellor privdata/local+	find -name \*.o -exec rm {} \;+	find -name \*.hi -exec rm {} \;++# hothasktags chokes on some template haskell etc, so ignore errors+tags:+	find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null++.PHONY: tags
+ Propellor.hs view
@@ -0,0 +1,25 @@+-- | Pulls in lots of useful modules for building Properties.++module Propellor (module X) where++import Propellor.Types as X+import Propellor.Property as X+import Propellor.Property.Cmd as X+import Propellor.PrivData as X++import Utility.PartialPrelude as X+import Utility.Process as X+import Utility.Exception as X+import Utility.Env as X+import Utility.Directory as X+import Utility.Tmp as X+import Utility.Monad as X+import Utility.Misc as X++import System.Directory as X+import System.IO as X+import System.FilePath as X+import Data.Maybe as X+import Data.Either as X+import Control.Applicative as X+import Control.Monad as X
+ Propellor/CmdLine.hs view
@@ -0,0 +1,108 @@+module Propellor.CmdLine where++import System.Environment+import Data.List+import System.Exit++import Propellor+import Utility.FileMode+import Utility.SafeCommand++data CmdLine+	= Run HostName+	| Spin HostName+	| Boot HostName+	| Set HostName PrivDataField++processCmdLine :: IO CmdLine+processCmdLine = go =<< getArgs+  where+  	go ("--help":_) = usage+  	go ("--spin":h:[]) = return $ Spin h+  	go ("--boot":h:[]) = return $ Boot h+	go ("--set":h:f:[]) = case readish f of+		Just pf -> return $ Set h pf+		Nothing -> error $ "Unknown privdata field " ++ f+	go (h:[]) = return $ Run h+	go [] = do+		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]+		if null s+			then error "Cannot determine hostname! Pass it on the command line."+			else return $ Run s+	go _ = usage+	+usage :: IO a+usage = do+	putStrLn $ unlines +		[ "Usage:"+		, "  propellor"+		, "  propellor hostname"+		, "  propellor --spin hostname"+		, "  propellor --set hostname field"+		]+	exitFailure++defaultMain :: (HostName -> Maybe [Property]) -> IO ()+defaultMain getprops = go =<< processCmdLine+  where+	go (Run host) = maybe (unknownhost host) ensureProperties (getprops host)+	go (Spin host) = spin host+	go (Boot host) = maybe (unknownhost host) boot (getprops host)+	go (Set host field) = setPrivData host field++unknownhost :: HostName -> IO a+unknownhost h = error $ unwords+	[ "Unknown host:", h+	, "(perhaps you should specify the real hostname on the command line?)"+	]++spin :: HostName -> IO ()+spin host = do+	url <- getUrl+	void $ boolSystem "git" [Param "commit", Param "-a", Param "-m", Param "propellor spin"]+	void $ boolSystem "git" [Param "push"]+	privdata <- gpgDecrypt (privDataFile host)+	withHandle StdinHandle createProcessSuccess+		(proc "ssh" ["root@"++host, bootstrap url]) $ \h -> do+			hPutStr h $ unlines $ map (privDataMarker ++) $ lines privdata+			hClose h+  where+	bootstrap url = shellWrap $ intercalate " && "+		[ intercalate " ; "+			[ "if [ ! -d " ++ localdir ++ " ]"+			, "then " ++ intercalate " && "+				[ "apt-get -y install git"+				, "git clone " ++ url ++ " " ++ localdir+				]+			, "fi"+			]+		, "cd " ++ localdir+		, "make pull build"+		, "./propellor --boot " ++ host+		]++boot :: [Property] -> IO ()+boot props = do+	privdata <- map (drop $ length privDataMarker ) +		. filter (privDataMarker `isPrefixOf`) +		. lines +		<$> getContents+	makePrivDataDir+	writeFileProtected privDataLocal (unlines privdata)+	ensureProperties props++localdir :: FilePath+localdir = "/usr/local/propellor"++getUrl :: IO String+getUrl = fromMaybe nourl <$> getM get urls+  where+	urls = ["remote.deploy.url", "remote.origin.url"]+	nourl = error $ "Cannot find deploy url in " ++ show urls+	get u = do+		v <- catchMaybeIO $ +			takeWhile (/= '\n') +				<$> readProcess "git" ["config", u]+		return $ case v of+			Just url | not (null url) -> Just url+			_ -> Nothing
+ Propellor/PrivData.hs view
@@ -0,0 +1,85 @@+module Propellor.PrivData where++import qualified Data.Map as M+import Control.Applicative+import System.FilePath+import System.IO+import System.Directory+import Data.Maybe+import Control.Monad++import Propellor.Types+import Propellor.Property+import Utility.Monad+import Utility.PartialPrelude+import Utility.Exception+import Utility.Process+import Utility.Tmp+import Utility.SafeCommand+import Utility.Misc++{- | Note that removing or changing field names will break the+ - serialized privdata files, so don't do that!+ - It's fine to add new fields. -}+data PrivDataField+	= DockerAuthentication+	| SshPrivKey UserName+	| Password UserName+	deriving (Read, Show, Ord, Eq)++withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result+withPrivData field a = maybe missing a =<< getPrivData field+  where+	missing = do+		warningMessage $ "Missing privdata " ++ show field+		return FailedChange++getPrivData :: PrivDataField -> IO (Maybe String)+getPrivData field = do+	m <- catchDefaultIO Nothing $ readish <$> readFile privDataLocal+	return $ maybe Nothing (M.lookup field) m++setPrivData :: HostName -> PrivDataField -> IO ()+setPrivData host field = do+	putStrLn "Enter private data on stdin; ctrl-D when done:"+	value <- hGetContentsStrict stdin+	makePrivDataDir+	let f = privDataFile host+	m <- fromMaybe M.empty . readish <$> gpgDecrypt f+	let m' = M.insert field value m+	gpgEncrypt f (show m')+	putStrLn "Private data set."+	void $ boolSystem "git" [Param "add", File f]++makePrivDataDir :: IO ()+makePrivDataDir = createDirectoryIfMissing False privDataDir++privDataDir :: FilePath+privDataDir = "privdata"++privDataFile :: HostName -> FilePath+privDataFile host = privDataDir </> host ++ ".gpg"++privDataLocal :: FilePath+privDataLocal = privDataDir </> "local"++privDataMarker :: String+privDataMarker = "PRIVDATA "++gpgDecrypt :: FilePath -> IO String+gpgDecrypt f = ifM (doesFileExist f)+	( readProcess "gpg" ["--decrypt", f]+	, return ""+	)++gpgEncrypt :: FilePath -> String -> IO ()+gpgEncrypt f s = do+	encrypted <- writeReadProcessEnv "gpg"+		[ "--default-recipient-self"+		, "--armor"+		, "--encrypt"+		]+		Nothing+		(Just $ flip hPutStr s)+		Nothing+	viaTmp writeFile f encrypted
+ Propellor/Property.hs view
@@ -0,0 +1,123 @@+module Propellor.Property where++import System.Directory+import Control.Monad+import System.Console.ANSI+import System.Exit+import System.IO++import Propellor.Types+import Utility.Monad+import Utility.Exception++makeChange :: IO () -> IO Result+makeChange a = a >> return MadeChange++noChange :: IO Result+noChange = return NoChange++{- | Combines a list of properties, resulting in a single property+ - that when run will run each property in the list in turn,+ - and print out the description of each as it's run. Does not stop+ - on failure; does propigate overall success/failure.+ -}+propertyList :: Desc -> [Property] -> Property+propertyList desc ps = Property desc $ ensureProperties' ps++{- | Combines a list of properties, resulting in one property that+ - ensures each in turn, stopping on failure. -}+combineProperties :: [Property] -> Property+combineProperties ps = Property desc $ go ps NoChange+  where+  	go [] rs = return rs+	go (l:ls) rs = do+		r <- ensureProperty l+		case r of+			FailedChange -> return FailedChange+			_ -> go ls (combineResult r rs)+	desc = case ps of+		(p:_) -> propertyDesc p+		_ -> "(empty)"++{- | Makes a perhaps non-idempotent Property be idempotent by using a flag+ - file to indicate whether it has run before.+ - Use with caution. -}+flagFile :: Property -> FilePath -> Property+flagFile property flagfile = Property (propertyDesc property) $+	go =<< doesFileExist flagfile+  where+	go True = return NoChange+	go False = do+		r <- ensureProperty property+		when (r == MadeChange) $+			writeFile flagfile ""+		return r++{- | Whenever a change has to be made for a Property, causes a hook+ - Property to also be run, but not otherwise. -}+onChange :: Property -> Property -> Property+property `onChange` hook = Property (propertyDesc property) $ do+	r <- ensureProperty property+	case r of+		MadeChange -> do+			r' <- ensureProperty hook+			return $ combineResult r r'+		_ -> return r++{- | Indicates that the first property can only be satisfied once+ - the second is. -} +requires :: Property -> Property -> Property+x `requires` y = combineProperties [y, x] `describe` propertyDesc x++describe :: Property -> Desc -> Property+describe p d = p { propertyDesc = d }++(==>) :: Desc -> Property -> Property+(==>) = flip describe+infixl 1 ==>++{- | Makes a Property only be performed when a test succeeds. -}+check :: IO Bool -> Property -> Property+check c property = Property (propertyDesc property) $ ifM c+	( ensureProperty property+	, return NoChange+	)++ensureProperty :: Property -> IO Result+ensureProperty = catchDefaultIO FailedChange . propertySatisfy++ensureProperties :: [Property] -> IO ()+ensureProperties ps = do+	r <- ensureProperties' [propertyList "overall" ps]+	case r of+		FailedChange -> exitWith (ExitFailure 1)+		_ -> exitWith ExitSuccess++ensureProperties' :: [Property] -> IO Result+ensureProperties' ps = ensure ps NoChange+  where+	ensure [] rs = return rs+	ensure (l:ls) rs = do+		r <- ensureProperty l+		clearFromCursorToLineBeginning+		setCursorColumn 0+		putStr $ propertyDesc l ++ "... "+		case r of+			FailedChange -> do+				setSGR [SetColor Foreground Vivid Red]+				putStrLn "failed"+			NoChange -> do+				setSGR [SetColor Foreground Dull Green]+				putStrLn "unchanged"+			MadeChange -> do+				setSGR [SetColor Foreground Vivid Green]+				putStrLn "done"+		setSGR []+		ensure ls (combineResult r rs)++warningMessage :: String -> IO ()+warningMessage s = do+	setSGR [SetColor Foreground Vivid Red]+	putStrLn $ "** warning: " ++ s+	setSGR []+	hFlush stdout
+ Propellor/Property/Apt.hs view
@@ -0,0 +1,132 @@+module Propellor.Property.Apt where++import Data.Maybe+import Control.Applicative+import Data.List+import System.IO+import Control.Monad++import Propellor+import qualified Propellor.Property.File as File+import Propellor.Property.File (Line)++sourcesList :: FilePath+sourcesList = "/etc/apt/sources.list"++type Url = String+type Section = String++data Suite = Stable | Testing | Unstable | Experimental+	deriving Show++showSuite :: Suite -> String+showSuite Stable = "stable"+showSuite Testing = "testing"+showSuite Unstable = "unstable"+showSuite Experimental = "experimental"++debLine :: Suite -> Url -> [Section] -> Line+debLine suite mirror sections = unwords $+	["deb", mirror, showSuite suite] ++ sections++srcLine :: Line -> Line+srcLine l = case words l of+	("deb":rest) -> unwords $ "deb-src" : rest+	_ -> ""++stdSections :: [Section]+stdSections = ["main", "contrib", "non-free"]++debCdn :: Suite -> [Line]+debCdn suite = [l, srcLine l]+  where+	l = debLine suite "http://cdn.debian.net/debian" stdSections++{- | Makes sources.list have a standard content using the mirror CDN,+ - with a particular Suite. -}+stdSourcesList :: Suite -> Property+stdSourcesList suite = setSourcesList (debCdn suite)+	`describe` ("standard sources.list for " ++ show suite)++setSourcesList :: [Line] -> Property+setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update++runApt :: [String] -> Property+runApt ps = cmdProperty' "apt-get" ps env+  where+	env =+		[ ("DEBIAN_FRONTEND", "noninteractive")+		, ("APT_LISTCHANGES_FRONTEND", "none")+		]++update :: Property+update = runApt ["update"]+	`describe` "apt update"++upgrade :: Property+upgrade = runApt ["-y", "dist-upgrade"]+	`describe` "apt dist-upgrade"++type Package = String++installed :: [Package] -> Property+installed ps = check (isInstallable ps) go+	`describe` (unwords $ "apt installed":ps)+  where+	go = runApt $ ["-y", "install"] ++ ps++removed :: [Package] -> Property+removed ps = check (or <$> isInstalled' ps) go+	`describe` (unwords $ "apt removed":ps)+  where+	go = runApt $ ["-y", "remove"] ++ ps++isInstallable :: [Package] -> IO Bool+isInstallable ps = do+	l <- isInstalled' ps+	return $ any (== False) l && not (null l)++isInstalled :: Package -> IO Bool+isInstalled p = (== [True]) <$> isInstalled' [p]++-- | Note that the order of the returned list will not always+-- correspond to the order of the input list. The number of items may+-- even vary. If apt does not know about a package at all, it will not+-- be included in the result list.+isInstalled' :: [Package] -> IO [Bool]+isInstalled' ps = catMaybes . map parse . lines+	<$> readProcess "apt-cache" ("policy":ps)+  where+	parse l+		| "Installed: (none)" `isInfixOf` l = Just False+		| "Installed: " `isInfixOf` l = Just True+		| otherwise = Nothing++autoRemove :: Property+autoRemove = runApt ["-y", "autoremove"]+	`describe` "apt autoremove"++unattendedUpgrades :: Bool -> Property+unattendedUpgrades enabled =+	(if enabled then installed else removed) ["unattended-upgrades"]+	`onChange` reConfigure "unattended-upgrades"+		[("unattended-upgrades/enable_auto_updates" , "boolean", v)]+	`describe` ("unattended upgrades " ++ v)+  where+	v+		| enabled = "true"+		| otherwise = "false"++-- | Preseeds debconf values and reconfigures the package so it takes+-- effect.+reConfigure :: Package -> [(String, String, String)] -> Property+reConfigure package vals = reconfigure `requires` setselections+	`describe` ("reconfigure " ++ package)+  where+	setselections = Property "preseed" $ makeChange $+		withHandle StdinHandle createProcessSuccess+			(proc "debconf-set-selections" []) $ \h -> do+				forM_ vals $ \(template, tmpltype, value) ->+					hPutStrLn h $ unwords [package, template, tmpltype, value]+				hClose h+	reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]
+ Propellor/Property/Cmd.hs view
@@ -0,0 +1,37 @@+module Propellor.Property.Cmd (+	cmdProperty,+	cmdProperty',+	scriptProperty+) where++import Control.Applicative+import Data.List++import Propellor.Types+import Utility.Monad+import Utility.SafeCommand+import Utility.Env++-- | A property that can be satisfied by running a command.+--+-- The command must exit 0 on success.+cmdProperty :: String -> [String] -> Property+cmdProperty cmd params = cmdProperty' cmd params []++-- | A property that can be satisfied by running a command,+-- with added environment.+cmdProperty' :: String -> [String] -> [(String, String)] -> Property+cmdProperty' cmd params env = Property desc $ do+	env' <- addEntries env <$> getEnvironment+	ifM (boolSystemEnv cmd (map Param params) (Just env'))+		( return MadeChange+		, return FailedChange+		)+  where+  	desc = unwords $ cmd : params++-- | A property that can be satisfied by running a series of shell commands.+scriptProperty :: [String] -> Property+scriptProperty script = cmdProperty "sh" ["-c", shellcmd]+  where+	shellcmd = intercalate " ; " ("set -e" : script)
+ Propellor/Property/Docker.hs view
@@ -0,0 +1,16 @@+module Propellor.Property.Docker where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt++-- | Configures docker with an authentication file, so that images can be+-- pushed to index.docker.io.+configured :: Property+configured = Property "docker configured" go `requires` installed+  where+	go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ +		"/root/.dockercfg" `File.hasContent` (lines cfg)+	+installed :: Property+installed = Apt.installed ["docker.io"]
+ Propellor/Property/File.hs view
@@ -0,0 +1,40 @@+module Propellor.Property.File where++import Propellor++type Line = String++{- | Replaces all the content of a file. -}+hasContent :: FilePath -> [Line] -> Property+f `hasContent` newcontent = fileProperty ("replace " ++ f)+	(\_oldcontent -> newcontent) f++{- | Ensures that a line is present in a file, adding it to the end if not. -}+containsLine :: FilePath -> Line -> Property+f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f+  where+	go ls+		| l `elem` ls = ls+		| otherwise = ls++[l]++{- | Ensures that a line is not present in a file.+ - Note that the file is ensured to exist, so if it doesn't, an empty+ - file will be written. -}+lacksLine :: FilePath -> Line -> Property+f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f++{- | Removes a file. Does not remove symlinks or non-plain-files. -}+notPresent :: FilePath -> Property+notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $ +	makeChange $ nukeFile f++fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property+fileProperty desc a f = Property desc $ go =<< doesFileExist f+  where+	go True = do+		ls <- lines <$> catchDefaultIO [] (readFile f)+		let ls' = a ls+		if ls' == ls+			then noChange+			else makeChange $ viaTmp writeFile f (unlines ls')+	go False = makeChange $ writeFile f (unlines $ a [])
+ Propellor/Property/GitHome.hs view
@@ -0,0 +1,31 @@+module Propellor.Property.GitHome where++import Propellor+import qualified Propellor.Property.Apt as Apt+import Propellor.Property.User+import Utility.SafeCommand++{- | Clones Joey Hess's git home directory, and runs its fixups script. -}+installedFor :: UserName -> Property+installedFor user = check (not <$> hasGitDir user) $ +	Property ("githome " ++ user) (go =<< homedir user)+		`requires` Apt.installed ["git", "myrepos"]+  where+ 	go Nothing = noChange+	go (Just home) = do+		let tmpdir = home </> "githome"+		ok <- boolSystem "git" [Param "clone", Param url, Param tmpdir]+			<&&> (and <$> moveout tmpdir home)+			<&&> (catchBoolIO $ removeDirectory tmpdir >> return True)+			<&&> boolSystem "su" [Param "-c", Param "cd; rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups", Param user]+		return $ if ok then MadeChange else FailedChange+	moveout tmpdir home = do+		fs <- dirContents tmpdir+		forM fs $ \f -> boolSystem "mv" [File f, File home]+	url = "git://git.kitenet.net/joey/home"++hasGitDir :: UserName -> IO Bool+hasGitDir user = go =<< homedir user+  where+	go Nothing = return False+	go (Just home) = doesDirectoryExist (home </> ".git")
+ Propellor/Property/Hostname.hs view
@@ -0,0 +1,9 @@+module Propellor.Property.Hostname where++import Propellor+import qualified Propellor.Property.File as File++set :: HostName -> Property+set hostname = "/etc/hostname" `File.hasContent` [hostname]+	`onChange` cmdProperty "hostname" [hostname]+	`describe` ("hostname " ++ hostname)
+ Propellor/Property/JoeySites.hs view
@@ -0,0 +1,23 @@+-- | Specific configuation for Joey Hess's sites. Probably not useful to+-- others except as an example.++module Propellor.Property.JoeySites where++import Propellor+import qualified Propellor.Property.Apt as Apt++oldUseNetshellBox :: Property+oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $+	propertyList ("olduse.net shellbox")+		[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")+			`describe` "olduse.net build deps"+		, scriptProperty+			[ "rm -rf /root/tmp/oldusenet" -- idenpotency+			, "git clone git://olduse.net/ /root/tmp/oldusenet/source"+			, "cd /root/tmp/oldusenet/source/"+			, "dpkg-buildpackage -us -uc"+			, "dpkg -i ../oldusenet*.deb || true"+			, "apt-get -fy install" -- dependencies+			, "rm -rf /root/tmp/oldusenet"+			] `describe` "olduse.net built"+		]
+ Propellor/Property/Network.hs view
@@ -0,0 +1,27 @@+module Propellor.Property.Network where++import Propellor+import Propellor.Property.File++interfaces :: FilePath+interfaces = "/etc/network/interfaces"++-- | 6to4 ipv6 connection, should work anywhere+ipv6to4 :: Property+ipv6to4 = fileProperty "ipv6to4" go interfaces+	`onChange` ifUp "sit0"+  where+	go ls+		| all (`elem` ls) stanza = ls+		| otherwise = ls ++ stanza+	stanza =+		[ "# Automatically added by propeller"+		, "iface sit0 inet6 static"+		, "\taddress 2002:5044:5531::1"+		, "\tnetmask 64"+		, "\tgateway ::192.88.99.1"+		, "# End automatically added by propeller"+		]++ifUp :: String -> Property+ifUp iface = cmdProperty "ifup" [iface]
+ Propellor/Property/Reboot.hs view
@@ -0,0 +1,7 @@+module Propellor.Property.Reboot where++import Propellor++now :: Property+now = cmdProperty "reboot" []+	`describe` "reboot now"
+ Propellor/Property/Ssh.hs view
@@ -0,0 +1,54 @@+module Propellor.Property.Ssh where++import Propellor+import qualified Propellor.Property.File as File+import Propellor.Property.User+import Utility.SafeCommand++sshBool :: Bool -> String+sshBool True = "yes"+sshBool False = "no"++sshdConfig :: FilePath+sshdConfig = "/etc/ssh/sshd_config"++setSshdConfig :: String -> Bool -> Property+setSshdConfig setting allowed = combineProperties+	[ sshdConfig `File.lacksLine` (sshline $ not allowed)+	, sshdConfig `File.containsLine` (sshline allowed)+	]+	`onChange` restartSshd+	`describe` unwords [ "ssh config:", setting, sshBool allowed ]+  where+	sshline v = setting ++ " " ++ sshBool v++permitRootLogin :: Bool -> Property+permitRootLogin = setSshdConfig "PermitRootLogin"++passwordAuthentication :: Bool -> Property+passwordAuthentication = setSshdConfig "PasswordAuthentication"++hasAuthorizedKeys :: UserName -> IO Bool+hasAuthorizedKeys = go <=< homedir+  where+	go Nothing = return False+	go (Just home) = not . null <$> catchDefaultIO ""+		(readFile $ home </> ".ssh" </> "authorized_keys")++restartSshd :: Property+restartSshd = cmdProperty "service" ["ssh", "restart"]++{- | Blow away existing host keys and make new ones. Use a flag+ - file to prevent doing this more than once. -}+uniqueHostKeys :: Property+uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"+	`onChange` restartSshd+  where+	prop = Property "ssh unique host keys" $ do+		void $ boolSystem "sh"+			[ Param "-c"+			, Param "rm -f /etc/ssh/ssh_host_*"+			]+		ensureProperty $+			cmdProperty "/var/lib/dpkg/info/openssh-server.postinst"+				["configure"]
+ Propellor/Property/Sudo.hs view
@@ -0,0 +1,34 @@+module Propellor.Property.Sudo where++import Data.List++import Propellor+import Propellor.Property.File+import qualified Propellor.Property.Apt as Apt+import Propellor.Property.User++{- | Allows a user to sudo. If the user has a password, sudo is configured+ - to require it. If not, NOPASSWORD is enabled for the user.+ -+ - TOOD: Full sudoers file format parse.. + -}+enabledFor :: UserName -> Property+enabledFor user = Property desc go `requires` Apt.installed ["sudo"]+  where+	go = do+		locked <- isLockedPassword user+		ensureProperty $+			fileProperty desc+				(modify locked . filter (wanted locked))+				"/etc/sudoers"+	desc = user ++ " is sudoer"+	sudobaseline = user ++ " ALL=(ALL:ALL)"+	sudoline True = sudobaseline ++ " NOPASSWD:ALL"+	sudoline False = sudobaseline ++ " ALL"+	wanted locked l+		| not (sudobaseline `isPrefixOf` l) = True+		| "NOPASSWD" `isInfixOf` l = locked+		| otherwise = True+ 	modify locked ls+		| sudoline locked `elem` ls = ls+		| otherwise = ls ++ [sudoline locked]
+ Propellor/Property/Tor.hs view
@@ -0,0 +1,19 @@+module Propellor.Property.Tor where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt++isBridge :: Property+isBridge = setup `requires` Apt.installed ["tor"]+	`describe` "tor bridge"+  where+	setup = "/etc/tor/torrc" `File.hasContent`+		[ "SocksPort 0"+		, "ORPort 443"+		, "BridgeRelay 1"+		, "Exitpolicy reject *:*"+		] `onChange` restartTor++restartTor :: Property+restartTor = cmdProperty "service" ["tor", "restart"]
+ Propellor/Property/User.hs view
@@ -0,0 +1,61 @@+module Propellor.Property.User where++import System.Posix++import Propellor++data Eep = YesReallyDeleteHome++sshAccountFor :: UserName -> Property+sshAccountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser"+	[ "--disabled-password"+	, "--gecos", ""+	, user+	]+	`describe` ("ssh account " ++ user)++{- | Removes user home directory!! Use with caution. -}+nuked :: UserName -> Eep -> Property+nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel"+	[ "-r"+	, user+	]+	`describe` ("nuked user " ++ user)++{- | Only ensures that the user has some password set. It may or may+ - not be the password from the PrivData. -}+hasSomePassword :: UserName -> Property+hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $+	hasPassword user++hasPassword :: UserName -> Property+hasPassword user = Property (user ++ " has password") $+	withPrivData (Password user) $ \password -> makeChange $+		withHandle StdinHandle createProcessSuccess+			(proc "chpasswd" []) $ \h -> do+				hPutStrLn h $ user ++ ":" ++ password+				hClose h++lockedPassword :: UserName -> Property+lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"+	[ "--lock"+	, user+	]+	`describe` ("locked " ++ user ++ " password")++data PasswordStatus = NoPassword | LockedPassword | HasPassword+	deriving (Eq)++getPasswordStatus :: UserName -> IO PasswordStatus+getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user]+  where+	parse (_:"L":_) = LockedPassword+	parse (_:"NP":_) = NoPassword+	parse (_:"P":_) = HasPassword+	parse _ = NoPassword++isLockedPassword :: UserName -> IO Bool+isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user++homedir :: UserName -> IO (Maybe FilePath)+homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user
+ Propellor/Types.hs view
@@ -0,0 +1,22 @@+module Propellor.Types where++type HostName = String+type UserName = String++data Property = Property+	{ propertyDesc :: Desc+	-- | must be idempotent; may run repeatedly+	, propertySatisfy :: IO Result+	}++type Desc = String++data Result = NoChange | MadeChange | FailedChange+	deriving (Show, Eq)++combineResult :: Result -> Result -> Result+combineResult FailedChange _ = FailedChange+combineResult _ FailedChange = FailedChange+combineResult MadeChange _ = MadeChange+combineResult _ MadeChange = MadeChange+combineResult NoChange NoChange = NoChange
+ README view
@@ -0,0 +1,42 @@+This is a work in progress configuration management system using Haskell+and Git.++Propellor enures that the system it's run in satisfies a list of+properties, taking action as necessary when a property is not yet met.++The design is intentionally very minimal.++Propellor lives in a git repository, and so to set it up it's cloned+to a system, and "make" can be used to pull down any new changes,+and compile and run propellor. This can be done by a cron job, or+something can ssh in and run it.++Properties are defined using Haskell. Edit config.hs to get started.++There is no special language as used in puppet, chef, ansible, etc.. just+the full power of Haskell. Hopefully that power can be put to good use in+making declarative properties that are powerful, nicely idempotent, and+easy to adapt to a system's special needs.++Also avoided is any form of node classification. Ie, which hosts are part+of which classes and share which configuration. It might be nice to use+reclass[1], but then again a host is configured using simply haskell code,+and so it's easy to factor out things like classes of hosts as desired.++To bootstrap propellor on a new host, use: propellor --spin $host+This looks up the git repository's remote.origin.url (or remote.deploy.url+if available) and logs into the host, clones the url (if not already+done), and sets up and runs propellor in /usr/local/propellor++Private data such as passwords, ssh private keys, etc should not be checked+into a propellor git repository in the clear, unless you want to restrict+access to the repository. Which would probably involve a separate fork +for each host and be annoying. ++Instead, propellor --spin $host looks for a privdata/$host.gpg file and+if found decrypts it and sends it to the host using ssh. To set a field+in such a file, use: propellor --set $host $field+The field name will be something like 'Password "root"'; see PrivData.hs+for available fields.++[1] http://reclass.pantsfullofunix.net/
+ Setup.hs view
@@ -0,0 +1,5 @@+{- cabal setup file -}++import Distribution.Simple++main = defaultMain
+ TODO view
@@ -0,0 +1,5 @@+* Need a way to run an action when a property changes, but only+  run it once for the whole. For example, may want to restart apache,+  but only once despite many config changes being made to satisfy+  properties. onChange is a poor substitute.+* I often seem to want to be able to combine Properties monadically.
+ Utility/Applicative.hs view
@@ -0,0 +1,16 @@+{- applicative stuff+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Applicative where++{- Like <$> , but supports one level of currying.+ - + - foo v = bar <$> action v  ==  foo = bar <$$> action+ -}+(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b+f <$$> v = fmap f . v+infixr 4 <$$>
+ Utility/Data.hs view
@@ -0,0 +1,17 @@+{- utilities for simple data types+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Data where++{- First item in the list that is not Nothing. -}+firstJust :: Eq a => [Maybe a] -> Maybe a+firstJust ms = case dropWhile (== Nothing) ms of+	[] -> Nothing+	(md:_) -> md++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe = either (const Nothing) Just
+ Utility/Directory.hs view
@@ -0,0 +1,135 @@+{- directory manipulation+ -+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Directory where++import System.IO.Error+import System.Directory+import Control.Exception (throw)+import Control.Monad+import Control.Monad.IfElse+import System.FilePath+import Control.Applicative+import System.IO.Unsafe (unsafeInterleaveIO)++import Utility.PosixFiles+import Utility.SafeCommand+import Utility.Tmp+import Utility.Exception+import Utility.Monad+import Utility.Applicative++dirCruft :: FilePath -> Bool+dirCruft "." = True+dirCruft ".." = True+dirCruft _ = False++{- Lists the contents of a directory.+ - Unlike getDirectoryContents, paths are not relative to the directory. -}+dirContents :: FilePath -> IO [FilePath]+dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d++{- Gets files in a directory, and then its subdirectories, recursively,+ - and lazily.+ -+ - Does not follow symlinks to other subdirectories.+ -+ - When the directory does not exist, no exception is thrown,+ - instead, [] is returned. -}+dirContentsRecursive :: FilePath -> IO [FilePath]+dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir++{- Skips directories whose basenames match the skipdir. -}+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]+dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]+  where+  	go [] = return []+	go (dir:dirs)+		| skipdir (takeFileName dir) = go dirs+		| otherwise = unsafeInterleaveIO $ do+			(files, dirs') <- collect [] []+				=<< catchDefaultIO [] (dirContents dir)+			files' <- go (dirs' ++ dirs)+			return (files ++ files')+	collect files dirs' [] = return (reverse files, reverse dirs')+	collect files dirs' (entry:entries)+		| dirCruft entry = collect files dirs' entries+		| otherwise = do+			let skip = collect (entry:files) dirs' entries+			let recurse = collect files (entry:dirs') entries+			ms <- catchMaybeIO $ getSymbolicLinkStatus entry+			case ms of+				(Just s) +					| isDirectory s -> recurse+					| isSymbolicLink s && followsubdirsymlinks ->+						ifM (doesDirectoryExist entry)+							( recurse+							, skip+							)+				_ -> skip++{- Gets the directory tree from a point, recursively and lazily,+ - with leaf directories **first**, skipping any whose basenames+ - match the skipdir. Does not follow symlinks. -}+dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]+  where+  	go c [] = return c+	go c (dir:dirs)+		| skipdir (takeFileName dir) = go c dirs+		| otherwise = unsafeInterleaveIO $ do+			subdirs <- go c+				=<< filterM (isDirectory <$$> getSymbolicLinkStatus)+				=<< catchDefaultIO [] (dirContents dir)+			go (subdirs++[dir]) dirs++{- Moves one filename to another.+ - First tries a rename, but falls back to moving across devices if needed. -}+moveFile :: FilePath -> FilePath -> IO ()+moveFile src dest = tryIO (rename src dest) >>= onrename+  where+	onrename (Right _) = noop+	onrename (Left e)+		| isPermissionError e = rethrow+		| isDoesNotExistError e = rethrow+		| otherwise = do+			-- copyFile is likely not as optimised as+			-- the mv command, so we'll use the latter.+			-- But, mv will move into a directory if+			-- dest is one, which is not desired.+			whenM (isdir dest) rethrow+			viaTmp mv dest undefined+	  where+		rethrow = throw e+		mv tmp _ = do+			ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]+			unless ok $ do+				-- delete any partial+				_ <- tryIO $ removeFile tmp+				rethrow++	isdir f = do+		r <- tryIO $ getFileStatus f+		case r of+			(Left _) -> return False+			(Right s) -> return $ isDirectory s++{- Removes a file, which may or may not exist, and does not have to+ - be a regular file.+ -+ - Note that an exception is thrown if the file exists but+ - cannot be removed. -}+nukeFile :: FilePath -> IO ()+nukeFile file = void $ tryWhenExists go+  where+#ifndef mingw32_HOST_OS+	go = removeLink file+#else+	go = removeFile file+#endif
+ Utility/Env.hs view
@@ -0,0 +1,81 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Env where++#ifdef mingw32_HOST_OS+import Utility.Exception+import Control.Applicative+import Data.Maybe+import qualified System.Environment as E+#else+import qualified System.Posix.Env as PE+#endif++getEnv :: String -> IO (Maybe String)+#ifndef mingw32_HOST_OS+getEnv = PE.getEnv+#else+getEnv = catchMaybeIO . E.getEnv+#endif++getEnvDefault :: String -> String -> IO String+#ifndef mingw32_HOST_OS+getEnvDefault = PE.getEnvDefault+#else+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var+#endif++getEnvironment :: IO [(String, String)]+#ifndef mingw32_HOST_OS+getEnvironment = PE.getEnvironment+#else+getEnvironment = E.getEnvironment+#endif++{- Returns True if it could successfully set the environment variable.+ -+ - There is, apparently, no way to do this in Windows. Instead,+ - environment varuables must be provided when running a new process. -}+setEnv :: String -> String -> Bool -> IO Bool+#ifndef mingw32_HOST_OS+setEnv var val overwrite = do+	PE.setEnv var val overwrite+	return True+#else+setEnv _ _ _ = return False+#endif++{- Returns True if it could successfully unset the environment variable. -}+unsetEnv :: String -> IO Bool+#ifndef mingw32_HOST_OS+unsetEnv var = do+	PE.unsetEnv var+	return True+#else+unsetEnv _ = return False+#endif++{- Adds the environment variable to the input environment. If already+ - present in the list, removes the old value.+ -+ - This does not really belong here, but Data.AssocList is for some reason+ - buried inside hxt.+ -}+addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]+addEntry k v l = ( (k,v) : ) $! delEntry k l++addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]+addEntries = foldr (.) id . map (uncurry addEntry) . reverse++delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]+delEntry _ []   = []+delEntry k (x@(k1,_) : rest)+	| k == k1 = rest+	| otherwise = ( x : ) $! delEntry k rest
+ Utility/Exception.hs view
@@ -0,0 +1,59 @@+{- Simple IO exception handling (and some more)+ -+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE ScopedTypeVariables #-}++module Utility.Exception where++import Control.Exception+import qualified Control.Exception as E+import Control.Applicative+import Control.Monad+import System.IO.Error (isDoesNotExistError)+import Utility.Data++{- Catches IO errors and returns a Bool -}+catchBoolIO :: IO Bool -> IO Bool+catchBoolIO a = catchDefaultIO False a++{- Catches IO errors and returns a Maybe -}+catchMaybeIO :: IO a -> IO (Maybe a)+catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a++{- Catches IO errors and returns a default value. -}+catchDefaultIO :: a -> IO a -> IO a+catchDefaultIO def a = catchIO a (const $ return def)++{- Catches IO errors and returns the error message. -}+catchMsgIO :: IO a -> IO (Either String a)+catchMsgIO a = either (Left . show) Right <$> tryIO a++{- catch specialized for IO errors only -}+catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = E.catch++{- try specialized for IO errors only -}+tryIO :: IO a -> IO (Either IOException a)+tryIO = try++{- Catches all exceptions except for async exceptions.+ - This is often better to use than catching them all, so that+ - ThreadKilled and UserInterrupt get through.+ -}+catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a+catchNonAsync a onerr = a `catches`+	[ Handler (\ (e :: AsyncException) -> throw e)+	, Handler (\ (e :: SomeException) -> onerr e)+	]++tryNonAsync :: IO a -> IO (Either SomeException a)+tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)++{- Catches only DoesNotExist exceptions, and lets all others through. -}+tryWhenExists :: IO a -> IO (Maybe a)+tryWhenExists a = eitherToMaybe <$>+	tryJust (guard . isDoesNotExistError) a
+ Utility/FileMode.hs view
@@ -0,0 +1,155 @@+{- File mode utilities.+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.FileMode where++import System.IO+import Control.Monad+import Control.Exception (bracket)+import System.PosixCompat.Types+#ifndef mingw32_HOST_OS+import System.Posix.Files+#endif+import Foreign (complement)++import Utility.Exception++{- Applies a conversion function to a file's mode. -}+modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()+modifyFileMode f convert = void $ modifyFileMode' f convert+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode+modifyFileMode' f convert = do+	s <- getFileStatus f+	let old = fileMode s+	let new = convert old+	when (new /= old) $+		setFileMode f new+	return old++{- Adds the specified FileModes to the input mode, leaving the rest+ - unchanged. -}+addModes :: [FileMode] -> FileMode -> FileMode+addModes ms m = combineModes (m:ms)++{- Removes the specified FileModes from the input mode. -}+removeModes :: [FileMode] -> FileMode -> FileMode+removeModes ms m = m `intersectFileModes` complement (combineModes ms)++{- Runs an action after changing a file's mode, then restores the old mode. -}+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a+withModifiedFileMode file convert a = bracket setup cleanup go+  where+	setup = modifyFileMode' file convert+	cleanup oldmode = modifyFileMode file (const oldmode)+	go _ = a++writeModes :: [FileMode]+writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]++readModes :: [FileMode]+readModes = [ownerReadMode, groupReadMode, otherReadMode]++executeModes :: [FileMode]+executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]++{- Removes the write bits from a file. -}+preventWrite :: FilePath -> IO ()+preventWrite f = modifyFileMode f $ removeModes writeModes++{- Turns a file's owner write bit back on. -}+allowWrite :: FilePath -> IO ()+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]++{- Turns a file's owner read bit back on. -}+allowRead :: FilePath -> IO ()+allowRead f = modifyFileMode f $ addModes [ownerReadMode]++{- Allows owner and group to read and write to a file. -}+groupSharedModes :: [FileMode]+groupSharedModes =+	[ ownerWriteMode, groupWriteMode+	, ownerReadMode, groupReadMode+	]++groupWriteRead :: FilePath -> IO ()+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes++checkMode :: FileMode -> FileMode -> Bool+checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor++{- Checks if a file mode indicates it's a symlink. -}+isSymLink :: FileMode -> Bool+#ifdef mingw32_HOST_OS+isSymLink _ = False+#else+isSymLink = checkMode symbolicLinkMode+#endif++{- Checks if a file has any executable bits set. -}+isExecutable :: FileMode -> Bool+isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0++{- Runs an action without that pesky umask influencing it, unless the+ - passed FileMode is the standard one. -}+noUmask :: FileMode -> IO a -> IO a+#ifndef mingw32_HOST_OS+noUmask mode a+	| mode == stdFileMode = a+	| otherwise = withUmask nullFileMode a+#else+noUmask _ a = a+#endif++withUmask :: FileMode -> IO a -> IO a+#ifndef mingw32_HOST_OS+withUmask umask a = bracket setup cleanup go+  where+	setup = setFileCreationMask umask+	cleanup = setFileCreationMask+	go _ = a+#else+withUmask _ a = a+#endif++combineModes :: [FileMode] -> FileMode+combineModes [] = undefined+combineModes [m] = m+combineModes (m:ms) = foldl unionFileModes m ms++isSticky :: FileMode -> Bool+#ifdef mingw32_HOST_OS+isSticky _ = False+#else+isSticky = checkMode stickyMode++stickyMode :: FileMode+stickyMode = 512++setSticky :: FilePath -> IO ()+setSticky f = modifyFileMode f $ addModes [stickyMode]+#endif++{- Writes a file, ensuring that its modes do not allow it to be read+ - or written by anyone other than the current user,+ - before any content is written.+ -+ - When possible, this is done using the umask.+ -+ - On a filesystem that does not support file permissions, this is the same+ - as writeFile.+ -}+writeFileProtected :: FilePath -> String -> IO ()+writeFileProtected file content = withUmask 0o0077 $+	withFile file WriteMode $ \h -> do+		void $ tryIO $ modifyFileMode file $+			removeModes+				[ groupReadMode, otherReadMode+				, groupWriteMode, otherWriteMode+				]+		hPutStr h content
+ Utility/FileSystemEncoding.hs view
@@ -0,0 +1,132 @@+{- GHC File system encoding handling.+ -+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.FileSystemEncoding (+	fileEncoding,+	withFilePath,+	md5FilePath,+	decodeBS,+	decodeW8,+	encodeW8,+	truncateFilePath,+) where++import qualified GHC.Foreign as GHC+import qualified GHC.IO.Encoding as Encoding+import Foreign.C+import System.IO+import System.IO.Unsafe+import qualified Data.Hash.MD5 as MD5+import Data.Word+import Data.Bits.Utils+import qualified Data.ByteString.Lazy as L+#ifdef mingw32_HOST_OS+import qualified Data.ByteString.Lazy.UTF8 as L8+#endif++{- Sets a Handle to use the filesystem encoding. This causes data+ - written or read from it to be encoded/decoded the same+ - as ghc 7.4 does to filenames etc. This special encoding+ - allows "arbitrary undecodable bytes to be round-tripped through it".+ -}+fileEncoding :: Handle -> IO ()+#ifndef mingw32_HOST_OS+fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding+#else+{- The file system encoding does not work well on Windows,+ - and Windows only has utf FilePaths anyway. -}+fileEncoding h = hSetEncoding h Encoding.utf8+#endif++{- Marshal a Haskell FilePath into a NUL terminated C string using temporary+ - storage. The FilePath is encoded using the filesystem encoding,+ - reversing the decoding that should have been done when the FilePath+ - was obtained. -}+withFilePath :: FilePath -> (CString -> IO a) -> IO a+withFilePath fp f = Encoding.getFileSystemEncoding+	>>= \enc -> GHC.withCString enc fp f++{- Encodes a FilePath into a String, applying the filesystem encoding.+ -+ - There are very few things it makes sense to do with such an encoded+ - string. It's not a legal filename; it should not be displayed.+ - So this function is not exported, but instead used by the few functions+ - that can usefully consume it.+ -+ - This use of unsafePerformIO is belived to be safe; GHC's interface+ - only allows doing this conversion with CStrings, and the CString buffer+ - is allocated, used, and deallocated within the call, with no side+ - effects.+ -}+{-# NOINLINE _encodeFilePath #-}+_encodeFilePath :: FilePath -> String+_encodeFilePath fp = unsafePerformIO $ do+	enc <- Encoding.getFileSystemEncoding+	GHC.withCString enc fp $ GHC.peekCString Encoding.char8++{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}+md5FilePath :: FilePath -> MD5.Str+md5FilePath = MD5.Str . _encodeFilePath++{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}+decodeBS :: L.ByteString -> FilePath+#ifndef mingw32_HOST_OS+decodeBS = encodeW8 . L.unpack+#else+{- On Windows, we assume that the ByteString is utf-8, since Windows+ - only uses unicode for filenames. -}+decodeBS = L8.toString+#endif++{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.+ -+ - w82c produces a String, which may contain Chars that are invalid+ - unicode. From there, this is really a simple matter of applying the+ - file system encoding, only complicated by GHC's interface to doing so.+ -}+{-# NOINLINE encodeW8 #-}+encodeW8 :: [Word8] -> FilePath+encodeW8 w8 = unsafePerformIO $ do+	enc <- Encoding.getFileSystemEncoding+	GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc++{- Useful when you want the actual number of bytes that will be used to+ - represent the FilePath on disk. -}+decodeW8 :: FilePath -> [Word8]+decodeW8 = s2w8 . _encodeFilePath++{- Truncates a FilePath to the given number of bytes (or less),+ - as represented on disk.+ -+ - Avoids returning an invalid part of a unicode byte sequence, at the+ - cost of efficiency when running on a large FilePath.+ -}+truncateFilePath :: Int -> FilePath -> FilePath+#ifndef mingw32_HOST_OS+truncateFilePath n = go . reverse+  where+  	go f =+		let bytes = decodeW8 f+		in if length bytes <= n+			then reverse f+			else go (drop 1 f)+#else+{- On Windows, count the number of bytes used by each utf8 character. -}+truncateFilePath n = reverse . go [] n . L8.fromString+  where+	go coll cnt bs+		| cnt <= 0 = coll+		| otherwise = case L8.decode bs of+			Just (c, x) | c /= L8.replacement_char ->+				let x' = fromIntegral x+				in if cnt - x' < 0+					then coll+					else go (c:coll) (cnt - x') (L8.drop 1 bs)+			_ -> coll+#endif
+ Utility/Misc.hs view
@@ -0,0 +1,148 @@+{- misc utility functions+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Misc where++import System.IO+import Control.Monad+import Foreign+import Data.Char+import Data.List+import Control.Applicative+import System.Exit+#ifndef mingw32_HOST_OS+import System.Posix.Process (getAnyProcessStatus)+import Utility.Exception+#endif++import Utility.FileSystemEncoding+import Utility.Monad++{- A version of hgetContents that is not lazy. Ensures file is + - all read before it gets closed. -}+hGetContentsStrict :: Handle -> IO String+hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s++{- A version of readFile that is not lazy. -}+readFileStrict :: FilePath -> IO String+readFileStrict = readFile >=> \s -> length s `seq` return s++{-  Reads a file strictly, and using the FileSystemEncoding, so it will+ -  never crash on a badly encoded file. -}+readFileStrictAnyEncoding :: FilePath -> IO String+readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do+	fileEncoding h+	hClose h `after` hGetContentsStrict h++{- Writes a file, using the FileSystemEncoding so it will never crash+ - on a badly encoded content string. -}+writeFileAnyEncoding :: FilePath -> String -> IO ()+writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do+	fileEncoding h+	hPutStr h content++{- Like break, but the item matching the condition is not included+ - in the second result list.+ -+ - separate (== ':') "foo:bar" = ("foo", "bar")+ - separate (== ':') "foobar" = ("foobar", "")+ -}+separate :: (a -> Bool) -> [a] -> ([a], [a])+separate c l = unbreak $ break c l+  where+	unbreak r@(a, b)+		| null b = r+		| otherwise = (a, tail b)++{- Breaks out the first line. -}+firstLine :: String -> String+firstLine = takeWhile (/= '\n')++{- Splits a list into segments that are delimited by items matching+ - a predicate. (The delimiters are not included in the segments.)+ - Segments may be empty. -}+segment :: (a -> Bool) -> [a] -> [[a]]+segment p l = map reverse $ go [] [] l+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] (c:r) is+		| otherwise = go (i:c) r is++prop_segment_regressionTest :: Bool+prop_segment_regressionTest = all id+	-- Even an empty list is a segment.+	[ segment (== "--") [] == [[]]+	-- There are two segements in this list, even though the first is empty.+	, segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]+	]++{- Includes the delimiters as segments of their own. -}+segmentDelim :: (a -> Bool) -> [a] -> [[a]]+segmentDelim p l = map reverse $ go [] [] l+  where+	go c r [] = reverse $ c:r+	go c r (i:is)+		| p i = go [] ([i]:c:r) is+		| otherwise = go (i:c) r is++{- Replaces multiple values in a string.+ -+ - Takes care to skip over just-replaced values, so that they are not+ - mangled. For example, massReplace [("foo", "new foo")] does not+ - replace the "new foo" with "new new foo".+ -}+massReplace :: [(String, String)] -> String -> String+massReplace vs = go [] vs+  where++	go acc _ [] = concat $ reverse acc+	go acc [] (c:cs) = go ([c]:acc) vs cs+	go acc ((val, replacement):rest) s+		| val `isPrefixOf` s =+			go (replacement:acc) vs (drop (length val) s)+		| otherwise = go acc rest s++{- Wrapper around hGetBufSome that returns a String.+ -+ - The null string is returned on eof, otherwise returns whatever+ - data is currently available to read from the handle, or waits for+ - data to be written to it if none is currently available.+ - + - Note on encodings: The normal encoding of the Handle is ignored;+ - each byte is converted to a Char. Not unicode clean!+ -}+hGetSomeString :: Handle -> Int -> IO String+hGetSomeString h sz = do+	fp <- mallocForeignPtrBytes sz+	len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz+	map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)+  where+	peekbytes :: Int -> Ptr Word8 -> IO [Word8]+	peekbytes len buf = mapM (peekElemOff buf) [0..pred len]++{- Reaps any zombie git processes. + -+ - Warning: Not thread safe. Anything that was expecting to wait+ - on a process and get back an exit status is going to be confused+ - if this reap gets there first. -}+reapZombies :: IO ()+#ifndef mingw32_HOST_OS+reapZombies = do+	-- throws an exception when there are no child processes+	catchDefaultIO Nothing (getAnyProcessStatus False True)+		>>= maybe (return ()) (const reapZombies)++#else+reapZombies = return ()+#endif++exitBool :: Bool -> IO a+exitBool False = exitFailure+exitBool True = exitSuccess
+ Utility/Monad.hs view
@@ -0,0 +1,69 @@+{- monadic stuff+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Monad where++import Data.Maybe+import Control.Monad++{- Return the first value from a list, if any, satisfying the given+ - predicate -}+firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+firstM _ [] = return Nothing+firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)++{- Runs the action on values from the list until it succeeds, returning+ - its result. -}+getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+getM _ [] = return Nothing+getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x++{- Returns true if any value in the list satisfies the predicate,+ - stopping once one is found. -}+anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool+anyM p = liftM isJust . firstM p++allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM _ [] = return True+allM p (x:xs) = p x <&&> allM p xs++{- Runs an action on values from a list until it succeeds. -}+untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool+untilTrue = flip anyM++{- if with a monadic conditional. -}+ifM :: Monad m => m Bool -> (m a, m a) -> m a+ifM cond (thenclause, elseclause) = do+	c <- cond+	if c then thenclause else elseclause++{- short-circuiting monadic || -}+(<||>) :: Monad m => m Bool -> m Bool -> m Bool+ma <||> mb = ifM ma ( return True , mb )++{- short-circuiting monadic && -}+(<&&>) :: Monad m => m Bool -> m Bool -> m Bool+ma <&&> mb = ifM ma ( mb , return False )++{- Same fixity as && and || -}+infixr 3 <&&>+infixr 2 <||>++{- Runs an action, passing its value to an observer before returning it. -}+observe :: Monad m => (a -> m b) -> m a -> m a+observe observer a = do+	r <- a+	_ <- observer r+	return r++{- b `after` a runs first a, then b, and returns the value of a -}+after :: Monad m => m b -> m a -> m a+after = observe . const++{- do nothing -}+noop :: Monad m => m ()+noop = return ()
+ Utility/PartialPrelude.hs view
@@ -0,0 +1,68 @@+{- Parts of the Prelude are partial functions, which are a common source of+ - bugs.+ -+ - This exports functions that conflict with the prelude, which avoids+ - them being accidentially used.+ -}++module Utility.PartialPrelude where++import qualified Data.Maybe++{- read should be avoided, as it throws an error+ - Instead, use: readish -}+read :: Read a => String -> a+read = Prelude.read++{- head is a partial function; head [] is an error+ - Instead, use: take 1 or headMaybe -}+head :: [a] -> a+head = Prelude.head++{- tail is also partial+ - Instead, use: drop 1 -}+tail :: [a] -> [a]+tail = Prelude.tail++{- init too+ - Instead, use: beginning -}+init :: [a] -> [a]+init = Prelude.init++{- last too+ - Instead, use: end or lastMaybe -}+last :: [a] -> a+last = Prelude.last++{- Attempts to read a value from a String.+ -+ - Ignores leading/trailing whitespace, and throws away any trailing+ - text after the part that can be read.+ -+ - readMaybe is available in Text.Read in new versions of GHC,+ - but that one requires the entire string to be consumed.+ -}+readish :: Read a => String -> Maybe a+readish s = case reads s of+	((x,_):_) -> Just x+	_ -> Nothing++{- Like head but Nothing on empty list. -}+headMaybe :: [a] -> Maybe a+headMaybe = Data.Maybe.listToMaybe++{- Like last but Nothing on empty list. -}+lastMaybe :: [a] -> Maybe a+lastMaybe [] = Nothing+lastMaybe v = Just $ Prelude.last v++{- All but the last element of a list.+ - (Like init, but no error on an empty list.) -}+beginning :: [a] -> [a]+beginning [] = []+beginning l = Prelude.init l++{- Like last, but no error on an empty list. -}+end :: [a] -> [a]+end [] = []+end l = [Prelude.last l]
+ Utility/PosixFiles.hs view
@@ -0,0 +1,33 @@+{- POSIX files (and compatablity wrappers).+ -+ - This is like System.PosixCompat.Files, except with a fixed rename.+ -+ - Copyright 2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.PosixFiles (+	module X,+	rename+) where++import System.PosixCompat.Files as X hiding (rename)++#ifndef mingw32_HOST_OS+import System.Posix.Files (rename)+#else+import qualified System.Win32.File as Win32+#endif++{- System.PosixCompat.Files.rename on Windows calls renameFile,+ - so cannot rename directories. + -+ - Instead, use Win32 moveFile, which can. It needs to be told to overwrite+ - any existing file. -}+#ifdef mingw32_HOST_OS+rename :: FilePath -> FilePath -> IO ()+rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING+#endif
+ Utility/Process.hs view
@@ -0,0 +1,360 @@+{- System.Process enhancements, including additional ways of running+ - processes, and logging.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP, Rank2Types #-}++module Utility.Process (+	module X,+	CreateProcess,+	StdHandle(..),+	readProcess,+	readProcessEnv,+	writeReadProcessEnv,+	forceSuccessProcess,+	checkSuccessProcess,+	ignoreFailureProcess,+	createProcessSuccess,+	createProcessChecked,+	createBackgroundProcess,+	processTranscript,+	processTranscript',+	withHandle,+	withBothHandles,+	withQuietOutput,+	createProcess,+	startInteractiveProcess,+	stdinHandle,+	stdoutHandle,+	stderrHandle,+	devNull,+) where++import qualified System.Process+import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)+import System.Process hiding (createProcess, readProcess)+import System.Exit+import System.IO+import System.Log.Logger+import Control.Concurrent+import qualified Control.Exception as E+import Control.Monad+#ifndef mingw32_HOST_OS+import System.Posix.IO+#else+import Control.Applicative+#endif+import Data.Maybe++import Utility.Misc+import Utility.Exception++type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a++data StdHandle = StdinHandle | StdoutHandle | StderrHandle+	deriving (Eq)++{- Normally, when reading from a process, it does not need to be fed any+ - standard input. -}+readProcess :: FilePath	-> [String] -> IO String+readProcess cmd args = readProcessEnv cmd args Nothing++readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String+readProcessEnv cmd args environ =+	withHandle StdoutHandle createProcessSuccess p $ \h -> do+		output  <- hGetContentsStrict h+		hClose h+		return output+  where+	p = (proc cmd args)+		{ std_out = CreatePipe+		, env = environ+		}++{- Runs an action to write to a process on its stdin, + - returns its output, and also allows specifying the environment.+ -}+writeReadProcessEnv+	:: FilePath+	-> [String]+	-> Maybe [(String, String)]+	-> (Maybe (Handle -> IO ()))+	-> (Maybe (Handle -> IO ()))+	-> IO String+writeReadProcessEnv cmd args environ writestdin adjusthandle = do+	(Just inh, Just outh, _, pid) <- createProcess p++	maybe (return ()) (\a -> a inh) adjusthandle+	maybe (return ()) (\a -> a outh) adjusthandle++	-- fork off a thread to start consuming the output+	output  <- hGetContents outh+	outMVar <- newEmptyMVar+	_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()++	-- now write and flush any input+	maybe (return ()) (\a -> a inh >> hFlush inh) writestdin+	hClose inh -- done with stdin++	-- wait on the output+	takeMVar outMVar+	hClose outh++	-- wait on the process+	forceSuccessProcess p pid++	return output++  where+	p = (proc cmd args)+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, env = environ+		}++{- Waits for a ProcessHandle, and throws an IOError if the process+ - did not exit successfully. -}+forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()+forceSuccessProcess p pid = do+	code <- waitForProcess pid+	case code of+		ExitSuccess -> return ()+		ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n++{- Waits for a ProcessHandle and returns True if it exited successfully.+ - Note that using this with createProcessChecked will throw away+ - the Bool, and is only useful to ignore the exit code of a process,+ - while still waiting for it. -}+checkSuccessProcess :: ProcessHandle -> IO Bool+checkSuccessProcess pid = do+	code <- waitForProcess pid+	return $ code == ExitSuccess++ignoreFailureProcess :: ProcessHandle -> IO Bool+ignoreFailureProcess pid = do+	void $ waitForProcess pid+	return True++{- Runs createProcess, then an action on its handles, and then+ - forceSuccessProcess. -}+createProcessSuccess :: CreateProcessRunner+createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a++{- Runs createProcess, then an action on its handles, and then+ - a checker action on its exit code, which must wait for the process. -}+createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner+createProcessChecked checker p a = do+	t@(_, _, _, pid) <- createProcess p+	r <- tryNonAsync $ a t+	_ <- checker pid+	either E.throw return r++{- Leaves the process running, suitable for lazy streaming.+ - Note: Zombies will result, and must be waited on. -}+createBackgroundProcess :: CreateProcessRunner+createBackgroundProcess p a = a =<< createProcess p++{- Runs a process, optionally feeding it some input, and+ - returns a transcript combining its stdout and stderr, and+ - whether it succeeded or failed. -}+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)+processTranscript cmd opts input = processTranscript' cmd opts Nothing input++processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)+#ifndef mingw32_HOST_OS+{- This implementation interleves stdout and stderr in exactly the order+ - the process writes them. -}+processTranscript' cmd opts environ input = do+	(readf, writef) <- createPipe+	readh <- fdToHandle readf+	writeh <- fdToHandle writef+	p@(_, _, _, pid) <- createProcess $+		(proc cmd opts)+			{ std_in = if isJust input then CreatePipe else Inherit+			, std_out = UseHandle writeh+			, std_err = UseHandle writeh+			, env = environ+			}+	hClose writeh++	get <- mkreader readh++	-- now write and flush any input+	case input of+		Just s -> do+			let inh = stdinHandle p+			unless (null s) $ do+				hPutStr inh s+				hFlush inh+			hClose inh+		Nothing -> return ()++	transcript <- get++	ok <- checkSuccessProcess pid+	return (transcript, ok)+#else+{- This implementation for Windows puts stderr after stdout. -}+processTranscript' cmd opts environ input = do+	p@(_, _, _, pid) <- createProcess $+		(proc cmd opts)+			{ std_in = if isJust input then CreatePipe else Inherit+			, std_out = CreatePipe+			, std_err = CreatePipe+			, env = environ+			}++	getout <- mkreader (stdoutHandle p)+	geterr <- mkreader (stderrHandle p)++	case input of+		Just s -> do+			let inh = stdinHandle p+			unless (null s) $ do+				hPutStr inh s+				hFlush inh+			hClose inh+		Nothing -> return ()+	+	transcript <- (++) <$> getout <*> geterr+	ok <- checkSuccessProcess pid+	return (transcript, ok)+#endif+  where+	mkreader h = do+		s <- hGetContents h+		v <- newEmptyMVar+		void $ forkIO $ do+			void $ E.evaluate (length s)+			putMVar v ()+		return $ do+			takeMVar v+			return s++{- Runs a CreateProcessRunner, on a CreateProcess structure, that+ - is adjusted to pipe only from/to a single StdHandle, and passes+ - the resulting Handle to an action. -}+withHandle+	:: StdHandle+	-> CreateProcessRunner+	-> CreateProcess+	-> (Handle -> IO a)+	-> IO a+withHandle h creator p a = creator p' $ a . select+  where+	base = p+		{ std_in = Inherit+		, std_out = Inherit+		, std_err = Inherit+		}+	(select, p')+		| h == StdinHandle  =+			(stdinHandle, base { std_in = CreatePipe })+		| h == StdoutHandle =+			(stdoutHandle, base { std_out = CreatePipe })+		| h == StderrHandle =+			(stderrHandle, base { std_err = CreatePipe })++{- Like withHandle, but passes (stdin, stdout) handles to the action. -}+withBothHandles+	:: CreateProcessRunner+	-> CreateProcess+	-> ((Handle, Handle) -> IO a)+	-> IO a+withBothHandles creator p a = creator p' $ a . bothHandles+  where+	p' = p+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		}++{- Forces the CreateProcessRunner to run quietly;+ - both stdout and stderr are discarded. -}+withQuietOutput+	:: CreateProcessRunner+	-> CreateProcess+	-> IO ()+withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do+	let p' = p+		{ std_out = UseHandle nullh+		, std_err = UseHandle nullh+		}+	creator p' $ const $ return ()++devNull :: FilePath+#ifndef mingw32_HOST_OS+devNull = "/dev/null"+#else+devNull = "NUL"+#endif++{- Extract a desired handle from createProcess's tuple.+ - These partial functions are safe as long as createProcess is run+ - with appropriate parameters to set up the desired handle.+ - Get it wrong and the runtime crash will always happen, so should be+ - easily noticed. -}+type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle+stdinHandle :: HandleExtractor+stdinHandle (Just h, _, _, _) = h+stdinHandle _ = error "expected stdinHandle"+stdoutHandle :: HandleExtractor+stdoutHandle (_, Just h, _, _) = h+stdoutHandle _ = error "expected stdoutHandle"+stderrHandle :: HandleExtractor+stderrHandle (_, _, Just h, _) = h+stderrHandle _ = error "expected stderrHandle"+bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)+bothHandles (Just hin, Just hout, _, _) = (hin, hout)+bothHandles _ = error "expected bothHandles"++{- Debugging trace for a CreateProcess. -}+debugProcess :: CreateProcess -> IO ()+debugProcess p = do+	debugM "Utility.Process" $ unwords+		[ action ++ ":"+		, showCmd p+		]+  where+	action+		| piped (std_in p) && piped (std_out p) = "chat"+		| piped (std_in p)                      = "feed"+		| piped (std_out p)                     = "read"+		| otherwise                             = "call"+	piped Inherit = False+	piped _ = True++{- Shows the command that a CreateProcess will run. -}+showCmd :: CreateProcess -> String+showCmd = go . cmdspec+  where+	go (ShellCommand s) = s+	go (RawCommand c ps) = c ++ " " ++ show ps++{- Starts an interactive process. Unlike runInteractiveProcess in+ - System.Process, stderr is inherited. -}+startInteractiveProcess+	:: FilePath+	-> [String]+	-> Maybe [(String, String)]+	-> IO (ProcessHandle, Handle, Handle)+startInteractiveProcess cmd args environ = do+	let p = (proc cmd args)+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, env = environ+		}+	(Just from, Just to, _, pid) <- createProcess p+	return (pid, to, from)++{- Wrapper around System.Process function that does debug logging. -}+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess p = do+	debugProcess p+	System.Process.createProcess p
+ Utility/SafeCommand.hs view
@@ -0,0 +1,120 @@+{- safely running shell commands+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.SafeCommand where++import System.Exit+import Utility.Process+import System.Process (env)+import Data.String.Utils+import Control.Applicative+import System.FilePath+import Data.Char++{- A type for parameters passed to a shell command. A command can+ - be passed either some Params (multiple parameters can be included,+ - whitespace-separated, or a single Param (for when parameters contain+ - whitespace), or a File.+ -}+data CommandParam = Params String | Param String | File FilePath+	deriving (Eq, Show, Ord)++{- Used to pass a list of CommandParams to a function that runs+ - a command and expects Strings. -}+toCommand :: [CommandParam] -> [String]+toCommand = concatMap unwrap+  where+	unwrap (Param s) = [s]+	unwrap (Params s) = filter (not . null) (split " " s)+	-- Files that start with a non-alphanumeric that is not a path+	-- separator are modified to avoid the command interpreting them as+	-- options or other special constructs.+	unwrap (File s@(h:_))+		| isAlphaNum h || h `elem` pathseps = [s]+		| otherwise = ["./" ++ s]+	unwrap (File s) = [s]+	-- '/' is explicitly included because it's an alternative+	-- path separator on Windows.+	pathseps = pathSeparator:"./"++{- Run a system command, and returns True or False+ - if it succeeded or failed.+ -}+boolSystem :: FilePath -> [CommandParam] -> IO Bool+boolSystem command params = boolSystemEnv command params Nothing++boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool+boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ+  where+	dispatch ExitSuccess = True+	dispatch _ = False++{- Runs a system command, returning the exit status. -}+safeSystem :: FilePath -> [CommandParam] -> IO ExitCode+safeSystem command params = safeSystemEnv command params Nothing++safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode+safeSystemEnv command params environ = do+	(_, _, _, pid) <- createProcess (proc command $ toCommand params)+		{ env = environ }+	waitForProcess pid++{- Wraps a shell command line inside sh -c, allowing it to be run in a+ - login shell that may not support POSIX shell, eg csh. -}+shellWrap :: String -> String+shellWrap cmdline = "sh -c " ++ shellEscape cmdline++{- Escapes a filename or other parameter to be safely able to be exposed to+ - the shell.+ -+ - This method works for POSIX shells, as well as other shells like csh.+ -}+shellEscape :: String -> String+shellEscape f = "'" ++ escaped ++ "'"+  where+	-- replace ' with '"'"'+	escaped = join "'\"'\"'" $ split "'" f++{- Unescapes a set of shellEscaped words or filenames. -}+shellUnEscape :: String -> [String]+shellUnEscape [] = []+shellUnEscape s = word : shellUnEscape rest+  where+	(word, rest) = findword "" s+	findword w [] = (w, "")+	findword w (c:cs)+		| c == ' ' = (w, cs)+		| c == '\'' = inquote c w cs+		| c == '"' = inquote c w cs+		| otherwise = findword (w++[c]) cs+	inquote _ w [] = (w, "")+	inquote q w (c:cs)+		| c == q = findword w cs+		| otherwise = inquote q (w++[c]) cs++{- For quickcheck. -}+prop_idempotent_shellEscape :: String -> Bool+prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s+prop_idempotent_shellEscape_multiword :: [String] -> Bool+prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s++{- Segements a list of filenames into groups that are all below the manximum+ - command-line length limit. Does not preserve order. -}+segmentXargs :: [FilePath] -> [[FilePath]]+segmentXargs l = go l [] 0 []+  where+	go [] c _ r = c:r+	go (f:fs) c accumlen r+		| len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)+		| otherwise = go fs (f:c) newlen r+	  where+		len = length f+		newlen = accumlen + len++	{- 10k of filenames per command, well under Linux's 20k limit;+	 - allows room for other parameters etc. -}+	maxlen = 10240
+ Utility/Tmp.hs view
@@ -0,0 +1,100 @@+{- Temporary files and directories.+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Utility.Tmp where++import Control.Exception (bracket)+import System.IO+import System.Directory+import Control.Monad.IfElse+import System.FilePath++import Utility.Exception+import Utility.FileSystemEncoding+import Utility.PosixFiles++type Template = String++{- Runs an action like writeFile, writing to a temp file first and+ - then moving it into place. The temp file is stored in the same+ - directory as the final file to avoid cross-device renames. -}+viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()+viaTmp a file content = do+	let (dir, base) = splitFileName file+	createDirectoryIfMissing True dir+	(tmpfile, handle) <- openTempFile dir (base ++ ".tmp")+	hClose handle+	a tmpfile content+	rename tmpfile file++{- Runs an action with a tmp file located in the system's tmp directory+ - (or in "." if there is none) then removes the file. -}+withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFile template a = do+	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	withTmpFileIn tmpdir template a++{- Runs an action with a tmp file located in the specified directory,+ - then removes the file. -}+withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a+withTmpFileIn tmpdir template a = bracket create remove use+  where+	create = openTempFile tmpdir template+	remove (name, handle) = do+		hClose handle+		catchBoolIO (removeFile name >> return True)+	use (name, handle) = a name handle++{- Runs an action with a tmp directory located within the system's tmp+ - directory (or within "." if there is none), then removes the tmp+ - directory and all its contents. -}+withTmpDir :: Template -> (FilePath -> IO a) -> IO a+withTmpDir template a = do+	tmpdir <- catchDefaultIO "." getTemporaryDirectory+	withTmpDirIn tmpdir template a++{- Runs an action with a tmp directory located within a specified directory,+ - then removes the tmp directory and all its contents. -}+withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a+withTmpDirIn tmpdir template = bracket create remove+  where+	remove d = whenM (doesDirectoryExist d) $ do+#if mingw32_HOST_OS+		-- Windows will often refuse to delete a file+		-- after a process has just written to it and exited.+		-- Because it's crap, presumably. So, ignore failure+		-- to delete the temp directory.+		_ <- tryIO $ removeDirectoryRecursive d+		return ()+#else+		removeDirectoryRecursive d+#endif+	create = do+		createDirectoryIfMissing True tmpdir+		makenewdir (tmpdir </> template) (0 :: Int)+	makenewdir t n = do+		let dir = t ++ "." ++ show n+		either (const $ makenewdir t $ n + 1) (const $ return dir)+			=<< tryIO (createDirectory dir)++{- It's not safe to use a FilePath of an existing file as the template+ - for openTempFile, because if the FilePath is really long, the tmpfile+ - will be longer, and may exceed the maximum filename length.+ -+ - This generates a template that is never too long.+ - (Well, it allocates 20 characters for use in making a unique temp file,+ - anyway, which is enough for the current implementation and any+ - likely implementation.)+ -}+relatedTemplate :: FilePath -> FilePath+relatedTemplate f+	| len > 20 = truncateFilePath (len - 20) f+	| otherwise = f+  where+	len = length f
+ config.hs view
@@ -0,0 +1,83 @@+{- This is the main configuration file for Propellor, and is used to build+ - the propellor program. -}++import Propellor+import Propellor.CmdLine+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Network as Network+import qualified Propellor.Property.Ssh as Ssh+import qualified Propellor.Property.Sudo as Sudo+import qualified Propellor.Property.User as User+import qualified Propellor.Property.Hostname as Hostname+import qualified Propellor.Property.Reboot as Reboot+import qualified Propellor.Property.Tor as Tor+import qualified Propellor.Property.Docker as Docker+import qualified Propellor.Property.GitHome as GitHome+import qualified Propellor.Property.JoeySites as JoeySites++main :: IO ()+main = defaultMain getProperties++{- | This is where the system's HostName, either as returned by uname+ - or one specified on the command line, is converted into a list of+ - Properties for that system.+ -+ - Edit this to configure propellor!+ -}+getProperties :: HostName -> Maybe [Property]+getProperties hostname@"clam.kitenet.net" = Just+	[ cleanCloudAtCost hostname+	, standardSystem Apt.Unstable+	, Network.ipv6to4+	-- Clam is a tor bridge, and an olduse.net shellbox.+	, Tor.isBridge+	, JoeySites.oldUseNetshellBox+	-- I play with docker on clam.+	, Docker.configured+	-- This is not an important system so I don't want to need to +	-- manually upgrade it.+	, Apt.unattendedUpgrades True+	-- Should come last as it reboots.+	, Apt.installed ["systemd-sysv"] `onChange` Reboot.now+	]+-- add more hosts here...+--getProperties "foo" =+getProperties _ = Nothing++-- This is my standard system setup+standardSystem :: Apt.Suite -> Property+standardSystem suite = propertyList "standard system"+	[ Apt.stdSourcesList suite `onChange` Apt.upgrade+	, Apt.installed ["etckeeper"]+	, Apt.installed ["ssh"]+	, GitHome.installedFor "root"+	, User.hasSomePassword "root"+	-- Harden the system, but only once root's authorized_keys+	-- is safely in place.+	, check (Ssh.hasAuthorizedKeys "root") $+		Ssh.passwordAuthentication False+	, User.sshAccountFor "joey"+	, User.hasSomePassword "joey"+	, Sudo.enabledFor "joey"+	, GitHome.installedFor "joey"+	, Apt.installed ["vim", "screen"]+	-- I use postfix, or no MTA.+	, Apt.removed ["exim4"] `onChange` Apt.autoRemove+	]++-- Clean up a system as installed by cloudatcost.com+cleanCloudAtCost :: HostName -> Property+cleanCloudAtCost hostname = propertyList "cloudatcost cleanup"+	[ Hostname.set hostname+	, Ssh.uniqueHostKeys+	, "worked around grub/lvm boot bug #743126" ==>+		"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"+		`onChange` cmdProperty "update-grub" []+		`onChange` cmdProperty "update-initramfs" ["-u"]+	, "nuked cloudatcost cruft" ==> combineProperties+		[ File.notPresent "/etc/rc.local"+		, File.notPresent "/etc/init.d/S97-setup.sh"+		, User.nuked "user" User.YesReallyDeleteHome+		]+	]
+ propellor.cabal view
@@ -0,0 +1,82 @@+Name: propellor+Version: 0.1+Cabal-Version: >= 1.6+License: GPL+Maintainer: Joey Hess <joey@kitenet.net>+Author: Joey Hess+Stability: Stable+Copyright: 2014 Joey Hess+License-File: GPL+Build-Type: Simple+Homepage: http://joeyh.name/code/propellor/+Category: Utility+Extra-Source-Files:+  README+  TODO+  Makefile+Synopsis: property-based host configuration management in haskell+Description:+ Propellor enures that the system it's run in satisfies a list of+ properties, taking action as necessary when a property is not yet met.+ .+ While Propellor can be installed from hackage, to customize and use it+ you should fork its git repository and modify it from there:+   git clone git://git.kitenet.net/propellor++Executable propellor+  Main-Is: config.hs+  GHC-Options: -Wall+  Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, +   IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,+   containers++  if (! os(windows))+    Build-Depends: unix++Library+  GHC-Options: -Wall+  Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, +   IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,+   containers++  if (! os(windows))+    Build-Depends: unix++  Exposed-Modules:+    Propellor+    Propellor.Property+    Propellor.Property.Apt+    Propellor.Property.Cmd+    Propellor.Property.Docker+    Propellor.Property.File+    Propellor.Property.GitHome+    Propellor.Property.Hostname+    Propellor.Property.JoeySites+    Propellor.Property.Network+    Propellor.Property.Reboot+    Propellor.Property.Ssh+    Propellor.Property.Sudo+    Propellor.Property.Tor+    Propellor.Property.User+    Propellor.CmdLine+    Propellor.PrivData+    Propellor.Types+  Other-Modules:+    Utility.Applicative+    Utility.Data+    Utility.Directory+    Utility.Env+    Utility.Exception+    Utility.FileMode+    Utility.FileSystemEncoding+    Utility.Misc+    Utility.Monad+    Utility.PartialPrelude+    Utility.PosixFiles+    Utility.Process+    Utility.SafeCommand+    Utility.Tmp++source-repository head+  type: git+  location: git://git.kitenet.net/propellor.git