packages feed

propellor 0.5.1 → 0.5.3

raw patch · 133 files changed

+6869/−7254 lines, 133 filesnew-component:exe:wrapperPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- Propellor.Property.SiteSpecific.GitAnnexBuilder: builder :: Architecture -> CronTimes -> Bool -> Property
+ Propellor.Property: doNothing :: Property
+ Propellor.Property.Docker: expose :: String -> Property
+ Propellor.Property.HostingProvider.CloudAtCost: decruft :: Property
+ Propellor.Property.HostingProvider.DigitalOcean: distroKernel :: Property
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: androidAutoBuilderContainer :: (System -> Image) -> CronTimes -> TimeOut -> Host
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: androidContainer :: (System -> Image) -> ContainerName -> Property -> FilePath -> Host
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: armelAutoBuilderContainer :: (System -> Image) -> CronTimes -> TimeOut -> Host
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: armelCompanionContainer :: (System -> Image) -> Host
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: autobuilder :: CronTimes -> TimeOut -> Bool -> Property
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: buildDepsApt :: Property
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: buildDepsFewHaskellLibs :: Property
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: buildDepsNoHaskellLibs :: Property
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: cabalDeps :: Property
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: standardAutoBuilderContainer :: (System -> Image) -> Architecture -> Int -> TimeOut -> Host
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: tree :: Architecture -> Property
+ Propellor.Property.SiteSpecific.GitAnnexBuilder: type TimeOut = String
+ Propellor.Property.SiteSpecific.JoeySites: ircBouncer :: Property

Files

CHANGELOG view
@@ -1,3 +1,24 @@+propellor (0.5.3) unstable; urgency=medium++  * Fix unattended-upgrades config for !stable.+  * Ensure that kernel hostname is same as /etc/hostname when configuring+    hostname.+  * Added modules for some hosting providers (DigitalOcean, CloudAtCost).++ -- Joey Hess <joeyh@debian.org>  Thu, 29 May 2014 14:29:53 -0400++propellor (0.5.2) unstable; urgency=medium++  * A bug that caused propellor to hang when updating a running docker+    container appears to have been fixed. Note that since it affects+    the propellor process that serves as "init" of docker containers,+    they have to be restarted for the fix to take effect.+  * Licence changed from GPL to BSD.+  * A few changes to allow building Propellor on OSX. One user reports+    successfully using it there.++ -- Joey Hess <joeyh@debian.org>  Sat, 17 May 2014 16:42:55 -0400+ propellor (0.5.1) unstable; urgency=medium    * Primary DNS servers now have allow-transfer automatically populated
− GPL 
@@ -1,674 +0,0 @@-                    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>.
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright 2014 Joey Hess <joeyh@debian.org> and contributors.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
Makefile view
@@ -19,7 +19,7 @@  install: 	install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor-	install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin+	install -s dist/build/wrapper/wrapper $(DESTDIR)/usr/bin/propellor 	$(CABAL) sdist 	cat dist/propellor-*.tar.gz | \ 		(cd $(DESTDIR)/usr/src/propellor && tar zx --strip-components=1)@@ -30,8 +30,10 @@ 	find -name \*.hi -exec rm {} \;  # hothasktags chokes on some template haskell etc, so ignore errors+# duplicate tags with Propellor.Property. removed from the start, as we+# often import qualified by just the module base name. tags:-	find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null+	find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags  2>/dev/null  # Upload to hackage. hackage:
− Propellor.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE PackageImports #-}---- | Pulls in lots of useful modules for building and using Properties.--- --- When propellor runs on a Host, it ensures that its list of Properties--- is satisfied, taking action as necessary when a Property is not--- currently satisfied.------ A simple propellor program example:------ > import Propellor--- > import Propellor.CmdLine--- > import qualified Propellor.Property.File as File--- > import qualified Propellor.Property.Apt as Apt--- > --- > main :: IO ()--- > main = defaultMain hosts--- > --- > hosts :: [Host]--- > hosts =--- >   [ host "example.com"--- >     & Apt.installed ["mydaemon"]--- >     & "/etc/mydaemon.conf" `File.containsLine` "secure=1"--- >       `onChange` cmdProperty "service" ["mydaemon", "restart"]--- >     ! Apt.installed ["unwantedpackage"]--- >   ]------ See config.hs for a more complete example, and clone Propellor's--- git repository for a deployable system using Propellor:--- git clone <git://git.kitenet.net/propellor>--module Propellor (-	  module Propellor.Types-	, module Propellor.Property-	, module Propellor.Property.Cmd-	, module Propellor.Attr-	, module Propellor.PrivData-	, module Propellor.Engine-	, module Propellor.Exception-	, module Propellor.Message-	, localdir--	, module X-) where--import Propellor.Types-import Propellor.Property-import Propellor.Engine-import Propellor.Property.Cmd-import Propellor.PrivData-import Propellor.Message-import Propellor.Exception-import Propellor.Attr--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-import Data.Monoid as X-import Control.Monad.IfElse as X-import "mtl" Control.Monad.Reader as X---- | This is where propellor installs itself when deploying a host.-localdir :: FilePath-localdir = "/usr/local/propellor"
− Propellor/Attr.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Propellor.Attr where--import Propellor.Types-import Propellor.Types.Attr--import "mtl" Control.Monad.Reader-import qualified Data.Set as S-import qualified Data.Map as M-import Data.Maybe-import Control.Applicative--pureAttrProperty :: Desc -> SetAttr -> Property -pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)--hostname :: HostName -> Property-hostname name = pureAttrProperty ("hostname " ++ name) $-	\d -> d { _hostname = name }--getHostName :: Propellor HostName-getHostName = asks _hostname--os :: System -> Property-os system = pureAttrProperty ("Operating " ++ show system) $-	\d -> d { _os = Just system }--getOS :: Propellor (Maybe System)-getOS = asks _os---- | Indidate that a host has an A record in the DNS.------ TODO check at run time if the host really has this address.--- (Can't change the host's address, but as a sanity check.)-ipv4 :: String -> Property-ipv4 addr = pureAttrProperty ("ipv4 " ++ addr)-	(addDNS $ Address $ IPv4 addr)---- | Indidate that a host has an AAAA record in the DNS.-ipv6 :: String -> Property-ipv6 addr = pureAttrProperty ("ipv6 " ++ addr)-	(addDNS $ Address $ IPv6 addr)---- | Indicates another name for the host in the DNS.-alias :: Domain -> Property-alias domain = pureAttrProperty ("alias " ++ domain)-	(addDNS $ CNAME $ AbsDomain domain)--addDNS :: Record -> SetAttr-addDNS record d = d { _dns = S.insert record (_dns d) }---- | Adds a DNS NamedConf stanza.------ Note that adding a Master stanza for a domain always overrides an--- existing Secondary stanza, while a Secondary stanza is only added--- when there is no existing Master stanza.-addNamedConf :: NamedConf -> SetAttr-addNamedConf conf d = d { _namedconf = new }-  where-	m = _namedconf d-	domain = confDomain conf-	new = case (confDnsServerType conf, confDnsServerType <$> M.lookup domain m) of-		(Secondary, Just Master) -> m-		_  -> M.insert domain conf m--getNamedConf :: Propellor (M.Map Domain NamedConf)-getNamedConf = asks _namedconf--sshPubKey :: String -> Property-sshPubKey k = pureAttrProperty ("ssh pubkey known") $-	\d -> d { _sshPubKey = Just k }--getSshPubKey :: Propellor (Maybe String)-getSshPubKey = asks _sshPubKey--hostnameless :: Attr-hostnameless = newAttr (error "hostname Attr not specified")--hostAttr :: Host -> Attr-hostAttr (Host _ mkattrs) = mkattrs hostnameless--hostProperties :: Host -> [Property]-hostProperties (Host ps _) = ps--hostMap :: [Host] -> M.Map HostName Host-hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l --hostAttrMap :: [Host] -> M.Map HostName Attr-hostAttrMap l = M.fromList $ zip (map _hostname attrs) attrs-  where-	attrs = map hostAttr l--findHost :: [Host] -> HostName -> Maybe Host-findHost l hn = M.lookup hn (hostMap l)--getAddresses :: Attr -> [IPAddr]-getAddresses = mapMaybe getIPAddr . S.toList . _dns--hostAddresses :: HostName -> [Host] -> [IPAddr]-hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of-	Nothing -> []-	Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr---- | Lifts an action into a different host.------ For example, `fromHost hosts "otherhost" getSshPubKey`-fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)-fromHost l hn getter = case findHost l hn of-	Nothing -> return Nothing-	Just h -> liftIO $ Just <$>-		runReaderT (runWithAttr getter) (hostAttr h)
− Propellor/CmdLine.hs 
@@ -1,383 +0,0 @@-module Propellor.CmdLine where--import System.Environment (getArgs)-import Data.List-import System.Exit-import System.Log.Logger-import System.Log.Formatter-import System.Log.Handler (setFormatter, LogHandler)-import System.Log.Handler.Simple-import System.PosixCompat-import Control.Exception (bracket)-import System.Posix.IO-import Data.Time.Clock.POSIX--import Propellor-import qualified Propellor.Property.Docker as Docker-import qualified Propellor.Property.Docker.Shim as DockerShim-import Utility.FileMode-import Utility.SafeCommand-import Utility.UserInfo--usage :: IO a-usage = do-	putStrLn $ unlines -		[ "Usage:"-		, "  propellor"-		, "  propellor hostname"-		, "  propellor --spin hostname"-		, "  propellor --set hostname field"-		, "  propellor --add-key keyid"-		]-	exitFailure--processCmdLine :: IO CmdLine-processCmdLine = go =<< getArgs-  where-  	go ("--help":_) = usage-  	go ("--spin":h:[]) = return $ Spin h-  	go ("--boot":h:[]) = return $ Boot h-	go ("--add-key":k:[]) = return $ AddKey k-	go ("--set":h:f:[]) = case readish f of-		Just pf -> return $ Set h pf-		Nothing -> errorMessage $ "Unknown privdata field " ++ f-	go ("--continue":s:[]) = case readish s of-		Just cmdline -> return $ Continue cmdline-		Nothing -> errorMessage "--continue serialization failure"-  	go ("--chain":h:[]) = return $ Chain h-	go ("--docker":h:[]) = return $ Docker h-	go (h:[])-		| "--" `isPrefixOf` h = usage-		| otherwise = return $ Run h-	go [] = do-		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]-		if null s-			then errorMessage "Cannot determine hostname! Pass it on the command line."-			else return $ Run s-	go _ = usage--defaultMain :: [Host] -> IO ()-defaultMain hostlist = do-	DockerShim.cleanEnv-	checkDebugMode-	cmdline <- processCmdLine-	debug ["command line: ", show cmdline]-	go True cmdline-  where-	go _ (Continue cmdline) = go False cmdline-	go _ (Set hn field) = setPrivData hn field-	go _ (AddKey keyid) = addKey keyid-	go _ (Chain hn) = withprops hn $ \attr ps -> do-		r <- runPropellor attr $ ensureProperties ps-		putStrLn $ "\n" ++ show r-	go _ (Docker hn) = Docker.chain hn-	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline-	go True cmdline = updateFirst cmdline $ go False cmdline-	go False (Spin hn) = withprops hn $ const . const $ spin hn-	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)-		( onlyProcess $ withprops hn mainProperties-		, go True (Spin hn)-		)-	go False (Boot hn) = onlyProcess $ withprops hn boot--	withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()-	withprops hn a = maybe-		(unknownhost hn)-		(\h -> a (hostAttr h) (hostProperties h))-		(findHost hostlist hn)--onlyProcess :: IO a -> IO a-onlyProcess a = bracket lock unlock (const a)-  where-	lock = do-		l <- createFile lockfile stdFileMode-		setLock l (WriteLock, AbsoluteSeek, 0, 0)-			`catchIO` const alreadyrunning-		return l-	unlock = closeFd-	alreadyrunning = error "Propellor is already running on this host!"-	lockfile = localdir </> ".lock"--unknownhost :: HostName -> IO a-unknownhost h = errorMessage $ unlines-	[ "Propellor does not know about host: " ++ h-	, "(Perhaps you should specify the real hostname on the command line?)"-	, "(Or, edit propellor's config.hs to configure this host)"-	]--buildFirst :: CmdLine -> IO () -> IO ()-buildFirst cmdline next = do-	oldtime <- getmtime-	ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])-		( do-			newtime <- getmtime-			if newtime == oldtime-				then next-				else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]-		, errorMessage "Propellor build failed!" -		)-  where-	getmtime = catchMaybeIO $ getModificationTime "propellor"--getCurrentBranch :: IO String-getCurrentBranch = takeWhile (/= '\n') -	<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]--updateFirst :: CmdLine -> IO () -> IO ()-updateFirst cmdline next = do-	branchref <- getCurrentBranch-	let originbranch = "origin" </> branchref--	void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]-	-	whenM (doesFileExist keyring) $ do-		{- To verify origin branch commit's signature, have to-		 - convince gpg to use our keyring. While running git log.-		 - Which has no way to pass options to gpg.-		 - Argh! -}-		let gpgconf = privDataDir </> "gpg.conf"-		writeFile gpgconf $ unlines-			[ " keyring " ++ keyring-			, "no-auto-check-trustdb"-			]-		-- gpg is picky about perms-		modifyFileMode privDataDir (removeModes otherGroupModes)-		s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]-			(Just [("GNUPGHOME", privDataDir)])-		nukeFile $ privDataDir </> "trustdb.gpg"-		nukeFile $ privDataDir </> "pubring.gpg"-		nukeFile $ privDataDir </> "gpg.conf"-		if s == "U\n" || s == "G\n"-			then do-				putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"-				hFlush stdout-			else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"-	-	oldsha <- getCurrentGitSha1 branchref-	void $ boolSystem "git" [Param "merge", Param originbranch]-	newsha <- getCurrentGitSha1 branchref--	if oldsha == newsha-		then next-		else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])-			( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]-			, errorMessage "Propellor build failed!" -			)--getCurrentGitSha1 :: String -> IO String-getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]--spin :: HostName -> IO ()-spin hn = do-	url <- getUrl-	void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]-	void $ boolSystem "git" [Param "push"]-	cacheparams <- toCommand <$> sshCachingParams hn-	go cacheparams url =<< gpgDecrypt (privDataFile hn)-  where-	go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do-		let finish = do-			senddata toh (privDataFile hn) privDataMarker privdata-			hClose toh-			-			-- Display remaining output.-			void $ tryIO $ forever $-				showremote =<< hGetLine fromh-			hClose fromh-		status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")-		case status of-			Ready -> finish-			NeedGitClone -> do-				hClose toh-				hClose fromh-				sendGitClone hn url-				go cacheparams url privdata-	-	user = "root@"++hn--	bootstrapcmd = shellWrap $ intercalate " ; "-		[ "if [ ! -d " ++ localdir ++ " ]"-		, "then " ++ intercalate " && "-			[ "apt-get --no-install-recommends --no-upgrade -y install git make"-			, "echo " ++ toMarked statusMarker (show NeedGitClone)-			]-		, "else " ++ intercalate " && "-			[ "cd " ++ localdir-			, "if ! test -x ./propellor; then make deps build; fi"-			, "./propellor --boot " ++ hn-			]-		, "fi"-		]--	getstatus :: Handle -> IO BootStrapStatus-	getstatus h = do-		l <- hGetLine h-		case readish =<< fromMarked statusMarker l of-			Nothing -> do-				showremote l-				getstatus h-			Just status -> return status-	-	showremote s = putStrLn s-	senddata toh f marker s = void $-		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do-			sendMarked toh marker s-			return True--sendGitClone :: HostName -> String -> IO ()-sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do-	branch <- getCurrentBranch-	cacheparams <- sshCachingParams hn-	withTmpFile "propellor.git" $ \tmp _ -> allM id-		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]-		]-  where-	remotebundle = "/usr/local/propellor.git"-	unpackcmd branch = shellWrap $ intercalate " && "-		[ "git clone " ++ remotebundle ++ " " ++ localdir-		, "cd " ++ localdir-		, "git checkout -b " ++ branch-		, "git remote rm origin"-		, "rm -f " ++ remotebundle-		, "git remote add origin " ++ url-		-- same as --set-upstream-to, except origin branch-		-- has not been pulled yet-		, "git config branch."++branch++".remote origin"-		, "git config branch."++branch++".merge refs/heads/"++branch-		]--data BootStrapStatus = Ready | NeedGitClone-	deriving (Read, Show, Eq)--type Marker = String-type Marked = String--statusMarker :: Marker-statusMarker = "STATUS"--privDataMarker :: String-privDataMarker = "PRIVDATA "--toMarked :: Marker -> String -> String-toMarked marker = intercalate "\n" . map (marker ++) . lines--sendMarked :: Handle -> Marker -> String -> IO ()-sendMarked h marker s = do-	-- Prefix string with newline because sometimes a-	-- incomplete line is output.-	hPutStrLn h ("\n" ++ toMarked marker s)-	hFlush h--fromMarked :: Marker -> Marked -> Maybe String-fromMarked marker s-	| null matches = Nothing-	| otherwise = Just $ intercalate "\n" $-		map (drop len) matches-  where-	len = length marker-	matches = filter (marker `isPrefixOf`) $ lines s--boot :: Attr -> [Property] -> IO ()-boot attr ps = do-	sendMarked stdout statusMarker $ show Ready-	reply <- hGetContentsStrict stdin--	makePrivDataDir-	maybe noop (writeFileProtected privDataLocal) $-		fromMarked privDataMarker reply-	mainProperties attr ps--addKey :: String -> IO ()-addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]-  where-	gpg = boolSystem "sh"-		[ Param "-c"-		, Param $ "gpg --export " ++ keyid ++ " | gpg " ++-			unwords (gpgopts ++ ["--import"])-		]-	gitadd = boolSystem "git"-		[ Param "add"-		, File keyring-		]-	gitcommit = gitCommit-		[ File keyring-		, Param "-m"-		, Param "propellor addkey"-		]--{- Automatically sign the commit if there'a a keyring. -}-gitCommit :: [CommandParam] -> IO Bool-gitCommit ps = do-	k <- doesFileExist keyring-	boolSystem "git" $ catMaybes $-		[ Just (Param "commit")-		, if k then Just (Param "--gpg-sign") else Nothing-		] ++ map Just ps--keyring :: FilePath-keyring = privDataDir </> "keyring.gpg"--gpgopts :: [String]-gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]--getUrl :: IO String-getUrl = maybe nourl return =<< getM get urls-  where-	urls = ["remote.deploy.url", "remote.origin.url"]-	nourl = errorMessage $ "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--checkDebugMode :: IO ()-checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"-  where-	go (Just s)-		| s == "1" = do-			f <- setFormatter-				<$> streamHandler stderr DEBUG-				<*> pure (simpleLogFormatter "[$time] $msg")-			updateGlobalLogger rootLoggerName $ -				setLevel DEBUG .  setHandlers [f]-	go _ = noop---- Parameters can be passed to both ssh and scp, to enable a ssh connection--- caching socket.------ If the socket already exists, check if its mtime is older than 10--- minutes, and if so stop that ssh process, in order to not try to--- use an old stale connection. (atime would be nicer, but there's--- a good chance a laptop uses noatime)-sshCachingParams :: HostName -> IO [CommandParam]-sshCachingParams hn = do-	home <- myHomeDir-	let cachedir = home </> ".ssh" </> "propellor"-	createDirectoryIfMissing False cachedir-	let socketfile = cachedir </> hn ++ ".sock"-	let ps = -		[ Param "-o", Param ("ControlPath=" ++ socketfile)-		, Params "-o ControlMaster=auto -o ControlPersist=yes"-		]--	maybe noop (expireold ps socketfile)-		=<< catchMaybeIO (getFileStatus socketfile)-	-	return ps-		-  where-	expireold ps f s = do-		now <- truncate <$> getPOSIXTime :: IO Integer-		if modificationTime s > fromIntegral now - tenminutes-			then touchFile f-			else do-				void $ boolSystem "ssh" $-					[ Params "-O stop" ] ++ ps ++-					[ Param "localhost" ]-				nukeFile f-	tenminutes = 600
− Propellor/Engine.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Propellor.Engine where--import System.Exit-import System.IO-import Data.Monoid-import System.Console.ANSI-import "mtl" Control.Monad.Reader--import Propellor.Types-import Propellor.Message-import Propellor.Exception--runPropellor :: Attr -> Propellor a -> IO a-runPropellor attr a = runReaderT (runWithAttr a) attr--mainProperties :: Attr -> [Property] -> IO ()-mainProperties attr ps = do-	r <- runPropellor attr $-		ensureProperties [Property "overall" (ensureProperties ps) id]-	setTitle "propellor: done"-	hFlush stdout-	case r of-		FailedChange -> exitWith (ExitFailure 1)-		_ -> exitWith ExitSuccess--ensureProperties :: [Property] -> Propellor Result-ensureProperties ps = ensure ps NoChange-  where-	ensure [] rs = return rs-	ensure (l:ls) rs = do-		r <- actionMessage (propertyDesc l) (ensureProperty l)-		ensure ls (r <> rs)--ensureProperty :: Property -> Propellor Result-ensureProperty = catchPropellor . propertySatisfy
− Propellor/Exception.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Propellor.Exception where--import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M-import Control.Exception--import Propellor.Types-import Propellor.Message---- | Catches IO exceptions and returns FailedChange.-catchPropellor :: Propellor Result -> Propellor Result-catchPropellor a = either err return =<< tryPropellor a-  where-	err e =  warningMessage (show e) >> return FailedChange--tryPropellor :: Propellor a -> Propellor (Either IOException a)-tryPropellor = M.try
− Propellor/Message.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Propellor.Message where--import System.Console.ANSI-import System.IO-import System.Log.Logger-import "mtl" Control.Monad.Reader--import Propellor.Types---- | Shows a message while performing an action, with a colored status--- display.-actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r-actionMessage desc a = do-	liftIO $ do-		setTitle $ "propellor: " ++ desc-		hFlush stdout--	r <- a--	liftIO $ do-		setTitle "propellor: running"-		let (msg, intensity, color) = getActionResult r-		putStr $ desc ++ " ... "-		colorLine intensity color msg-		hFlush stdout--	return r--warningMessage :: MonadIO m => String -> m ()-warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s--colorLine :: ColorIntensity -> Color -> String -> IO ()-colorLine intensity color msg = do-	setSGR [SetColor Foreground intensity color]-	putStr msg-	setSGR []-	-- Note this comes after the color is reset, so that-	-- the color set and reset happen in the same line.-	putStrLn ""-	hFlush stdout--errorMessage :: String -> IO a-errorMessage s = do-	liftIO $ colorLine Vivid Red $ "** error: " ++ s-	error "Cannot continue!"---- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1-debug :: [String] -> IO ()-debug = debugM "propellor" . unwords
− Propellor/PrivData.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE PackageImports #-}--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 Data.List-import Control.Monad-import "mtl" Control.Monad.Reader--import Propellor.Types-import Propellor.Attr-import Propellor.Message-import Utility.Monad-import Utility.PartialPrelude-import Utility.Exception-import Utility.Process-import Utility.Tmp-import Utility.SafeCommand-import Utility.Misc---- | When the specified PrivDataField is available on the host Propellor--- is provisioning, it provies the data to the action. Otherwise, it prints--- a message to help the user make the necessary private data available.-withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result-withPrivData field a = maybe missing a =<< liftIO (getPrivData field)-  where-	missing = do-		host <- getHostName-		let host' = if ".docker" `isSuffixOf` host-			then "$parent_host"-			else host-		liftIO $ do-			warningMessage $ "Missing privdata " ++ show field-			putStrLn $ "Fix this by running: propellor --set "++host'++" '" ++ 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 <- chomp <$> 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]-  where-	chomp s-		| end s == "\n" = chomp (beginning s)-		| otherwise = s--makePrivDataDir :: IO ()-makePrivDataDir = createDirectoryIfMissing False privDataDir--privDataDir :: FilePath-privDataDir = "privdata"--privDataFile :: HostName -> FilePath-privDataFile host = privDataDir </> host ++ ".gpg"--privDataLocal :: FilePath-privDataLocal = privDataDir </> "local"--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 
@@ -1,163 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Propellor.Property where--import System.Directory-import Control.Monad-import Data.Monoid-import Data.List-import Control.Monad.IfElse-import "mtl" Control.Monad.Reader--import Propellor.Types-import Propellor.Types.Attr-import Propellor.Attr-import Propellor.Engine-import Utility.Monad-import System.FilePath---- Constructs a Property.-property :: Desc -> Propellor Result -> Property-property d s = Property d s id---- | 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) (combineSetAttrs ps)---- | Combines a list of properties, resulting in one property that--- ensures each in turn, stopping on failure.-combineProperties :: Desc -> [Property] -> Property-combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)-  where-  	go [] rs = return rs-	go (l:ls) rs = do-		r <- ensureProperty l-		case r of-			FailedChange -> return FailedChange-			_ -> go ls (r <> rs)---- | Combines together two properties, resulting in one property--- that ensures the first, and if the first succeeds, ensures the second.--- The property uses the description of the first property.-before :: Property -> Property -> Property-p1 `before` p2 = p2 `requires` p1-	`describe` (propertyDesc p1)---- | 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 p = flagFile' p . return--flagFile' :: Property -> IO FilePath -> Property-flagFile' p getflagfile = adjustProperty p $ \satisfy -> do-	flagfile <- liftIO getflagfile-	go satisfy flagfile =<< liftIO (doesFileExist flagfile)-  where-	go _ _ True = return NoChange-	go satisfy flagfile False = do-		r <- satisfy-		when (r == MadeChange) $ liftIO $ -			unlessM (doesFileExist flagfile) $ do-				createDirectoryIfMissing True (takeDirectory flagfile)-				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-p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)-  where-	satisfy = do-		r <- ensureProperty p-		case r of-			MadeChange -> do-				r' <- ensureProperty hook-				return $ r <> r'-			_ -> return r--(==>) :: Desc -> Property -> Property-(==>) = flip describe-infixl 1 ==>---- | Makes a Property only need to do anything when a test succeeds.-check :: IO Bool -> Property -> Property-check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)-	( satisfy-	, return NoChange-	)---- | Marks a Property as trivial. It can only return FailedChange or--- NoChange. ------ Useful when it's just as expensive to check if a change needs--- to be made as it is to just idempotently assure the property is--- satisfied. For example, chmodding a file.-trivial :: Property -> Property-trivial p = adjustProperty p $ \satisfy -> do-	r <- satisfy-	if r == MadeChange-		then return NoChange-		else return r---- | Makes a property that is satisfied differently depending on the host's--- operating system. ------ Note that the operating system may not be declared for some hosts.-withOS :: Desc -> (Maybe System -> Propellor Result) -> Property-withOS desc a = property desc $ a =<< getOS--boolProperty :: Desc -> IO Bool -> Property-boolProperty desc a = property desc $ ifM (liftIO a)-	( return MadeChange-	, return FailedChange-	)---- | Undoes the effect of a property.-revert :: RevertableProperty -> RevertableProperty-revert (RevertableProperty p1 p2) = RevertableProperty p2 p1---- | Starts accumulating the properties of a Host.------ > host "example.com"--- > 	& someproperty--- > 	! oldproperty--- > 	& otherproperty-host :: HostName -> Host-host hn = Host [] (\_ -> newAttr hn)---- | Adds a property to a Host------ Can add Properties and RevertableProperties-(&) :: IsProp p => Host -> p -> Host-(Host ps as) & p = Host (ps ++ [toProp p]) (setAttr p . as)--infixl 1 &---- | Adds a property to the Host in reverted form.-(!) :: Host -> RevertableProperty -> Host-(Host ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as)-  where-	q = revert p--infixl 1 !---- Changes the action that is performed to satisfy a property. -adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property-adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }---- Combines the Attr settings of two properties.-combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr-combineSetAttr p q = setAttr p . setAttr q--combineSetAttrs :: IsProp p => [p] -> SetAttr-combineSetAttrs = foldl' (.) id . map setAttr--makeChange :: IO () -> Propellor Result-makeChange a = liftIO a >> return MadeChange--noChange :: Propellor Result-noChange = return NoChange
− Propellor/Property/Apache.hs 
@@ -1,62 +0,0 @@-module Propellor.Property.Apache where--import Propellor-import qualified Propellor.Property.File as File-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Service as Service--type ConfigFile = [String]--siteEnabled :: HostName -> ConfigFile -> RevertableProperty-siteEnabled hn cf = RevertableProperty enable disable-  where-	enable = trivial $ cmdProperty "a2ensite" ["--quiet", hn]-		`describe` ("apache site enabled " ++ hn)-		`requires` siteAvailable hn cf-		`requires` installed-		`onChange` reloaded-	disable = trivial $ File.notPresent (siteCfg hn)-		`describe` ("apache site disabled " ++ hn)-		`onChange` cmdProperty "a2dissite" ["--quiet", hn]-		`requires` installed-		`onChange` reloaded--siteAvailable :: HostName -> ConfigFile -> Property-siteAvailable hn cf = siteCfg hn `File.hasContent` (comment:cf)-	`describe` ("apache site available " ++ hn)-  where-	comment = "# deployed with propellor, do not modify"--modEnabled :: String -> RevertableProperty-modEnabled modname = RevertableProperty enable disable-  where-	enable = trivial $ cmdProperty "a2enmod" ["--quiet", modname]-		`describe` ("apache module enabled " ++ modname)-		`requires` installed-		`onChange` reloaded-	disable = trivial $ cmdProperty "a2dismod" ["--quiet", modname]-		`describe` ("apache module disabled " ++ modname)-		`requires` installed-		`onChange` reloaded--siteCfg :: HostName -> FilePath-siteCfg hn = "/etc/apache2/sites-available/" ++ hn--installed :: Property-installed = Apt.installed ["apache2"]--restarted :: Property-restarted = cmdProperty "service" ["apache2", "restart"]--reloaded :: Property-reloaded = Service.reloaded "apache2"---- | Configure apache to use SNI to differentiate between--- https hosts.-multiSSL :: Property-multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`-	[ "NameVirtualHost *:443"-	, "SSLStrictSNIVHostCheck off"-	]-	`describe` "apache SNI enabled"-	`onChange` reloaded
− Propellor/Property/Apt.hs 
@@ -1,256 +0,0 @@-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 qualified Propellor.Property.Service as Service-import Propellor.Property.File (Line)--sourcesList :: FilePath-sourcesList = "/etc/apt/sources.list"--type Url = String-type Section = String--type SourcesGenerator = DebianSuite -> [Line]--showSuite :: DebianSuite -> String-showSuite Stable = "stable"-showSuite Testing = "testing"-showSuite Unstable = "unstable"-showSuite Experimental = "experimental"-showSuite (DebianRelease r) = r--backportSuite :: String-backportSuite = showSuite stableRelease ++ "-backports"--debLine :: String -> Url -> [Section] -> Line-debLine suite mirror sections = unwords $-	["deb", mirror, suite] ++ sections--srcLine :: Line -> Line-srcLine l = case words l of-	("deb":rest) -> unwords $ "deb-src" : rest-	_ -> ""--stdSections :: [Section]-stdSections = ["main", "contrib", "non-free"]--binandsrc :: String -> SourcesGenerator-binandsrc url suite-	| isStable suite = [l, srcLine l, bl, srcLine bl]-	| otherwise = [l, srcLine l]-  where-	l = debLine (showSuite suite) url stdSections-	bl = debLine backportSuite url stdSections--debCdn :: SourcesGenerator-debCdn = binandsrc "http://cdn.debian.net/debian"--kernelOrg :: SourcesGenerator-kernelOrg = binandsrc "http://mirrors.kernel.org/debian"---- | Only available for Stable and Testing-securityUpdates :: SourcesGenerator-securityUpdates suite-	| isStable suite || suite == Testing =-		let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections-		in [l, srcLine l]-	| otherwise = []---- | Makes sources.list have a standard content using the mirror CDN,--- with a particular DebianSuite.------ Since the CDN is sometimes unreliable, also adds backup lines using--- kernel.org.-stdSourcesList :: DebianSuite -> Property-stdSourcesList suite = stdSourcesList' suite []---- | Adds additional sources.list generators.------ Note that if a Property needs to enable an apt source, it's better--- to do so via a separate file in /etc/apt/sources.list.d/-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property-stdSourcesList' suite more = setSourcesList-	(concatMap (\gen -> gen suite) generators)-	`describe` ("standard sources.list for " ++ show suite)-  where-	generators = [debCdn, kernelOrg, securityUpdates] ++ more--setSourcesList :: [Line] -> Property-setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update--setSourcesListD :: [Line] -> FilePath -> Property-setSourcesListD ls basename = f `File.hasContent` ls `onChange` update-  where-	f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"--runApt :: [String] -> Property-runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv--noninteractiveEnv :: [(String, String)]-noninteractiveEnv =-		[ ("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 = installed' ["-y"]--installed' :: [String] -> [Package] -> Property-installed' params ps = robustly $ check (isInstallable ps) go-	`describe` (unwords $ "apt installed":ps)-  where-	go = runApt $ params ++ ["install"] ++ ps--installedBackport :: [Package] -> Property-installedBackport ps = trivial $ withOS desc $ \o -> case o of-	Nothing -> error "cannot install backports; os not declared"-	(Just (System (Debian suite) _))-		| isStable suite -> -			ensureProperty $ runApt $ -				["install", "-t", backportSuite, "-y"] ++ ps-	_ -> error $ "backports not supported on " ++ show o-  where-	desc = (unwords $ "apt installed backport":ps)---- | Minimal install of package, without recommends.-installedMin :: [Package] -> Property-installedMin = installed' ["--no-install-recommends", "-y"]--removed :: [Package] -> Property-removed ps = check (or <$> isInstalled' ps) go-	`describe` (unwords $ "apt removed":ps)-  where-	go = runApt $ ["-y", "remove"] ++ ps--buildDep :: [Package] -> Property-buildDep ps = robustly go-	`describe` (unwords $ "apt build-dep":ps)-  where-	go = runApt $ ["-y", "build-dep"] ++ ps---- | Installs the build deps for the source package unpacked--- in the specifed directory, with a dummy package also--- installed so that autoRemove won't remove them.-buildDepIn :: FilePath -> Property-buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]-  where-	go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]-			noninteractiveEnv---- | Package installation may fail becuse the archive has changed.--- Run an update in that case and retry.-robustly :: Property -> Property-robustly p = adjustProperty p $ \satisfy -> do-	r <- satisfy-	if r == FailedChange-		then ensureProperty $ p `requires` update-		else return r--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"---- | Enables unattended upgrades. Revert to disable.-unattendedUpgrades :: RevertableProperty-unattendedUpgrades = RevertableProperty enable disable-  where-	enable = setup True-		`before` Service.running "cron"-		`before` configure-	disable = setup False--	setup 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"-	-	configure = withOS "unattended upgrades configured" $ \o ->-		case o of-			-- the package defaults to only upgrading stable-			(Just (System (Debian suite) _))-				| not (isStable suite) -> ensureProperty $-					"/etc/apt/apt.conf.d/50unattended-upgrades"-						`File.containsLine`-					("\t\"o=Debian,a="++showSuite suite++"\";")-			_ -> noChange---- | 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 $ \(tmpl, tmpltype, value) ->-					hPutStrLn h $ unwords [package, tmpl, tmpltype, value]-				hClose h-	reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv---- | Ensures that a service is installed and running.------ Assumes that there is a 1:1 mapping between service names and apt--- package names.-serviceInstalledRunning :: Package -> Property-serviceInstalledRunning svc = Service.running svc `requires` installed [svc]--data AptKey = AptKey-	{ keyname :: String-	, pubkey :: String-	}--trustsKey :: AptKey -> RevertableProperty-trustsKey k = RevertableProperty trust untrust-  where-	desc = "apt trusts key " ++ keyname k-	f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"-	untrust = File.notPresent f-	trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do-		withHandle StdinHandle createProcessSuccess-			(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do-				hPutStr h (pubkey k)-				hClose h-		nukeFile $ f ++ "~" -- gpg dropping
− Propellor/Property/Cmd.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Propellor.Property.Cmd (-	cmdProperty,-	cmdProperty',-	scriptProperty,-	userScriptProperty,-) where--import Control.Applicative-import Data.List-import "mtl" Control.Monad.Reader--import Propellor.Types-import Propellor.Property-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 $ liftIO $ 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)---- | A property that can satisfied by running a series of shell commands,--- as user (cd'd to their home directory).-userScriptProperty :: UserName -> [String] -> Property-userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]-  where-	shellcmd = intercalate " ; " ("set -e" : "cd" : script)
− Propellor/Property/Cron.hs 
@@ -1,49 +0,0 @@-module Propellor.Property.Cron where--import Propellor-import qualified Propellor.Property.File as File-import qualified Propellor.Property.Apt as Apt-import Utility.SafeCommand--import Data.Char--type CronTimes = String---- | Installs a cron job, run as a specified user, in a particular--- directory. Note that the Desc must be unique, as it is used for the --- cron.d/ filename.--- --- Only one instance of the cron job is allowed to run at a time, no matter--- how long it runs. This is accomplished using flock locking of the cron--- job file.------ The cron job's output will only be emailed if it exits nonzero.-job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property-job desc times user cddir command = cronjobfile `File.hasContent`-	[ "# Generated by propellor"-	, ""-	, "SHELL=/bin/sh"-	, "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin"-	, ""-	, times ++ "\t" ++ user ++ "\t"-		++ "chronic flock -n " ++ shellEscape cronjobfile-		++ " sh -c " ++ shellEscape cmdline-	]-	`requires` Apt.serviceInstalledRunning "cron"-	`requires` Apt.installed ["util-linux", "moreutils"]-	`describe` ("cronned " ++ desc)-  where-	cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )"-	cronjobfile = "/etc/cron.d/" ++ map sanitize desc-	sanitize c-		| isAlphaNum c = c-		| otherwise = '_'---- | Installs a cron job, and runs it niced and ioniced.-niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property-niceJob desc times user cddir command = job desc times user cddir-	("nice ionice -c 3 " ++ command)---- | Installs a cron job to run propellor.-runPropellor :: CronTimes -> Property-runPropellor times = niceJob "propellor" times "root" localdir "make"
− Propellor/Property/Dns.hs 
@@ -1,405 +0,0 @@-module Propellor.Property.Dns (-	module Propellor.Types.Dns,-	primary,-	secondary,-	secondaryFor,-	mkSOA,-	writeZoneFile,-	nextSerialNumber,-	adjustSerialNumber,-	serialNumberOffset,-	WarningMessage,-	genZone,-) where--import Propellor-import Propellor.Types.Dns-import Propellor.Property.File-import Propellor.Types.Attr-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Service as Service-import Utility.Applicative--import qualified Data.Map as M-import qualified Data.Set as S-import Data.List---- | Primary dns server for a domain.------ Most of the content of the zone file is configured by setting properties--- of hosts. For example,------ > host "foo.example.com"--- >   & ipv4 "192.168.1.1"--- >   & alias "mail.exmaple.com"------ Will cause that hostmame and its alias to appear in the zone file,--- with the configured IP address.------ The [(BindDomain, Record)] list can be used for additional records--- that cannot be configured elsewhere. This often includes NS records,--- TXT records and perhaps CNAMEs pointing at hosts that propellor does--- not control.------ The primary server is configured to only allow zone transfers to--- secondary dns servers. These are determined in two ways:------ 1. By looking at the properties of other hosts, to find hosts that--- are configured as the secondary dns server.------ 2. By looking for NS Records in the passed list of records.------ In either case, the secondary dns server Host should have an ipv4 and/or--- ipv6 property defined.-primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty-primary hosts domain soa rs = RevertableProperty setup cleanup-  where-	setup = withwarnings (check needupdate baseprop)-		`requires` servingZones-		`onChange` Service.reloaded "bind9"-	cleanup = check (doesFileExist zonefile) $-		property ("removed dns primary for " ++ domain)-			(makeChange $ removeZoneFile zonefile)-			`requires` namedConfWritten-			`onChange` Service.reloaded "bind9"--	(partialzone, zonewarnings) = genZone hosts domain soa-	zone = partialzone { zHosts = zHosts partialzone ++ rs }-	zonefile = "/etc/bind/propellor/db." ++ domain-	baseprop = Property ("dns primary for " ++ domain)-		(makeChange $ writeZoneFile zone zonefile)-		(addNamedConf conf)-	withwarnings p = adjustProperty p $ \satisfy -> do-		mapM_ warningMessage $ zonewarnings ++ secondarywarnings-		satisfy-	conf = NamedConf-		{ confDomain = domain-		, confDnsServerType = Master-		, confFile = zonefile-		, confMasters = []-		, confAllowTransfer = nub $-			concatMap (\h -> hostAddresses h hosts) $-				secondaries ++ nssecondaries-		, confLines = []-		}-	secondaries = otherServers Secondary hosts domain-	secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $-		filter (\h -> null (hostAddresses h hosts)) secondaries-	nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords-	rootRecords = map snd $-		filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs-	needupdate = do-		v <- readZonePropellorFile zonefile-		return $ case v of-			Nothing -> True-			Just oldzone ->-				-- compare everything except serial-				let oldserial = sSerial (zSOA oldzone)-				    z = zone { zSOA = (zSOA zone) { sSerial = oldserial } }-				in z /= oldzone || oldserial < sSerial (zSOA zone)---- | Secondary dns server for a domain.------ The primary server is determined by looking at the properties of other--- hosts to find which one is configured as the primary.------ Note that if a host is declared to be a primary and a secondary dns--- server for the same domain, the primary server config always wins.-secondary :: [Host] -> Domain -> RevertableProperty-secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain---- | This variant is useful if the primary server does not have its DNS--- configured via propellor.-secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty-secondaryFor masters hosts domain = RevertableProperty setup cleanup-  where-	setup = pureAttrProperty desc (addNamedConf conf)-		`requires` servingZones-	cleanup = namedConfWritten-- 	desc = "dns secondary for " ++ domain-	conf = NamedConf-		{ confDomain = domain-		, confDnsServerType = Secondary-		, confFile = "db." ++ domain-		, confMasters = concatMap (\m -> hostAddresses m hosts) masters-		, confAllowTransfer = []-		, confLines = []-		}--otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]-otherServers wantedtype hosts domain =-	M.keys $ M.filter wanted $ hostAttrMap hosts-  where-	wanted attr = case M.lookup domain (_namedconf attr) of-		Nothing -> False-		Just conf -> confDnsServerType conf == wantedtype-			&& confDomain conf == domain---- | Rewrites the whole named.conf.local file to serve the zones--- configured by `primary` and `secondary`, and ensures that bind9 is--- running.-servingZones :: Property-servingZones = namedConfWritten-	`onChange` Service.reloaded "bind9"-	`requires` Apt.serviceInstalledRunning "bind9"--namedConfWritten :: Property-namedConfWritten = property "named.conf configured" $ do-	zs <- getNamedConf-	ensureProperty $-		hasContent namedConfFile $-			concatMap confStanza $ M.elems zs--confStanza :: NamedConf -> [Line]-confStanza c =-	[ "// automatically generated by propellor"-	, "zone \"" ++ confDomain c ++ "\" {"-	, cfgline "type" (if confDnsServerType c == Master then "master" else "slave")-	, cfgline "file" ("\"" ++ confFile c ++ "\"")-	] ++-	mastersblock ++-	allowtransferblock ++-	(map (\l -> "\t" ++ l ++ ";") (confLines c)) ++-	[ "};"-	, ""-	]-  where-	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"-	ipblock name l = -		[ "\t" ++ name ++ " {" ] ++-		(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++-		[ "\t};" ]-	mastersblock-		| null (confMasters c) = []-		| otherwise = ipblock "masters" (confMasters c)-	-- an empty block prohibits any transfers-	allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c)--namedConfFile :: FilePath-namedConfFile = "/etc/bind/named.conf.local"---- | Generates a SOA with some fairly sane numbers in it.------ The Domain is the domain to use in the SOA record. Typically--- something like ns1.example.com. So, not the domain that this is the SOA--- record for.------ The SerialNumber can be whatever serial number was used by the domain--- before propellor started managing it. Or 0 if the domain has only ever--- been managed by propellor.------ You do not need to increment the SerialNumber when making changes!--- Propellor will automatically add the number of commits in the git--- repository to the SerialNumber.-mkSOA :: Domain -> SerialNumber -> SOA-mkSOA d sn = SOA-	{ sDomain = AbsDomain d-	, sSerial = sn-	, sRefresh = hours 4-	, sRetry = hours 1-	, sExpire = 2419200 -- 4 weeks-	, sNegativeCacheTTL = hours 8-	}-  where-	hours n = n * 60 * 60--dValue :: BindDomain -> String-dValue (RelDomain d) = d-dValue (AbsDomain d) = d ++ "."-dValue (RootDomain) = "@"--rField :: Record -> String-rField (Address (IPv4 _)) = "A"-rField (Address (IPv6 _)) = "AAAA"-rField (CNAME _) = "CNAME"-rField (MX _ _) = "MX"-rField (NS _) = "NS"-rField (TXT _) = "TXT"-rField (SRV _ _ _ _) = "SRV"--rValue :: Record -> String-rValue (Address (IPv4 addr)) = addr-rValue (Address (IPv6 addr)) = addr-rValue (CNAME d) = dValue d-rValue (MX pri d) = show pri ++ " " ++ dValue d-rValue (NS d) = dValue d-rValue (SRV priority weight port target) = unwords-	[ show priority-	, show weight-	, show port-	, dValue target-	]-rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]-  where-	q = '"'---- | Adjusts the serial number of the zone to always be larger--- than the serial number in the Zone record,--- and always be larger than the passed SerialNumber.-nextSerialNumber :: Zone -> SerialNumber -> Zone-nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial--adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone-adjustSerialNumber (Zone d soa l) f = Zone d soa' l-  where-	soa' = soa { sSerial = f (sSerial soa) }---- | Count the number of git commits made to the current branch.-serialNumberOffset :: IO SerialNumber-serialNumberOffset = fromIntegral . length . lines-	<$> readProcess "git" ["log", "--pretty=%H"]---- | Write a Zone out to a to a file.------ The serial number in the Zone automatically has the serialNumberOffset--- added to it. Also, just in case, the old serial number used in the zone--- file is checked, and if it is somehow larger, its succ is used.-writeZoneFile :: Zone -> FilePath -> IO ()-writeZoneFile z f = do-	oldserial <- oldZoneFileSerialNumber f-	offset <- serialNumberOffset-	let z' = nextSerialNumber-		(adjustSerialNumber z (+ offset))-		oldserial-	createDirectoryIfMissing True (takeDirectory f)-	writeFile f (genZoneFile z')-	writeZonePropellorFile f z'--removeZoneFile :: FilePath -> IO ()-removeZoneFile f = do-	nukeFile f-	nukeFile (zonePropellorFile f)---- | Next to the zone file, is a ".propellor" file, which contains--- the serialized Zone. This saves the bother of parsing--- the horrible bind zone file format.-zonePropellorFile :: FilePath -> FilePath-zonePropellorFile f = f ++ ".propellor"--oldZoneFileSerialNumber :: FilePath -> IO SerialNumber-oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile--writeZonePropellorFile :: FilePath -> Zone -> IO ()-writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z)--readZonePropellorFile :: FilePath -> IO (Maybe Zone)-readZonePropellorFile f = catchDefaultIO Nothing $-	readish <$> readFileStrict (zonePropellorFile f)---- | Generating a zone file.-genZoneFile :: Zone -> String-genZoneFile (Zone zdomain soa rs) = unlines $-	header : genSOA soa ++ map (genRecord zdomain) rs-  where-	header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit."--genRecord :: Domain -> (BindDomain, Record) -> String-genRecord zdomain (domain, record) = intercalate "\t"-	[ domainHost zdomain domain-	, "IN"-	, rField record-	, rValue record-	]--genSOA :: SOA -> [String]-genSOA soa = -	-- "@ IN SOA ns1.example.com. root ("-	[ intercalate "\t"-		[ dValue RootDomain -		, "IN"-		, "SOA"-		, dValue (sDomain soa)-		, "root"-		, "("-		]-	, headerline sSerial "Serial"-	, headerline sRefresh "Refresh"-	, headerline sRetry "Retry"-	, headerline sExpire "Expire"-	, headerline sNegativeCacheTTL "Negative Cache TTL"-	, inheader ")"-	]-  where-	headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment-	inheader l = "\t\t\t" ++ l---- | Comment line in a zone file.-com :: String -> String-com s = "; " ++ s--type WarningMessage = String---- | Generates a Zone for a particular Domain from the DNS properies of all--- hosts that propellor knows about that are in that Domain.-genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage])-genZone hosts zdomain soa =-	let (warnings, zhosts) = partitionEithers $ concat $ map concat-		[ map hostips inzdomain-		, map hostrecords inzdomain-		, map addcnames (M.elems m)-		]-	in (Zone zdomain soa (nub zhosts), warnings)-  where-	m = hostAttrMap hosts-	-- Known hosts with hostname located in the zone's domain.-	inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m-	-	-- Each host with a hostname located in the zdomain-	-- should have 1 or more IPAddrs in its Attr.-	---	-- If a host lacks any IPAddr, it's probably a misconfiguration,-	-- so warn.-	hostips :: Attr -> [Either WarningMessage (BindDomain, Record)]-	hostips attr-		| null l = [Left $ "no IP address defined for host " ++ _hostname attr]-		| otherwise = map Right l-	  where-		l = zip (repeat $ AbsDomain $ _hostname attr)-			(map Address $ getAddresses attr)--	-- Any host, whether its hostname is in the zdomain or not,-	-- may have cnames which are in the zdomain. The cname may even be-	-- the same as the root of the zdomain, which is a nice way to-	-- specify IP addresses for a SOA record.-	---	-- Add Records for those.. But not actually, usually, cnames!-	-- Why not? Well, using cnames doesn't allow doing some things,-	-- including MX and round robin DNS, and certianly CNAMES-	-- shouldn't be used in SOA records.-	---	-- We typically know the host's IPAddrs anyway.-	-- So we can just use the IPAddrs.-	addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)]-	addcnames attr = concatMap gen $ filter (inDomain zdomain) $-		mapMaybe getCNAME $ S.toList (_dns attr)-	  where-		gen c = case getAddresses attr of-			[] -> [ret (CNAME c)]-			l -> map (ret . Address) l-		  where-		  	ret record = Right (c, record)-	-	-- Adds any other DNS records for a host located in the zdomain.-	hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)]-	hostrecords attr = map Right l-	  where-		l = zip (repeat $ AbsDomain $ _hostname attr)-			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr))--inDomain :: Domain -> BindDomain -> Bool-inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d-inDomain _ _ = False -- can't tell, so assume not---- | Gets the hostname of the second domain, relative to the first domain,--- suitable for using in a zone file.-domainHost :: Domain -> BindDomain -> String-domainHost _ (RelDomain d) = d-domainHost _ RootDomain = "@"-domainHost base (AbsDomain d)-	| dotbase `isSuffixOf` d = take (length d - length dotbase) d-	| base == d = "@"-	| otherwise = d-  where-	dotbase = '.':base-
− Propellor/Property/Docker.hs 
@@ -1,459 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- | Docker support for propellor------ The existance of a docker container is just another Property of a system,--- which propellor can set up. See config.hs for an example.--module Propellor.Property.Docker where--import Propellor-import Propellor.SimpleSh-import Propellor.Types.Attr-import qualified Propellor.Property.File as File-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Docker.Shim as Shim-import Utility.SafeCommand-import Utility.Path--import Control.Concurrent.Async-import System.Posix.Directory-import System.Posix.Process-import Data.List-import Data.List.Utils---- | 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"]---- | A short descriptive name for a container.--- Should not contain whitespace or other unusual characters,--- only [a-zA-Z0-9_-] are allowed-type ContainerName = String---- | Starts accumulating the properties of a Docker container.------ > container "web-server" "debian"--- >    & publish "80:80"--- >    & Apt.installed {"apache2"]--- >    & ...-container :: ContainerName -> Image -> Host-container cn image = Host [] (\_ -> attr)-  where-	attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }--cn2hn :: ContainerName -> HostName-cn2hn cn = cn ++ ".docker"---- | Ensures that a docker container is set up and running. The container--- has its own Properties which are handled by running propellor--- inside the container.------ Reverting this property ensures that the container is stopped and--- removed.-docked-	:: [Host]-	-> ContainerName-	-> RevertableProperty-docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)-  where-	go desc a = property (desc ++ " " ++ cn) $ do-		hn <- getHostName-  		let cid = ContainerId hn cn-		ensureProperties [findContainer hosts cid cn $ a cid]--	setup cid (Container image runparams) =-		provisionContainer cid-			`requires`-		runningContainer cid image runparams-			`requires`-		installed--	teardown cid (Container image _runparams) =-		combineProperties ("undocked " ++ fromContainerId cid)-			[ stoppedContainer cid-			, property ("cleaned up " ++ fromContainerId cid) $-				liftIO $ report <$> mapM id-					[ removeContainer cid-					, removeImage image-					]-			]--findContainer-	:: [Host]-	-> ContainerId-	-> ContainerName-	-> (Container -> Property)-	-> Property-findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of-	Nothing -> cantfind-	Just h -> maybe cantfind mk (mkContainer cid h)-  where-	cantfind = containerDesc cid $ property "" $ do-		liftIO $ warningMessage $-			"missing definition for docker container \"" ++ cn2hn cn-		return FailedChange--mkContainer :: ContainerId -> Host -> Maybe Container-mkContainer cid@(ContainerId hn _cn) h = Container-	<$> _dockerImage attr-	<*> pure (map (\a -> a hn) (_dockerRunParams attr))-  where-	attr = hostAttr h'-  	h' = h-		-- expose propellor directory inside the container-		& volume (localdir++":"++localdir)-		-- name the container in a predictable way so we-		-- and the user can easily find it later-		& name (fromContainerId cid)---- | Causes *any* docker images that are not in use by running containers to--- be deleted. And deletes any containers that propellor has set up--- before that are not currently running. Does not delete any containers--- that were not set up using propellor.------ Generally, should come after the properties for the desired containers.-garbageCollected :: Property-garbageCollected = propertyList "docker garbage collected"-	[ gccontainers-	, gcimages-	]-  where-	gccontainers = property "docker containers garbage collected" $-		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)-	gcimages = property "docker images garbage collected" $ do-		liftIO $ report <$> (mapM removeImage =<< listImages)--data Container = Container Image [RunParam]---- | Parameters to pass to `docker run` when creating a container.-type RunParam = String---- | A docker image, that can be used to run a container.-type Image = String---- | Set custom dns server for container.-dns :: String -> Property-dns = runProp "dns"---- | Set container host name.-hostname :: String -> Property-hostname = runProp "hostname"---- | Set name for container. (Normally done automatically.)-name :: String -> Property-name = runProp "name"---- | Publish a container's port to the host--- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)-publish :: String -> Property-publish = runProp "publish"---- | Username or UID for container.-user :: String -> Property-user = runProp "user"---- | Mount a volume--- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]--- With just a directory, creates a volume in the container.-volume :: String -> Property-volume = runProp "volume"---- | Mount a volume from the specified container into the current--- container.-volumes_from :: ContainerName -> Property-volumes_from cn = genProp "volumes-from" $ \hn ->-	fromContainerId (ContainerId hn cn)---- | Work dir inside the container. -workdir :: String -> Property-workdir = runProp "workdir"---- | Memory limit for container.---Format: <number><optional unit>, where unit = b, k, m or g-memory :: String -> Property-memory = runProp "memory"---- | Link with another container on the same host.-link :: ContainerName -> ContainerAlias -> Property-link linkwith calias = genProp "link" $ \hn ->-	fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias---- | A short alias for a linked container.--- Each container has its own alias namespace.-type ContainerAlias = String---- | A container is identified by its name, and the host--- on which it's deployed.-data ContainerId = ContainerId HostName ContainerName-	deriving (Eq, Read, Show)---- | Two containers with the same ContainerIdent were started from--- the same base image (possibly a different version though), and--- with the same RunParams.-data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]-	deriving (Read, Show, Eq)--ident2id :: ContainerIdent -> ContainerId-ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn--toContainerId :: String -> Maybe ContainerId-toContainerId s-	| myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of-		(cn, hn)-			| null hn || null cn -> Nothing-			| otherwise -> Just $ ContainerId hn cn-	| otherwise = Nothing-  where-	desuffix = reverse . drop len . reverse-	len = length myContainerSuffix--fromContainerId :: ContainerId -> String-fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix--containerHostName :: ContainerId -> HostName-containerHostName (ContainerId _ cn) = cn2hn cn--myContainerSuffix :: String-myContainerSuffix = ".propellor"--containerDesc :: ContainerId -> Property -> Property-containerDesc cid p = p `describe` desc-  where-	desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p--runningContainer :: ContainerId -> Image -> [RunParam] -> Property-runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do-	l <- liftIO $ listContainers RunningContainers-	if cid `elem` l-		then do-			-- Check if the ident has changed; if so the-			-- parameters of the container differ and it must-			-- be restarted.-			runningident <- liftIO $ getrunningident-			if runningident == Just ident-				then noChange-				else do-					void $ liftIO $ stopContainer cid-					restartcontainer-		else ifM (liftIO $ elem cid <$> listContainers AllContainers)-			( restartcontainer-			, go image-			)-  where-	ident = ContainerIdent image hn cn runps--	restartcontainer = do-		oldimage <- liftIO $ fromMaybe image <$> commitContainer cid-		void $ liftIO $ removeContainer cid-		go oldimage--	getrunningident :: IO (Maybe ContainerIdent)-	getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do-		let !v = extractident rs-		return v--	extractident :: [Resp] -> Maybe ContainerIdent-	extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout--	go img = do-		liftIO $ do-			clearProvisionedFlag cid-			createDirectoryIfMissing True (takeDirectory $ identFile cid)-		shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)-		liftIO $ writeFile (identFile cid) (show ident)-		ensureProperty $ boolProperty "run" $ runContainer img-			(runps ++ ["-i", "-d", "-t"])-			[shim, "--docker", fromContainerId cid]---- | Called when propellor is running inside a docker container.--- The string should be the container's ContainerId.------ This process is effectively init inside the container.--- It even needs to wait on zombie processes!------ Fork a thread to run the SimpleSh server in the background.--- In the foreground, run an interactive bash (or sh) shell,--- so that the user can interact with it when attached to the container.------ When the system reboots, docker restarts the container, and this is run--- again. So, to make the necessary services get started on boot, this needs--- to provision the container then. However, if the container is already--- being provisioned by the calling propellor, it would be redundant and--- problimatic to also provisoon it here.------ The solution is a flag file. If the flag file exists, then the container--- was already provisioned. So, it must be a reboot, and time to provision--- again. If the flag file doesn't exist, don't provision here.-chain :: String -> IO ()-chain s = case toContainerId s of-	Nothing -> error $ "Invalid ContainerId: " ++ s-	Just cid -> do-		changeWorkingDirectory localdir-		writeFile propellorIdent . show =<< readIdentFile cid-		-- Run boot provisioning before starting simpleSh,-		-- to avoid ever provisioning twice at the same time.-		whenM (checkProvisionedFlag cid) $ do-			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)-			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $-				warningMessage "Boot provision failed!"-		void $ async $ job reapzombies-		void $ async $ job $ simpleSh $ namedPipe cid-		job $ do-			void $ tryIO $ ifM (inPath "bash")-				( boolSystem "bash" [Param "-l"]-				, boolSystem "/bin/sh" []-				)-			putStrLn "Container is still running. Press ^P^Q to detach."-  where-	job = forever . void . tryIO-	reapzombies = void $ getAnyProcessStatus True False---- | Once a container is running, propellor can be run inside--- it to provision it.------ Note that there is a race here, between the simplesh--- server starting up in the container, and this property--- being run. So, retry connections to the client for up to--- 1 minute.-provisionContainer :: ContainerId -> Property-provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do-	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)-	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)-	when (r /= FailedChange) $-		setProvisionedFlag cid -	return r-  where-	params = ["--continue", show $ Chain $ containerHostName cid]--	go lastline (v:rest) = case v of-		StdoutLine s -> do-			debug ["stdout: ", show s]-			maybe noop putStrLn lastline-			hFlush stdout-			go (Just s) rest-		StderrLine s -> do-			debug ["stderr: ", show s]-			maybe noop putStrLn lastline-			hFlush stdout-			hPutStrLn stderr s-			hFlush stderr-			go Nothing rest-		Done -> ret lastline-	go lastline [] = ret lastline--	ret lastline = return $ fromMaybe FailedChange $-		readish =<< lastline--stopContainer :: ContainerId -> IO Bool-stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]--stoppedContainer :: ContainerId -> Property-stoppedContainer cid = containerDesc cid $ property desc $ -	ifM (liftIO $ elem cid <$> listContainers RunningContainers)-		( liftIO cleanup `after` ensureProperty -			(boolProperty desc $ stopContainer cid)-		, return NoChange-		)-  where-	desc = "stopped"-	cleanup = do-		nukeFile $ namedPipe cid-		nukeFile $ identFile cid-		removeDirectoryRecursive $ shimdir cid-		clearProvisionedFlag cid--removeContainer :: ContainerId -> IO Bool-removeContainer cid = catchBoolIO $-	snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing--removeImage :: Image -> IO Bool-removeImage image = catchBoolIO $-	snd <$> processTranscript dockercmd ["rmi", image ] Nothing--runContainer :: Image -> [RunParam] -> [String] -> IO Bool-runContainer image ps cmd = boolSystem dockercmd $ map Param $-	"run" : (ps ++ image : cmd)--commitContainer :: ContainerId -> IO (Maybe Image)-commitContainer cid = catchMaybeIO $-	takeWhile (/= '\n') -		<$> readProcess dockercmd ["commit", fromContainerId cid]--data ContainerFilter = RunningContainers | AllContainers-	deriving (Eq)---- | Only lists propellor managed containers.-listContainers :: ContainerFilter -> IO [ContainerId]-listContainers status = -	catMaybes . map toContainerId . concat . map (split ",")-		. catMaybes . map (lastMaybe . words) . lines-		<$> readProcess dockercmd ps-  where-	ps-		| status == AllContainers = baseps ++ ["--all"]-		| otherwise = baseps-	baseps = ["ps", "--no-trunc"]--listImages :: IO [Image]-listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]--runProp :: String -> RunParam -> Property-runProp field val = pureAttrProperty (param) $ \attr ->-	attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }-  where-	param = field++"="++val--genProp :: String -> (HostName -> RunParam) -> Property-genProp field mkval = pureAttrProperty field $ \attr ->-	attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }---- | The ContainerIdent of a container is written to--- /.propellor-ident inside it. This can be checked to see if--- the container has the same ident later.-propellorIdent :: FilePath-propellorIdent = "/.propellor-ident"---- | Named pipe used for communication with the container.-namedPipe :: ContainerId -> FilePath-namedPipe cid = "docker" </> fromContainerId cid--provisionedFlag :: ContainerId -> FilePath-provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"--clearProvisionedFlag :: ContainerId -> IO ()-clearProvisionedFlag = nukeFile . provisionedFlag--setProvisionedFlag :: ContainerId -> IO ()-setProvisionedFlag cid = do-	createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))-	writeFile (provisionedFlag cid) "1"--checkProvisionedFlag :: ContainerId -> IO Bool-checkProvisionedFlag = doesFileExist . provisionedFlag--shimdir :: ContainerId -> FilePath-shimdir cid = "docker" </> fromContainerId cid ++ ".shim"--identFile :: ContainerId -> FilePath-identFile cid = "docker" </> fromContainerId cid ++ ".ident"--readIdentFile :: ContainerId -> IO ContainerIdent-readIdentFile cid = fromMaybe (error "bad ident in identFile")-	. readish <$> readFile (identFile cid)--dockercmd :: String-dockercmd = "docker.io"--report :: [Bool] -> Result-report rmed-	| or rmed = MadeChange-	| otherwise = NoChange-
− Propellor/Property/Docker/Shim.hs 
@@ -1,61 +0,0 @@--- | Support for running propellor, as built outside a docker container,--- inside the container.------ Note: This is currently Debian specific, due to glibcLibs.--module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where--import Propellor-import Utility.LinuxMkLibs-import Utility.SafeCommand-import Utility.Path-import Utility.FileMode--import Data.List-import System.Posix.Files---- | Sets up a shimmed version of the program, in a directory, and--- returns its path.-setup :: FilePath -> FilePath -> IO FilePath-setup propellorbin dest = do-	createDirectoryIfMissing True dest--	libs <- parseLdd <$> readProcess "ldd" [propellorbin]-	glibclibs <- glibcLibs-	let libs' = nub $ libs ++ glibclibs-	libdirs <- map (dest ++) . nub . catMaybes-		<$> mapM (installLib installFile dest) libs'-	-	let linker = (dest ++) $ -		fromMaybe (error "cannot find ld-linux linker") $-			headMaybe $ filter ("ld-linux" `isInfixOf`) libs'-	let gconvdir = (dest ++) $ parentDir $-		fromMaybe (error "cannot find gconv directory") $-			headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs-	let linkerparams = ["--library-path", intercalate ":" libdirs ]-	let shim = file propellorbin dest-	writeFile shim $ unlines-		[ "#!/bin/sh"-		, "GCONV_PATH=" ++ shellEscape gconvdir-		, "export GCONV_PATH"-		, "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ -			" " ++ shellEscape propellorbin ++ " \"$@\""-		]-	modifyFileMode shim (addModes executeModes)-	return shim--cleanEnv :: IO ()-cleanEnv = void $ unsetEnv "GCONV_PATH"--file :: FilePath -> FilePath -> FilePath-file propellorbin dest = dest </> takeFileName propellorbin--installFile :: FilePath -> FilePath -> IO ()-installFile top f = do-	createDirectoryIfMissing True destdir-	nukeFile dest-	createLink f dest `catchIO` (const copy)-  where-	copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest]-	destdir = inTop top $ parentDir f-	dest = inTop top f
− Propellor/Property/File.hs 
@@ -1,94 +0,0 @@-module Propellor.Property.File where--import Propellor-import Utility.FileMode--import System.Posix.Files-import System.PosixCompat.Types--type Line = String---- | Replaces all the content of a file.-hasContent :: FilePath -> [Line] -> Property-f `hasContent` newcontent = fileProperty ("replace " ++ f)-	(\_oldcontent -> newcontent) f---- | Ensures a file has contents that comes from PrivData.------ The file's permissions are preserved if the file already existed.--- Otherwise, they're set to 600.-hasPrivContent :: FilePath -> Property-hasPrivContent f = property desc $ withPrivData (PrivFile f) $ \privcontent -> -	ensureProperty $ fileProperty' writeFileProtected desc-		(\_oldcontent -> lines privcontent) f-  where-	desc = "privcontent " ++ f---- | Leaves the file world-readable.-hasPrivContentExposed :: FilePath -> Property-hasPrivContentExposed f = hasPrivContent f `onChange`-	mode f (combineModes (ownerWriteMode:readModes))---- | Ensures that a line is present in a file, adding it to the end if not.-containsLine :: FilePath -> Line -> Property-f `containsLine` l = f `containsLines` [l]--containsLines :: FilePath -> [Line] -> Property-f `containsLines` l = fileProperty (f ++ " contains:" ++ show l) go f-  where-	go ls-		| all (`elem` ls) l = 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 = fileProperty' writeFile-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property-fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)-  where-	go True = do-		ls <- liftIO $ lines <$> readFile f-		let ls' = a ls-		if ls' == ls-			then noChange-			else makeChange $ viaTmp updatefile f (unlines ls')-	go False = makeChange $ writer f (unlines $ a [])--	-- viaTmp makes the temp file mode 600.-	-- Replicate the original file's owner and mode.-	updatefile f' content = do-		writer f' content-		s <- getFileStatus f-		setFileMode f' (fileMode s)-		setOwnerAndGroup f' (fileOwner s) (fileGroup s)---- | Ensures a directory exists.-dirExists :: FilePath -> Property-dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $-	makeChange $ createDirectoryIfMissing True d---- | Ensures that a file/dir has the specified owner and group.-ownerGroup :: FilePath -> UserName -> GroupName -> Property-ownerGroup f owner group = property (f ++ " owner " ++ og) $ do-	r <- ensureProperty $ cmdProperty "chown" [og, f]-	if r == FailedChange-		then return r-		else noChange-  where-	og = owner ++ ":" ++ group---- | Ensures that a file/dir has the specfied mode.-mode :: FilePath -> FileMode -> Property-mode f v = property (f ++ " mode " ++ show v) $ do-	liftIO $ modifyFileMode f (\_old -> v)-	noChange
− Propellor/Property/Git.hs 
@@ -1,89 +0,0 @@-module Propellor.Property.Git where--import Propellor-import Propellor.Property.File-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Service as Service-import Utility.SafeCommand--import Data.List---- | Exports all git repos in a directory (that user nobody can read)--- using git-daemon, run from inetd.------ Note that reverting this property does not remove or stop inetd.-daemonRunning :: FilePath -> RevertableProperty-daemonRunning exportdir = RevertableProperty setup unsetup-  where-	setup = containsLine conf (mkl "tcp4")-		`requires`-		containsLine conf (mkl "tcp6")-		`requires`-		dirExists exportdir-		`requires`-		Apt.serviceInstalledRunning "openbsd-inetd"-		`onChange`-		Service.running "openbsd-inetd"-		`describe` ("git-daemon exporting " ++ exportdir)-	unsetup = lacksLine conf (mkl "tcp4")-		`requires`-		lacksLine conf (mkl "tcp6")-		`onChange`-		Service.reloaded "openbsd-inetd"--	conf = "/etc/inetd.conf"--	mkl tcpv = intercalate "\t"-		[ "git"-		, "stream"-		, tcpv-		, "nowait"-		, "nobody"-		, "/usr/bin/git"-		, "git"-		, "daemon"-		, "--inetd"-		, "--export-all"-		, "--base-path=" ++ exportdir-		, exportdir-		]--installed :: Property-installed = Apt.installed ["git"]--type RepoUrl = String--type Branch = String---- | Specified git repository is cloned to the specified directory.------ If the firectory exists with some other content, it will be recursively--- deleted.------ A branch can be specified, to check out.-cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property-cloned owner url dir mbranch = check originurl (property desc checkout)-	`requires` installed-  where-	desc = "git cloned " ++ url ++ " to " ++ dir-	gitconfig = dir </> ".git/config"-	originurl = ifM (doesFileExist gitconfig)-		( do-			v <- catchDefaultIO Nothing $ headMaybe . lines <$>-				readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"]-			return (v /= Just url)-		, return True-		)-	checkout = do-		liftIO $ do-			whenM (doesDirectoryExist dir) $-				removeDirectoryRecursive dir-			createDirectoryIfMissing True (takeDirectory dir)-		ensureProperty $ userScriptProperty owner $ catMaybes-			-- The </dev/null fixes an intermittent-			-- "fatal: read error: Bad file descriptor"-			-- when run across ssh with propellor --spin-			[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"-			, Just $ "cd " ++ shellEscape dir-			, ("git checkout " ++) <$> mbranch-			]
− Propellor/Property/Gpg.hs 
@@ -1,41 +0,0 @@-module Propellor.Property.Gpg where--import Propellor-import qualified Propellor.Property.Apt as Apt-import Utility.FileSystemEncoding--import System.PosixCompat--installed :: Property-installed = Apt.installed ["gnupg"]---- | Sets up a user with a gpg key from the privdata.------ Note that if a secret key is exported using gpg -a --export-secret-key,--- the public key is also included. Or just a public key could be--- exported, and this would set it up just as well.------ Recommend only using this for low-value dedicated role keys.--- No attempt has been made to scrub the key out of memory once it's used.------ The GpgKeyId does not have to be a numeric id; it can just as easily--- be a description of the key.-keyImported :: GpgKeyId -> UserName -> Property-keyImported keyid user = flagFile' (property desc go) genflag-	`requires` installed-  where-	desc = user ++ " has gpg key " ++ show keyid-	genflag = do-		d <- dotDir user-		return $ d </> ".propellor-imported-keyid-" ++ keyid-	go = withPrivData (GpgKey keyid) $ \key -> makeChange $-		withHandle StdinHandle createProcessSuccess-			(proc "su" ["-c", "gpg --import", user]) $ \h -> do-				fileEncoding h-				hPutStr h key-				hClose h--dotDir :: UserName -> IO FilePath-dotDir user = do-	home <- homeDirectory <$> getUserEntryForName user-	return $ home </> ".gnupg"
− Propellor/Property/Hostname.hs 
@@ -1,33 +0,0 @@-module Propellor.Property.Hostname where--import Propellor-import qualified Propellor.Property.File as File---- | Ensures that the hostname is set to the HostAttr value.--- Configures /etc/hostname and the current hostname.------ A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is--- standard at least on Debian to set the FDQN (127.0.0.1 is localhost).-sane :: Property-sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName)--setTo :: HostName -> Property-setTo hn = combineProperties desc go-	`onChange` cmdProperty "hostname" [basehost]-  where-	desc = "hostname " ++ hn-	(basehost, domain) = separate (== '.') hn--	go = catMaybes-		[ Just $ "/etc/hostname" `File.hasContent` [basehost]-		, if null domain-			then Nothing -			else Just $ File.fileProperty desc-				addhostline "/etc/hosts"-		]-	-	hostip = "127.0.1.1"-	hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost--	addhostline ls = hostline : filter (not . hashostip) ls-	hashostip l = headMaybe (words l) == Just hostip
− Propellor/Property/Network.hs 
@@ -1,30 +0,0 @@-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"-		, "auto sit0"-		, "# End automatically added by propeller"-		]--type Interface = String--ifUp :: Interface -> Property-ifUp iface = cmdProperty "ifup" [iface]
− Propellor/Property/Obnam.hs 
@@ -1,155 +0,0 @@-module Propellor.Property.Obnam where--import Propellor-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Cron as Cron-import Utility.SafeCommand--import Data.List--type ObnamParam = String---- | An obnam repository can be used by multiple clients. Obnam uses--- locking to allow only one client to write at a time. Since stale lock--- files can prevent backups from happening, it's more robust, if you know--- a repository has only one client, to force the lock before starting a--- backup. Using OnlyClient allows propellor to do so when running obnam.-data NumClients = OnlyClient | MultipleClients-	deriving (Eq)---- | Installs a cron job that causes a given directory to be backed--- up, by running obnam with some parameters.------ If the directory does not exist, or exists but is completely empty,--- this Property will immediately restore it from an existing backup.------ So, this property can be used to deploy a directory of content--- to a host, while also ensuring any changes made to it get backed up.--- And since Obnam encrypts, just make this property depend on a gpg--- key, and tell obnam to use the key, and your data will be backed--- up securely. For example: ------ >	& Obnam.backup "/srv/git" "33 3 * * *"--- >		[ "--repository=sftp://2318@usw-s002.rsync.net/~/mygitrepos.obnam"--- >		, "--encrypt-with=1B169BE1"--- >		] Obnam.OnlyClient--- >		`requires` Gpg.keyImported "1B169BE1" "root"--- >		`requires` Ssh.keyImported SshRsa "root"------ How awesome is that?-backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property-backup dir crontimes params numclients = cronjob `describe` desc-	`requires` restored dir params-  where-	desc = dir ++ " backed up by obnam"-	cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $-		intercalate ";" $ catMaybes-			[ if numclients == OnlyClient-				then Just $ unwords $-					[ "obnam"-					, "force-lock"-					] ++ map shellEscape params-				else Nothing-			, Just $ unwords $-				[ "obnam"-				, "backup"-				, shellEscape dir-				] ++ map shellEscape params-			]---- | Restores a directory from an obnam backup.------ Only does anything if the directory does not exist, or exists,--- but is completely empty.------ The restore is performed atomically; restoring to a temp directory--- and then moving it to the directory.-restored :: FilePath -> [ObnamParam] -> Property-restored dir params = property (dir ++ " restored by obnam") go-	`requires` installed-  where-	go = ifM (liftIO needsRestore)-		( do-			warningMessage $ dir ++ " is empty/missing; restoring from backup ..."-			liftIO restore-		, noChange-		)--	needsRestore = null <$> catchDefaultIO [] (dirContents dir)--	restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do-		ok <- boolSystem "obnam" $-			[ Param "restore"-			, Param "--to"-			, Param tmpdir-			] ++ map Param params-		let restoreddir = tmpdir ++ "/" ++ dir-		ifM (pure ok <&&> doesDirectoryExist restoreddir)-			( do-				void $ tryIO $ removeDirectory dir-				renameDirectory restoreddir dir-				return MadeChange-			, return FailedChange-			)--installed :: Property-installed = Apt.installed ["obnam"]---- | Ensures that a recent version of obnam gets installed.------ Only does anything for Debian Stable.-latestVersion :: Property-latestVersion = withOS "obnam latest version" $ \o -> case o of-	(Just (System (Debian suite) _)) | isStable suite -> ensureProperty $-		Apt.setSourcesListD (sources suite) "obnam"-			`requires` toProp (Apt.trustsKey key)-	_ -> noChange-  where-	sources suite = -		[ "deb http://code.liw.fi/debian " ++ Apt.showSuite suite ++ " main"-		]-	-- gpg key used by the code.liw.fi repository.-	key = Apt.AptKey "obnam" $ unlines-		[ "-----BEGIN PGP PUBLIC KEY BLOCK-----"-		, "Version: GnuPG v1.4.9 (GNU/Linux)"-		, ""-		, "mQGiBEfzuTgRBACcVNG/H6QJqLx5qiQs2zmPe6D6BWOWHfgNgG4IWzNstm21YDxb"-		, "KqwFG0gxcnZJGHkXAhkSfqTokYd0lc5eBemcA1pkceNjzMEX8wwiZ810HzJD4eEH"-		, "sjoWR8+qKrZeixzZqReAfqztcXoBGKQ0u1R1vpg1txUa75OM4BUqaUbsmwCgmS4x"-		, "DjMxSaUSPuu6vQ7ZGZBXSP0D/RQw8DBHMfsv3DiaqFqk8tkuUkpMFPIekHidSHlO"-		, "EACbncqbbyHksyCpFNVNcQIDHrOLjOZK9BAXkSd8I3ww7U+nLdDcCblrW8CZnJtm"-		, "ZYrxfaXaHZ/It9/RCAsQ+c8xtmyUPjsf//4Vf8olxNQHzgBSe5/LJRi4Vd53he+K"-		, "YP4LA/9IZbjvVmm8+8Y0pQrTHlI6nTImtzdBXHc4+T3lLBj9XODHLozC2kSBOQky"-		, "q/EisTITHTXL8vYg4NsKm5RTbPAuBwdtxcny8CXfOqKtGOdrebmKotGllTozzdPv"-		, "9p53cuce6oJ2oMUodc074JOGTWwDSgLiJX4nViGcU1wy/vtQnrQkY29kZS5saXcu"-		, "ZmkgYXJjaGl2ZSBrZXkgPGxpd0BsaXcuZmk+iGAEExECACAFAkfzuTgCGwMGCwkI"-		, "BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRBG53tJR95LscKrAJ0ZtKqa2x6Kplwa2mzx"-		, "ItImbIGMJACdETqofDYzUN91yLAFlOnxAyrE+UyIRgQQEQIABgUCSFd5GgAKCRAf"-		, "u5W/LZrMjqr8AJ4xPVHpW8ZNlgMwDSVb075RnA2DiACgg2SR69jAHFQOWV6xfLRr"-		, "vh0bLKGJAhwEEAEIAAYFAktEyIwACgkQ61zh116FEfm7Lg//Wiy3TjWAk8YHUddv"-		, "zOioYzCxQ985GsVhJGAVPqSGOc9vfTWBJZ8J3l0NnYTRpEGucmbF9G+mAt9iGXu6"-		, "7yZkxyFdvbo7EDsqMU1wLOM6PiU+Un63MKlbTNmFn7OKE8aXPRAFgcyUO/qjdqoD"-		, "sa9FgU5Z0f60m9qah6BPXH6IzMLHYoiP7t8rCBIwLgyl3w2w+Fjt1DFpbW9Kb7jz"-		, "i8jFvC8jPmxV8xh2OSgVZyNk4qg6hIV8GVQY7AJt8OurZSckgQd7ifHK9JTGohtF"-		, "tXCiqeDEvnMF4A9HI/TcXJBzonZ8ds1JCq42nSSKmL+8TyjtUSD/xHygazuc0CK0"-		, "hFnQWBub60IfyV6F0oTagJ8cmARv2sezHAeHDkzPHE8RdjgktazH1eJrA4LheEd6"-		, "KeSnVtYWpw8dgMv5PleFyQiAj/t3C/N50fd15tUyfnH15G7nFjMQV2Yx35uwSxOj"-		, "376OWnDN/YGTNk283XXULbyVJYR8Q2unso20XQ94yQ2A5EpHHPrHoLxrL/ydM08d"-		, "nvKstLZIZtal1seiMkymtlSiGz25A5oqsclwS6VZCKdWA8HO/wlElOMcaHyl6Y1y"-		, "gYP7y9O5yFYKFOrCH0nFjJbwmkRiBLsxuuWsYgJigVGq/atSrtawkHdshpCw0HCY"-		, "N/RFcWkJ864BdsO0C0sDzueNkQO5Ag0ER/O5RBAIAJiwPH9tyJTgXcC2Y4XWboOq"-		, "rx5CkOnr5b45oS9cK2eIJ8TKxE3XgKLxUr3mIH0QR2kZgDOwNl0WY+7/CXjn+Spn"-		, "BokPg54rafEUePodGpGdUXdgrHhAMHYjh8fXFJ1SlQcg46/zc1wDI7jBCkGrK3V8"-		, "5cXDqwTFTN5LcjoSRWeM4Voa6pEfDdL3rMlnOw9R9gDHRBBb6CDSjWXqM86pR889"-		, "5QrR0SDwiJNrMoyxSjMXFKGBQAsYHJ82myZrlbuZbroZjVp5Uh7eB1ZiPljNVtcr"-		, "sksACIWBCo1rvLzrPXsLYOeV3cDDtYAkSwGfuzC1Etbe+qgfIroFTOqdefMw4s8A"-		, "AwUH/0KLXm4MS54QQspg3evu4Q4U/E8Hem5/FqB0GhBCitQ4rUsucKyY8/ItpUn5"-		, "ismLE60bQqka+Mzd/Zw18TCTzImv0ozAaZ2sNtBado7f6jcC8EDfY5zzK1ukcsAr"-		, "Qc5hdLHYuTQW5KpA6fKaW969OUzIwPbdVaCOLOBpxKC6N6iBspQYd6uiQtLw6EUO"-		, "50oQqUiJABf0eOocvdw5e2KQQpuC3205+VMYtyl4w3pdJihK8NK0AikGXzDVsbQt"-		, "l8kmB5ZrN4WIKhMke1FxbqQC5Q3XATvYRzpzzisZb/HYGNti8W6du5EUwJ0D2NRh"-		, "cu+twocOzW0VKfmrDApfifJ9OsSISQQYEQIACQUCR/O5RAIbDAAKCRBG53tJR95L"-		, "seQOAJ95KUyzjRjdYgZkDC69Mgu25L86UACdGduINUaRly43ag4kwUXxpqswBBM="-		, "=i2c3"-		, "-----END PGP PUBLIC KEY BLOCK-----"-		]
− Propellor/Property/OpenId.hs 
@@ -1,29 +0,0 @@-module Propellor.Property.OpenId where--import Propellor-import qualified Propellor.Property.File as File-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.Service as Service--import Data.List--providerFor :: [UserName] -> String -> Property-providerFor users baseurl = propertyList desc $-	[ Apt.serviceInstalledRunning "apache2"-	, Apt.installed ["simpleid"]-		`onChange` Service.restarted "apache2"-	, File.fileProperty (desc ++ " configured")-		(map setbaseurl) "/etc/simpleid/config.inc"-	] ++ map identfile users-  where-	url = "http://"++baseurl++"/simpleid"-	desc = "openid provider " ++ url-	setbaseurl l-		| "SIMPLEID_BASE_URL" `isInfixOf` l = -			"define('SIMPLEID_BASE_URL', '"++url++"');"-		| otherwise = l-	-	-- the identitites directory controls access, so open up-	-- file mode-	identfile u = File.hasPrivContentExposed $-		concat $ [ "/var/lib/simpleid/identities/", u, ".identity" ]
− Propellor/Property/Postfix.hs 
@@ -1,25 +0,0 @@-module Propellor.Property.Postfix where--import Propellor-import qualified Propellor.Property.Apt as Apt--installed :: Property-installed = Apt.serviceInstalledRunning "postfix"---- | Configures postfix as a satellite system, which --- relats all mail through a relay host, which defaults to smtp.domain. ------ The smarthost may refuse to relay mail on to other domains, without--- futher coniguration/keys. But this should be enough to get cron job--- mail flowing to a place where it will be seen.-satellite :: Property-satellite = setup `requires` installed-  where-	setup = trivial $ property "postfix satellite system" $ do-		hn <- getHostName-		ensureProperty $ Apt.reConfigure "postfix"-			[ ("postfix/main_mailer_type", "select", "Satellite system")-			, ("postfix/root_address", "string", "root")-			, ("postfix/destinations", "string", " ")-			, ("postfix/mailname", "string", hn)-			]
− Propellor/Property/Reboot.hs 
@@ -1,7 +0,0 @@-module Propellor.Property.Reboot where--import Propellor--now :: Property-now = cmdProperty "reboot" []-	`describe` "reboot now"
− Propellor/Property/Scheduled.hs 
@@ -1,67 +0,0 @@-module Propellor.Property.Scheduled-	( period-	, periodParse-	, Recurrance(..)-	, WeekDay-	, MonthDay-	, YearDay-	) where--import Propellor-import Utility.Scheduled--import Data.Time.Clock-import Data.Time.LocalTime-import qualified Data.Map as M---- | Makes a Property only be checked every so often.------ This uses the description of the Property to keep track of when it was--- last run.-period :: Property -> Recurrance -> Property-period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do-	lasttime <- liftIO $ getLastChecked (propertyDesc prop)-	nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime-	t <- liftIO localNow-	if Just t >= nexttime-		then do-			r <- satisfy-			liftIO $ setLastChecked t (propertyDesc prop)-			return r-		else noChange-  where-	schedule = Schedule recurrance AnyTime-	desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"---- | Like period, but parse a human-friendly string.-periodParse :: Property -> String -> Property-periodParse prop s = case toRecurrance s of-	Just recurrance -> period prop recurrance-	Nothing -> property "periodParse" $ do-		liftIO $ warningMessage $ "failed periodParse: " ++ s-		noChange--lastCheckedFile :: FilePath-lastCheckedFile = localdir </> ".lastchecked"--getLastChecked :: Desc -> IO (Maybe LocalTime)-getLastChecked desc = M.lookup desc <$> readLastChecked--localNow :: IO LocalTime-localNow = do-	now <- getCurrentTime-	tz <- getTimeZone now-	return $ utcToLocalTime tz now--setLastChecked :: LocalTime -> Desc -> IO ()-setLastChecked time desc = do-	m <- readLastChecked-	writeLastChecked (M.insert desc time m)--readLastChecked :: IO (M.Map Desc LocalTime)-readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go-  where-	go = readish <$> readFileStrict lastCheckedFile--writeLastChecked :: M.Map Desc LocalTime -> IO ()-writeLastChecked = writeFile lastCheckedFile . show
− Propellor/Property/Service.hs 
@@ -1,31 +0,0 @@-module Propellor.Property.Service where--import Propellor-import Utility.SafeCommand--type ServiceName = String---- | Ensures that a service is running. Does not ensure that--- any package providing that service is installed. See--- Apt.serviceInstalledRunning------ Note that due to the general poor state of init scripts, the best--- we can do is try to start the service, and if it fails, assume--- this means it's already running.-running :: ServiceName -> Property-running svc = property ("running " ++ svc) $ do-	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]-	return NoChange--restarted :: ServiceName -> Property-restarted svc = property ("restarted " ++ svc) $ do-	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"]-	return NoChange--reloaded :: ServiceName -> Property-reloaded svc = property ("reloaded " ++ svc) $ do-	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"]-	return NoChange
− Propellor/Property/SiteSpecific/GitAnnexBuilder.hs 
@@ -1,57 +0,0 @@-module Propellor.Property.SiteSpecific.GitAnnexBuilder where--import Propellor-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.User as User-import qualified Propellor.Property.Cron as Cron-import Propellor.Property.Cron (CronTimes)--builduser :: UserName-builduser = "builder"--homedir :: FilePath-homedir = "/home/builder"--gitbuilderdir :: FilePath-gitbuilderdir = homedir </> "gitbuilder"--builddir :: FilePath-builddir = gitbuilderdir </> "build"--builder :: Architecture -> CronTimes -> Bool -> Property-builder arch crontimes rsyncupload = combineProperties "gitannexbuilder"-	[ Apt.stdSourcesList Unstable-	, Apt.buildDep ["git-annex"]-	, Apt.installed ["git", "rsync", "moreutils", "ca-certificates",-		"liblockfile-simple-perl", "cabal-install", "vim", "less"]-	, Apt.serviceInstalledRunning "cron"-	, User.accountFor builduser-	, check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser-		[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir-		, "cd " ++ gitbuilderdir-		, "git checkout " ++ arch-		]-		`describe` "gitbuilder setup"-	, check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser-		[ "git clone git://git-annex.branchable.com/ " ++ builddir-		]-	, "git-annex source build deps installed" ==> Apt.buildDepIn builddir-	, Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir "git pull ; ./autobuild"-	-- The builduser account does not have a password set,-	-- instead use the password privdata to hold the rsync server-	-- password used to upload the built image.-	, property "rsync password" $ do-		let f = homedir </> "rsyncpassword"-		if rsyncupload -			then withPrivData (Password builduser) $ \p -> do-				oldp <- liftIO $ catchDefaultIO "" $-					readFileStrict f-				if p /= oldp-					then makeChange $ writeFile f p-					else noChange-			else do-				ifM (liftIO $ doesFileExist f)-					( noChange-					, makeChange $ writeFile f "no password configured"-					)-	]
− Propellor/Property/SiteSpecific/GitHome.hs 
@@ -1,34 +0,0 @@-module Propellor.Property.SiteSpecific.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 =<< liftIO (homedir user))-		`requires` Apt.installed ["git"]-  where-	go home = do-		let tmpdir = home </> "githome"-		ensureProperty $ combineProperties "githome setup"-			[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]-			, property "moveout" $ makeChange $ void $-				moveout tmpdir home-			, property "rmdir" $ makeChange $ void $-				catchMaybeIO $ removeDirectory tmpdir-			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]-			]-	moveout tmpdir home = do-		fs <- dirContents tmpdir-		forM fs $ \f -> boolSystem "mv" [File f, File home]--url :: String-url = "git://git.kitenet.net/joey/home"--hasGitDir :: UserName -> IO Bool-hasGitDir user = go =<< homedir user-  where-	go home = doesDirectoryExist (home </> ".git")
− Propellor/Property/SiteSpecific/JoeySites.hs 
@@ -1,295 +0,0 @@--- | Specific configuation for Joey Hess's sites. Probably not useful to--- others except as an example.--module Propellor.Property.SiteSpecific.JoeySites where--import Propellor-import qualified Propellor.Property.Apt as Apt-import qualified Propellor.Property.File as File-import qualified Propellor.Property.Gpg as Gpg-import qualified Propellor.Property.Ssh as Ssh-import qualified Propellor.Property.Git as Git-import qualified Propellor.Property.Cron as Cron-import qualified Propellor.Property.Service as Service-import qualified Propellor.Property.User as User-import qualified Propellor.Property.Obnam as Obnam-import qualified Propellor.Property.Apache as Apache-import Utility.SafeCommand--import Data.List-import System.Posix.Files--oldUseNetServer :: [Host] -> Property-oldUseNetServer hosts = propertyList ("olduse.net server")-	[ oldUseNetInstalled "oldusenet-server"-	, Obnam.latestVersion-	, Obnam.backup datadir "33 4 * * *"-		[ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"-		, "--client-name=spool"-		] Obnam.OnlyClient-		`requires` Ssh.keyImported SshRsa "root"-		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"-	, check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $-		property "olduse.net spool in place" $ makeChange $ do-			removeDirectoryRecursive newsspool-			createSymbolicLink (datadir </> "news") newsspool-	, Apt.installed ["leafnode"]-	, "/etc/news/leafnode/config" `File.hasContent` -		[ "# olduse.net configuration (deployed by propellor)"-		, "expire = 1000000" -- no expiry via texpire-		, "server = " -- no upstream server-		, "debugmode = 1"-		, "allowSTRANGERS = 42" -- lets anyone connect-		, "nopost = 1" -- no new posting (just gather them)-		]-	, "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"-	, Apt.serviceInstalledRunning "openbsd-inetd"-	, File.notPresent "/etc/cron.daily/leafnode"-	, File.notPresent "/etc/cron.d/leafnode"-	, Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";"-		[ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60  -print | xargs --no-run-if-empty rm"-		, "find -type d -empty | xargs --no-run-if-empty rmdir"-		]-	, Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $-		"/usr/bin/uucp " ++ datadir-	, toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False-		[ "  DocumentRoot " ++ datadir ++ "/"-		, "  <Directory " ++ datadir ++ "/>"-		, "    Options Indexes FollowSymlinks"-		, "    AllowOverride None"-		-- I had this in the file before.-		-- This may be needed by a newer version of apache?-		--, "    Require all granted"-		, "  </Directory>"-		]-	]-  where-	newsspool = "/var/spool/news"-	datadir = "/var/spool/oldusenet"--oldUseNetShellBox :: Property-oldUseNetShellBox = oldUseNetInstalled "oldusenet"--oldUseNetInstalled :: Apt.Package -> Property-oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $-	propertyList ("olduse.net " ++ pkg)-		[ 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 ../" ++ pkg ++ "_*.deb || true"-			, "apt-get -fy install" -- dependencies-			, "rm -rf /root/tmp/oldusenet"-			] `describe` "olduse.net built"-		]---kgbServer :: Property-kgbServer = withOS desc $ \o -> case o of-	(Just (System (Debian Unstable) _)) ->-		ensureProperty $ propertyList desc-			[ Apt.serviceInstalledRunning "kgb-bot"-			, File.hasPrivContent "/etc/kgb-bot/kgb.conf"-				`onChange` Service.restarted "kgb-bot"-			, "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"-				`describe` "kgb bot enabled"-				`onChange` Service.running "kgb-bot"-			]-	_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"-  where-	desc = "kgb.kitenet.net setup"--mumbleServer :: [Host] -> Property-mumbleServer hosts = combineProperties "mumble.debian.net" -	[ Obnam.latestVersion-	, Obnam.backup "/var/lib/mumble-server" "55 5 * * *"-		[ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/mumble.debian.net.obnam"-		, "--client-name=mumble"-		] Obnam.OnlyClient-		`requires` Ssh.keyImported SshRsa "root"-		`requires` Ssh.knownHost hosts "turtle.kitenet.net" "root"-	, trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]-	, Apt.serviceInstalledRunning "mumble-server"-	]--obnamLowMem :: Property-obnamLowMem = combineProperties "obnam tuned for low memory use"-	[ Obnam.latestVersion-	, "/etc/obnam.conf" `File.containsLines`-		[ "[config]"-		, "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)."-		, "upload-queue-size = 128"-		, "lru-size = 128"-		]-	]---- git.kitenet.net and git.joeyh.name-gitServer :: [Host] -> Property-gitServer hosts = propertyList "git.kitenet.net setup"-	[ Obnam.latestVersion-	, Obnam.backup "/srv/git" "33 3 * * *"-		[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"-		, "--encrypt-with=1B169BE1"-		, "--client-name=wren"-		] Obnam.OnlyClient-		`requires` Gpg.keyImported "1B169BE1" "root"-		`requires` Ssh.keyImported SshRsa "root"-		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"-		`requires` Ssh.authorizedKeys "family"-		`requires` User.accountFor "family"-	, Apt.installed ["git", "rsync", "kgb-client-git", "gitweb"]-	, Apt.installedBackport ["git-annex"]-	, File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf"-	, toProp $ Git.daemonRunning "/srv/git"-	, "/etc/gitweb.conf" `File.containsLines`-		[ "$projectroot = '/srv/git';"-		, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"-		, "# disable snapshot download; overloads server"-		, "$feature{'snapshot'}{'default'} = [];"-		]-		`describe` "gitweb configured"-	-- Repos push on to github.-	, Ssh.knownHost hosts "github.com" "joey"-	-- I keep the website used for gitweb checked into git..-	, Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing-	, website "git.kitenet.net"-	, website "git.joeyh.name"-	, toProp $ Apache.modEnabled "cgi"-	]-  where-	website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True-		[ "  DocumentRoot /srv/web/git.kitenet.net/"-		, "  <Directory /srv/web/git.kitenet.net/>"-		, "    Options Indexes ExecCGI FollowSymlinks"-		, "    AllowOverride None"-		, "    AddHandler cgi-script .cgi"-		, "    DirectoryIndex index.cgi"-		, "  </Directory>"-		, ""-		, "  ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"-		, "  <Directory /usr/lib/cgi-bin>"-		, "    SetHandler cgi-script"-		, "    Options ExecCGI"-		, "  </Directory>"-		]--type AnnexUUID = String---- | A website, with files coming from a git-annex repository.-annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property-annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex")-	[ Git.cloned "joey" origin dir Nothing-		`onChange` setup-	, setupapache-	]-  where-	dir = "/srv/web/" ++ hn-	setup = userScriptProperty "joey" setupscript-		`requires` Ssh.keyImported SshRsa "joey"-		`requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey"-	setupscript = -		[ "cd " ++ shellEscape dir-		, "git config annex.uuid " ++ shellEscape uuid-		] ++ map addremote remotes ++-		[ "git annex get"-		]-	addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url-	setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ -		[ "  ServerAlias www."++hn-		, ""-		, "  DocumentRoot /srv/web/"++hn-		, "  <Directory /srv/web/"++hn++">"-		, "    Options FollowSymLinks"-		, "    AllowOverride None"-		, "  </Directory>"-		, "  <Directory /srv/web/"++hn++">"-		, "    Options Indexes FollowSymLinks ExecCGI"-		, "    AllowOverride None"-		, "    AddHandler cgi-script .cgi"-		, "    DirectoryIndex index.html index.cgi"-		, "    Order allow,deny"-		, "    allow from all"-		, "  </Directory>"-		]--apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile-apachecfg hn withssl middle-	| withssl = vhost False ++ vhost True-	| otherwise = vhost False-  where-	vhost ssl = -		[ "<VirtualHost *:"++show port++">"-		, "  ServerAdmin grue@joeyh.name"-		, "  ServerName "++hn++":"++show port-		]-		++ mainhttpscert ssl-		++ middle ++-		[ ""-		, "  ErrorLog /var/log/apache2/error.log"-		, "  LogLevel warn"-		, "  CustomLog /var/log/apache2/access.log combined"-		, "  ServerSignature On"-		, "  "-		, "  <Directory \"/usr/share/apache2/icons\">"-		, "      Options Indexes MultiViews"-		, "      AllowOverride None"-		, "      Order allow,deny"-		, "      Allow from all"-		, "  </Directory>"-		, "</VirtualHost>"-		]-	  where-		port = if ssl then 443 else 80 :: Int--mainhttpscert :: Bool -> Apache.ConfigFile-mainhttpscert False = []-mainhttpscert True = -	[ "  SSLEngine on"-	, "  SSLCertificateFile /etc/ssl/certs/web.pem"-	, "  SSLCertificateKeyFile /etc/ssl/private/web.pem"-	, "  SSLCertificateChainFile /etc/ssl/certs/startssl.pem"-	]-		-gitAnnexDistributor :: Property-gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer"-	[ Apt.installed ["rsync"]-	, File.hasPrivContent "/etc/rsyncd.conf"-	, File.hasPrivContent "/etc/rsyncd.secrets"-	, "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"-			`onChange` Service.running "rsync"-	, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"-	, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"-	-- git-annex distribution signing key-	, Gpg.keyImported "89C809CB" "joey"-	]-  where-	endpoint d = combineProperties ("endpoint " ++ d)-		[ File.dirExists d-		, File.ownerGroup d "joey" "joey"-		]---- Twitter, you kill us.-twitRss :: Property-twitRss = combineProperties "twitter rss"-	[ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing-	, check (not <$> doesFileExist (dir </> "twitRss")) $-		userScriptProperty "joey"-			[ "cd " ++ dir-			, "ghc --make twitRss" -			]-			`requires` Apt.installed-				[ "libghc-xml-dev"-				, "libghc-feed-dev"-				, "libghc-tagsoup-dev"-				]-	, feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"-	, feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"-	]-  where-	dir = "/srv/web/tmp.kitenet.net/twitrss"-	crontime = "15 * * * *"-	feed url desc = Cron.job desc crontime "joey" dir $-		"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")
− Propellor/Property/Ssh.hs 
@@ -1,152 +0,0 @@-module Propellor.Property.Ssh (-	setSshdConfig,-	permitRootLogin,-	passwordAuthentication,-	hasAuthorizedKeys,-	restartSshd,-	randomHostKeys,-	hostKey,-	keyImported,-	knownHost,-	authorizedKeys-) where--import Propellor-import qualified Propellor.Property.File as File-import Propellor.Property.User-import Utility.SafeCommand-import Utility.FileMode--import System.PosixCompat--sshBool :: Bool -> String-sshBool True = "yes"-sshBool False = "no"--sshdConfig :: FilePath-sshdConfig = "/etc/ssh/sshd_config"--setSshdConfig :: String -> Bool -> Property-setSshdConfig setting allowed = combineProperties "sshd config"-	[ 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"--dotDir :: UserName -> IO FilePath-dotDir user = do-	h <- homedir user-	return $ h </> ".ssh"--dotFile :: FilePath -> UserName -> IO FilePath-dotFile f user = do-	d <- dotDir user-	return $ d </> f--hasAuthorizedKeys :: UserName -> IO Bool-hasAuthorizedKeys = go <=< dotFile "authorized_keys"-  where-	go f = not . null <$> catchDefaultIO "" (readFile f)--restartSshd :: Property-restartSshd = cmdProperty "service" ["ssh", "restart"]---- | Blows away existing host keys and make new ones.--- Useful for systems installed from an image that might reuse host keys.--- A flag file is used to only ever do this once.-randomHostKeys :: Property-randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"-	`onChange` restartSshd-  where-	prop = property "ssh random host keys" $ do-		void $ liftIO $ boolSystem "sh"-			[ Param "-c"-			, Param "rm -f /etc/ssh/ssh_host_*"-			]-		ensureProperty $-			cmdProperty "/var/lib/dpkg/info/openssh-server.postinst"-				["configure"]---- | Sets ssh host keys from the site's PrivData.--- --- (Uses a null username for host keys.)-hostKey :: SshKeyType -> Property-hostKey keytype = combineProperties desc-	[ property desc (install writeFile (SshPubKey keytype "") ".pub")-	, property desc (install writeFileProtected (SshPrivKey keytype "") "")-	]-	`onChange` restartSshd-  where- 	desc = "known ssh host key (" ++ fromKeyType keytype ++ ")"-	install writer p ext = withPrivData p $ \key -> do-		let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext-		s <- liftIO $ readFileStrict f-		if s == key-			then noChange-			else makeChange $ writer f key---- | Sets up a user with a ssh private key and public key pair--- from the site's PrivData.-keyImported :: SshKeyType -> UserName -> Property-keyImported keytype user = combineProperties desc-	[ property desc (install writeFile (SshPubKey keytype user) ".pub")-	, property desc (install writeFileProtected (SshPrivKey keytype user) "")-	]-  where-	desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")"-	install writer p ext = do-		f <- liftIO $ keyfile ext-		ifM (liftIO $ doesFileExist f)-			( noChange-			, ensureProperty $ combineProperties desc-				[ property desc $ -					withPrivData p $ \key -> makeChange $-						writer f key-				, File.ownerGroup f user user-				]-			)-	keyfile ext = do-		home <- homeDirectory <$> getUserEntryForName user-		return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext--fromKeyType :: SshKeyType -> String-fromKeyType SshRsa = "rsa"-fromKeyType SshDsa = "dsa"-fromKeyType SshEcdsa = "ecdsa"-fromKeyType SshEd25519 = "ed25519"---- | Puts some host's ssh public key into the known_hosts file for a user.-knownHost :: [Host] -> HostName -> UserName -> Property-knownHost hosts hn user = property desc $-	go =<< fromHost hosts hn getSshPubKey-  where-	desc = user ++ " knows ssh key for " ++ hn-	go (Just (Just k)) = do-		f <- liftIO $ dotFile "known_hosts" user-		ensureProperty $ combineProperties desc-			[ File.dirExists (takeDirectory f)-			, f `File.containsLine` (hn ++ " " ++ k)-			, File.ownerGroup f user user-			]-	go _ = do-		warningMessage $ "no configred sshPubKey for " ++ hn-		return FailedChange---- | Makes a user have authorized_keys from the PrivData-authorizedKeys :: UserName -> Property-authorizedKeys user = property (user ++ " has authorized_keys") $-	withPrivData (SshAuthorizedKeys user) $ \v -> do-		f <- liftIO $ dotFile "authorized_keys" user-		liftIO $ do-			createDirectoryIfMissing True (takeDirectory f)-			writeFileProtected f v-		ensureProperty $ File.ownerGroup f user user
− Propellor/Property/Sudo.hs 
@@ -1,32 +0,0 @@-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.-enabledFor :: UserName -> Property-enabledFor user = property desc go `requires` Apt.installed ["sudo"]-  where-	go = do-		locked <- liftIO $ 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-		-- TOOD: Full sudoers file format parse.. -		| 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 
@@ -1,19 +0,0 @@-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 
@@ -1,61 +0,0 @@-module Propellor.Property.User where--import System.Posix--import Propellor--data Eep = YesReallyDeleteHome--accountFor :: UserName -> Property-accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"-	[ "--disabled-password"-	, "--gecos", ""-	, user-	]-	`describe` ("account for " ++ user)---- | Removes user home directory!! Use with caution.-nuked :: UserName -> Eep -> Property-nuked user _ = check (isJust <$> catchMaybeIO (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 FilePath-homedir user = homeDirectory <$> getUserEntryForName user
− Propellor/SimpleSh.hs 
@@ -1,97 +0,0 @@--- | Simple server, using a named pipe. Client connects, sends a command,--- and gets back all the output from the command, in a stream.------ This is useful for eg, docker.--module Propellor.SimpleSh where--import Network.Socket-import Control.Concurrent.Chan-import Control.Concurrent.Async-import System.Process (std_in, std_out, std_err)--import Propellor-import Utility.FileMode-import Utility.ThreadScheduler--data Cmd = Cmd String [String]-	deriving (Read, Show)--data Resp = StdoutLine String | StderrLine String | Done-	deriving (Read, Show)--simpleSh :: FilePath -> IO ()-simpleSh namedpipe = do-	nukeFile namedpipe-	let dir = takeDirectory namedpipe-	createDirectoryIfMissing True dir-	modifyFileMode dir (removeModes otherGroupModes)-	s <- socket AF_UNIX Stream defaultProtocol-	bindSocket s (SockAddrUnix namedpipe)-	listen s 2-	forever $ do-		(client, _addr) <- accept s-		h <- socketToHandle client ReadWriteMode-		maybe noop (run h) . readish =<< hGetLine h-  where-	run h (Cmd cmd params) = do-		let p = (proc cmd params)-                	{ std_in = Inherit-	                , std_out = CreatePipe-			, std_err = CreatePipe-			}-		(Nothing, Just outh, Just errh, pid) <- createProcess p-		chan <- newChan--		let runwriter = do-			v <- readChan chan-			hPutStrLn h (show v)-			hFlush h-			case v of-				Done -> noop-				_ -> runwriter-		writer <- async runwriter--		let mkreader t from = maybe noop (const $ mkreader t from) -			=<< catchMaybeIO (writeChan chan . t =<< hGetLine from)-		void $ concurrently-			(mkreader StdoutLine outh)-			(mkreader StderrLine errh)-		-		void $ tryIO $ waitForProcess pid--		writeChan chan Done--		wait writer--		hClose outh-		hClose errh-		hClose h--simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a-simpleShClient namedpipe cmd params handler = do-	s <- socket AF_UNIX Stream defaultProtocol-	connect s (SockAddrUnix namedpipe)-	h <- socketToHandle s ReadWriteMode-	hPutStrLn h $ show $ Cmd cmd params-	hFlush h-	resps <- catMaybes . map readish . lines <$> hGetContents h-	hClose h `after` handler resps--simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a-simpleShClientRetry retries namedpipe cmd params handler = go retries-  where-	run = simpleShClient namedpipe cmd params handler-	go n-		| n < 1 = run-		| otherwise = do-			v <- tryIO run-			case v of-				Right r -> return r-				Left _ -> do-					threadDelaySeconds (Seconds 1)-					go (n - 1)--getStdout :: Resp -> Maybe String-getStdout (StdoutLine s) = Just s-getStdout _ = Nothing
− Propellor/Types.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ExistentialQuantification #-}--module Propellor.Types-	( Host(..)-	, Attr-	, SetAttr-	, Propellor(..)-	, Property(..)-	, RevertableProperty(..)-	, IsProp-	, describe-	, toProp-	, setAttr-	, requires-	, Desc-	, Result(..)-	, ActionResult(..)-	, CmdLine(..)-	, PrivDataField(..)-	, GpgKeyId-	, SshKeyType(..)-	, module Propellor.Types.OS-	, module Propellor.Types.Dns-	) where--import Data.Monoid-import Control.Applicative-import System.Console.ANSI-import "mtl" Control.Monad.Reader-import "MonadCatchIO-transformers" Control.Monad.CatchIO--import Propellor.Types.Attr-import Propellor.Types.OS-import Propellor.Types.Dns--data Host = Host [Property] SetAttr---- | Propellor's monad provides read-only access to attributes of the--- system.-newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }-	deriving-		( Monad-		, Functor-		, Applicative-		, MonadReader Attr -		, MonadIO-		, MonadCatchIO-		)---- | The core data type of Propellor, this represents a property--- that the system should have, and an action to ensure it has the--- property.-data Property = Property-	{ propertyDesc :: Desc-	, propertySatisfy :: Propellor Result-	-- ^ must be idempotent; may run repeatedly-	, propertyAttr :: SetAttr-	-- ^ a property can set an Attr on the host that has the property.-	}---- | A property that can be reverted.-data RevertableProperty = RevertableProperty Property Property--class IsProp p where-	-- | Sets description.-	describe :: p -> Desc -> p-	toProp :: p -> Property-	-- | Indicates that the first property can only be satisfied-	-- once the second one is.-	requires :: p -> Property -> p-	setAttr :: p -> SetAttr--instance IsProp Property where-	describe p d = p { propertyDesc = d }-	toProp p = p-	setAttr = propertyAttr-	x `requires` y = Property (propertyDesc x) satisfy attr-	  where-	  	attr = propertyAttr x . propertyAttr y-		satisfy = do-			r <- propertySatisfy y-			case r of-				FailedChange -> return FailedChange-				_ -> propertySatisfy x-			--instance IsProp RevertableProperty where-	-- | Sets the description of both sides.-	describe (RevertableProperty p1 p2) d = -		RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))-	toProp (RevertableProperty p1 _) = p1-	(RevertableProperty p1 p2) `requires` y =-		RevertableProperty (p1 `requires` y) p2-	-- | Return the SetAttr of the currently active side.-	setAttr (RevertableProperty p1 _p2) = setAttr p1--type Desc = String--data Result = NoChange | MadeChange | FailedChange-	deriving (Read, Show, Eq)--instance Monoid Result where-	mempty = NoChange--	mappend FailedChange _ = FailedChange-	mappend _ FailedChange = FailedChange-	mappend MadeChange _ = MadeChange-	mappend _ MadeChange = MadeChange-	mappend NoChange NoChange = NoChange---- | Results of actions, with color.-class ActionResult a where-	getActionResult :: a -> (String, ColorIntensity, Color)--instance ActionResult Bool where-	getActionResult False = ("failed", Vivid, Red)-	getActionResult True = ("done", Dull, Green)--instance ActionResult Result where-	getActionResult NoChange = ("ok", Dull, Green)-	getActionResult MadeChange = ("done", Vivid, Green)-	getActionResult FailedChange = ("failed", Vivid, Red)--data CmdLine-	= Run HostName-	| Spin HostName-	| Boot HostName-	| Set HostName PrivDataField-	| AddKey String-	| Continue CmdLine-	| Chain HostName-	| Docker HostName-  deriving (Read, Show, Eq)---- | 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-	| SshPubKey SshKeyType UserName-	| SshPrivKey SshKeyType UserName-	| SshAuthorizedKeys UserName-	| Password UserName-	| PrivFile FilePath-	| GpgKey GpgKeyId-	deriving (Read, Show, Ord, Eq)--type GpgKeyId = String--data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519-	deriving (Read, Show, Ord, Eq)
− Propellor/Types/Attr.hs 
@@ -1,48 +0,0 @@-module Propellor.Types.Attr where--import Propellor.Types.OS-import qualified Propellor.Types.Dns as Dns--import qualified Data.Set as S-import qualified Data.Map as M---- | The attributes of a host. For example, its hostname.-data Attr = Attr-	{ _hostname :: HostName-	, _os :: Maybe System-	, _sshPubKey :: Maybe String-	, _dns :: S.Set Dns.Record-	, _namedconf :: M.Map Dns.Domain Dns.NamedConf--	, _dockerImage :: Maybe String-	, _dockerRunParams :: [HostName -> String]-	}--instance Eq Attr where-	x == y = and-		[ _hostname x == _hostname y-		, _os x == _os y-		, _dns x == _dns y-		, _namedconf x == _namedconf y-		, _sshPubKey x == _sshPubKey y--		, _dockerImage x == _dockerImage y-		, let simpl v = map (\a -> a "") (_dockerRunParams v)-		  in simpl x == simpl y-		]--instance Show Attr where-	show a = unlines-		[ "hostname " ++ _hostname a-		, "OS " ++ show (_os a)-		, "sshPubKey " ++ show (_sshPubKey a)-		, "dns " ++ show (_dns a)-		, "namedconf " ++ show (_namedconf a)-		, "docker image " ++ show (_dockerImage a)-		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))-		]--newAttr :: HostName -> Attr-newAttr hn = Attr hn Nothing Nothing S.empty M.empty Nothing []--type SetAttr = Attr -> Attr
− Propellor/Types/Dns.hs 
@@ -1,92 +0,0 @@-module Propellor.Types.Dns where--import Propellor.Types.OS (HostName)--import Data.Word--type Domain = String--data IPAddr = IPv4 String | IPv6 String-	deriving (Read, Show, Eq, Ord)--fromIPAddr :: IPAddr -> String-fromIPAddr (IPv4 addr) = addr-fromIPAddr (IPv6 addr) = addr---- | Represents a bind 9 named.conf file.-data NamedConf = NamedConf-	{ confDomain :: Domain-	, confDnsServerType :: DnsServerType-	, confFile :: FilePath-	, confMasters :: [IPAddr]-	, confAllowTransfer :: [IPAddr]-	, confLines :: [String]-	}-	deriving (Show, Eq, Ord)--data DnsServerType = Master | Secondary-	deriving (Show, Eq, Ord)---- | Represents a bind 9 zone file.-data Zone = Zone-	{ zDomain :: Domain-	, zSOA :: SOA-	, zHosts :: [(BindDomain, Record)]-	}-	deriving (Read, Show, Eq)---- | Every domain has a SOA record, which is big and complicated.-data SOA = SOA-	{ sDomain :: BindDomain-	-- ^ Typically ns1.your.domain-	, sSerial :: SerialNumber-	-- ^ The most important parameter is the serial number,-	-- which must increase after each change.-	, sRefresh :: Integer-	, sRetry :: Integer-	, sExpire :: Integer-	, sNegativeCacheTTL :: Integer-	}-	deriving (Read, Show, Eq)---- | Types of DNS records.------ This is not a complete list, more can be added.-data Record-	= Address IPAddr-	| CNAME BindDomain-	| MX Int BindDomain-	| NS BindDomain-	| TXT String-	| SRV Word16 Word16 Word16 BindDomain-	deriving (Read, Show, Eq, Ord)--getIPAddr :: Record -> Maybe IPAddr-getIPAddr (Address addr) = Just addr-getIPAddr _ = Nothing--getCNAME :: Record -> Maybe BindDomain-getCNAME (CNAME d) = Just d-getCNAME _ = Nothing--getNS :: Record -> Maybe BindDomain-getNS (NS d) = Just d-getNS _ = Nothing---- | Bind serial numbers are unsigned, 32 bit integers.-type SerialNumber = Word32---- | Domains in the zone file must end with a period if they are absolute.------ Let's use a type to keep absolute domains straight from relative--- domains.------ The RootDomain refers to the top level of the domain, so can be used--- to add nameservers, MX's, etc to a domain.-data BindDomain = RelDomain Domain | AbsDomain Domain | RootDomain-	deriving (Read, Show, Eq, Ord)--domainHostName :: BindDomain -> Maybe HostName-domainHostName (RelDomain d) = Just d-domainHostName (AbsDomain d) = Just d-domainHostName RootDomain = Nothing
− Propellor/Types/OS.hs 
@@ -1,27 +0,0 @@-module Propellor.Types.OS where--type HostName = String-type UserName = String-type GroupName = String---- | High level descritption of a operating system.-data System = System Distribution Architecture-	deriving (Show, Eq)--data Distribution-	= Debian DebianSuite-	| Ubuntu Release-	deriving (Show, Eq)--data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release-	deriving (Show, Eq)---- | The release that currently corresponds to stable.-stableRelease :: DebianSuite-stableRelease = DebianRelease "wheezy"--isStable :: DebianSuite -> Bool-isStable s = s == Stable || s == stableRelease--type Release = String-type Architecture = String
README.md view
@@ -6,7 +6,8 @@ Propellor is configured via a git repository, which typically lives in `~/.propellor/` on your development machine. Propellor clones the repository to each host it manages, in a -[secure](http://propellor.branchable.com/security/) way.+[secure](http://propellor.branchable.com/security/) way. The git repository+contains the full source code to Propellor, along with its config file.  Properties are defined using Haskell. Edit `~/.propellor/config.hs` to get started. There is fairly complete @@ -40,11 +41,12 @@      `apt-get install propellor` 2. Run propellor for the first time. It will set up a `~/.propellor/` git    repository for you.-3. `cd ~/.propellor/`; use git to push the repository to a central+3. If you don't have a gpg private key already, generate one: `gpg --gen-key`+4. Run: `propellor --add-key $KEYID`, which will make propellor trust+   your gpg key, and will sign your `~/.propellor` repository using it.+5. `cd ~/.propellor/`; use git to push the repository to a central    server (github, or your own git server). Configure that central    server as the origin remote of the repository.-4. If you don't have a gpg private key, generate one: `gpg --gen-key`-5. Run: `propellor --add-key $KEYID` 6. Edit `~/.propellor/config.hs`, and add a host you want to manage.    You can start by not adding any properties, or only a few. 7. Pick a host and run: `propellor --spin $HOST`
− Utility/Applicative.hs 
@@ -1,16 +0,0 @@-{- 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 
@@ -1,17 +0,0 @@-{- 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 
@@ -1,135 +0,0 @@-{- 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 
@@ -1,81 +0,0 @@-{- 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 
@@ -1,59 +0,0 @@-{- 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 
@@ -1,157 +0,0 @@-{- 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]--otherGroupModes :: [FileMode]-otherGroupModes = -	[ groupReadMode, otherReadMode-	, groupWriteMode, otherWriteMode-	]--{- 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 otherGroupModes-		hPutStr h content
− Utility/FileSystemEncoding.hs 
@@ -1,132 +0,0 @@-{- 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/LinuxMkLibs.hs 
@@ -1,61 +0,0 @@-{- Linux library copier and binary shimmer- -- - Copyright 2013 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Utility.LinuxMkLibs where--import Control.Applicative-import Data.Maybe-import System.Directory-import Data.List.Utils-import System.Posix.Files-import Data.Char-import Control.Monad.IfElse--import Utility.PartialPrelude-import Utility.Directory-import Utility.Process-import Utility.Monad-import Utility.Path--{- Installs a library. If the library is a symlink to another file,- - install the file it links to, and update the symlink to be relative. -}-installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)-installLib installfile top lib = ifM (doesFileExist lib)-	( do-		installfile top lib-		checksymlink lib-		return $ Just $ parentDir lib-	, return Nothing-	)-  where-	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do-		l <- readSymbolicLink (inTop top f)-		let absl = absPathFrom (parentDir f) l-		let target = relPathDirToFile (parentDir f) absl-		installfile top absl-		nukeFile (top ++ f)-		createSymbolicLink target (inTop top f)-		checksymlink absl---- Note that f is not relative, so cannot use </>-inTop :: FilePath -> FilePath -> FilePath-inTop top f = top ++ f--{- Parse ldd output, getting all the libraries that the input files- - link to. Note that some of the libraries may not exist - - (eg, linux-vdso.so) -}-parseLdd :: String -> [FilePath]-parseLdd = catMaybes . map (getlib . dropWhile isSpace) . lines-  where-	getlib l = headMaybe . words =<< lastMaybe (split " => " l)--{- Get all glibc libs and other support files, including gconv files- -- - XXX Debian specific. -}-glibcLibs :: IO [FilePath]-glibcLibs = lines <$> readProcess "sh"-	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]
− Utility/Misc.hs 
@@ -1,148 +0,0 @@-{- 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 
@@ -1,69 +0,0 @@-{- 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 
@@ -1,68 +0,0 @@-{- 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/Path.hs 
@@ -1,293 +0,0 @@-{- path manipulation- -- - Copyright 2010-2014 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE PackageImports, CPP #-}--module Utility.Path where--import Data.String.Utils-import System.FilePath-import System.Directory-import Data.List-import Data.Maybe-import Data.Char-import Control.Applicative--#ifdef mingw32_HOST_OS-import qualified System.FilePath.Posix as Posix-#else-import System.Posix.Files-#endif--import qualified "MissingH" System.Path as MissingH-import Utility.Monad-import Utility.UserInfo--{- Simplifies a path, removing any ".." or ".", and removing the trailing- - path separator.- -- - On Windows, preserves whichever style of path separator might be used in- - the input FilePaths. This is done because some programs in Windows- - demand a particular path separator -- and which one actually varies!- -- - This does not guarantee that two paths that refer to the same location,- - and are both relative to the same location (or both absolute) will- - yeild the same result. Run both through normalise from System.FilePath- - to ensure that.- -}-simplifyPath :: FilePath -> FilePath-simplifyPath path = dropTrailingPathSeparator $ -	joinDrive drive $ joinPath $ norm [] $ splitPath path'-  where-	(drive, path') = splitDrive path--	norm c [] = reverse c-	norm c (p:ps)-		| p' == ".." = norm (drop 1 c) ps-		| p' == "." = norm c ps-		| otherwise = norm (p:c) ps-	  where-		p' = dropTrailingPathSeparator p--{- Makes a path absolute.- -- - The first parameter is a base directory (ie, the cwd) to use if the path- - is not already absolute.- -- - Does not attempt to deal with edge cases or ensure security with- - untrusted inputs.- -}-absPathFrom :: FilePath -> FilePath -> FilePath-absPathFrom dir path = simplifyPath (combine dir path)--{- On Windows, this converts the paths to unix-style, in order to run- - MissingH's absNormPath on them. Resulting path will use / separators. -}-absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath-#ifndef mingw32_HOST_OS-absNormPathUnix dir path = MissingH.absNormPath dir path-#else-absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)-  where-	fromdos = replace "\\" "/"-	todos = replace "/" "\\"-#endif--{- Returns the parent directory of a path.- -- - To allow this to be easily used in loops, which terminate upon reaching the- - top, the parent of / is "" -}-parentDir :: FilePath -> FilePath-parentDir dir-	| null dirs = ""-	| otherwise = joinDrive drive (join s $ init dirs)-  where-	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""-	(drive, path) = splitDrive dir-	dirs = filter (not . null) $ split s path-	s = [pathSeparator]--prop_parentDir_basics :: FilePath -> Bool-prop_parentDir_basics dir-	| null dir = True-	| dir == "/" = parentDir dir == ""-	| otherwise = p /= dir-  where-	p = parentDir dir--{- Checks if the first FilePath is, or could be said to contain the second.- - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc- - are all equivilant.- -}-dirContains :: FilePath -> FilePath -> Bool-dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'-  where-	a' = norm a-	b' = norm b-	norm = normalise . simplifyPath--{- Converts a filename into an absolute path.- -- - Unlike Directory.canonicalizePath, this does not require the path- - already exists. -}-absPath :: FilePath -> IO FilePath-absPath file = do-	cwd <- getCurrentDirectory-	return $ absPathFrom cwd file--{- Constructs a relative path from the CWD to a file.- -- - For example, assuming CWD is /tmp/foo/bar:- -    relPathCwdToFile "/tmp/foo" == ".."- -    relPathCwdToFile "/tmp/foo/bar" == "" - -}-relPathCwdToFile :: FilePath -> IO FilePath-relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f--{- Constructs a relative path from a directory to a file.- -- - Both must be absolute, and cannot contain .. etc. (eg use absPath first).- -}-relPathDirToFile :: FilePath -> FilePath -> FilePath-relPathDirToFile from to = join s $ dotdots ++ uncommon-  where-	s = [pathSeparator]-	pfrom = split s from-	pto = split s to-	common = map fst $ takeWhile same $ zip pfrom pto-	same (c,d) = c == d-	uncommon = drop numcommon pto-	dotdots = replicate (length pfrom - numcommon) ".."-	numcommon = length common--prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool-prop_relPathDirToFile_basics from to-	| from == to = null r-	| otherwise = not (null r)-  where-	r = relPathDirToFile from to --prop_relPathDirToFile_regressionTest :: Bool-prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference-  where-	{- Two paths have the same directory component at the same-	 - location, but it's not really the same directory.-	 - Code used to get this wrong. -}-	same_dir_shortcurcuits_at_difference =-		relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])-			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])-				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]--{- Given an original list of paths, and an expanded list derived from it,- - generates a list of lists, where each sublist corresponds to one of the- - original paths. When the original path is a directory, any items- - in the expanded list that are contained in that directory will appear in- - its segment.- -}-segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]-segmentPaths [] new = [new]-segmentPaths [_] new = [new] -- optimisation-segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest-  where-	(found, rest)=partition (l `dirContains`) new--{- This assumes that it's cheaper to call segmentPaths on the result,- - than it would be to run the action separately with each path. In- - the case of git file list commands, that assumption tends to hold.- -}-runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]-runSegmentPaths a paths = segmentPaths paths <$> a paths--{- Converts paths in the home directory to use ~/ -}-relHome :: FilePath -> IO String-relHome path = do-	home <- myHomeDir-	return $ if dirContains home path-		then "~/" ++ relPathDirToFile home path-		else path--{- Checks if a command is available in PATH.- -- - The command may be fully-qualified, in which case, this succeeds as- - long as it exists. -}-inPath :: String -> IO Bool-inPath command = isJust <$> searchPath command--{- Finds a command in PATH and returns the full path to it.- -- - The command may be fully qualified already, in which case it will- - be returned if it exists.- -}-searchPath :: String -> IO (Maybe FilePath)-searchPath command-	| isAbsolute command = check command-	| otherwise = getSearchPath >>= getM indir-  where-	indir d = check $ d </> command-	check f = firstM doesFileExist-#ifdef mingw32_HOST_OS-		[f, f ++ ".exe"]-#else-		[f]-#endif--{- Checks if a filename is a unix dotfile. All files inside dotdirs- - count as dotfiles. -}-dotfile :: FilePath -> Bool-dotfile file-	| f == "." = False-	| f == ".." = False-	| f == "" = False-	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)-  where-	f = takeFileName file--{- Converts a DOS style path to a Cygwin style path. Only on Windows.- - Any trailing '\' is preserved as a trailing '/' -}-toCygPath :: FilePath -> FilePath-#ifndef mingw32_HOST_OS-toCygPath = id-#else-toCygPath p-	| null drive = recombine parts-	| otherwise = recombine $ "/cygdrive" : driveletter drive : parts-  where-  	(drive, p') = splitDrive p-	parts = splitDirectories p'-  	driveletter = map toLower . takeWhile (/= ':')-	recombine = fixtrailing . Posix.joinPath-  	fixtrailing s-		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s-		| otherwise = s-#endif--{- Maximum size to use for a file in a specified directory.- -- - Many systems have a 255 byte limit to the name of a file, - - so that's taken as the max if the system has a larger limit, or has no- - limit.- -}-fileNameLengthLimit :: FilePath -> IO Int-#ifdef mingw32_HOST_OS-fileNameLengthLimit _ = return 255-#else-fileNameLengthLimit dir = do-	l <- fromIntegral <$> getPathVar dir FileNameLimit-	if l <= 0-		then return 255-		else return $ minimum [l, 255]-  where-#endif--{- Given a string that we'd like to use as the basis for FilePath, but that- - was provided by a third party and is not to be trusted, returns the closest- - sane FilePath.- -- - All spaces and punctuation and other wacky stuff are replaced- - with '_', except for '.' "../" will thus turn into ".._", which is safe.- -}-sanitizeFilePath :: String -> FilePath-sanitizeFilePath = map sanitize-  where-  	sanitize c-		| c == '.' = c-		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'-		| otherwise = c--{- Similar to splitExtensions, but knows that some things in FilePaths- - after a dot are too long to be extensions. -}-splitShortExtensions :: FilePath -> (FilePath, [String])-splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"-splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])-splitShortExtensions' maxextension = go []-  where-	go c f-		| len > 0 && len <= maxextension && not (null base) = -			go (ext:c) base-		| otherwise = (f, c)-	  where-		(base, ext) = splitExtension f-		len = length ext
− Utility/PosixFiles.hs 
@@ -1,33 +0,0 @@-{- 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 
@@ -1,360 +0,0 @@-{- 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/QuickCheck.hs 
@@ -1,52 +0,0 @@-{- QuickCheck with additional instances- -- - Copyright 2012-2014 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Utility.QuickCheck-	( module X-	, module Utility.QuickCheck-	) where--import Test.QuickCheck as X-import Data.Time.Clock.POSIX-import System.Posix.Types-import qualified Data.Map as M-import qualified Data.Set as S-import Control.Applicative--instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where-	arbitrary = M.fromList <$> arbitrary--instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where-	arbitrary = S.fromList <$> arbitrary--{- Times before the epoch are excluded. -}-instance Arbitrary POSIXTime where-	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral--instance Arbitrary EpochTime where-	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral--{- Pids are never negative, or 0. -}-instance Arbitrary ProcessID where-	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)--{- Inodes are never negative. -}-instance Arbitrary FileID where-	arbitrary = nonNegative arbitrarySizedIntegral--{- File sizes are never negative. -}-instance Arbitrary FileOffset where-	arbitrary = nonNegative arbitrarySizedIntegral--nonNegative :: (Num a, Ord a) => Gen a -> Gen a-nonNegative g = g `suchThat` (>= 0)--positive :: (Num a, Ord a) => Gen a -> Gen a-positive g = g `suchThat` (> 0)
− Utility/SafeCommand.hs 
@@ -1,120 +0,0 @@-{- 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/Scheduled.hs 
@@ -1,396 +0,0 @@-{- scheduled activities- - - - Copyright 2013-2014 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Utility.Scheduled (-	Schedule(..),-	Recurrance(..),-	ScheduledTime(..),-	NextTime(..),-	WeekDay,-	MonthDay,-	YearDay,-	nextTime,-	calcNextTime,-	startTime,-	fromSchedule,-	fromScheduledTime,-	toScheduledTime,-	fromRecurrance,-	toRecurrance,-	toSchedule,-	parseSchedule,-	prop_schedule_roundtrips,-	prop_past_sane,-) where--import Utility.Data-import Utility.QuickCheck-import Utility.PartialPrelude-import Utility.Misc--import Control.Applicative-import Data.List-import Data.Time.Clock-import Data.Time.LocalTime-import Data.Time.Calendar-import Data.Time.Calendar.WeekDate-import Data.Time.Calendar.OrdinalDate-import Data.Tuple.Utils-import Data.Char--{- Some sort of scheduled event. -}-data Schedule = Schedule Recurrance ScheduledTime-  deriving (Eq, Read, Show, Ord)--data Recurrance-	= Daily-	| Weekly (Maybe WeekDay)-	| Monthly (Maybe MonthDay)-	| Yearly (Maybe YearDay)-	| Divisible Int Recurrance-	-- ^ Days, Weeks, or Months of the year evenly divisible by a number.-	-- (Divisible Year is years evenly divisible by a number.)-  deriving (Eq, Read, Show, Ord)--type WeekDay = Int-type MonthDay = Int-type YearDay = Int--data ScheduledTime-	= AnyTime-	| SpecificTime Hour Minute-  deriving (Eq, Read, Show, Ord)--type Hour = Int-type Minute = Int---- | Next time a Schedule should take effect. The NextTimeWindow is used--- when a Schedule is allowed to start at some point within the window.-data NextTime-	= NextTimeExactly LocalTime-	| NextTimeWindow LocalTime LocalTime-  deriving (Eq, Read, Show)--startTime :: NextTime -> LocalTime-startTime (NextTimeExactly t) = t-startTime (NextTimeWindow t _) = t--nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)-nextTime schedule lasttime = do-	now <- getCurrentTime-	tz <- getTimeZone now-	return $ calcNextTime schedule lasttime $ utcToLocalTime tz now---- | Calculate the next time that fits a Schedule, based on the--- last time it occurred, and the current time.-calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime-calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime-	| scheduledtime == AnyTime = do-		next <- findfromtoday True-		return $ case next of-			NextTimeWindow _ _ -> next-			NextTimeExactly t -> window (localDay t) (localDay t)-	| otherwise = NextTimeExactly . startTime <$> findfromtoday False-  where-  	findfromtoday anytime = findfrom recurrance afterday today-	  where-	  	today = localDay currenttime-		afterday = sameaslastrun || toolatetoday-		toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime-		sameaslastrun = lastrun == Just today-	lastrun = localDay <$> lasttime-	nexttime = case scheduledtime of-		AnyTime -> TimeOfDay 0 0 0-		SpecificTime h m -> TimeOfDay h m 0-	exactly d = NextTimeExactly $ LocalTime d nexttime-	window startd endd = NextTimeWindow-		(LocalTime startd nexttime)-		(LocalTime endd (TimeOfDay 23 59 0))-	findfrom r afterday candidate-		| ynum candidate > (ynum (localDay currenttime)) + 100 =-			-- avoid possible infinite recusion-			error $ "bug: calcNextTime did not find a time within 100 years to run " ++-			show (schedule, lasttime, currenttime)-		| otherwise = findfromChecked r afterday candidate-	findfromChecked r afterday candidate = case r of-		Daily-			| afterday -> Just $ exactly $ addDays 1 candidate-			| otherwise -> Just $ exactly candidate-		Weekly Nothing-			| afterday -> skip 1-			| otherwise -> case (wday <$> lastrun, wday candidate) of-				(Nothing, _) -> Just $ window candidate (addDays 6 candidate)-				(Just old, curr)-					| old == curr -> Just $ window candidate (addDays 6 candidate)-					| otherwise -> skip 1-		Monthly Nothing-			| afterday -> skip 1-			| maybe True (candidate `oneMonthPast`) lastrun ->-				Just $ window candidate (endOfMonth candidate)-			| otherwise -> skip 1-		Yearly Nothing-			| afterday -> skip 1-			| maybe True (candidate `oneYearPast`) lastrun ->-				Just $ window candidate (endOfYear candidate)-			| otherwise -> skip 1-		Weekly (Just w)-			| w < 0 || w > maxwday -> Nothing-			| w == wday candidate -> if afterday-				then Just $ exactly $ addDays 7 candidate-				else Just $ exactly candidate-			| otherwise -> Just $ exactly $-				addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate-		Monthly (Just m)-			| m < 0 || m > maxmday -> Nothing-			-- TODO can be done more efficiently than recursing-			| m == mday candidate -> if afterday-				then skip 1-				else Just $ exactly candidate-			| otherwise -> skip 1-		Yearly (Just y)-			| y < 0 || y > maxyday -> Nothing-			| y == yday candidate -> if afterday-				then skip 365-				else Just $ exactly candidate-			| otherwise -> skip 1-		Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)-		Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)-		Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)-		Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing-		Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate-	  where-	  	skip n = findfrom r False (addDays n candidate)-	  	handlediv n r' getval mmax-			| n > 0 && maybe True (n <=) mmax =-				findfromwhere r' (divisible n . getval) afterday candidate-			| otherwise = Nothing-	findfromwhere r p afterday candidate-		| maybe True (p . getday) next = next-		| otherwise = maybe Nothing (findfromwhere r p True . getday) next-	  where-		next = findfrom r afterday candidate-		getday = localDay . startTime-	divisible n v = v `rem` n == 0---- Check if the new Day occurs one month or more past the old Day.-oneMonthPast :: Day -> Day -> Bool-new `oneMonthPast` old = fromGregorian y (m+1) d <= new-  where-	(y,m,d) = toGregorian old---- Check if the new Day occurs one year or more past the old Day.-oneYearPast :: Day -> Day -> Bool-new `oneYearPast` old = fromGregorian (y+1) m d <= new-  where-	(y,m,d) = toGregorian old--endOfMonth :: Day -> Day-endOfMonth day =-	let (y,m,_d) = toGregorian day-	in fromGregorian y m (gregorianMonthLength y m)--endOfYear :: Day -> Day-endOfYear day =-	let (y,_m,_d) = toGregorian day-	in endOfMonth (fromGregorian y maxmnum 1)---- extracting various quantities from a Day-wday :: Day -> Int-wday = thd3 . toWeekDate-wnum :: Day -> Int-wnum = snd3 . toWeekDate-mday :: Day -> Int-mday = thd3 . toGregorian-mnum :: Day -> Int-mnum = snd3 . toGregorian-yday :: Day -> Int-yday = snd . toOrdinalDate-ynum :: Day -> Int-ynum = fromIntegral . fst . toOrdinalDate---- Calendar max values.-maxyday :: Int-maxyday = 366 -- with leap days-maxwnum :: Int-maxwnum = 53 -- some years have more than 52-maxmday :: Int-maxmday = 31-maxmnum :: Int-maxmnum = 12-maxwday :: Int-maxwday = 7--fromRecurrance :: Recurrance -> String-fromRecurrance (Divisible n r) =-	fromRecurrance' (++ "s divisible by " ++ show n) r-fromRecurrance r = fromRecurrance' ("every " ++) r--fromRecurrance' :: (String -> String) -> Recurrance -> String-fromRecurrance' a Daily = a "day"-fromRecurrance' a (Weekly n) = onday n (a "week")-fromRecurrance' a (Monthly n) = onday n (a "month")-fromRecurrance' a (Yearly n) = onday n (a "year")-fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used--onday :: Maybe Int -> String -> String-onday (Just n) s = "on day " ++ show n ++ " of " ++ s-onday Nothing s = s--toRecurrance :: String -> Maybe Recurrance-toRecurrance s = case words s of-	("every":"day":[]) -> Just Daily-	("on":"day":sd:"of":"every":something:[]) -> withday sd something-	("every":something:[]) -> noday something-	("days":"divisible":"by":sn:[]) -> -		Divisible <$> getdivisor sn <*> pure Daily-	("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> -		Divisible-			<$> getdivisor sn-			<*> withday sd something-	("every":something:"divisible":"by":sn:[]) -> -		Divisible-			<$> getdivisor sn-			<*> noday something-	(something:"divisible":"by":sn:[]) -> -		Divisible-			<$> getdivisor sn-			<*> noday something-	_ -> Nothing-  where-	constructor "week" = Just Weekly-	constructor "month" = Just Monthly-	constructor "year" = Just Yearly-	constructor u-		| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u-		| otherwise = Nothing-  	withday sd u = do-		c <- constructor u-		d <- readish sd-		Just $ c (Just d)-	noday u = do-		c <- constructor u-		Just $ c Nothing-	getdivisor sn = do-		n <- readish sn-		if n > 0-			then Just n-			else Nothing--fromScheduledTime :: ScheduledTime -> String-fromScheduledTime AnyTime = "any time"-fromScheduledTime (SpecificTime h m) = -	show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm-  where-  	pad n s = take (n - length s) (repeat '0') ++ s-	(h', ampm)-		| h == 0 = (12, "AM")-		| h < 12 = (h, "AM")-		| h == 12 = (h, "PM")-		| otherwise = (h - 12, "PM")--toScheduledTime :: String -> Maybe ScheduledTime-toScheduledTime "any time" = Just AnyTime-toScheduledTime v = case words v of-	(s:ampm:[])-		| map toUpper ampm == "AM" ->-			go s h0-		| map toUpper ampm == "PM" ->-			go s (\h -> (h0 h) + 12)-		| otherwise -> Nothing-	(s:[]) -> go s id-	_ -> Nothing-  where-  	h0 h-		| h == 12 = 0-		| otherwise = h-  	go :: String -> (Int -> Int) -> Maybe ScheduledTime-	go s adjust =-		let (h, m) = separate (== ':') s-		in SpecificTime-			<$> (adjust <$> readish h)-			<*> if null m then Just 0 else readish m--fromSchedule :: Schedule -> String-fromSchedule (Schedule recurrance scheduledtime) = unwords-	[ fromRecurrance recurrance-	, "at"-	, fromScheduledTime scheduledtime-	]--toSchedule :: String -> Maybe Schedule-toSchedule = eitherToMaybe . parseSchedule--parseSchedule :: String -> Either String Schedule-parseSchedule s = do-	r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right-		(toRecurrance recurrance)-	t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right-		(toScheduledTime scheduledtime)-	Right $ Schedule r t-  where-	(rws, tws) = separate (== "at") (words s)-	recurrance = unwords rws-	scheduledtime = unwords tws--instance Arbitrary Schedule where-	arbitrary = Schedule <$> arbitrary <*> arbitrary--instance Arbitrary ScheduledTime where-	arbitrary = oneof-		[ pure AnyTime-		, SpecificTime -			<$> choose (0, 23)-			<*> choose (1, 59)-		]--instance Arbitrary Recurrance where-	arbitrary = oneof-		[ pure Daily-		, Weekly <$> arbday-		, Monthly <$> arbday-		, Yearly <$> arbday-		, Divisible-			<$> positive arbitrary-			<*> oneof -- no nested Divisibles-				[ pure Daily-				, Weekly <$> arbday-				, Monthly <$> arbday-				, Yearly <$> arbday-				]-		]-	  where-	  	arbday = oneof-			[ Just <$> nonNegative arbitrary-			, pure Nothing-			]--prop_schedule_roundtrips :: Schedule -> Bool-prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s--prop_past_sane :: Bool-prop_past_sane = and-	[ all (checksout oneMonthPast) (mplus1 ++ yplus1)-	, all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))-	, all (checksout oneYearPast) yplus1-	, all (not . (checksout oneYearPast)) (map swap yplus1)-	]-  where-	mplus1 =   -- new date               old date, 1+ months before it-		[ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)-		, (fromGregorian 2014 01 15, fromGregorian 2013 02 15)-		, (fromGregorian 2014 02 15, fromGregorian 2013 01 15)-		, (fromGregorian 2014 03 01, fromGregorian 2013 01 15)-		, (fromGregorian 2014 03 01, fromGregorian 2013 12 15)-		, (fromGregorian 2015 01 01, fromGregorian 2010 01 01)-		]-	yplus1 =   -- new date               old date, 1+ years before it-		[ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)-		, (fromGregorian 2014 01 15, fromGregorian 2013 01 14)-		, (fromGregorian 2022 12 31, fromGregorian 2000 01 01)-		]-	checksout cmp (new, old) = new `cmp` old-	swap (a,b) = (b,a)
− Utility/ThreadScheduler.hs 
@@ -1,73 +0,0 @@-{- thread scheduling- -- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>- - Copyright 2011 Bas van Dijk & Roel van Dijk- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE CPP #-}--module Utility.ThreadScheduler where--import Control.Monad-import Control.Monad.IfElse-import System.Posix.IO-import Control.Concurrent-#ifndef mingw32_HOST_OS-import System.Posix.Signals-#ifndef __ANDROID__-import System.Posix.Terminal-#endif-#endif--newtype Seconds = Seconds { fromSeconds :: Int }-	deriving (Eq, Ord, Show)--type Microseconds = Integer--{- Runs an action repeatedly forever, sleeping at least the specified number- - of seconds in between. -}-runEvery :: Seconds -> IO a -> IO a-runEvery n a = forever $ do-	threadDelaySeconds n-	a--threadDelaySeconds :: Seconds -> IO ()-threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)--{- Like threadDelay, but not bounded by an Int.- -- - There is no guarantee that the thread will be rescheduled promptly when the- - delay has expired, but the thread will never continue to run earlier than- - specified.- - - - Taken from the unbounded-delay package to avoid a dependency for 4 lines- - of code.- -}-unboundDelay :: Microseconds -> IO ()-unboundDelay time = do-	let maxWait = min time $ toInteger (maxBound :: Int)-	threadDelay $ fromInteger maxWait-	when (maxWait /= time) $ unboundDelay (time - maxWait)--{- Pauses the main thread, letting children run until program termination. -}-waitForTermination :: IO ()-waitForTermination = do-#ifdef mingw32_HOST_OS-	runEvery (Seconds 600) $-		void getLine-#else-	lock <- newEmptyMVar-	let check sig = void $-		installHandler sig (CatchOnce $ putMVar lock ()) Nothing-	check softwareTermination-#ifndef __ANDROID__-	whenM (queryTerminal stdInput) $-		check keyboardSignal-#endif-	takeMVar lock-#endif--oneSecond :: Microseconds-oneSecond = 1000000
− Utility/Tmp.hs 
@@ -1,100 +0,0 @@-{- 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
− Utility/UserInfo.hs 
@@ -1,55 +0,0 @@-{- user info- -- - Copyright 2012 Joey Hess <joey@kitenet.net>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE CPP #-}--module Utility.UserInfo (-	myHomeDir,-	myUserName,-	myUserGecos,-) where--import Control.Applicative-import System.PosixCompat--import Utility.Env--{- Current user's home directory.- -- - getpwent will fail on LDAP or NIS, so use HOME if set. -}-myHomeDir :: IO FilePath-myHomeDir = myVal env homeDirectory-  where-#ifndef mingw32_HOST_OS-	env = ["HOME"]-#else-	env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin-#endif--{- Current user's user name. -}-myUserName :: IO String-myUserName = myVal env userName-  where-#ifndef mingw32_HOST_OS-	env = ["USER", "LOGNAME"]-#else-	env = ["USERNAME", "USER", "LOGNAME"]-#endif--myUserGecos :: IO String-#ifdef __ANDROID__-myUserGecos = return "" -- userGecos crashes on Android-#else-myUserGecos = myVal [] userGecos-#endif--myVal :: [String] -> (UserEntry -> String) -> IO String-myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars-  where-	check [] = return Nothing-	check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v-	getpwent = getUserEntryForID =<< getEffectiveUserID
config-joey.hs view
@@ -1,4 +1,5 @@ -- This is the live config file used by propellor's author.+module Main where  import Propellor import Propellor.CmdLine@@ -19,32 +20,33 @@ import qualified Propellor.Property.Git as Git import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix+import qualified Propellor.Property.Service as Service+import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean+import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.SiteSpecific.GitHome as GitHome import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites -main :: IO ()-main = defaultMain hosts --                      --     _         ______`|                          ,-.__ - {- Propellor          --  /   \___-=O`/|O`/__|                         (____.'-    Deployed -}         -- \          / | /    )             _.-"-._-                        --  `/-==__ _/__|/__=-|             (       \_-hosts :: [Host]        --   *             \ | |              '--------'-hosts =               --                  (o)  `+main :: IO ()           --     _         ______`|                       ,-.__ +main = defaultMain hosts --  /   \___-=O`/|O`/__|                      (____.'+  {- Propellor            -- \          / | /    )          _.-"-._+     Deployed -}          --  `/-==__ _/__|/__=-|          (       \_+hosts :: [Host]          --   *             \ | |           '--------'+hosts =                 --                  (o)  ` 	-- My laptop 	[ host "darkstar.kitenet.net" 		& ipv6 "2001:4830:1600:187::2" -- sixxs tunnel 		& Docker.configured 		& Apt.buildDep ["git-annex"] `period` Daily+		& Docker.docked hosts "android-git-annex"  	-- Nothing super-important lives here. 	, standardSystem "clam.kitenet.net" Unstable "amd64" 		& ipv4 "162.248.143.249" 		& ipv6 "2002:5044:5531::1" -		& cleanCloudAtCost+		& CloudAtCost.decruft 		& Apt.unattendedUpgrades 		& Network.ipv6to4 		& Tor.isBridge@@ -56,7 +58,7 @@  		& alias "openid.kitenet.net" 		& Docker.docked hosts "openid-provider"-		 	`requires` Apt.installed ["ntp"]+		 	`requires` Apt.serviceInstalledRunning "ntp"  		& alias "ancient.kitenet.net" 		& Docker.docked hosts "ancient-kitenet"@@ -70,7 +72,15 @@ 		 		& alias "ns9.kitenet.net" 		& myDnsSecondary+		+		& alias "znc.kitenet.net"+		& JoeySites.ircBouncer +		-- Nothing is using https on clam, so listen on that port+		-- for ssh, for traveling on bad networks.+		& "/etc/ssh/sshd_config" `File.containsLine` "Port 443"+			`onChange` Service.restarted "ssh"+ 		& Docker.garbageCollected `period` Daily 		& Apt.installed ["git-annex", "mtr", "screen"] 	@@ -84,8 +94,9 @@ 		& Docker.configured 		& Docker.docked hosts "amd64-git-annex-builder" 		& Docker.docked hosts "i386-git-annex-builder"-		! Docker.docked hosts "armel-git-annex-builder-companion"-		! Docker.docked hosts "armel-git-annex-builder"+		& Docker.docked hosts "armel-git-annex-builder-companion"+		& Docker.docked hosts "armel-git-annex-builder"+		& Docker.docked hosts "android-git-annex-builder" 		& Docker.garbageCollected `period` Daily 		& Apt.buildDep ["git-annex"] `period` Daily 	@@ -93,6 +104,7 @@   	, standardSystem "diatom.kitenet.net" Stable "amd64" 		& ipv4 "107.170.31.195" +		& DigitalOcean.distroKernel 		& Hostname.sane 		& Ssh.hostKey SshDsa 		& Ssh.hostKey SshRsa@@ -179,29 +191,18 @@ 			(Just "remotes/origin/old-kitenet.net") 	 	-- git-annex autobuilder containers-	, gitAnnexBuilder "amd64" 15-	, gitAnnexBuilder "i386" 45-	-- armel builder has a companion container that run amd64 and-	-- runs the build first to get TH splices. They share a home-	-- directory, and need to have the same versions of all haskell-	-- libraries installed.-	, Docker.container "armel-git-annex-builder-companion"-		(image $ System (Debian Unstable) "amd64")-		& Docker.volume GitAnnexBuilder.homedir-		& Apt.unattendedUpgrades-	, Docker.container "armel-git-annex-builder"-		(image $ System (Debian Unstable) "armel")-		& Docker.link "armel-git-annex-builder-companion" "companion"-		& Docker.volumes_from "armel-git-annex-builder-companion"---		& GitAnnexBuilder.builder "armel" "15 * * * *" True-		& Apt.unattendedUpgrades-	] ++ monsters+	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "amd64" 15 "2h"+	, GitAnnexBuilder.standardAutoBuilderContainer dockerImage "i386" 45 "2h"+	, GitAnnexBuilder.armelCompanionContainer dockerImage+	, GitAnnexBuilder.armelAutoBuilderContainer dockerImage "1 3 * * *" "5h"+	, GitAnnexBuilder.androidAutoBuilderContainer dockerImage "1 1 * * *" "3h" -gitAnnexBuilder :: Architecture -> Int -> Host-gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")-	(image $ System (Debian Unstable) arch)-	& GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True-	& Apt.unattendedUpgrades+	-- for development of git-annex for android, using my git-annex+	-- work tree+	, let gitannexdir = GitAnnexBuilder.homedir </> "git-annex"+	  in GitAnnexBuilder.androidContainer dockerImage "android-git-annex" doNothing gitannexdir+		& Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir)+	] ++ monsters  -- This is my standard system setup. standardSystem :: HostName -> DebianSuite -> Architecture -> Host@@ -229,7 +230,7 @@  -- This is my standard container setup, featuring automatic upgrades. standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host-standardContainer name suite arch = Docker.container name (image system)+standardContainer name suite arch = Docker.container name (dockerImage system) 	& os (System (Debian suite) arch) 	& Apt.stdSourcesList suite 	& Apt.unattendedUpgrades@@ -237,26 +238,10 @@ 	system = System (Debian suite) arch  -- Docker images I prefer to use.-image :: System -> Docker.Image-image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch-image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch-image _ = "debian-stable-official" -- does not currently exist!---- Clean up a system as installed by cloudatcost.com-cleanCloudAtCost :: Property-cleanCloudAtCost = propertyList "cloudatcost cleanup"-	[ Hostname.sane-	, Ssh.randomHostKeys-	, "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"]-	, combineProperties "nuked cloudatcost cruft"-		[ File.notPresent "/etc/rc.local"-		, File.notPresent "/etc/init.d/S97-setup.sh"-		, User.nuked "user" User.YesReallyDeleteHome-		]-	]+dockerImage :: System -> Docker.Image+dockerImage (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch+dockerImage (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch+dockerImage _ = "debian-stable-official" -- does not currently exist!  myDnsSecondary :: Property myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp@@ -321,8 +306,8 @@ 		& alias "wortroot.kitenet.net" 		& alias "www.wortroot.kitenet.net" 		& alias "joey.kitenet.net"-		& alias "annex.kitenet.net" 		& alias "ipv6.kitenet.net"+		& alias "bitlbee.kitenet.net" 	, host "mouse.kitenet.net" 		& ipv6 "2001:4830:1600:492::2" 	, host "beaver.kitenet.net"
− config.hs 
@@ -1,46 +0,0 @@--- This is the main configuration file for Propellor, and is used to build--- the propellor program.--import Propellor-import Propellor.CmdLine-import Propellor.Property.Scheduled-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.Cron as Cron---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--main :: IO ()-main = defaultMain hosts---- The hosts propellor knows about.--- Edit this to configure propellor!-hosts :: [Host]-hosts =-	[ host "mybox.example.com"-		& Apt.stdSourcesList Unstable-		& Apt.unattendedUpgrades-		& Apt.installed ["etckeeper"]-		& Apt.installed ["ssh"]-		& User.hasSomePassword "root"-		& Network.ipv6to4-		& File.dirExists "/var/www"-		& Docker.docked hosts "webserver"-		& Docker.garbageCollected `period` Daily-		& Cron.runPropellor "30 * * * *"--	-- A generic webserver in a Docker container.-	, Docker.container "webserver" "joeyh/debian-unstable"-		& Docker.publish "80:80"-		& Docker.volume "/var/www:/var/www"-		& Apt.serviceInstalledRunning "apache2"--	-- add more hosts here...-	--, host "foo.example.com" = ...-	]
debian/changelog view
@@ -1,3 +1,24 @@+propellor (0.5.3) unstable; urgency=medium++  * Fix unattended-upgrades config for !stable.+  * Ensure that kernel hostname is same as /etc/hostname when configuring+    hostname.+  * Added modules for some hosting providers (DigitalOcean, CloudAtCost).++ -- Joey Hess <joeyh@debian.org>  Thu, 29 May 2014 14:29:53 -0400++propellor (0.5.2) unstable; urgency=medium++  * A bug that caused propellor to hang when updating a running docker+    container appears to have been fixed. Note that since it affects+    the propellor process that serves as "init" of docker containers,+    they have to be restarted for the fix to take effect.+  * Licence changed from GPL to BSD.+  * A few changes to allow building Propellor on OSX. One user reports+    successfully using it there.++ -- Joey Hess <joeyh@debian.org>  Sat, 17 May 2014 16:42:55 -0400+ propellor (0.5.1) unstable; urgency=medium    * Primary DNS servers now have allow-transfer automatically populated
debian/copyright view
@@ -3,9 +3,26 @@  Files: * Copyright: © 2010-2014 Joey Hess <joey@kitenet.net>-License: GPL-3++License: BSD-2-clause -License: GPL-3+- The full text of version 3 of the GPL is distributed as GPL in- this package's source, or in /usr/share/common-licenses/GPL-3 on- Debian systems.+License: BSD-2-clause+ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:+ 1. Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+ 2. Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.+ .+ THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ SUCH DAMAGE.
debian/lintian-overrides view
@@ -1,3 +1,2 @@ # These files are used in a git repository that propellor sets up. propellor: package-contains-vcs-control-file usr/src/propellor/.gitignore-propellor: extra-license-file usr/src/propellor/GPL
doc/README.mdwn view
@@ -6,7 +6,8 @@ Propellor is configured via a git repository, which typically lives in `~/.propellor/` on your development machine. Propellor clones the repository to each host it manages, in a -[secure](http://propellor.branchable.com/security/) way.+[secure](http://propellor.branchable.com/security/) way. The git repository+contains the full source code to Propellor, along with its config file.  Properties are defined using Haskell. Edit `~/.propellor/config.hs` to get started. There is fairly complete @@ -40,11 +41,12 @@      `apt-get install propellor` 2. Run propellor for the first time. It will set up a `~/.propellor/` git    repository for you.-3. `cd ~/.propellor/`; use git to push the repository to a central+3. If you don't have a gpg private key already, generate one: `gpg --gen-key`+4. Run: `propellor --add-key $KEYID`, which will make propellor trust+   your gpg key, and will sign your `~/.propellor` repository using it.+5. `cd ~/.propellor/`; use git to push the repository to a central    server (github, or your own git server). Configure that central    server as the origin remote of the repository.-4. If you don't have a gpg private key, generate one: `gpg --gen-key`-5. Run: `propellor --add-key $KEYID` 6. Edit `~/.propellor/config.hs`, and add a host you want to manage.    You can start by not adding any properties, or only a few. 7. Pick a host and run: `propellor --spin $HOST`
propellor.cabal view
@@ -1,12 +1,12 @@ Name: propellor-Version: 0.5.1+Version: 0.5.3 Cabal-Version: >= 1.6-License: GPL+License: BSD3 Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess Stability: Stable Copyright: 2014 Joey Hess-License-File: GPL+License-File: LICENSE Build-Type: Simple Homepage: https://propellor.branchable.com/ Category: Utility@@ -33,9 +33,10 @@  .  It is configured using haskell. -Executable propellor-  Main-Is: propellor.hs+Executable wrapper+  Main-Is: wrapper.hs   GHC-Options: -Wall -threaded+  Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,     IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,    containers, network, async, time, QuickCheck, mtl,@@ -47,6 +48,7 @@ Executable config   Main-Is: config.hs   GHC-Options: -Wall -threaded+  Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,     IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,    containers, network, async, time, QuickCheck, mtl,@@ -57,6 +59,7 @@  Library   GHC-Options: -Wall+  Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,     IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,    containers, network, async, time, QuickCheck, mtl,@@ -89,6 +92,8 @@     Propellor.Property.Sudo     Propellor.Property.Tor     Propellor.Property.User+    Propellor.Property.HostingProvider.DigitalOcean+    Propellor.Property.HostingProvider.CloudAtCost     Propellor.Property.SiteSpecific.GitHome     Propellor.Property.SiteSpecific.JoeySites     Propellor.Property.SiteSpecific.GitAnnexBuilder
− propellor.hs 
@@ -1,91 +0,0 @@--- | Wrapper program for propellor distribution.------ Distributions should install this program into PATH.--- (Cabal builds it as dict/build/propellor.------ This is not the propellor main program (that's config.hs)------ This installs propellor's source into ~/.propellor,--- uses it to build the real propellor program (if not already built),--- and runs it.--- --- The source is either copied from /usr/src/propellor, or is cloned from--- git over the network.--import Utility.UserInfo-import Utility.Monad-import Utility.Process-import Utility.SafeCommand-import Utility.Directory--import Control.Monad-import Control.Monad.IfElse-import System.Directory-import System.FilePath-import System.Environment (getArgs)-import System.Exit-import System.Posix.Directory--srcdir :: FilePath-srcdir = "/usr/src/propellor"---- Using the github mirror of the main propellor repo because--- it is accessible over https for better security.-srcrepo :: String-srcrepo = "https://github.com/joeyh/propellor.git"--main :: IO ()-main = do-	args <- getArgs-	home <- myHomeDir-	let propellordir = home </> ".propellor"-	let propellorbin = propellordir </> "propellor"-	wrapper args propellordir propellorbin--wrapper :: [String] -> FilePath -> FilePath -> IO ()-wrapper args propellordir propellorbin = do-	unlessM (doesDirectoryExist propellordir) $-		makeRepo-	buildruncfg-  where-	chain = do-		(_, _, _, pid) <- createProcess (proc propellorbin args) -		exitWith =<< waitForProcess pid-	makeRepo = do-		putStrLn $ "Setting up your propellor repo in " ++ propellordir-		putStrLn ""-		ifM (doesDirectoryExist srcdir)-			( do-				void $ boolSystem "cp" [Param "-a", File srcdir, File propellordir]-				changeWorkingDirectory propellordir-				void $ boolSystem "git" [Param "init"]-				void $ boolSystem "git" [Param "add", Param "."]-				setuprepo True-			, do-				void $ boolSystem "git" [Param "clone", Param srcrepo, File propellordir] -				void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"]-				setuprepo False-			)-	setuprepo fromsrcdir = do-		changeWorkingDirectory propellordir-		whenM (doesDirectoryExist "privdata") $-			mapM_ nukeFile =<< dirContents "privdata"-		void $ boolSystem "git" [Param "commit", Param "--allow-empty", Param "--quiet", Param "-m", Param "setting up propellor git repository"]-		void $ boolSystem "git" [Param "remote", Param "add", Param "upstream", Param srcrepo]-		-- Connect synthetic git repo with upstream history so-		-- merging with upstream will work going forward.-		-- Note -s ours is used to avoid getting any divergent-		-- changes from upstream.-		when fromsrcdir $ do-			void $ boolSystem "git" [Param "fetch", Param "upstream"]-			version <- readProcess "dpkg-query" ["--showformat", "${Version}", "--show", "propellor"]-			void $ boolSystem "git" [Param "merge", Param "-s", Param "ours", Param version]-	buildruncfg = do-		changeWorkingDirectory propellordir-		ifM (boolSystem "make" [Param "build"])-			( do-				putStrLn ""-				putStrLn ""-				chain-			, error "Propellor build failed."-			)
+ src/Propellor.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE PackageImports #-}++-- | Pulls in lots of useful modules for building and using Properties.+-- +-- When propellor runs on a Host, it ensures that its list of Properties+-- is satisfied, taking action as necessary when a Property is not+-- currently satisfied.+--+-- A simple propellor program example:+--+-- > import Propellor+-- > import Propellor.CmdLine+-- > import qualified Propellor.Property.File as File+-- > import qualified Propellor.Property.Apt as Apt+-- > +-- > main :: IO ()+-- > main = defaultMain hosts+-- > +-- > hosts :: [Host]+-- > hosts =+-- >   [ host "example.com"+-- >     & Apt.installed ["mydaemon"]+-- >     & "/etc/mydaemon.conf" `File.containsLine` "secure=1"+-- >       `onChange` cmdProperty "service" ["mydaemon", "restart"]+-- >     ! Apt.installed ["unwantedpackage"]+-- >   ]+--+-- See config.hs for a more complete example, and clone Propellor's+-- git repository for a deployable system using Propellor:+-- git clone <git://git.kitenet.net/propellor>++module Propellor (+	  module Propellor.Types+	, module Propellor.Property+	, module Propellor.Property.Cmd+	, module Propellor.Attr+	, module Propellor.PrivData+	, module Propellor.Engine+	, module Propellor.Exception+	, module Propellor.Message+	, localdir++	, module X+) where++import Propellor.Types+import Propellor.Property+import Propellor.Engine+import Propellor.Property.Cmd+import Propellor.PrivData+import Propellor.Message+import Propellor.Exception+import Propellor.Attr++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+import Data.Monoid as X+import Control.Monad.IfElse as X+import "mtl" Control.Monad.Reader as X++-- | This is where propellor installs itself when deploying a host.+localdir :: FilePath+localdir = "/usr/local/propellor"
+ src/Propellor/Attr.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE PackageImports #-}++module Propellor.Attr where++import Propellor.Types+import Propellor.Types.Attr++import "mtl" Control.Monad.Reader+import qualified Data.Set as S+import qualified Data.Map as M+import Data.Maybe+import Control.Applicative++pureAttrProperty :: Desc -> SetAttr -> Property +pureAttrProperty desc = Property ("has " ++ desc) (return NoChange)++hostname :: HostName -> Property+hostname name = pureAttrProperty ("hostname " ++ name) $+	\d -> d { _hostname = name }++getHostName :: Propellor HostName+getHostName = asks _hostname++os :: System -> Property+os system = pureAttrProperty ("Operating " ++ show system) $+	\d -> d { _os = Just system }++getOS :: Propellor (Maybe System)+getOS = asks _os++-- | Indidate that a host has an A record in the DNS.+--+-- TODO check at run time if the host really has this address.+-- (Can't change the host's address, but as a sanity check.)+ipv4 :: String -> Property+ipv4 addr = pureAttrProperty ("ipv4 " ++ addr)+	(addDNS $ Address $ IPv4 addr)++-- | Indidate that a host has an AAAA record in the DNS.+ipv6 :: String -> Property+ipv6 addr = pureAttrProperty ("ipv6 " ++ addr)+	(addDNS $ Address $ IPv6 addr)++-- | Indicates another name for the host in the DNS.+alias :: Domain -> Property+alias domain = pureAttrProperty ("alias " ++ domain)+	(addDNS $ CNAME $ AbsDomain domain)++addDNS :: Record -> SetAttr+addDNS record d = d { _dns = S.insert record (_dns d) }++-- | Adds a DNS NamedConf stanza.+--+-- Note that adding a Master stanza for a domain always overrides an+-- existing Secondary stanza, while a Secondary stanza is only added+-- when there is no existing Master stanza.+addNamedConf :: NamedConf -> SetAttr+addNamedConf conf d = d { _namedconf = new }+  where+	m = _namedconf d+	domain = confDomain conf+	new = case (confDnsServerType conf, confDnsServerType <$> M.lookup domain m) of+		(Secondary, Just Master) -> m+		_  -> M.insert domain conf m++getNamedConf :: Propellor (M.Map Domain NamedConf)+getNamedConf = asks _namedconf++sshPubKey :: String -> Property+sshPubKey k = pureAttrProperty ("ssh pubkey known") $+	\d -> d { _sshPubKey = Just k }++getSshPubKey :: Propellor (Maybe String)+getSshPubKey = asks _sshPubKey++hostnameless :: Attr+hostnameless = newAttr (error "hostname Attr not specified")++hostAttr :: Host -> Attr+hostAttr (Host _ mkattrs) = mkattrs hostnameless++hostProperties :: Host -> [Property]+hostProperties (Host ps _) = ps++hostMap :: [Host] -> M.Map HostName Host+hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l ++hostAttrMap :: [Host] -> M.Map HostName Attr+hostAttrMap l = M.fromList $ zip (map _hostname attrs) attrs+  where+	attrs = map hostAttr l++findHost :: [Host] -> HostName -> Maybe Host+findHost l hn = M.lookup hn (hostMap l)++getAddresses :: Attr -> [IPAddr]+getAddresses = mapMaybe getIPAddr . S.toList . _dns++hostAddresses :: HostName -> [Host] -> [IPAddr]+hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of+	Nothing -> []+	Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr++-- | Lifts an action into a different host.+--+-- For example, `fromHost hosts "otherhost" getSshPubKey`+fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)+fromHost l hn getter = case findHost l hn of+	Nothing -> return Nothing+	Just h -> liftIO $ Just <$>+		runReaderT (runWithAttr getter) (hostAttr h)
+ src/Propellor/CmdLine.hs view
@@ -0,0 +1,392 @@+module Propellor.CmdLine where++import System.Environment (getArgs)+import Data.List+import System.Exit+import System.Log.Logger+import System.Log.Formatter+import System.Log.Handler (setFormatter, LogHandler)+import System.Log.Handler.Simple+import System.PosixCompat+import Control.Exception (bracket)+import System.Posix.IO+import Data.Time.Clock.POSIX++import Propellor+import qualified Propellor.Property.Docker as Docker+import qualified Propellor.Property.Docker.Shim as DockerShim+import Utility.FileMode+import Utility.SafeCommand+import Utility.UserInfo++usage :: IO a+usage = do+	putStrLn $ unlines +		[ "Usage:"+		, "  propellor"+		, "  propellor hostname"+		, "  propellor --spin hostname"+		, "  propellor --set hostname field"+		, "  propellor --add-key keyid"+		]+	exitFailure++processCmdLine :: IO CmdLine+processCmdLine = go =<< getArgs+  where+  	go ("--help":_) = usage+  	go ("--spin":h:[]) = return $ Spin h+  	go ("--boot":h:[]) = return $ Boot h+	go ("--add-key":k:[]) = return $ AddKey k+	go ("--set":h:f:[]) = case readish f of+		Just pf -> return $ Set h pf+		Nothing -> errorMessage $ "Unknown privdata field " ++ f+	go ("--continue":s:[]) = case readish s of+		Just cmdline -> return $ Continue cmdline+		Nothing -> errorMessage "--continue serialization failure"+  	go ("--chain":h:[]) = return $ Chain h+	go ("--docker":h:[]) = return $ Docker h+	go (h:[])+		| "--" `isPrefixOf` h = usage+		| otherwise = return $ Run h+	go [] = do+		s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]+		if null s+			then errorMessage "Cannot determine hostname! Pass it on the command line."+			else return $ Run s+	go _ = usage++defaultMain :: [Host] -> IO ()+defaultMain hostlist = do+	DockerShim.cleanEnv+	checkDebugMode+	cmdline <- processCmdLine+	debug ["command line: ", show cmdline]+	go True cmdline+  where+	go _ (Continue cmdline) = go False cmdline+	go _ (Set hn field) = setPrivData hn field+	go _ (AddKey keyid) = addKey keyid+	go _ (Chain hn) = withprops hn $ \attr ps -> do+		r <- runPropellor attr $ ensureProperties ps+		putStrLn $ "\n" ++ show r+	go _ (Docker hn) = Docker.chain hn+	go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline+	go True cmdline = updateFirst cmdline $ go False cmdline+	go False (Spin hn) = withprops hn $ const . const $ spin hn+	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)+		( onlyProcess $ withprops hn mainProperties+		, go True (Spin hn)+		)+	go False (Boot hn) = onlyProcess $ withprops hn boot++	withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()+	withprops hn a = maybe+		(unknownhost hn)+		(\h -> a (hostAttr h) (hostProperties h))+		(findHost hostlist hn)++onlyProcess :: IO a -> IO a+onlyProcess a = bracket lock unlock (const a)+  where+	lock = do+		l <- createFile lockfile stdFileMode+		setLock l (WriteLock, AbsoluteSeek, 0, 0)+			`catchIO` const alreadyrunning+		return l+	unlock = closeFd+	alreadyrunning = error "Propellor is already running on this host!"+	lockfile = localdir </> ".lock"++unknownhost :: HostName -> IO a+unknownhost h = errorMessage $ unlines+	[ "Propellor does not know about host: " ++ h+	, "(Perhaps you should specify the real hostname on the command line?)"+	, "(Or, edit propellor's config.hs to configure this host)"+	]++buildFirst :: CmdLine -> IO () -> IO ()+buildFirst cmdline next = do+	oldtime <- getmtime+	ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])+		( do+			newtime <- getmtime+			if newtime == oldtime+				then next+				else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]+		, errorMessage "Propellor build failed!" +		)+  where+	getmtime = catchMaybeIO $ getModificationTime "propellor"++getCurrentBranch :: IO String+getCurrentBranch = takeWhile (/= '\n') +	<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]++updateFirst :: CmdLine -> IO () -> IO ()+updateFirst cmdline next = do+	branchref <- getCurrentBranch+	let originbranch = "origin" </> branchref++	void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]+	+	whenM (doesFileExist keyring) $ do+		{- To verify origin branch commit's signature, have to+		 - convince gpg to use our keyring. While running git log.+		 - Which has no way to pass options to gpg.+		 - Argh! -}+		let gpgconf = privDataDir </> "gpg.conf"+		writeFile gpgconf $ unlines+			[ " keyring " ++ keyring+			, "no-auto-check-trustdb"+			]+		-- gpg is picky about perms+		modifyFileMode privDataDir (removeModes otherGroupModes)+		s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]+			(Just [("GNUPGHOME", privDataDir)])+		nukeFile $ privDataDir </> "trustdb.gpg"+		nukeFile $ privDataDir </> "pubring.gpg"+		nukeFile $ privDataDir </> "gpg.conf"+		if s == "U\n" || s == "G\n"+			then do+				putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"+				hFlush stdout+			else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"+	+	oldsha <- getCurrentGitSha1 branchref+	void $ boolSystem "git" [Param "merge", Param originbranch]+	newsha <- getCurrentGitSha1 branchref++	if oldsha == newsha+		then next+		else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])+			( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]+			, errorMessage "Propellor build failed!" +			)++getCurrentGitSha1 :: String -> IO String+getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]++spin :: HostName -> IO ()+spin hn = do+	url <- getUrl+	void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]+	void $ boolSystem "git" [Param "push"]+	cacheparams <- toCommand <$> sshCachingParams hn+	go cacheparams url =<< gpgDecrypt (privDataFile hn)+  where+	go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do+		let finish = do+			senddata toh (privDataFile hn) privDataMarker privdata+			hClose toh+			+			-- Display remaining output.+			void $ tryIO $ forever $+				showremote =<< hGetLine fromh+			hClose fromh+		status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")+		case status of+			Ready -> finish+			NeedGitClone -> do+				hClose toh+				hClose fromh+				sendGitClone hn url+				go cacheparams url privdata+	+	user = "root@"++hn++	bootstrapcmd = shellWrap $ intercalate " ; "+		[ "if [ ! -d " ++ localdir ++ " ]"+		, "then " ++ intercalate " && "+			[ "apt-get --no-install-recommends --no-upgrade -y install git make"+			, "echo " ++ toMarked statusMarker (show NeedGitClone)+			]+		, "else " ++ intercalate " && "+			[ "cd " ++ localdir+			, "if ! test -x ./propellor; then make deps build; fi"+			, "./propellor --boot " ++ hn+			]+		, "fi"+		]++	getstatus :: Handle -> IO BootStrapStatus+	getstatus h = do+		l <- hGetLine h+		case readish =<< fromMarked statusMarker l of+			Nothing -> do+				showremote l+				getstatus h+			Just status -> return status+	+	showremote s = putStrLn s+	senddata toh f marker s = void $+		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do+			sendMarked toh marker s+			return True++sendGitClone :: HostName -> String -> IO ()+sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do+	branch <- getCurrentBranch+	cacheparams <- sshCachingParams hn+	withTmpFile "propellor.git" $ \tmp _ -> allM id+		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]+		]+  where+	remotebundle = "/usr/local/propellor.git"+	unpackcmd branch = shellWrap $ intercalate " && "+		[ "git clone " ++ remotebundle ++ " " ++ localdir+		, "cd " ++ localdir+		, "git checkout -b " ++ branch+		, "git remote rm origin"+		, "rm -f " ++ remotebundle+		, "git remote add origin " ++ url+		-- same as --set-upstream-to, except origin branch+		-- has not been pulled yet+		, "git config branch."++branch++".remote origin"+		, "git config branch."++branch++".merge refs/heads/"++branch+		]++data BootStrapStatus = Ready | NeedGitClone+	deriving (Read, Show, Eq)++type Marker = String+type Marked = String++statusMarker :: Marker+statusMarker = "STATUS"++privDataMarker :: String+privDataMarker = "PRIVDATA "++toMarked :: Marker -> String -> String+toMarked marker = intercalate "\n" . map (marker ++) . lines++sendMarked :: Handle -> Marker -> String -> IO ()+sendMarked h marker s = do+	-- Prefix string with newline because sometimes a+	-- incomplete line is output.+	hPutStrLn h ("\n" ++ toMarked marker s)+	hFlush h++fromMarked :: Marker -> Marked -> Maybe String+fromMarked marker s+	| null matches = Nothing+	| otherwise = Just $ intercalate "\n" $+		map (drop len) matches+  where+	len = length marker+	matches = filter (marker `isPrefixOf`) $ lines s++boot :: Attr -> [Property] -> IO ()+boot attr ps = do+	sendMarked stdout statusMarker $ show Ready+	reply <- hGetContentsStrict stdin++	makePrivDataDir+	maybe noop (writeFileProtected privDataLocal) $+		fromMarked privDataMarker reply+	mainProperties attr ps++addKey :: String -> IO ()+addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ]+  where+	gpg = do+		createDirectoryIfMissing True privDataDir+		boolSystem "sh"+			[ Param "-c"+			, Param $ "gpg --export " ++ keyid ++ " | gpg " +++				unwords (gpgopts ++ ["--import"])+			]+	gitadd = boolSystem "git"+		[ Param "add"+		, File keyring+		]++	gitconfig = boolSystem "git"+		[ Param "config"+		, Param "user.signingkey"+		, Param keyid+		]++	gitcommit = gitCommit+		[ File keyring+		, Param "-m"+		, Param "propellor addkey"+		]++{- Automatically sign the commit if there'a a keyring. -}+gitCommit :: [CommandParam] -> IO Bool+gitCommit ps = do+	k <- doesFileExist keyring+	boolSystem "git" $ catMaybes $+		[ Just (Param "commit")+		, if k then Just (Param "--gpg-sign") else Nothing+		] ++ map Just ps++keyring :: FilePath+keyring = privDataDir </> "keyring.gpg"++gpgopts :: [String]+gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]++getUrl :: IO String+getUrl = maybe nourl return =<< getM get urls+  where+	urls = ["remote.deploy.url", "remote.origin.url"]+	nourl = errorMessage $ "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++checkDebugMode :: IO ()+checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"+  where+	go (Just s)+		| s == "1" = do+		f <- setFormatter+			<$> streamHandler stderr DEBUG+			<*> pure (simpleLogFormatter "[$time] $msg")+		updateGlobalLogger rootLoggerName $ +			setLevel DEBUG .  setHandlers [f]+	go _ = noop++-- Parameters can be passed to both ssh and scp, to enable a ssh connection+-- caching socket.+--+-- If the socket already exists, check if its mtime is older than 10+-- minutes, and if so stop that ssh process, in order to not try to+-- use an old stale connection. (atime would be nicer, but there's+-- a good chance a laptop uses noatime)+sshCachingParams :: HostName -> IO [CommandParam]+sshCachingParams hn = do+	home <- myHomeDir+	let cachedir = home </> ".ssh" </> "propellor"+	createDirectoryIfMissing False cachedir+	let socketfile = cachedir </> hn ++ ".sock"+	let ps = +		[ Param "-o", Param ("ControlPath=" ++ socketfile)+		, Params "-o ControlMaster=auto -o ControlPersist=yes"+		]++	maybe noop (expireold ps socketfile)+		=<< catchMaybeIO (getFileStatus socketfile)+	+	return ps+		+  where+	expireold ps f s = do+		now <- truncate <$> getPOSIXTime :: IO Integer+		if modificationTime s > fromIntegral now - tenminutes+			then touchFile f+			else do+				void $ boolSystem "ssh" $+					[ Params "-O stop" ] ++ ps +++					[ Param "localhost" ]+				nukeFile f+	tenminutes = 600
+ src/Propellor/Engine.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE PackageImports #-}++module Propellor.Engine where++import System.Exit+import System.IO+import Data.Monoid+import System.Console.ANSI+import "mtl" Control.Monad.Reader++import Propellor.Types+import Propellor.Message+import Propellor.Exception++runPropellor :: Attr -> Propellor a -> IO a+runPropellor attr a = runReaderT (runWithAttr a) attr++mainProperties :: Attr -> [Property] -> IO ()+mainProperties attr ps = do+	r <- runPropellor attr $+		ensureProperties [Property "overall" (ensureProperties ps) id]+	setTitle "propellor: done"+	hFlush stdout+	case r of+		FailedChange -> exitWith (ExitFailure 1)+		_ -> exitWith ExitSuccess++ensureProperties :: [Property] -> Propellor Result+ensureProperties ps = ensure ps NoChange+  where+	ensure [] rs = return rs+	ensure (l:ls) rs = do+		r <- actionMessage (propertyDesc l) (ensureProperty l)+		ensure ls (r <> rs)++ensureProperty :: Property -> Propellor Result+ensureProperty = catchPropellor . propertySatisfy
+ src/Propellor/Exception.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE PackageImports #-}++module Propellor.Exception where++import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M+import Control.Exception++import Propellor.Types+import Propellor.Message++-- | Catches IO exceptions and returns FailedChange.+catchPropellor :: Propellor Result -> Propellor Result+catchPropellor a = either err return =<< tryPropellor a+  where+	err e =  warningMessage (show e) >> return FailedChange++tryPropellor :: Propellor a -> Propellor (Either IOException a)+tryPropellor = M.try
+ src/Propellor/Message.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE PackageImports #-}++module Propellor.Message where++import System.Console.ANSI+import System.IO+import System.Log.Logger+import "mtl" Control.Monad.Reader++import Propellor.Types++-- | Shows a message while performing an action, with a colored status+-- display.+actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r+actionMessage desc a = do+	liftIO $ do+		setTitle $ "propellor: " ++ desc+		hFlush stdout++	r <- a++	liftIO $ do+		setTitle "propellor: running"+		let (msg, intensity, color) = getActionResult r+		putStr $ desc ++ " ... "+		colorLine intensity color msg+		hFlush stdout++	return r++warningMessage :: MonadIO m => String -> m ()+warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s++colorLine :: ColorIntensity -> Color -> String -> IO ()+colorLine intensity color msg = do+	setSGR [SetColor Foreground intensity color]+	putStr msg+	setSGR []+	-- Note this comes after the color is reset, so that+	-- the color set and reset happen in the same line.+	putStrLn ""+	hFlush stdout++errorMessage :: String -> IO a+errorMessage s = do+	liftIO $ colorLine Vivid Red $ "** error: " ++ s+	error "Cannot continue!"++-- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1+debug :: [String] -> IO ()+debug = debugM "propellor" . unwords
+ src/Propellor/PrivData.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE PackageImports #-}++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 Data.List+import Control.Monad+import "mtl" Control.Monad.Reader++import Propellor.Types+import Propellor.Attr+import Propellor.Message+import Utility.Monad+import Utility.PartialPrelude+import Utility.Exception+import Utility.Process+import Utility.Tmp+import Utility.SafeCommand+import Utility.Misc++-- | When the specified PrivDataField is available on the host Propellor+-- is provisioning, it provies the data to the action. Otherwise, it prints+-- a message to help the user make the necessary private data available.+withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result+withPrivData field a = maybe missing a =<< liftIO (getPrivData field)+  where+	missing = do+		host <- getHostName+		let host' = if ".docker" `isSuffixOf` host+			then "$parent_host"+			else host+		liftIO $ do+			warningMessage $ "Missing privdata " ++ show field+			putStrLn $ "Fix this by running: propellor --set "++host'++" '" ++ 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 <- chomp <$> 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]+  where+	chomp s+		| end s == "\n" = chomp (beginning s)+		| otherwise = s++makePrivDataDir :: IO ()+makePrivDataDir = createDirectoryIfMissing False privDataDir++privDataDir :: FilePath+privDataDir = "privdata"++privDataFile :: HostName -> FilePath+privDataFile host = privDataDir </> host ++ ".gpg"++privDataLocal :: FilePath+privDataLocal = privDataDir </> "local"++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
+ src/Propellor/Property.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE PackageImports #-}++module Propellor.Property where++import System.Directory+import Control.Monad+import Data.Monoid+import Data.List+import Control.Monad.IfElse+import "mtl" Control.Monad.Reader++import Propellor.Types+import Propellor.Types.Attr+import Propellor.Attr+import Propellor.Engine+import Utility.Monad+import System.FilePath++-- Constructs a Property.+property :: Desc -> Propellor Result -> Property+property d s = Property d s id++-- | 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) (combineSetAttrs ps)++-- | Combines a list of properties, resulting in one property that+-- ensures each in turn, stopping on failure.+combineProperties :: Desc -> [Property] -> Property+combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)+  where+  	go [] rs = return rs+	go (l:ls) rs = do+		r <- ensureProperty l+		case r of+			FailedChange -> return FailedChange+			_ -> go ls (r <> rs)++-- | Combines together two properties, resulting in one property+-- that ensures the first, and if the first succeeds, ensures the second.+-- The property uses the description of the first property.+before :: Property -> Property -> Property+p1 `before` p2 = p2 `requires` p1+	`describe` (propertyDesc p1)++-- | 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 p = flagFile' p . return++flagFile' :: Property -> IO FilePath -> Property+flagFile' p getflagfile = adjustProperty p $ \satisfy -> do+	flagfile <- liftIO getflagfile+	go satisfy flagfile =<< liftIO (doesFileExist flagfile)+  where+	go _ _ True = return NoChange+	go satisfy flagfile False = do+		r <- satisfy+		when (r == MadeChange) $ liftIO $ +			unlessM (doesFileExist flagfile) $ do+				createDirectoryIfMissing True (takeDirectory flagfile)+				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+p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)+  where+	satisfy = do+		r <- ensureProperty p+		case r of+			MadeChange -> do+				r' <- ensureProperty hook+				return $ r <> r'+			_ -> return r++(==>) :: Desc -> Property -> Property+(==>) = flip describe+infixl 1 ==>++-- | Makes a Property only need to do anything when a test succeeds.+check :: IO Bool -> Property -> Property+check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)+	( satisfy+	, return NoChange+	)++-- | Marks a Property as trivial. It can only return FailedChange or+-- NoChange. +--+-- Useful when it's just as expensive to check if a change needs+-- to be made as it is to just idempotently assure the property is+-- satisfied. For example, chmodding a file.+trivial :: Property -> Property+trivial p = adjustProperty p $ \satisfy -> do+	r <- satisfy+	if r == MadeChange+		then return NoChange+		else return r++doNothing :: Property+doNothing = property "noop property" noChange++-- | Makes a property that is satisfied differently depending on the host's+-- operating system. +--+-- Note that the operating system may not be declared for some hosts.+withOS :: Desc -> (Maybe System -> Propellor Result) -> Property+withOS desc a = property desc $ a =<< getOS++boolProperty :: Desc -> IO Bool -> Property+boolProperty desc a = property desc $ ifM (liftIO a)+	( return MadeChange+	, return FailedChange+	)++-- | Undoes the effect of a property.+revert :: RevertableProperty -> RevertableProperty+revert (RevertableProperty p1 p2) = RevertableProperty p2 p1++-- | Starts accumulating the properties of a Host.+--+-- > host "example.com"+-- > 	& someproperty+-- > 	! oldproperty+-- > 	& otherproperty+host :: HostName -> Host+host hn = Host [] (\_ -> newAttr hn)++-- | Adds a property to a Host+--+-- Can add Properties and RevertableProperties+(&) :: IsProp p => Host -> p -> Host+(Host ps as) & p = Host (ps ++ [toProp p]) (setAttr p . as)++infixl 1 &++-- | Adds a property to the Host in reverted form.+(!) :: Host -> RevertableProperty -> Host+(Host ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as)+  where+	q = revert p++infixl 1 !++-- Changes the action that is performed to satisfy a property. +adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property+adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }++-- Combines the Attr settings of two properties.+combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr+combineSetAttr p q = setAttr p . setAttr q++combineSetAttrs :: IsProp p => [p] -> SetAttr+combineSetAttrs = foldl' (.) id . map setAttr++makeChange :: IO () -> Propellor Result+makeChange a = liftIO a >> return MadeChange++noChange :: Propellor Result+noChange = return NoChange
+ src/Propellor/Property/Apache.hs view
@@ -0,0 +1,62 @@+module Propellor.Property.Apache where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service++type ConfigFile = [String]++siteEnabled :: HostName -> ConfigFile -> RevertableProperty+siteEnabled hn cf = RevertableProperty enable disable+  where+	enable = trivial $ cmdProperty "a2ensite" ["--quiet", hn]+		`describe` ("apache site enabled " ++ hn)+		`requires` siteAvailable hn cf+		`requires` installed+		`onChange` reloaded+	disable = trivial $ File.notPresent (siteCfg hn)+		`describe` ("apache site disabled " ++ hn)+		`onChange` cmdProperty "a2dissite" ["--quiet", hn]+		`requires` installed+		`onChange` reloaded++siteAvailable :: HostName -> ConfigFile -> Property+siteAvailable hn cf = siteCfg hn `File.hasContent` (comment:cf)+	`describe` ("apache site available " ++ hn)+  where+	comment = "# deployed with propellor, do not modify"++modEnabled :: String -> RevertableProperty+modEnabled modname = RevertableProperty enable disable+  where+	enable = trivial $ cmdProperty "a2enmod" ["--quiet", modname]+		`describe` ("apache module enabled " ++ modname)+		`requires` installed+		`onChange` reloaded+	disable = trivial $ cmdProperty "a2dismod" ["--quiet", modname]+		`describe` ("apache module disabled " ++ modname)+		`requires` installed+		`onChange` reloaded++siteCfg :: HostName -> FilePath+siteCfg hn = "/etc/apache2/sites-available/" ++ hn++installed :: Property+installed = Apt.installed ["apache2"]++restarted :: Property+restarted = cmdProperty "service" ["apache2", "restart"]++reloaded :: Property+reloaded = Service.reloaded "apache2"++-- | Configure apache to use SNI to differentiate between+-- https hosts.+multiSSL :: Property+multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`+	[ "NameVirtualHost *:443"+	, "SSLStrictSNIVHostCheck off"+	]+	`describe` "apache SNI enabled"+	`onChange` reloaded
+ src/Propellor/Property/Apt.hs view
@@ -0,0 +1,256 @@+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 qualified Propellor.Property.Service as Service+import Propellor.Property.File (Line)++sourcesList :: FilePath+sourcesList = "/etc/apt/sources.list"++type Url = String+type Section = String++type SourcesGenerator = DebianSuite -> [Line]++showSuite :: DebianSuite -> String+showSuite Stable = "stable"+showSuite Testing = "testing"+showSuite Unstable = "unstable"+showSuite Experimental = "experimental"+showSuite (DebianRelease r) = r++backportSuite :: String+backportSuite = showSuite stableRelease ++ "-backports"++debLine :: String -> Url -> [Section] -> Line+debLine suite mirror sections = unwords $+	["deb", mirror, suite] ++ sections++srcLine :: Line -> Line+srcLine l = case words l of+	("deb":rest) -> unwords $ "deb-src" : rest+	_ -> ""++stdSections :: [Section]+stdSections = ["main", "contrib", "non-free"]++binandsrc :: String -> SourcesGenerator+binandsrc url suite+	| isStable suite = [l, srcLine l, bl, srcLine bl]+	| otherwise = [l, srcLine l]+  where+	l = debLine (showSuite suite) url stdSections+	bl = debLine backportSuite url stdSections++debCdn :: SourcesGenerator+debCdn = binandsrc "http://cdn.debian.net/debian"++kernelOrg :: SourcesGenerator+kernelOrg = binandsrc "http://mirrors.kernel.org/debian"++-- | Only available for Stable and Testing+securityUpdates :: SourcesGenerator+securityUpdates suite+	| isStable suite || suite == Testing =+		let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections+		in [l, srcLine l]+	| otherwise = []++-- | Makes sources.list have a standard content using the mirror CDN,+-- with a particular DebianSuite.+--+-- Since the CDN is sometimes unreliable, also adds backup lines using+-- kernel.org.+stdSourcesList :: DebianSuite -> Property+stdSourcesList suite = stdSourcesList' suite []++-- | Adds additional sources.list generators.+--+-- Note that if a Property needs to enable an apt source, it's better+-- to do so via a separate file in /etc/apt/sources.list.d/+stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property+stdSourcesList' suite more = setSourcesList+	(concatMap (\gen -> gen suite) generators)+	`describe` ("standard sources.list for " ++ show suite)+  where+	generators = [debCdn, kernelOrg, securityUpdates] ++ more++setSourcesList :: [Line] -> Property+setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update++setSourcesListD :: [Line] -> FilePath -> Property+setSourcesListD ls basename = f `File.hasContent` ls `onChange` update+  where+	f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"++runApt :: [String] -> Property+runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv++noninteractiveEnv :: [(String, String)]+noninteractiveEnv =+		[ ("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 = installed' ["-y"]++installed' :: [String] -> [Package] -> Property+installed' params ps = robustly $ check (isInstallable ps) go+	`describe` (unwords $ "apt installed":ps)+  where+	go = runApt $ params ++ ["install"] ++ ps++installedBackport :: [Package] -> Property+installedBackport ps = trivial $ withOS desc $ \o -> case o of+	Nothing -> error "cannot install backports; os not declared"+	(Just (System (Debian suite) _))+		| isStable suite -> +			ensureProperty $ runApt $ +				["install", "-t", backportSuite, "-y"] ++ ps+	_ -> error $ "backports not supported on " ++ show o+  where+	desc = (unwords $ "apt installed backport":ps)++-- | Minimal install of package, without recommends.+installedMin :: [Package] -> Property+installedMin = installed' ["--no-install-recommends", "-y"]++removed :: [Package] -> Property+removed ps = check (or <$> isInstalled' ps) go+	`describe` (unwords $ "apt removed":ps)+  where+	go = runApt $ ["-y", "remove"] ++ ps++buildDep :: [Package] -> Property+buildDep ps = robustly go+	`describe` (unwords $ "apt build-dep":ps)+  where+	go = runApt $ ["-y", "build-dep"] ++ ps++-- | Installs the build deps for the source package unpacked+-- in the specifed directory, with a dummy package also+-- installed so that autoRemove won't remove them.+buildDepIn :: FilePath -> Property+buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]+  where+	go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]+			noninteractiveEnv++-- | Package installation may fail becuse the archive has changed.+-- Run an update in that case and retry.+robustly :: Property -> Property+robustly p = adjustProperty p $ \satisfy -> do+	r <- satisfy+	if r == FailedChange+		then ensureProperty $ p `requires` update+		else return r++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"++-- | Enables unattended upgrades. Revert to disable.+unattendedUpgrades :: RevertableProperty+unattendedUpgrades = RevertableProperty enable disable+  where+	enable = setup True+		`before` Service.running "cron"+		`before` configure+	disable = setup False++	setup 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"+	+	configure = withOS "unattended upgrades configured" $ \o ->+		case o of+			-- the package defaults to only upgrading stable+			(Just (System (Debian suite) _))+				| not (isStable suite) -> ensureProperty $+					"/etc/apt/apt.conf.d/50unattended-upgrades"+						`File.containsLine`+					("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")+			_ -> noChange++-- | 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 $ \(tmpl, tmpltype, value) ->+					hPutStrLn h $ unwords [package, tmpl, tmpltype, value]+				hClose h+	reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv++-- | Ensures that a service is installed and running.+--+-- Assumes that there is a 1:1 mapping between service names and apt+-- package names.+serviceInstalledRunning :: Package -> Property+serviceInstalledRunning svc = Service.running svc `requires` installed [svc]++data AptKey = AptKey+	{ keyname :: String+	, pubkey :: String+	}++trustsKey :: AptKey -> RevertableProperty+trustsKey k = RevertableProperty trust untrust+  where+	desc = "apt trusts key " ++ keyname k+	f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"+	untrust = File.notPresent f+	trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do+		withHandle StdinHandle createProcessSuccess+			(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do+				hPutStr h (pubkey k)+				hClose h+		nukeFile $ f ++ "~" -- gpg dropping
+ src/Propellor/Property/Cmd.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE PackageImports #-}++module Propellor.Property.Cmd (+	cmdProperty,+	cmdProperty',+	scriptProperty,+	userScriptProperty,+) where++import Control.Applicative+import Data.List+import "mtl" Control.Monad.Reader++import Propellor.Types+import Propellor.Property+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 $ liftIO $ 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)++-- | A property that can satisfied by running a series of shell commands,+-- as user (cd'd to their home directory).+userScriptProperty :: UserName -> [String] -> Property+userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]+  where+	shellcmd = intercalate " ; " ("set -e" : "cd" : script)
+ src/Propellor/Property/Cron.hs view
@@ -0,0 +1,49 @@+module Propellor.Property.Cron where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import Utility.SafeCommand++import Data.Char++type CronTimes = String++-- | Installs a cron job, run as a specified user, in a particular+-- directory. Note that the Desc must be unique, as it is used for the +-- cron.d/ filename.+-- +-- Only one instance of the cron job is allowed to run at a time, no matter+-- how long it runs. This is accomplished using flock locking of the cron+-- job file.+--+-- The cron job's output will only be emailed if it exits nonzero.+job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property+job desc times user cddir command = cronjobfile `File.hasContent`+	[ "# Generated by propellor"+	, ""+	, "SHELL=/bin/sh"+	, "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin"+	, ""+	, times ++ "\t" ++ user ++ "\t"+		++ "chronic flock -n " ++ shellEscape cronjobfile+		++ " sh -c " ++ shellEscape cmdline+	]+	`requires` Apt.serviceInstalledRunning "cron"+	`requires` Apt.installed ["util-linux", "moreutils"]+	`describe` ("cronned " ++ desc)+  where+	cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )"+	cronjobfile = "/etc/cron.d/" ++ map sanitize desc+	sanitize c+		| isAlphaNum c = c+		| otherwise = '_'++-- | Installs a cron job, and runs it niced and ioniced.+niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property+niceJob desc times user cddir command = job desc times user cddir+	("nice ionice -c 3 " ++ command)++-- | Installs a cron job to run propellor.+runPropellor :: CronTimes -> Property+runPropellor times = niceJob "propellor" times "root" localdir "make"
+ src/Propellor/Property/Dns.hs view
@@ -0,0 +1,405 @@+module Propellor.Property.Dns (+	module Propellor.Types.Dns,+	primary,+	secondary,+	secondaryFor,+	mkSOA,+	writeZoneFile,+	nextSerialNumber,+	adjustSerialNumber,+	serialNumberOffset,+	WarningMessage,+	genZone,+) where++import Propellor+import Propellor.Types.Dns+import Propellor.Property.File+import Propellor.Types.Attr+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service+import Utility.Applicative++import qualified Data.Map as M+import qualified Data.Set as S+import Data.List++-- | Primary dns server for a domain.+--+-- Most of the content of the zone file is configured by setting properties+-- of hosts. For example,+--+-- > host "foo.example.com"+-- >   & ipv4 "192.168.1.1"+-- >   & alias "mail.exmaple.com"+--+-- Will cause that hostmame and its alias to appear in the zone file,+-- with the configured IP address.+--+-- The [(BindDomain, Record)] list can be used for additional records+-- that cannot be configured elsewhere. This often includes NS records,+-- TXT records and perhaps CNAMEs pointing at hosts that propellor does+-- not control.+--+-- The primary server is configured to only allow zone transfers to+-- secondary dns servers. These are determined in two ways:+--+-- 1. By looking at the properties of other hosts, to find hosts that+-- are configured as the secondary dns server.+--+-- 2. By looking for NS Records in the passed list of records.+--+-- In either case, the secondary dns server Host should have an ipv4 and/or+-- ipv6 property defined.+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty+primary hosts domain soa rs = RevertableProperty setup cleanup+  where+	setup = withwarnings (check needupdate baseprop)+		`requires` servingZones+		`onChange` Service.reloaded "bind9"+	cleanup = check (doesFileExist zonefile) $+		property ("removed dns primary for " ++ domain)+			(makeChange $ removeZoneFile zonefile)+			`requires` namedConfWritten+			`onChange` Service.reloaded "bind9"++	(partialzone, zonewarnings) = genZone hosts domain soa+	zone = partialzone { zHosts = zHosts partialzone ++ rs }+	zonefile = "/etc/bind/propellor/db." ++ domain+	baseprop = Property ("dns primary for " ++ domain)+		(makeChange $ writeZoneFile zone zonefile)+		(addNamedConf conf)+	withwarnings p = adjustProperty p $ \satisfy -> do+		mapM_ warningMessage $ zonewarnings ++ secondarywarnings+		satisfy+	conf = NamedConf+		{ confDomain = domain+		, confDnsServerType = Master+		, confFile = zonefile+		, confMasters = []+		, confAllowTransfer = nub $+			concatMap (\h -> hostAddresses h hosts) $+				secondaries ++ nssecondaries+		, confLines = []+		}+	secondaries = otherServers Secondary hosts domain+	secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $+		filter (\h -> null (hostAddresses h hosts)) secondaries+	nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords+	rootRecords = map snd $+		filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs+	needupdate = do+		v <- readZonePropellorFile zonefile+		return $ case v of+			Nothing -> True+			Just oldzone ->+				-- compare everything except serial+				let oldserial = sSerial (zSOA oldzone)+				    z = zone { zSOA = (zSOA zone) { sSerial = oldserial } }+				in z /= oldzone || oldserial < sSerial (zSOA zone)++-- | Secondary dns server for a domain.+--+-- The primary server is determined by looking at the properties of other+-- hosts to find which one is configured as the primary.+--+-- Note that if a host is declared to be a primary and a secondary dns+-- server for the same domain, the primary server config always wins.+secondary :: [Host] -> Domain -> RevertableProperty+secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain++-- | This variant is useful if the primary server does not have its DNS+-- configured via propellor.+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty+secondaryFor masters hosts domain = RevertableProperty setup cleanup+  where+	setup = pureAttrProperty desc (addNamedConf conf)+		`requires` servingZones+	cleanup = namedConfWritten++ 	desc = "dns secondary for " ++ domain+	conf = NamedConf+		{ confDomain = domain+		, confDnsServerType = Secondary+		, confFile = "db." ++ domain+		, confMasters = concatMap (\m -> hostAddresses m hosts) masters+		, confAllowTransfer = []+		, confLines = []+		}++otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]+otherServers wantedtype hosts domain =+	M.keys $ M.filter wanted $ hostAttrMap hosts+  where+	wanted attr = case M.lookup domain (_namedconf attr) of+		Nothing -> False+		Just conf -> confDnsServerType conf == wantedtype+			&& confDomain conf == domain++-- | Rewrites the whole named.conf.local file to serve the zones+-- configured by `primary` and `secondary`, and ensures that bind9 is+-- running.+servingZones :: Property+servingZones = namedConfWritten+	`onChange` Service.reloaded "bind9"+	`requires` Apt.serviceInstalledRunning "bind9"++namedConfWritten :: Property+namedConfWritten = property "named.conf configured" $ do+	zs <- getNamedConf+	ensureProperty $+		hasContent namedConfFile $+			concatMap confStanza $ M.elems zs++confStanza :: NamedConf -> [Line]+confStanza c =+	[ "// automatically generated by propellor"+	, "zone \"" ++ confDomain c ++ "\" {"+	, cfgline "type" (if confDnsServerType c == Master then "master" else "slave")+	, cfgline "file" ("\"" ++ confFile c ++ "\"")+	] +++	mastersblock +++	allowtransferblock +++	(map (\l -> "\t" ++ l ++ ";") (confLines c)) +++	[ "};"+	, ""+	]+  where+	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"+	ipblock name l = +		[ "\t" ++ name ++ " {" ] +++		(map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) +++		[ "\t};" ]+	mastersblock+		| null (confMasters c) = []+		| otherwise = ipblock "masters" (confMasters c)+	-- an empty block prohibits any transfers+	allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c)++namedConfFile :: FilePath+namedConfFile = "/etc/bind/named.conf.local"++-- | Generates a SOA with some fairly sane numbers in it.+--+-- The Domain is the domain to use in the SOA record. Typically+-- something like ns1.example.com. So, not the domain that this is the SOA+-- record for.+--+-- The SerialNumber can be whatever serial number was used by the domain+-- before propellor started managing it. Or 0 if the domain has only ever+-- been managed by propellor.+--+-- You do not need to increment the SerialNumber when making changes!+-- Propellor will automatically add the number of commits in the git+-- repository to the SerialNumber.+mkSOA :: Domain -> SerialNumber -> SOA+mkSOA d sn = SOA+	{ sDomain = AbsDomain d+	, sSerial = sn+	, sRefresh = hours 4+	, sRetry = hours 1+	, sExpire = 2419200 -- 4 weeks+	, sNegativeCacheTTL = hours 8+	}+  where+	hours n = n * 60 * 60++dValue :: BindDomain -> String+dValue (RelDomain d) = d+dValue (AbsDomain d) = d ++ "."+dValue (RootDomain) = "@"++rField :: Record -> String+rField (Address (IPv4 _)) = "A"+rField (Address (IPv6 _)) = "AAAA"+rField (CNAME _) = "CNAME"+rField (MX _ _) = "MX"+rField (NS _) = "NS"+rField (TXT _) = "TXT"+rField (SRV _ _ _ _) = "SRV"++rValue :: Record -> String+rValue (Address (IPv4 addr)) = addr+rValue (Address (IPv6 addr)) = addr+rValue (CNAME d) = dValue d+rValue (MX pri d) = show pri ++ " " ++ dValue d+rValue (NS d) = dValue d+rValue (SRV priority weight port target) = unwords+	[ show priority+	, show weight+	, show port+	, dValue target+	]+rValue (TXT s) = [q] ++ filter (/= q) s ++ [q]+  where+	q = '"'++-- | Adjusts the serial number of the zone to always be larger+-- than the serial number in the Zone record,+-- and always be larger than the passed SerialNumber.+nextSerialNumber :: Zone -> SerialNumber -> Zone+nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial++adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone+adjustSerialNumber (Zone d soa l) f = Zone d soa' l+  where+	soa' = soa { sSerial = f (sSerial soa) }++-- | Count the number of git commits made to the current branch.+serialNumberOffset :: IO SerialNumber+serialNumberOffset = fromIntegral . length . lines+	<$> readProcess "git" ["log", "--pretty=%H"]++-- | Write a Zone out to a to a file.+--+-- The serial number in the Zone automatically has the serialNumberOffset+-- added to it. Also, just in case, the old serial number used in the zone+-- file is checked, and if it is somehow larger, its succ is used.+writeZoneFile :: Zone -> FilePath -> IO ()+writeZoneFile z f = do+	oldserial <- oldZoneFileSerialNumber f+	offset <- serialNumberOffset+	let z' = nextSerialNumber+		(adjustSerialNumber z (+ offset))+		oldserial+	createDirectoryIfMissing True (takeDirectory f)+	writeFile f (genZoneFile z')+	writeZonePropellorFile f z'++removeZoneFile :: FilePath -> IO ()+removeZoneFile f = do+	nukeFile f+	nukeFile (zonePropellorFile f)++-- | Next to the zone file, is a ".propellor" file, which contains+-- the serialized Zone. This saves the bother of parsing+-- the horrible bind zone file format.+zonePropellorFile :: FilePath -> FilePath+zonePropellorFile f = f ++ ".propellor"++oldZoneFileSerialNumber :: FilePath -> IO SerialNumber+oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile++writeZonePropellorFile :: FilePath -> Zone -> IO ()+writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z)++readZonePropellorFile :: FilePath -> IO (Maybe Zone)+readZonePropellorFile f = catchDefaultIO Nothing $+	readish <$> readFileStrict (zonePropellorFile f)++-- | Generating a zone file.+genZoneFile :: Zone -> String+genZoneFile (Zone zdomain soa rs) = unlines $+	header : genSOA soa ++ map (genRecord zdomain) rs+  where+	header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit."++genRecord :: Domain -> (BindDomain, Record) -> String+genRecord zdomain (domain, record) = intercalate "\t"+	[ domainHost zdomain domain+	, "IN"+	, rField record+	, rValue record+	]++genSOA :: SOA -> [String]+genSOA soa = +	-- "@ IN SOA ns1.example.com. root ("+	[ intercalate "\t"+		[ dValue RootDomain +		, "IN"+		, "SOA"+		, dValue (sDomain soa)+		, "root"+		, "("+		]+	, headerline sSerial "Serial"+	, headerline sRefresh "Refresh"+	, headerline sRetry "Retry"+	, headerline sExpire "Expire"+	, headerline sNegativeCacheTTL "Negative Cache TTL"+	, inheader ")"+	]+  where+	headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment+	inheader l = "\t\t\t" ++ l++-- | Comment line in a zone file.+com :: String -> String+com s = "; " ++ s++type WarningMessage = String++-- | Generates a Zone for a particular Domain from the DNS properies of all+-- hosts that propellor knows about that are in that Domain.+genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage])+genZone hosts zdomain soa =+	let (warnings, zhosts) = partitionEithers $ concat $ map concat+		[ map hostips inzdomain+		, map hostrecords inzdomain+		, map addcnames (M.elems m)+		]+	in (Zone zdomain soa (nub zhosts), warnings)+  where+	m = hostAttrMap hosts+	-- Known hosts with hostname located in the zone's domain.+	inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m+	+	-- Each host with a hostname located in the zdomain+	-- should have 1 or more IPAddrs in its Attr.+	--+	-- If a host lacks any IPAddr, it's probably a misconfiguration,+	-- so warn.+	hostips :: Attr -> [Either WarningMessage (BindDomain, Record)]+	hostips attr+		| null l = [Left $ "no IP address defined for host " ++ _hostname attr]+		| otherwise = map Right l+	  where+		l = zip (repeat $ AbsDomain $ _hostname attr)+			(map Address $ getAddresses attr)++	-- Any host, whether its hostname is in the zdomain or not,+	-- may have cnames which are in the zdomain. The cname may even be+	-- the same as the root of the zdomain, which is a nice way to+	-- specify IP addresses for a SOA record.+	--+	-- Add Records for those.. But not actually, usually, cnames!+	-- Why not? Well, using cnames doesn't allow doing some things,+	-- including MX and round robin DNS, and certianly CNAMES+	-- shouldn't be used in SOA records.+	--+	-- We typically know the host's IPAddrs anyway.+	-- So we can just use the IPAddrs.+	addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)]+	addcnames attr = concatMap gen $ filter (inDomain zdomain) $+		mapMaybe getCNAME $ S.toList (_dns attr)+	  where+		gen c = case getAddresses attr of+			[] -> [ret (CNAME c)]+			l -> map (ret . Address) l+		  where+		  	ret record = Right (c, record)+	+	-- Adds any other DNS records for a host located in the zdomain.+	hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)]+	hostrecords attr = map Right l+	  where+		l = zip (repeat $ AbsDomain $ _hostname attr)+			(S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr))++inDomain :: Domain -> BindDomain -> Bool+inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d+inDomain _ _ = False -- can't tell, so assume not++-- | Gets the hostname of the second domain, relative to the first domain,+-- suitable for using in a zone file.+domainHost :: Domain -> BindDomain -> String+domainHost _ (RelDomain d) = d+domainHost _ RootDomain = "@"+domainHost base (AbsDomain d)+	| dotbase `isSuffixOf` d = take (length d - length dotbase) d+	| base == d = "@"+	| otherwise = d+  where+	dotbase = '.':base+
+ src/Propellor/Property/Docker.hs view
@@ -0,0 +1,460 @@+{-# LANGUAGE BangPatterns #-}++-- | Docker support for propellor+--+-- The existance of a docker container is just another Property of a system,+-- which propellor can set up. See config.hs for an example.++module Propellor.Property.Docker where++import Propellor+import Propellor.SimpleSh+import Propellor.Types.Attr+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Docker.Shim as Shim+import Utility.SafeCommand+import Utility.Path++import Control.Concurrent.Async+import System.Posix.Directory+import System.Posix.Process+import Data.List+import Data.List.Utils++-- | 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"]++-- | A short descriptive name for a container.+-- Should not contain whitespace or other unusual characters,+-- only [a-zA-Z0-9_-] are allowed+type ContainerName = String++-- | Starts accumulating the properties of a Docker container.+--+-- > container "web-server" "debian"+-- >    & publish "80:80"+-- >    & Apt.installed {"apache2"]+-- >    & ...+container :: ContainerName -> Image -> Host+container cn image = Host [] (\_ -> attr)+  where+	attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }++cn2hn :: ContainerName -> HostName+cn2hn cn = cn ++ ".docker"++-- | Ensures that a docker container is set up and running. The container+-- has its own Properties which are handled by running propellor+-- inside the container.+--+-- Reverting this property ensures that the container is stopped and+-- removed.+docked+	:: [Host]+	-> ContainerName+	-> RevertableProperty+docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)+  where+	go desc a = property (desc ++ " " ++ cn) $ do+		hn <- getHostName+  		let cid = ContainerId hn cn+		ensureProperties [findContainer hosts cid cn $ a cid]++	setup cid (Container image runparams) =+		provisionContainer cid+			`requires`+		runningContainer cid image runparams+			`requires`+		installed++	teardown cid (Container image _runparams) =+		combineProperties ("undocked " ++ fromContainerId cid)+			[ stoppedContainer cid+			, property ("cleaned up " ++ fromContainerId cid) $+				liftIO $ report <$> mapM id+					[ removeContainer cid+					, removeImage image+					]+			]++findContainer+	:: [Host]+	-> ContainerId+	-> ContainerName+	-> (Container -> Property)+	-> Property+findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of+	Nothing -> cantfind+	Just h -> maybe cantfind mk (mkContainer cid h)+  where+	cantfind = containerDesc cid $ property "" $ do+		liftIO $ warningMessage $+			"missing definition for docker container \"" ++ cn2hn cn+		return FailedChange++mkContainer :: ContainerId -> Host -> Maybe Container+mkContainer cid@(ContainerId hn _cn) h = Container+	<$> _dockerImage attr+	<*> pure (map (\a -> a hn) (_dockerRunParams attr))+  where+	attr = hostAttr h'+  	h' = h+		-- expose propellor directory inside the container+		& volume (localdir++":"++localdir)+		-- name the container in a predictable way so we+		-- and the user can easily find it later+		& name (fromContainerId cid)++-- | Causes *any* docker images that are not in use by running containers to+-- be deleted. And deletes any containers that propellor has set up+-- before that are not currently running. Does not delete any containers+-- that were not set up using propellor.+--+-- Generally, should come after the properties for the desired containers.+garbageCollected :: Property+garbageCollected = propertyList "docker garbage collected"+	[ gccontainers+	, gcimages+	]+  where+	gccontainers = property "docker containers garbage collected" $+		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)+	gcimages = property "docker images garbage collected" $ do+		liftIO $ report <$> (mapM removeImage =<< listImages)++data Container = Container Image [RunParam]++-- | Parameters to pass to `docker run` when creating a container.+type RunParam = String++-- | A docker image, that can be used to run a container.+type Image = String++-- | Set custom dns server for container.+dns :: String -> Property+dns = runProp "dns"++-- | Set container host name.+hostname :: String -> Property+hostname = runProp "hostname"++-- | Set name for container. (Normally done automatically.)+name :: String -> Property+name = runProp "name"++-- | Publish a container's port to the host+-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)+publish :: String -> Property+publish = runProp "publish"++-- | Expose a container's port without publishing it.+expose :: String -> Property+expose = runProp "expose"++-- | Username or UID for container.+user :: String -> Property+user = runProp "user"++-- | Mount a volume+-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]+-- With just a directory, creates a volume in the container.+volume :: String -> Property+volume = runProp "volume"++-- | Mount a volume from the specified container into the current+-- container.+volumes_from :: ContainerName -> Property+volumes_from cn = genProp "volumes-from" $ \hn ->+	fromContainerId (ContainerId hn cn)++-- | Work dir inside the container. +workdir :: String -> Property+workdir = runProp "workdir"++-- | Memory limit for container.+--Format: <number><optional unit>, where unit = b, k, m or g+memory :: String -> Property+memory = runProp "memory"++-- | Link with another container on the same host.+link :: ContainerName -> ContainerAlias -> Property+link linkwith calias = genProp "link" $ \hn ->+	fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias++-- | A short alias for a linked container.+-- Each container has its own alias namespace.+type ContainerAlias = String++-- | A container is identified by its name, and the host+-- on which it's deployed.+data ContainerId = ContainerId HostName ContainerName+	deriving (Eq, Read, Show)++-- | Two containers with the same ContainerIdent were started from+-- the same base image (possibly a different version though), and+-- with the same RunParams.+data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]+	deriving (Read, Show, Eq)++ident2id :: ContainerIdent -> ContainerId+ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn++toContainerId :: String -> Maybe ContainerId+toContainerId s+	| myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of+		(cn, hn)+			| null hn || null cn -> Nothing+			| otherwise -> Just $ ContainerId hn cn+	| otherwise = Nothing+  where+	desuffix = reverse . drop len . reverse+	len = length myContainerSuffix++fromContainerId :: ContainerId -> String+fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix++containerHostName :: ContainerId -> HostName+containerHostName (ContainerId _ cn) = cn2hn cn++myContainerSuffix :: String+myContainerSuffix = ".propellor"++containerDesc :: ContainerId -> Property -> Property+containerDesc cid p = p `describe` desc+  where+	desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p++runningContainer :: ContainerId -> Image -> [RunParam] -> Property+runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do+	l <- liftIO $ listContainers RunningContainers+	if cid `elem` l+		then do+			-- Check if the ident has changed; if so the+			-- parameters of the container differ and it must+			-- be restarted.+			runningident <- liftIO $ getrunningident+			if runningident == Just ident+				then noChange+				else do+					void $ liftIO $ stopContainer cid+					restartcontainer+		else ifM (liftIO $ elem cid <$> listContainers AllContainers)+			( restartcontainer+			, go image+			)+  where+	ident = ContainerIdent image hn cn runps++	restartcontainer = do+		oldimage <- liftIO $ fromMaybe image <$> commitContainer cid+		void $ liftIO $ removeContainer cid+		go oldimage++	getrunningident :: IO (Maybe ContainerIdent)+	getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do+		let !v = extractident rs+		return v++	extractident :: [Resp] -> Maybe ContainerIdent+	extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout++	go img = do+		liftIO $ do+			clearProvisionedFlag cid+			createDirectoryIfMissing True (takeDirectory $ identFile cid)+		shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)+		liftIO $ writeFile (identFile cid) (show ident)+		ensureProperty $ boolProperty "run" $ runContainer img+			(runps ++ ["-i", "-d", "-t"])+			[shim, "--docker", fromContainerId cid]++-- | Called when propellor is running inside a docker container.+-- The string should be the container's ContainerId.+--+-- This process is effectively init inside the container.+-- It even needs to wait on zombie processes!+--+-- Fork a thread to run the SimpleSh server in the background.+-- In the foreground, run an interactive bash (or sh) shell,+-- so that the user can interact with it when attached to the container.+--+-- When the system reboots, docker restarts the container, and this is run+-- again. So, to make the necessary services get started on boot, this needs+-- to provision the container then. However, if the container is already+-- being provisioned by the calling propellor, it would be redundant and+-- problimatic to also provisoon it here.+--+-- The solution is a flag file. If the flag file exists, then the container+-- was already provisioned. So, it must be a reboot, and time to provision+-- again. If the flag file doesn't exist, don't provision here.+chain :: String -> IO ()+chain s = case toContainerId s of+	Nothing -> error $ "Invalid ContainerId: " ++ s+	Just cid -> do+		changeWorkingDirectory localdir+		writeFile propellorIdent . show =<< readIdentFile cid+		-- Run boot provisioning before starting simpleSh,+		-- to avoid ever provisioning twice at the same time.+		whenM (checkProvisionedFlag cid) $ do+			let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)+			unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $+				warningMessage "Boot provision failed!"+		void $ async $ job reapzombies+		void $ async $ job $ simpleSh $ namedPipe cid+		job $ do+			void $ tryIO $ ifM (inPath "bash")+				( boolSystem "bash" [Param "-l"]+				, boolSystem "/bin/sh" []+				)+			putStrLn "Container is still running. Press ^P^Q to detach."+  where+	job = forever . void . tryIO+	reapzombies = void $ getAnyProcessStatus True False++-- | Once a container is running, propellor can be run inside+-- it to provision it.+--+-- Note that there is a race here, between the simplesh+-- server starting up in the container, and this property+-- being run. So, retry connections to the client for up to+-- 1 minute.+provisionContainer :: ContainerId -> Property+provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do+	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)+	r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)+	when (r /= FailedChange) $+		setProvisionedFlag cid +	return r+  where+	params = ["--continue", show $ Chain $ containerHostName cid]++	go lastline (v:rest) = case v of+		StdoutLine s -> do+			maybe noop putStrLn lastline+			hFlush stdout+			go (Just s) rest+		StderrLine s -> do+			maybe noop putStrLn lastline+			hFlush stdout+			hPutStrLn stderr s+			hFlush stderr+			go Nothing rest+		Done -> ret lastline+	go lastline [] = ret lastline++	ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline++stopContainer :: ContainerId -> IO Bool+stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]++stoppedContainer :: ContainerId -> Property+stoppedContainer cid = containerDesc cid $ property desc $ +	ifM (liftIO $ elem cid <$> listContainers RunningContainers)+		( liftIO cleanup `after` ensureProperty +			(boolProperty desc $ stopContainer cid)+		, return NoChange+		)+  where+	desc = "stopped"+	cleanup = do+		nukeFile $ namedPipe cid+		nukeFile $ identFile cid+		removeDirectoryRecursive $ shimdir cid+		clearProvisionedFlag cid++removeContainer :: ContainerId -> IO Bool+removeContainer cid = catchBoolIO $+	snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing++removeImage :: Image -> IO Bool+removeImage image = catchBoolIO $+	snd <$> processTranscript dockercmd ["rmi", image ] Nothing++runContainer :: Image -> [RunParam] -> [String] -> IO Bool+runContainer image ps cmd = boolSystem dockercmd $ map Param $+	"run" : (ps ++ image : cmd)++commitContainer :: ContainerId -> IO (Maybe Image)+commitContainer cid = catchMaybeIO $+	takeWhile (/= '\n') +		<$> readProcess dockercmd ["commit", fromContainerId cid]++data ContainerFilter = RunningContainers | AllContainers+	deriving (Eq)++-- | Only lists propellor managed containers.+listContainers :: ContainerFilter -> IO [ContainerId]+listContainers status = +	catMaybes . map toContainerId . concat . map (split ",")+		. catMaybes . map (lastMaybe . words) . lines+		<$> readProcess dockercmd ps+  where+	ps+		| status == AllContainers = baseps ++ ["--all"]+		| otherwise = baseps+	baseps = ["ps", "--no-trunc"]++listImages :: IO [Image]+listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]++runProp :: String -> RunParam -> Property+runProp field val = pureAttrProperty (param) $ \attr ->+	attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }+  where+	param = field++"="++val++genProp :: String -> (HostName -> RunParam) -> Property+genProp field mkval = pureAttrProperty field $ \attr ->+	attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }++-- | The ContainerIdent of a container is written to+-- /.propellor-ident inside it. This can be checked to see if+-- the container has the same ident later.+propellorIdent :: FilePath+propellorIdent = "/.propellor-ident"++-- | Named pipe used for communication with the container.+namedPipe :: ContainerId -> FilePath+namedPipe cid = "docker" </> fromContainerId cid++provisionedFlag :: ContainerId -> FilePath+provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"++clearProvisionedFlag :: ContainerId -> IO ()+clearProvisionedFlag = nukeFile . provisionedFlag++setProvisionedFlag :: ContainerId -> IO ()+setProvisionedFlag cid = do+	createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))+	writeFile (provisionedFlag cid) "1"++checkProvisionedFlag :: ContainerId -> IO Bool+checkProvisionedFlag = doesFileExist . provisionedFlag++shimdir :: ContainerId -> FilePath+shimdir cid = "docker" </> fromContainerId cid ++ ".shim"++identFile :: ContainerId -> FilePath+identFile cid = "docker" </> fromContainerId cid ++ ".ident"++readIdentFile :: ContainerId -> IO ContainerIdent+readIdentFile cid = fromMaybe (error "bad ident in identFile")+	. readish <$> readFile (identFile cid)++dockercmd :: String+dockercmd = "docker.io"++report :: [Bool] -> Result+report rmed+	| or rmed = MadeChange+	| otherwise = NoChange+
+ src/Propellor/Property/Docker/Shim.hs view
@@ -0,0 +1,61 @@+-- | Support for running propellor, as built outside a docker container,+-- inside the container.+--+-- Note: This is currently Debian specific, due to glibcLibs.++module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where++import Propellor+import Utility.LinuxMkLibs+import Utility.SafeCommand+import Utility.Path+import Utility.FileMode++import Data.List+import System.Posix.Files++-- | Sets up a shimmed version of the program, in a directory, and+-- returns its path.+setup :: FilePath -> FilePath -> IO FilePath+setup propellorbin dest = do+	createDirectoryIfMissing True dest++	libs <- parseLdd <$> readProcess "ldd" [propellorbin]+	glibclibs <- glibcLibs+	let libs' = nub $ libs ++ glibclibs+	libdirs <- map (dest ++) . nub . catMaybes+		<$> mapM (installLib installFile dest) libs'+	+	let linker = (dest ++) $ +		fromMaybe (error "cannot find ld-linux linker") $+			headMaybe $ filter ("ld-linux" `isInfixOf`) libs'+	let gconvdir = (dest ++) $ parentDir $+		fromMaybe (error "cannot find gconv directory") $+			headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs+	let linkerparams = ["--library-path", intercalate ":" libdirs ]+	let shim = file propellorbin dest+	writeFile shim $ unlines+		[ "#!/bin/sh"+		, "GCONV_PATH=" ++ shellEscape gconvdir+		, "export GCONV_PATH"+		, "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ +			" " ++ shellEscape propellorbin ++ " \"$@\""+		]+	modifyFileMode shim (addModes executeModes)+	return shim++cleanEnv :: IO ()+cleanEnv = void $ unsetEnv "GCONV_PATH"++file :: FilePath -> FilePath -> FilePath+file propellorbin dest = dest </> takeFileName propellorbin++installFile :: FilePath -> FilePath -> IO ()+installFile top f = do+	createDirectoryIfMissing True destdir+	nukeFile dest+	createLink f dest `catchIO` (const copy)+  where+	copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest]+	destdir = inTop top $ parentDir f+	dest = inTop top f
+ src/Propellor/Property/File.hs view
@@ -0,0 +1,94 @@+module Propellor.Property.File where++import Propellor+import Utility.FileMode++import System.Posix.Files+import System.PosixCompat.Types++type Line = String++-- | Replaces all the content of a file.+hasContent :: FilePath -> [Line] -> Property+f `hasContent` newcontent = fileProperty ("replace " ++ f)+	(\_oldcontent -> newcontent) f++-- | Ensures a file has contents that comes from PrivData.+--+-- The file's permissions are preserved if the file already existed.+-- Otherwise, they're set to 600.+hasPrivContent :: FilePath -> Property+hasPrivContent f = property desc $ withPrivData (PrivFile f) $ \privcontent -> +	ensureProperty $ fileProperty' writeFileProtected desc+		(\_oldcontent -> lines privcontent) f+  where+	desc = "privcontent " ++ f++-- | Leaves the file world-readable.+hasPrivContentExposed :: FilePath -> Property+hasPrivContentExposed f = hasPrivContent f `onChange`+	mode f (combineModes (ownerWriteMode:readModes))++-- | Ensures that a line is present in a file, adding it to the end if not.+containsLine :: FilePath -> Line -> Property+f `containsLine` l = f `containsLines` [l]++containsLines :: FilePath -> [Line] -> Property+f `containsLines` l = fileProperty (f ++ " contains:" ++ show l) go f+  where+	go ls+		| all (`elem` ls) l = 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 = fileProperty' writeFile+fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property+fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)+  where+	go True = do+		ls <- liftIO $ lines <$> readFile f+		let ls' = a ls+		if ls' == ls+			then noChange+			else makeChange $ viaTmp updatefile f (unlines ls')+	go False = makeChange $ writer f (unlines $ a [])++	-- viaTmp makes the temp file mode 600.+	-- Replicate the original file's owner and mode.+	updatefile f' content = do+		writer f' content+		s <- getFileStatus f+		setFileMode f' (fileMode s)+		setOwnerAndGroup f' (fileOwner s) (fileGroup s)++-- | Ensures a directory exists.+dirExists :: FilePath -> Property+dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $+	makeChange $ createDirectoryIfMissing True d++-- | Ensures that a file/dir has the specified owner and group.+ownerGroup :: FilePath -> UserName -> GroupName -> Property+ownerGroup f owner group = property (f ++ " owner " ++ og) $ do+	r <- ensureProperty $ cmdProperty "chown" [og, f]+	if r == FailedChange+		then return r+		else noChange+  where+	og = owner ++ ":" ++ group++-- | Ensures that a file/dir has the specfied mode.+mode :: FilePath -> FileMode -> Property+mode f v = property (f ++ " mode " ++ show v) $ do+	liftIO $ modifyFileMode f (\_old -> v)+	noChange
+ src/Propellor/Property/Git.hs view
@@ -0,0 +1,93 @@+module Propellor.Property.Git where++import Propellor+import Propellor.Property.File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service+import Utility.SafeCommand++import Data.List++-- | Exports all git repos in a directory (that user nobody can read)+-- using git-daemon, run from inetd.+--+-- Note that reverting this property does not remove or stop inetd.+daemonRunning :: FilePath -> RevertableProperty+daemonRunning exportdir = RevertableProperty setup unsetup+  where+	setup = containsLine conf (mkl "tcp4")+		`requires`+		containsLine conf (mkl "tcp6")+		`requires`+		dirExists exportdir+		`requires`+		Apt.serviceInstalledRunning "openbsd-inetd"+		`onChange`+		Service.running "openbsd-inetd"+		`describe` ("git-daemon exporting " ++ exportdir)+	unsetup = lacksLine conf (mkl "tcp4")+		`requires`+		lacksLine conf (mkl "tcp6")+		`onChange`+		Service.reloaded "openbsd-inetd"++	conf = "/etc/inetd.conf"++	mkl tcpv = intercalate "\t"+		[ "git"+		, "stream"+		, tcpv+		, "nowait"+		, "nobody"+		, "/usr/bin/git"+		, "git"+		, "daemon"+		, "--inetd"+		, "--export-all"+		, "--base-path=" ++ exportdir+		, exportdir+		]++installed :: Property+installed = Apt.installed ["git"]++type RepoUrl = String++type Branch = String++-- | Specified git repository is cloned to the specified directory.+--+-- If the firectory exists with some other content, it will be recursively+-- deleted.+--+-- A branch can be specified, to check out.+cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property+cloned owner url dir mbranch = check originurl (property desc checkout)+	`requires` installed+  where+	desc = "git cloned " ++ url ++ " to " ++ dir+	gitconfig = dir </> ".git/config"+	originurl = ifM (doesFileExist gitconfig)+		( do+			v <- catchDefaultIO Nothing $ headMaybe . lines <$>+				readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"]+			return (v /= Just url)+		, return True+		)+	checkout = do+		liftIO $ do+			whenM (doesDirectoryExist dir) $+				removeDirectoryRecursive dir+			createDirectoryIfMissing True (takeDirectory dir)+		ensureProperty $ userScriptProperty owner $ catMaybes+			-- The </dev/null fixes an intermittent+			-- "fatal: read error: Bad file descriptor"+			-- when run across ssh with propellor --spin+			[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"+			, Just $ "cd " ++ shellEscape dir+			, ("git checkout " ++) <$> mbranch+			-- In case this repo is exposted via the web,+			-- although the hook to do this ongoing is not+			-- installed here.+			, Just "git update-server-info"+			]
+ src/Propellor/Property/Gpg.hs view
@@ -0,0 +1,41 @@+module Propellor.Property.Gpg where++import Propellor+import qualified Propellor.Property.Apt as Apt+import Utility.FileSystemEncoding++import System.PosixCompat++installed :: Property+installed = Apt.installed ["gnupg"]++-- | Sets up a user with a gpg key from the privdata.+--+-- Note that if a secret key is exported using gpg -a --export-secret-key,+-- the public key is also included. Or just a public key could be+-- exported, and this would set it up just as well.+--+-- Recommend only using this for low-value dedicated role keys.+-- No attempt has been made to scrub the key out of memory once it's used.+--+-- The GpgKeyId does not have to be a numeric id; it can just as easily+-- be a description of the key.+keyImported :: GpgKeyId -> UserName -> Property+keyImported keyid user = flagFile' (property desc go) genflag+	`requires` installed+  where+	desc = user ++ " has gpg key " ++ show keyid+	genflag = do+		d <- dotDir user+		return $ d </> ".propellor-imported-keyid-" ++ keyid+	go = withPrivData (GpgKey keyid) $ \key -> makeChange $+		withHandle StdinHandle createProcessSuccess+			(proc "su" ["-c", "gpg --import", user]) $ \h -> do+				fileEncoding h+				hPutStr h key+				hClose h++dotDir :: UserName -> IO FilePath+dotDir user = do+	home <- homeDirectory <$> getUserEntryForName user+	return $ home </> ".gnupg"
+ src/Propellor/Property/HostingProvider/CloudAtCost.hs view
@@ -0,0 +1,24 @@+module Propellor.Property.HostingProvider.CloudAtCost where++import Propellor+import qualified Propellor.Property.Hostname as Hostname+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Ssh as Ssh+import qualified Propellor.Property.User as User++-- Clean up a system as installed by cloudatcost.com+decruft :: Property+decruft = propertyList "cloudatcost cleanup"+	[ Hostname.sane+	, Ssh.randomHostKeys+	, "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"]+	, combineProperties "nuked cloudatcost cruft"+		[ File.notPresent "/etc/rc.local"+		, File.notPresent "/etc/init.d/S97-setup.sh"+		, User.nuked "user" User.YesReallyDeleteHome+		]+	]+
+ src/Propellor/Property/HostingProvider/DigitalOcean.hs view
@@ -0,0 +1,21 @@+module Propellor.Property.HostingProvider.DigitalOcean where++import Propellor+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.File as File++-- Digital Ocean does not provide any way to boot+-- the kernel provided by the distribution, except using kexec.+-- Without this, some old, and perhaps insecure kernel will be used.+--+-- Note that this only causes the new kernel to be loaded on reboot.+-- If the power is cycled, the old kernel still boots up.+-- TODO: detect this and reboot immediately?+distroKernel :: Property+distroKernel = propertyList "digital ocean distro kernel hack"+	[ Apt.installed ["grub-pc", "kexec-tools"]+	, "/etc/default/kexec" `File.containsLines`+		[ "LOAD_KEXEC=true"+		, "USE_GRUB_CONFIG=true"+		] `describe` "kexec configured"+	]
+ src/Propellor/Property/Hostname.hs view
@@ -0,0 +1,33 @@+module Propellor.Property.Hostname where++import Propellor+import qualified Propellor.Property.File as File++-- | Ensures that the hostname is set to the HostAttr value.+-- Configures /etc/hostname and the current hostname.+--+-- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is+-- standard at least on Debian to set the FDQN (127.0.0.1 is localhost).+sane :: Property+sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName)++setTo :: HostName -> Property+setTo hn = combineProperties desc go+  where+	desc = "hostname " ++ hn+	(basehost, domain) = separate (== '.') hn++	go = catMaybes+		[ Just $ "/etc/hostname" `File.hasContent` [basehost]+		, if null domain+			then Nothing +			else Just $ File.fileProperty desc+				addhostline "/etc/hosts"+		, Just $ trivial $ cmdProperty "hostname" [basehost]+		]+	+	hostip = "127.0.1.1"+	hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost++	addhostline ls = hostline : filter (not . hashostip) ls+	hashostip l = headMaybe (words l) == Just hostip
+ src/Propellor/Property/Network.hs view
@@ -0,0 +1,30 @@+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"+		, "auto sit0"+		, "# End automatically added by propeller"+		]++type Interface = String++ifUp :: Interface -> Property+ifUp iface = cmdProperty "ifup" [iface]
+ src/Propellor/Property/Obnam.hs view
@@ -0,0 +1,155 @@+module Propellor.Property.Obnam where++import Propellor+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Cron as Cron+import Utility.SafeCommand++import Data.List++type ObnamParam = String++-- | An obnam repository can be used by multiple clients. Obnam uses+-- locking to allow only one client to write at a time. Since stale lock+-- files can prevent backups from happening, it's more robust, if you know+-- a repository has only one client, to force the lock before starting a+-- backup. Using OnlyClient allows propellor to do so when running obnam.+data NumClients = OnlyClient | MultipleClients+	deriving (Eq)++-- | Installs a cron job that causes a given directory to be backed+-- up, by running obnam with some parameters.+--+-- If the directory does not exist, or exists but is completely empty,+-- this Property will immediately restore it from an existing backup.+--+-- So, this property can be used to deploy a directory of content+-- to a host, while also ensuring any changes made to it get backed up.+-- And since Obnam encrypts, just make this property depend on a gpg+-- key, and tell obnam to use the key, and your data will be backed+-- up securely. For example: +--+-- >	& Obnam.backup "/srv/git" "33 3 * * *"+-- >		[ "--repository=sftp://2318@usw-s002.rsync.net/~/mygitrepos.obnam"+-- >		, "--encrypt-with=1B169BE1"+-- >		] Obnam.OnlyClient+-- >		`requires` Gpg.keyImported "1B169BE1" "root"+-- >		`requires` Ssh.keyImported SshRsa "root"+--+-- How awesome is that?+backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property+backup dir crontimes params numclients = cronjob `describe` desc+	`requires` restored dir params+  where+	desc = dir ++ " backed up by obnam"+	cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $+		intercalate ";" $ catMaybes+			[ if numclients == OnlyClient+				then Just $ unwords $+					[ "obnam"+					, "force-lock"+					] ++ map shellEscape params+				else Nothing+			, Just $ unwords $+				[ "obnam"+				, "backup"+				, shellEscape dir+				] ++ map shellEscape params+			]++-- | Restores a directory from an obnam backup.+--+-- Only does anything if the directory does not exist, or exists,+-- but is completely empty.+--+-- The restore is performed atomically; restoring to a temp directory+-- and then moving it to the directory.+restored :: FilePath -> [ObnamParam] -> Property+restored dir params = property (dir ++ " restored by obnam") go+	`requires` installed+  where+	go = ifM (liftIO needsRestore)+		( do+			warningMessage $ dir ++ " is empty/missing; restoring from backup ..."+			liftIO restore+		, noChange+		)++	needsRestore = null <$> catchDefaultIO [] (dirContents dir)++	restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do+		ok <- boolSystem "obnam" $+			[ Param "restore"+			, Param "--to"+			, Param tmpdir+			] ++ map Param params+		let restoreddir = tmpdir ++ "/" ++ dir+		ifM (pure ok <&&> doesDirectoryExist restoreddir)+			( do+				void $ tryIO $ removeDirectory dir+				renameDirectory restoreddir dir+				return MadeChange+			, return FailedChange+			)++installed :: Property+installed = Apt.installed ["obnam"]++-- | Ensures that a recent version of obnam gets installed.+--+-- Only does anything for Debian Stable.+latestVersion :: Property+latestVersion = withOS "obnam latest version" $ \o -> case o of+	(Just (System (Debian suite) _)) | isStable suite -> ensureProperty $+		Apt.setSourcesListD (sources suite) "obnam"+			`requires` toProp (Apt.trustsKey key)+	_ -> noChange+  where+	sources suite = +		[ "deb http://code.liw.fi/debian " ++ Apt.showSuite suite ++ " main"+		]+	-- gpg key used by the code.liw.fi repository.+	key = Apt.AptKey "obnam" $ unlines+		[ "-----BEGIN PGP PUBLIC KEY BLOCK-----"+		, "Version: GnuPG v1.4.9 (GNU/Linux)"+		, ""+		, "mQGiBEfzuTgRBACcVNG/H6QJqLx5qiQs2zmPe6D6BWOWHfgNgG4IWzNstm21YDxb"+		, "KqwFG0gxcnZJGHkXAhkSfqTokYd0lc5eBemcA1pkceNjzMEX8wwiZ810HzJD4eEH"+		, "sjoWR8+qKrZeixzZqReAfqztcXoBGKQ0u1R1vpg1txUa75OM4BUqaUbsmwCgmS4x"+		, "DjMxSaUSPuu6vQ7ZGZBXSP0D/RQw8DBHMfsv3DiaqFqk8tkuUkpMFPIekHidSHlO"+		, "EACbncqbbyHksyCpFNVNcQIDHrOLjOZK9BAXkSd8I3ww7U+nLdDcCblrW8CZnJtm"+		, "ZYrxfaXaHZ/It9/RCAsQ+c8xtmyUPjsf//4Vf8olxNQHzgBSe5/LJRi4Vd53he+K"+		, "YP4LA/9IZbjvVmm8+8Y0pQrTHlI6nTImtzdBXHc4+T3lLBj9XODHLozC2kSBOQky"+		, "q/EisTITHTXL8vYg4NsKm5RTbPAuBwdtxcny8CXfOqKtGOdrebmKotGllTozzdPv"+		, "9p53cuce6oJ2oMUodc074JOGTWwDSgLiJX4nViGcU1wy/vtQnrQkY29kZS5saXcu"+		, "ZmkgYXJjaGl2ZSBrZXkgPGxpd0BsaXcuZmk+iGAEExECACAFAkfzuTgCGwMGCwkI"+		, "BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRBG53tJR95LscKrAJ0ZtKqa2x6Kplwa2mzx"+		, "ItImbIGMJACdETqofDYzUN91yLAFlOnxAyrE+UyIRgQQEQIABgUCSFd5GgAKCRAf"+		, "u5W/LZrMjqr8AJ4xPVHpW8ZNlgMwDSVb075RnA2DiACgg2SR69jAHFQOWV6xfLRr"+		, "vh0bLKGJAhwEEAEIAAYFAktEyIwACgkQ61zh116FEfm7Lg//Wiy3TjWAk8YHUddv"+		, "zOioYzCxQ985GsVhJGAVPqSGOc9vfTWBJZ8J3l0NnYTRpEGucmbF9G+mAt9iGXu6"+		, "7yZkxyFdvbo7EDsqMU1wLOM6PiU+Un63MKlbTNmFn7OKE8aXPRAFgcyUO/qjdqoD"+		, "sa9FgU5Z0f60m9qah6BPXH6IzMLHYoiP7t8rCBIwLgyl3w2w+Fjt1DFpbW9Kb7jz"+		, "i8jFvC8jPmxV8xh2OSgVZyNk4qg6hIV8GVQY7AJt8OurZSckgQd7ifHK9JTGohtF"+		, "tXCiqeDEvnMF4A9HI/TcXJBzonZ8ds1JCq42nSSKmL+8TyjtUSD/xHygazuc0CK0"+		, "hFnQWBub60IfyV6F0oTagJ8cmARv2sezHAeHDkzPHE8RdjgktazH1eJrA4LheEd6"+		, "KeSnVtYWpw8dgMv5PleFyQiAj/t3C/N50fd15tUyfnH15G7nFjMQV2Yx35uwSxOj"+		, "376OWnDN/YGTNk283XXULbyVJYR8Q2unso20XQ94yQ2A5EpHHPrHoLxrL/ydM08d"+		, "nvKstLZIZtal1seiMkymtlSiGz25A5oqsclwS6VZCKdWA8HO/wlElOMcaHyl6Y1y"+		, "gYP7y9O5yFYKFOrCH0nFjJbwmkRiBLsxuuWsYgJigVGq/atSrtawkHdshpCw0HCY"+		, "N/RFcWkJ864BdsO0C0sDzueNkQO5Ag0ER/O5RBAIAJiwPH9tyJTgXcC2Y4XWboOq"+		, "rx5CkOnr5b45oS9cK2eIJ8TKxE3XgKLxUr3mIH0QR2kZgDOwNl0WY+7/CXjn+Spn"+		, "BokPg54rafEUePodGpGdUXdgrHhAMHYjh8fXFJ1SlQcg46/zc1wDI7jBCkGrK3V8"+		, "5cXDqwTFTN5LcjoSRWeM4Voa6pEfDdL3rMlnOw9R9gDHRBBb6CDSjWXqM86pR889"+		, "5QrR0SDwiJNrMoyxSjMXFKGBQAsYHJ82myZrlbuZbroZjVp5Uh7eB1ZiPljNVtcr"+		, "sksACIWBCo1rvLzrPXsLYOeV3cDDtYAkSwGfuzC1Etbe+qgfIroFTOqdefMw4s8A"+		, "AwUH/0KLXm4MS54QQspg3evu4Q4U/E8Hem5/FqB0GhBCitQ4rUsucKyY8/ItpUn5"+		, "ismLE60bQqka+Mzd/Zw18TCTzImv0ozAaZ2sNtBado7f6jcC8EDfY5zzK1ukcsAr"+		, "Qc5hdLHYuTQW5KpA6fKaW969OUzIwPbdVaCOLOBpxKC6N6iBspQYd6uiQtLw6EUO"+		, "50oQqUiJABf0eOocvdw5e2KQQpuC3205+VMYtyl4w3pdJihK8NK0AikGXzDVsbQt"+		, "l8kmB5ZrN4WIKhMke1FxbqQC5Q3XATvYRzpzzisZb/HYGNti8W6du5EUwJ0D2NRh"+		, "cu+twocOzW0VKfmrDApfifJ9OsSISQQYEQIACQUCR/O5RAIbDAAKCRBG53tJR95L"+		, "seQOAJ95KUyzjRjdYgZkDC69Mgu25L86UACdGduINUaRly43ag4kwUXxpqswBBM="+		, "=i2c3"+		, "-----END PGP PUBLIC KEY BLOCK-----"+		]
+ src/Propellor/Property/OpenId.hs view
@@ -0,0 +1,29 @@+module Propellor.Property.OpenId where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service++import Data.List++providerFor :: [UserName] -> String -> Property+providerFor users baseurl = propertyList desc $+	[ Apt.serviceInstalledRunning "apache2"+	, Apt.installed ["simpleid"]+		`onChange` Service.restarted "apache2"+	, File.fileProperty (desc ++ " configured")+		(map setbaseurl) "/etc/simpleid/config.inc"+	] ++ map identfile users+  where+	url = "http://"++baseurl++"/simpleid"+	desc = "openid provider " ++ url+	setbaseurl l+		| "SIMPLEID_BASE_URL" `isInfixOf` l = +			"define('SIMPLEID_BASE_URL', '"++url++"');"+		| otherwise = l+	+	-- the identitites directory controls access, so open up+	-- file mode+	identfile u = File.hasPrivContentExposed $+		concat $ [ "/var/lib/simpleid/identities/", u, ".identity" ]
+ src/Propellor/Property/Postfix.hs view
@@ -0,0 +1,25 @@+module Propellor.Property.Postfix where++import Propellor+import qualified Propellor.Property.Apt as Apt++installed :: Property+installed = Apt.serviceInstalledRunning "postfix"++-- | Configures postfix as a satellite system, which +-- relats all mail through a relay host, which defaults to smtp.domain. +--+-- The smarthost may refuse to relay mail on to other domains, without+-- futher coniguration/keys. But this should be enough to get cron job+-- mail flowing to a place where it will be seen.+satellite :: Property+satellite = setup `requires` installed+  where+	setup = trivial $ property "postfix satellite system" $ do+		hn <- getHostName+		ensureProperty $ Apt.reConfigure "postfix"+			[ ("postfix/main_mailer_type", "select", "Satellite system")+			, ("postfix/root_address", "string", "root")+			, ("postfix/destinations", "string", " ")+			, ("postfix/mailname", "string", hn)+			]
+ src/Propellor/Property/Reboot.hs view
@@ -0,0 +1,7 @@+module Propellor.Property.Reboot where++import Propellor++now :: Property+now = cmdProperty "reboot" []+	`describe` "reboot now"
+ src/Propellor/Property/Scheduled.hs view
@@ -0,0 +1,67 @@+module Propellor.Property.Scheduled+	( period+	, periodParse+	, Recurrance(..)+	, WeekDay+	, MonthDay+	, YearDay+	) where++import Propellor+import Utility.Scheduled++import Data.Time.Clock+import Data.Time.LocalTime+import qualified Data.Map as M++-- | Makes a Property only be checked every so often.+--+-- This uses the description of the Property to keep track of when it was+-- last run.+period :: Property -> Recurrance -> Property+period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do+	lasttime <- liftIO $ getLastChecked (propertyDesc prop)+	nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime+	t <- liftIO localNow+	if Just t >= nexttime+		then do+			r <- satisfy+			liftIO $ setLastChecked t (propertyDesc prop)+			return r+		else noChange+  where+	schedule = Schedule recurrance AnyTime+	desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"++-- | Like period, but parse a human-friendly string.+periodParse :: Property -> String -> Property+periodParse prop s = case toRecurrance s of+	Just recurrance -> period prop recurrance+	Nothing -> property "periodParse" $ do+		liftIO $ warningMessage $ "failed periodParse: " ++ s+		noChange++lastCheckedFile :: FilePath+lastCheckedFile = localdir </> ".lastchecked"++getLastChecked :: Desc -> IO (Maybe LocalTime)+getLastChecked desc = M.lookup desc <$> readLastChecked++localNow :: IO LocalTime+localNow = do+	now <- getCurrentTime+	tz <- getTimeZone now+	return $ utcToLocalTime tz now++setLastChecked :: LocalTime -> Desc -> IO ()+setLastChecked time desc = do+	m <- readLastChecked+	writeLastChecked (M.insert desc time m)++readLastChecked :: IO (M.Map Desc LocalTime)+readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go+  where+	go = readish <$> readFileStrict lastCheckedFile++writeLastChecked :: M.Map Desc LocalTime -> IO ()+writeLastChecked = writeFile lastCheckedFile . show
+ src/Propellor/Property/Service.hs view
@@ -0,0 +1,31 @@+module Propellor.Property.Service where++import Propellor+import Utility.SafeCommand++type ServiceName = String++-- | Ensures that a service is running. Does not ensure that+-- any package providing that service is installed. See+-- Apt.serviceInstalledRunning+--+-- Note that due to the general poor state of init scripts, the best+-- we can do is try to start the service, and if it fails, assume+-- this means it's already running.+running :: ServiceName -> Property+running svc = property ("running " ++ svc) $ do+	void $ ensureProperty $+		scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]+	return NoChange++restarted :: ServiceName -> Property+restarted svc = property ("restarted " ++ svc) $ do+	void $ ensureProperty $+		scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"]+	return NoChange++reloaded :: ServiceName -> Property+reloaded svc = property ("reloaded " ++ svc) $ do+	void $ ensureProperty $+		scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"]+	return NoChange
+ src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs view
@@ -0,0 +1,176 @@+module Propellor.Property.SiteSpecific.GitAnnexBuilder where++import Propellor+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.User as User+import qualified Propellor.Property.Cron as Cron+import qualified Propellor.Property.Ssh as Ssh+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Docker as Docker+import Propellor.Property.Cron (CronTimes)++builduser :: UserName+builduser = "builder"++homedir :: FilePath+homedir = "/home/builder"++gitbuilderdir :: FilePath+gitbuilderdir = homedir </> "gitbuilder"++builddir :: FilePath+builddir = gitbuilderdir </> "build"++type TimeOut = String -- eg, 5h++autobuilder :: CronTimes -> TimeOut -> Bool -> Property+autobuilder crontimes timeout rsyncupload = combineProperties "gitannexbuilder"+	[ Apt.serviceInstalledRunning "cron"+	, Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $+		"git pull ; timeout " ++ timeout ++ " ./autobuild"+	-- The builduser account does not have a password set,+	-- instead use the password privdata to hold the rsync server+	-- password used to upload the built image.+	, property "rsync password" $ do+		let f = homedir </> "rsyncpassword"+		if rsyncupload +			then withPrivData (Password builduser) $ \p -> do+				oldp <- liftIO $ catchDefaultIO "" $+					readFileStrict f+				if p /= oldp+					then makeChange $ writeFile f p+					else noChange+			else do+				ifM (liftIO $ doesFileExist f)+					( noChange+					, makeChange $ writeFile f "no password configured"+					)+	]++tree :: Architecture -> Property+tree buildarch = combineProperties "gitannexbuilder tree"+	[ Apt.installed ["git"]+	-- gitbuilderdir directory already exists when docker volume is used,+	-- but with wrong owner.+	, File.dirExists gitbuilderdir+	, File.ownerGroup gitbuilderdir builduser builduser+	, check (not <$> (doesDirectoryExist (gitbuilderdir </> ".git"))) $ +		userScriptProperty builduser+			[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir+			, "cd " ++ gitbuilderdir+			, "git checkout " ++ buildarch+			]+			`describe` "gitbuilder setup"+	, check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser+		[ "git clone git://git-annex.branchable.com/ " ++ builddir+		]+	]++buildDepsApt :: Property+buildDepsApt = combineProperties "gitannexbuilder build deps"+	[ Apt.buildDep ["git-annex"]+	, buildDepsFewHaskellLibs+	, "git-annex source build deps installed" ==> Apt.buildDepIn builddir+	]++buildDepsFewHaskellLibs :: Property+buildDepsFewHaskellLibs = combineProperties "gitannexbuilder build deps"+	[ buildDepsNoHaskellLibs+	-- these haskell libs depend on C libs and don't use TH+	, Apt.installed ["libghc-dbus-dev", "libghc-fdo-notify-dev", "libghc-network-protocol-xmpp-dev"]+	]++buildDepsNoHaskellLibs :: Property+buildDepsNoHaskellLibs = Apt.installed+	["git", "rsync", "moreutils", "ca-certificates",+	"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt",+	"liblockfile-simple-perl", "cabal-install", "vim", "less",+	"alex", "happy", "c2hs"+	]++-- Installs current versions of git-annex's deps from cabal, but only+-- does so once.+cabalDeps :: Property+cabalDeps = flagFile go cabalupdated+	where+		go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"]+		cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"++standardAutoBuilderContainer :: (System -> Docker.Image) -> Architecture -> Int -> TimeOut -> Host+standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.container (arch ++ "-git-annex-builder")+	(dockerImage $ System (Debian Unstable) arch)+	& Apt.stdSourcesList Unstable+	& Apt.unattendedUpgrades+	& buildDepsApt+	& autobuilder (show buildminute ++ " * * * *") timeout True+		`requires` tree arch++androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host+androidAutoBuilderContainer dockerImage crontimes timeout =+	androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir+		& Apt.unattendedUpgrades+		& autobuilder crontimes timeout True++-- Android is cross-built in a Debian i386 container, using the Android NDK.+androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host+androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name+	(dockerImage $ System (Debian Stable) "i386")+	& Apt.stdSourcesList Stable+	& User.accountFor builduser+	& File.dirExists gitbuilderdir+	& File.ownerGroup homedir builduser builduser+	& buildDepsNoHaskellLibs+	& flagFile chrootsetup ("/chrootsetup")+		`requires` setupgitannexdir+	-- TODO: automate installing haskell libs+	-- (Currently have to run+	-- git-annex/standalone/android/install-haskell-packages+	-- which is not fully automated.)+  where+	-- Use git-annex's android chroot setup script, which will install+	-- ghc-android and the NDK, all build deps, etc, in the home+	-- directory of the builder user.+	chrootsetup = scriptProperty+		[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"+		]++-- armel builder has a companion container using amd64 that+-- runs the build first to get TH splices. They need+-- to have the same versions of all haskell libraries installed.+armelCompanionContainer :: (System -> Docker.Image) -> Host+armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder-companion"+	(dockerImage $ System (Debian Unstable) "amd64")+	& Apt.stdSourcesList Unstable+	& Apt.unattendedUpgrades+	-- This volume is shared with the armel builder.+	& Docker.volume gitbuilderdir+	-- Install current versions of build deps from cabal.+	& tree "armel"+	& buildDepsFewHaskellLibs+	& cabalDeps+	-- The armel builder can ssh to this companion.+	& Docker.expose "22"+	& Apt.serviceInstalledRunning "ssh"+	& Ssh.authorizedKeys builduser++armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host+armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder"+	(dockerImage $ System (Debian Unstable) "armel")+	& Apt.stdSourcesList Unstable+	& Apt.unattendedUpgrades+	& Apt.installed ["openssh-client"]+	& Docker.link "armel-git-annex-builder-companion" "companion"+	& Docker.volumes_from "armel-git-annex-builder-companion"+	-- TODO: automate installing haskell libs+	-- (Currently have to run+	-- git-annex/standalone/linux/install-haskell-packages+	-- which is not fully automated.)+	& buildDepsFewHaskellLibs+	& autobuilder crontimes timeout True+		`requires` tree "armel"+	& Ssh.keyImported SshRsa builduser+	& trivial writecompanionaddress+  where+	writecompanionaddress = scriptProperty+		[ "echo \"$COMPANION_PORT_22_TCP_ADDR\" > " ++ homedir </> "companion_address"+		] `describe` "companion_address file"
+ src/Propellor/Property/SiteSpecific/GitHome.hs view
@@ -0,0 +1,34 @@+module Propellor.Property.SiteSpecific.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 =<< liftIO (homedir user))+		`requires` Apt.installed ["git"]+  where+	go home = do+		let tmpdir = home </> "githome"+		ensureProperty $ combineProperties "githome setup"+			[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]+			, property "moveout" $ makeChange $ void $+				moveout tmpdir home+			, property "rmdir" $ makeChange $ void $+				catchMaybeIO $ removeDirectory tmpdir+			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]+			]+	moveout tmpdir home = do+		fs <- dirContents tmpdir+		forM fs $ \f -> boolSystem "mv" [File f, File home]++url :: String+url = "git://git.kitenet.net/joey/home"++hasGitDir :: UserName -> IO Bool+hasGitDir user = go =<< homedir user+  where+	go home = doesDirectoryExist (home </> ".git")
+ src/Propellor/Property/SiteSpecific/JoeySites.hs view
@@ -0,0 +1,319 @@+-- | Specific configuation for Joey Hess's sites. Probably not useful to+-- others except as an example.++module Propellor.Property.SiteSpecific.JoeySites where++import Propellor+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Gpg as Gpg+import qualified Propellor.Property.Ssh as Ssh+import qualified Propellor.Property.Git as Git+import qualified Propellor.Property.Cron as Cron+import qualified Propellor.Property.Service as Service+import qualified Propellor.Property.User as User+import qualified Propellor.Property.Obnam as Obnam+import qualified Propellor.Property.Apache as Apache+import Utility.SafeCommand+import Utility.FileMode++import Data.List+import System.Posix.Files++oldUseNetServer :: [Host] -> Property+oldUseNetServer hosts = propertyList ("olduse.net server")+	[ oldUseNetInstalled "oldusenet-server"+	, Obnam.latestVersion+	, Obnam.backup datadir "33 4 * * *"+		[ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"+		, "--client-name=spool"+		] Obnam.OnlyClient+		`requires` Ssh.keyImported SshRsa "root"+		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"+	, check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $+		property "olduse.net spool in place" $ makeChange $ do+			removeDirectoryRecursive newsspool+			createSymbolicLink (datadir </> "news") newsspool+	, Apt.installed ["leafnode"]+	, "/etc/news/leafnode/config" `File.hasContent` +		[ "# olduse.net configuration (deployed by propellor)"+		, "expire = 1000000" -- no expiry via texpire+		, "server = " -- no upstream server+		, "debugmode = 1"+		, "allowSTRANGERS = 42" -- lets anyone connect+		, "nopost = 1" -- no new posting (just gather them)+		]+	, "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"+	, Apt.serviceInstalledRunning "openbsd-inetd"+	, File.notPresent "/etc/cron.daily/leafnode"+	, File.notPresent "/etc/cron.d/leafnode"+	, Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";"+		[ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60  -print | xargs --no-run-if-empty rm"+		, "find -type d -empty | xargs --no-run-if-empty rmdir"+		]+	, Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $+		"/usr/bin/uucp " ++ datadir+	, toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False+		[ "  DocumentRoot " ++ datadir ++ "/"+		, "  <Directory " ++ datadir ++ "/>"+		, "    Options Indexes FollowSymlinks"+		, "    AllowOverride None"+		-- I had this in the file before.+		-- This may be needed by a newer version of apache?+		--, "    Require all granted"+		, "  </Directory>"+		]+	]+  where+	newsspool = "/var/spool/news"+	datadir = "/var/spool/oldusenet"++oldUseNetShellBox :: Property+oldUseNetShellBox = oldUseNetInstalled "oldusenet"++oldUseNetInstalled :: Apt.Package -> Property+oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $+	propertyList ("olduse.net " ++ pkg)+		[ 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 ../" ++ pkg ++ "_*.deb || true"+			, "apt-get -fy install" -- dependencies+			, "rm -rf /root/tmp/oldusenet"+			] `describe` "olduse.net built"+		]+++kgbServer :: Property+kgbServer = withOS desc $ \o -> case o of+	(Just (System (Debian Unstable) _)) ->+		ensureProperty $ propertyList desc+			[ Apt.serviceInstalledRunning "kgb-bot"+			, File.hasPrivContent "/etc/kgb-bot/kgb.conf"+				`onChange` Service.restarted "kgb-bot"+			, "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"+				`describe` "kgb bot enabled"+				`onChange` Service.running "kgb-bot"+			]+	_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"+  where+	desc = "kgb.kitenet.net setup"++mumbleServer :: [Host] -> Property+mumbleServer hosts = combineProperties "mumble.debian.net" +	[ Apt.serviceInstalledRunning "mumble-server"+	, Obnam.latestVersion+	, Obnam.backup "/var/lib/mumble-server" "55 5 * * *"+		[ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/mumble.debian.net.obnam"+		, "--client-name=mumble"+		] Obnam.OnlyClient+		`requires` Ssh.keyImported SshRsa "root"+		`requires` Ssh.knownHost hosts "turtle.kitenet.net" "root"+	, trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]+	]++obnamLowMem :: Property+obnamLowMem = combineProperties "obnam tuned for low memory use"+	[ Obnam.latestVersion+	, "/etc/obnam.conf" `File.containsLines`+		[ "[config]"+		, "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)."+		, "upload-queue-size = 128"+		, "lru-size = 128"+		]+	]++-- git.kitenet.net and git.joeyh.name+gitServer :: [Host] -> Property+gitServer hosts = propertyList "git.kitenet.net setup"+	[ Obnam.latestVersion+	, Obnam.backup "/srv/git" "33 3 * * *"+		[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"+		, "--encrypt-with=1B169BE1"+		, "--client-name=wren"+		] Obnam.OnlyClient+		`requires` Gpg.keyImported "1B169BE1" "root"+		`requires` Ssh.keyImported SshRsa "root"+		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"+		`requires` Ssh.authorizedKeys "family"+		`requires` User.accountFor "family"+	, Apt.installed ["git", "rsync", "gitweb"]+	-- backport avoids channel flooding on branch merge+	, Apt.installedBackport ["kgb-client"]+	-- backport supports ssh event notification+	, Apt.installedBackport ["git-annex"]+	, File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf"+	, toProp $ Git.daemonRunning "/srv/git"+	, "/etc/gitweb.conf" `File.containsLines`+		[ "$projectroot = '/srv/git';"+		, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"+		, "# disable snapshot download; overloads server"+		, "$feature{'snapshot'}{'default'} = [];"+		]+		`describe` "gitweb configured"+	-- Repos push on to github.+	, Ssh.knownHost hosts "github.com" "joey"+	-- I keep the website used for gitweb checked into git..+	, Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing+	, website "git.kitenet.net"+	, website "git.joeyh.name"+	, toProp $ Apache.modEnabled "cgi"+	]+  where+	website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True+		[ "  DocumentRoot /srv/web/git.kitenet.net/"+		, "  <Directory /srv/web/git.kitenet.net/>"+		, "    Options Indexes ExecCGI FollowSymlinks"+		, "    AllowOverride None"+		, "    AddHandler cgi-script .cgi"+		, "    DirectoryIndex index.cgi"+		, "  </Directory>"+		, ""+		, "  ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"+		, "  <Directory /usr/lib/cgi-bin>"+		, "    SetHandler cgi-script"+		, "    Options ExecCGI"+		, "  </Directory>"+		]++type AnnexUUID = String++-- | A website, with files coming from a git-annex repository.+annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property+annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex")+	[ Git.cloned "joey" origin dir Nothing+		`onChange` setup+	, postupdatehook `File.hasContent`+		[ "#!/bin/sh"+		, "exec git update-server-info"+		] `onChange`+			(postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes)))+	, setupapache+	]+  where+	dir = "/srv/web/" ++ hn+	postupdatehook = dir </> ".git/hooks/post-update"+	setup = userScriptProperty "joey" setupscript+		`requires` Ssh.keyImported SshRsa "joey"+		`requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey"+	setupscript = +		[ "cd " ++ shellEscape dir+		, "git config annex.uuid " ++ shellEscape uuid+		] ++ map addremote remotes +++		[ "git annex get"+		]+	addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url+	setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ +		[ "  ServerAlias www."++hn+		, ""+		, "  DocumentRoot /srv/web/"++hn+		, "  <Directory /srv/web/"++hn++">"+		, "    Options FollowSymLinks"+		, "    AllowOverride None"+		, "  </Directory>"+		, "  <Directory /srv/web/"++hn++">"+		, "    Options Indexes FollowSymLinks ExecCGI"+		, "    AllowOverride None"+		, "    AddHandler cgi-script .cgi"+		, "    DirectoryIndex index.html index.cgi"+		, "    Order allow,deny"+		, "    allow from all"+		, "  </Directory>"+		]++apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile+apachecfg hn withssl middle+	| withssl = vhost False ++ vhost True+	| otherwise = vhost False+  where+	vhost ssl = +		[ "<VirtualHost *:"++show port++">"+		, "  ServerAdmin grue@joeyh.name"+		, "  ServerName "++hn++":"++show port+		]+		++ mainhttpscert ssl+		++ middle +++		[ ""+		, "  ErrorLog /var/log/apache2/error.log"+		, "  LogLevel warn"+		, "  CustomLog /var/log/apache2/access.log combined"+		, "  ServerSignature On"+		, "  "+		, "  <Directory \"/usr/share/apache2/icons\">"+		, "      Options Indexes MultiViews"+		, "      AllowOverride None"+		, "      Order allow,deny"+		, "      Allow from all"+		, "  </Directory>"+		, "</VirtualHost>"+		]+	  where+		port = if ssl then 443 else 80 :: Int++mainhttpscert :: Bool -> Apache.ConfigFile+mainhttpscert False = []+mainhttpscert True = +	[ "  SSLEngine on"+	, "  SSLCertificateFile /etc/ssl/certs/web.pem"+	, "  SSLCertificateKeyFile /etc/ssl/private/web.pem"+	, "  SSLCertificateChainFile /etc/ssl/certs/startssl.pem"+	]+		+gitAnnexDistributor :: Property+gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer"+	[ Apt.installed ["rsync"]+	, File.hasPrivContent "/etc/rsyncd.conf"+		`onChange` Service.restarted "rsync"+	, File.hasPrivContent "/etc/rsyncd.secrets"+		`onChange` Service.restarted "rsync"+	, "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"+		`onChange` Service.running "rsync"+	, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"+	, endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks"+	-- git-annex distribution signing key+	, Gpg.keyImported "89C809CB" "joey"+	]+  where+	endpoint d = combineProperties ("endpoint " ++ d)+		[ File.dirExists d+		, File.ownerGroup d "joey" "joey"+		]++-- Twitter, you kill us.+twitRss :: Property+twitRss = combineProperties "twitter rss"+	[ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing+	, check (not <$> doesFileExist (dir </> "twitRss")) $+		userScriptProperty "joey"+			[ "cd " ++ dir+			, "ghc --make twitRss" +			]+			`requires` Apt.installed+				[ "libghc-xml-dev"+				, "libghc-feed-dev"+				, "libghc-tagsoup-dev"+				]+	, feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter"+	, feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep"+	]+  where+	dir = "/srv/web/tmp.kitenet.net/twitrss"+	crontime = "15 * * * *"+	feed url desc = Cron.job desc crontime "joey" dir $+		"./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss")++ircBouncer :: Property+ircBouncer = propertyList "IRC bouncer"+	[ Apt.installed ["znc"]+	, User.accountFor "znc"+	, File.hasPrivContent conf+	, File.ownerGroup conf "znc" "znc"+	, Cron.job "znconboot" "@reboot" "znc" "~" "znc"+	, Cron.job "zncrunning" "@hourly" "znc" "~" "znc || true"+	]+  where+	conf = "/home/znc/.znc/configs/znc.conf"
+ src/Propellor/Property/Ssh.hs view
@@ -0,0 +1,157 @@+module Propellor.Property.Ssh (+	setSshdConfig,+	permitRootLogin,+	passwordAuthentication,+	hasAuthorizedKeys,+	restartSshd,+	randomHostKeys,+	hostKey,+	keyImported,+	knownHost,+	authorizedKeys+) where++import Propellor+import qualified Propellor.Property.File as File+import Propellor.Property.User+import Utility.SafeCommand+import Utility.FileMode++import System.PosixCompat++sshBool :: Bool -> String+sshBool True = "yes"+sshBool False = "no"++sshdConfig :: FilePath+sshdConfig = "/etc/ssh/sshd_config"++setSshdConfig :: String -> Bool -> Property+setSshdConfig setting allowed = combineProperties "sshd config"+	[ 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"++dotDir :: UserName -> IO FilePath+dotDir user = do+	h <- homedir user+	return $ h </> ".ssh"++dotFile :: FilePath -> UserName -> IO FilePath+dotFile f user = do+	d <- dotDir user+	return $ d </> f++hasAuthorizedKeys :: UserName -> IO Bool+hasAuthorizedKeys = go <=< dotFile "authorized_keys"+  where+	go f = not . null <$> catchDefaultIO "" (readFile f)++restartSshd :: Property+restartSshd = cmdProperty "service" ["ssh", "restart"]++-- | Blows away existing host keys and make new ones.+-- Useful for systems installed from an image that might reuse host keys.+-- A flag file is used to only ever do this once.+randomHostKeys :: Property+randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"+	`onChange` restartSshd+  where+	prop = property "ssh random host keys" $ do+		void $ liftIO $ boolSystem "sh"+			[ Param "-c"+			, Param "rm -f /etc/ssh/ssh_host_*"+			]+		ensureProperty $+			cmdProperty "/var/lib/dpkg/info/openssh-server.postinst"+				["configure"]++-- | Sets ssh host keys from the site's PrivData.+-- +-- (Uses a null username for host keys.)+hostKey :: SshKeyType -> Property+hostKey keytype = combineProperties desc+	[ property desc (install writeFile (SshPubKey keytype "") ".pub")+	, property desc (install writeFileProtected (SshPrivKey keytype "") "")+	]+	`onChange` restartSshd+  where+ 	desc = "known ssh host key (" ++ fromKeyType keytype ++ ")"+	install writer p ext = withPrivData p $ \key -> do+		let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext+		s <- liftIO $ readFileStrict f+		if s == key+			then noChange+			else makeChange $ writer f key++-- | Sets up a user with a ssh private key and public key pair+-- from the site's PrivData.+keyImported :: SshKeyType -> UserName -> Property+keyImported keytype user = combineProperties desc+	[ property desc (install writeFile (SshPubKey keytype user) ".pub")+	, property desc (install writeFileProtected (SshPrivKey keytype user) "")+	]+  where+	desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")"+	install writer p ext = do+		f <- liftIO $ keyfile ext+		ifM (liftIO $ doesFileExist f)+			( noChange+			, ensureProperties+				[ property desc $ +					withPrivData p $ \key -> makeChange $ do+						createDirectoryIfMissing True (takeDirectory f)+						writer f key+				, File.ownerGroup f user user+				, File.ownerGroup (takeDirectory f) user user+				]+			)+	keyfile ext = do+		home <- homeDirectory <$> getUserEntryForName user+		return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext++fromKeyType :: SshKeyType -> String+fromKeyType SshRsa = "rsa"+fromKeyType SshDsa = "dsa"+fromKeyType SshEcdsa = "ecdsa"+fromKeyType SshEd25519 = "ed25519"++-- | Puts some host's ssh public key into the known_hosts file for a user.+knownHost :: [Host] -> HostName -> UserName -> Property+knownHost hosts hn user = property desc $+	go =<< fromHost hosts hn getSshPubKey+  where+	desc = user ++ " knows ssh key for " ++ hn+	go (Just (Just k)) = do+		f <- liftIO $ dotFile "known_hosts" user+		ensureProperty $ combineProperties desc+			[ File.dirExists (takeDirectory f)+			, f `File.containsLine` (hn ++ " " ++ k)+			, File.ownerGroup f user user+			]+	go _ = do+		warningMessage $ "no configred sshPubKey for " ++ hn+		return FailedChange++-- | Makes a user have authorized_keys from the PrivData+authorizedKeys :: UserName -> Property+authorizedKeys user = property (user ++ " has authorized_keys") $+	withPrivData (SshAuthorizedKeys user) $ \v -> do+		f <- liftIO $ dotFile "authorized_keys" user+		liftIO $ do+			createDirectoryIfMissing True (takeDirectory f)+			writeFileProtected f v+		ensureProperties +			[ File.ownerGroup f user user+			, File.ownerGroup (takeDirectory f) user user+			]
+ src/Propellor/Property/Sudo.hs view
@@ -0,0 +1,32 @@+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.+enabledFor :: UserName -> Property+enabledFor user = property desc go `requires` Apt.installed ["sudo"]+  where+	go = do+		locked <- liftIO $ 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+		-- TOOD: Full sudoers file format parse.. +		| not (sudobaseline `isPrefixOf` l) = True+		| "NOPASSWD" `isInfixOf` l = locked+		| otherwise = True+ 	modify locked ls+		| sudoline locked `elem` ls = ls+		| otherwise = ls ++ [sudoline locked]
+ src/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"]
+ src/Propellor/Property/User.hs view
@@ -0,0 +1,61 @@+module Propellor.Property.User where++import System.Posix++import Propellor++data Eep = YesReallyDeleteHome++accountFor :: UserName -> Property+accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"+	[ "--disabled-password"+	, "--gecos", ""+	, user+	]+	`describe` ("account for " ++ user)++-- | Removes user home directory!! Use with caution.+nuked :: UserName -> Eep -> Property+nuked user _ = check (isJust <$> catchMaybeIO (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 FilePath+homedir user = homeDirectory <$> getUserEntryForName user
+ src/Propellor/SimpleSh.hs view
@@ -0,0 +1,101 @@+-- | Simple server, using a named pipe. Client connects, sends a command,+-- and gets back all the output from the command, in a stream.+--+-- This is useful for eg, docker.++module Propellor.SimpleSh where++import Network.Socket+import Control.Concurrent+import Control.Concurrent.Async+import System.Process (std_in, std_out, std_err)++import Propellor+import Utility.FileMode+import Utility.ThreadScheduler++data Cmd = Cmd String [String]+	deriving (Read, Show)++data Resp = StdoutLine String | StderrLine String | Done+	deriving (Read, Show)++simpleSh :: FilePath -> IO ()+simpleSh namedpipe = do+	nukeFile namedpipe+	let dir = takeDirectory namedpipe+	createDirectoryIfMissing True dir+	modifyFileMode dir (removeModes otherGroupModes)+	s <- socket AF_UNIX Stream defaultProtocol+	bindSocket s (SockAddrUnix namedpipe)+	listen s 2+	forever $ do+		(client, _addr) <- accept s+		forkIO $ do+			h <- socketToHandle client ReadWriteMode+			maybe noop (run h) . readish =<< hGetLine h+  where+	run h (Cmd cmd params) = do+		chan <- newChan+		let runwriter = do+			v <- readChan chan+			hPutStrLn h (show v)+			hFlush h+			case v of+				Done -> noop+				_ -> runwriter+		writer <- async runwriter++		flip catchIO (\_e -> writeChan chan Done) $ do+			let p = (proc cmd params)+	                	{ std_in = Inherit+		                , std_out = CreatePipe+				, std_err = CreatePipe+				}+			(Nothing, Just outh, Just errh, pid) <- createProcess p++			let mkreader t from = maybe noop (const $ mkreader t from) +				=<< catchMaybeIO (writeChan chan . t =<< hGetLine from)+			void $ concurrently+				(mkreader StdoutLine outh)+				(mkreader StderrLine errh)+		+			void $ tryIO $ waitForProcess pid++			writeChan chan Done++			hClose outh+			hClose errh++		wait writer+		hClose h++simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a+simpleShClient namedpipe cmd params handler = do+	s <- socket AF_UNIX Stream defaultProtocol+	connect s (SockAddrUnix namedpipe)+	h <- socketToHandle s ReadWriteMode+	hPutStrLn h $ show $ Cmd cmd params+	hFlush h+	resps <- catMaybes . map readish . lines <$> hGetContents h+	v <- hClose h `after` handler resps+	return v++simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a+simpleShClientRetry retries namedpipe cmd params handler = go retries+  where+	run = simpleShClient namedpipe cmd params handler+	go n+		| n < 1 = run+		| otherwise = do+			v <- tryIO run+			case v of+				Right r -> return r+				Left e -> do+					debug ["simplesh connection retry", show e]+					threadDelaySeconds (Seconds 1)+					go (n - 1)++getStdout :: Resp -> Maybe String+getStdout (StdoutLine s) = Just s+getStdout _ = Nothing
+ src/Propellor/Types.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Propellor.Types+	( Host(..)+	, Attr+	, SetAttr+	, Propellor(..)+	, Property(..)+	, RevertableProperty(..)+	, IsProp+	, describe+	, toProp+	, setAttr+	, requires+	, Desc+	, Result(..)+	, ActionResult(..)+	, CmdLine(..)+	, PrivDataField(..)+	, GpgKeyId+	, SshKeyType(..)+	, module Propellor.Types.OS+	, module Propellor.Types.Dns+	) where++import Data.Monoid+import Control.Applicative+import System.Console.ANSI+import "mtl" Control.Monad.Reader+import "MonadCatchIO-transformers" Control.Monad.CatchIO++import Propellor.Types.Attr+import Propellor.Types.OS+import Propellor.Types.Dns++-- | Everything Propellor knows about a system: Its properties and+-- attributes.+data Host = Host [Property] SetAttr++-- | Propellor's monad provides read-only access to attributes of the+-- system.+newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }+	deriving+		( Monad+		, Functor+		, Applicative+		, MonadReader Attr +		, MonadIO+		, MonadCatchIO+		)++-- | The core data type of Propellor, this represents a property+-- that the system should have, and an action to ensure it has the+-- property.+data Property = Property+	{ propertyDesc :: Desc+	, propertySatisfy :: Propellor Result+	-- ^ must be idempotent; may run repeatedly+	, propertyAttr :: SetAttr+	-- ^ a property can set an Attr on the host that has the property.+	}++-- | A property that can be reverted.+data RevertableProperty = RevertableProperty Property Property++class IsProp p where+	-- | Sets description.+	describe :: p -> Desc -> p+	toProp :: p -> Property+	-- | Indicates that the first property can only be satisfied+	-- once the second one is.+	requires :: p -> Property -> p+	setAttr :: p -> SetAttr++instance IsProp Property where+	describe p d = p { propertyDesc = d }+	toProp p = p+	setAttr = propertyAttr+	x `requires` y = Property (propertyDesc x) satisfy attr+	  where+	  	attr = propertyAttr x . propertyAttr y+		satisfy = do+			r <- propertySatisfy y+			case r of+				FailedChange -> return FailedChange+				_ -> propertySatisfy x+			++instance IsProp RevertableProperty where+	-- | Sets the description of both sides.+	describe (RevertableProperty p1 p2) d = +		RevertableProperty (describe p1 d) (describe p2 ("not " ++ d))+	toProp (RevertableProperty p1 _) = p1+	(RevertableProperty p1 p2) `requires` y =+		RevertableProperty (p1 `requires` y) p2+	-- | Return the SetAttr of the currently active side.+	setAttr (RevertableProperty p1 _p2) = setAttr p1++type Desc = String++data Result = NoChange | MadeChange | FailedChange+	deriving (Read, Show, Eq)++instance Monoid Result where+	mempty = NoChange++	mappend FailedChange _ = FailedChange+	mappend _ FailedChange = FailedChange+	mappend MadeChange _ = MadeChange+	mappend _ MadeChange = MadeChange+	mappend NoChange NoChange = NoChange++-- | Results of actions, with color.+class ActionResult a where+	getActionResult :: a -> (String, ColorIntensity, Color)++instance ActionResult Bool where+	getActionResult False = ("failed", Vivid, Red)+	getActionResult True = ("done", Dull, Green)++instance ActionResult Result where+	getActionResult NoChange = ("ok", Dull, Green)+	getActionResult MadeChange = ("done", Vivid, Green)+	getActionResult FailedChange = ("failed", Vivid, Red)++data CmdLine+	= Run HostName+	| Spin HostName+	| Boot HostName+	| Set HostName PrivDataField+	| AddKey String+	| Continue CmdLine+	| Chain HostName+	| Docker HostName+  deriving (Read, Show, Eq)++-- | 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+	| SshPubKey SshKeyType UserName+	| SshPrivKey SshKeyType UserName+	| SshAuthorizedKeys UserName+	| Password UserName+	| PrivFile FilePath+	| GpgKey GpgKeyId+	deriving (Read, Show, Ord, Eq)++type GpgKeyId = String++data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519+	deriving (Read, Show, Ord, Eq)
+ src/Propellor/Types/Attr.hs view
@@ -0,0 +1,48 @@+module Propellor.Types.Attr where++import Propellor.Types.OS+import qualified Propellor.Types.Dns as Dns++import qualified Data.Set as S+import qualified Data.Map as M++-- | The attributes of a host. For example, its hostname.+data Attr = Attr+	{ _hostname :: HostName+	, _os :: Maybe System+	, _sshPubKey :: Maybe String+	, _dns :: S.Set Dns.Record+	, _namedconf :: M.Map Dns.Domain Dns.NamedConf++	, _dockerImage :: Maybe String+	, _dockerRunParams :: [HostName -> String]+	}++instance Eq Attr where+	x == y = and+		[ _hostname x == _hostname y+		, _os x == _os y+		, _dns x == _dns y+		, _namedconf x == _namedconf y+		, _sshPubKey x == _sshPubKey y++		, _dockerImage x == _dockerImage y+		, let simpl v = map (\a -> a "") (_dockerRunParams v)+		  in simpl x == simpl y+		]++instance Show Attr where+	show a = unlines+		[ "hostname " ++ _hostname a+		, "OS " ++ show (_os a)+		, "sshPubKey " ++ show (_sshPubKey a)+		, "dns " ++ show (_dns a)+		, "namedconf " ++ show (_namedconf a)+		, "docker image " ++ show (_dockerImage a)+		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))+		]++newAttr :: HostName -> Attr+newAttr hn = Attr hn Nothing Nothing S.empty M.empty Nothing []++type SetAttr = Attr -> Attr
+ src/Propellor/Types/Dns.hs view
@@ -0,0 +1,92 @@+module Propellor.Types.Dns where++import Propellor.Types.OS (HostName)++import Data.Word++type Domain = String++data IPAddr = IPv4 String | IPv6 String+	deriving (Read, Show, Eq, Ord)++fromIPAddr :: IPAddr -> String+fromIPAddr (IPv4 addr) = addr+fromIPAddr (IPv6 addr) = addr++-- | Represents a bind 9 named.conf file.+data NamedConf = NamedConf+	{ confDomain :: Domain+	, confDnsServerType :: DnsServerType+	, confFile :: FilePath+	, confMasters :: [IPAddr]+	, confAllowTransfer :: [IPAddr]+	, confLines :: [String]+	}+	deriving (Show, Eq, Ord)++data DnsServerType = Master | Secondary+	deriving (Show, Eq, Ord)++-- | Represents a bind 9 zone file.+data Zone = Zone+	{ zDomain :: Domain+	, zSOA :: SOA+	, zHosts :: [(BindDomain, Record)]+	}+	deriving (Read, Show, Eq)++-- | Every domain has a SOA record, which is big and complicated.+data SOA = SOA+	{ sDomain :: BindDomain+	-- ^ Typically ns1.your.domain+	, sSerial :: SerialNumber+	-- ^ The most important parameter is the serial number,+	-- which must increase after each change.+	, sRefresh :: Integer+	, sRetry :: Integer+	, sExpire :: Integer+	, sNegativeCacheTTL :: Integer+	}+	deriving (Read, Show, Eq)++-- | Types of DNS records.+--+-- This is not a complete list, more can be added.+data Record+	= Address IPAddr+	| CNAME BindDomain+	| MX Int BindDomain+	| NS BindDomain+	| TXT String+	| SRV Word16 Word16 Word16 BindDomain+	deriving (Read, Show, Eq, Ord)++getIPAddr :: Record -> Maybe IPAddr+getIPAddr (Address addr) = Just addr+getIPAddr _ = Nothing++getCNAME :: Record -> Maybe BindDomain+getCNAME (CNAME d) = Just d+getCNAME _ = Nothing++getNS :: Record -> Maybe BindDomain+getNS (NS d) = Just d+getNS _ = Nothing++-- | Bind serial numbers are unsigned, 32 bit integers.+type SerialNumber = Word32++-- | Domains in the zone file must end with a period if they are absolute.+--+-- Let's use a type to keep absolute domains straight from relative+-- domains.+--+-- The RootDomain refers to the top level of the domain, so can be used+-- to add nameservers, MX's, etc to a domain.+data BindDomain = RelDomain Domain | AbsDomain Domain | RootDomain+	deriving (Read, Show, Eq, Ord)++domainHostName :: BindDomain -> Maybe HostName+domainHostName (RelDomain d) = Just d+domainHostName (AbsDomain d) = Just d+domainHostName RootDomain = Nothing
+ src/Propellor/Types/OS.hs view
@@ -0,0 +1,27 @@+module Propellor.Types.OS where++type HostName = String+type UserName = String+type GroupName = String++-- | High level descritption of a operating system.+data System = System Distribution Architecture+	deriving (Show, Eq)++data Distribution+	= Debian DebianSuite+	| Ubuntu Release+	deriving (Show, Eq)++data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release+	deriving (Show, Eq)++-- | The release that currently corresponds to stable.+stableRelease :: DebianSuite+stableRelease = DebianRelease "wheezy"++isStable :: DebianSuite -> Bool+isStable s = s == Stable || s == stableRelease++type Release = String+type Architecture = String
+ src/Utility/Applicative.hs view
@@ -0,0 +1,16 @@+{- applicative stuff+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++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 <$$>
+ src/Utility/Data.hs view
@@ -0,0 +1,17 @@+{- utilities for simple data types+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++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
+ src/Utility/Directory.hs view
@@ -0,0 +1,135 @@+{- directory manipulation+ -+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# 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 = dirContentsRecursiveSkipping (const False) True++{- 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
+ src/Utility/Env.hs view
@@ -0,0 +1,81 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# 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
+ src/Utility/Exception.hs view
@@ -0,0 +1,59 @@+{- Simple IO exception handling (and some more)+ -+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# 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 = catchDefaultIO False++{- 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
+ src/Utility/FileMode.hs view
@@ -0,0 +1,158 @@+{- File mode utilities.+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.FileMode where++import System.IO+import Control.Monad+import Control.Exception (bracket)+import System.PosixCompat.Types+import Utility.PosixFiles+#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]++otherGroupModes :: [FileMode]+otherGroupModes = +	[ groupReadMode, otherReadMode+	, groupWriteMode, otherWriteMode+	]++{- 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 otherGroupModes+		hPutStr h content
+ src/Utility/FileSystemEncoding.hs view
@@ -0,0 +1,132 @@+{- GHC File system encoding handling.+ -+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# 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
+ src/Utility/LinuxMkLibs.hs view
@@ -0,0 +1,61 @@+{- Linux library copier and binary shimmer+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++module Utility.LinuxMkLibs where++import Control.Applicative+import Data.Maybe+import System.Directory+import Data.List.Utils+import System.Posix.Files+import Data.Char+import Control.Monad.IfElse++import Utility.PartialPrelude+import Utility.Directory+import Utility.Process+import Utility.Monad+import Utility.Path++{- Installs a library. If the library is a symlink to another file,+ - install the file it links to, and update the symlink to be relative. -}+installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)+installLib installfile top lib = ifM (doesFileExist lib)+	( do+		installfile top lib+		checksymlink lib+		return $ Just $ parentDir lib+	, return Nothing+	)+  where+	checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do+		l <- readSymbolicLink (inTop top f)+		let absl = absPathFrom (parentDir f) l+		let target = relPathDirToFile (parentDir f) absl+		installfile top absl+		nukeFile (top ++ f)+		createSymbolicLink target (inTop top f)+		checksymlink absl++-- Note that f is not relative, so cannot use </>+inTop :: FilePath -> FilePath -> FilePath+inTop top f = top ++ f++{- Parse ldd output, getting all the libraries that the input files+ - link to. Note that some of the libraries may not exist + - (eg, linux-vdso.so) -}+parseLdd :: String -> [FilePath]+parseLdd = mapMaybe (getlib . dropWhile isSpace) . lines+  where+	getlib l = headMaybe . words =<< lastMaybe (split " => " l)++{- Get all glibc libs and other support files, including gconv files+ -+ - XXX Debian specific. -}+glibcLibs :: IO [FilePath]+glibcLibs = lines <$> readProcess "sh"+	["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]
+ src/Utility/Misc.hs view
@@ -0,0 +1,148 @@+{- misc utility functions+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# 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
+ src/Utility/Monad.hs view
@@ -0,0 +1,69 @@+{- monadic stuff+ -+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++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 ()
+ src/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]
+ src/Utility/Path.hs view
@@ -0,0 +1,293 @@+{- path manipulation+ -+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE PackageImports, CPP #-}++module Utility.Path where++import Data.String.Utils+import System.FilePath+import System.Directory+import Data.List+import Data.Maybe+import Data.Char+import Control.Applicative++#ifdef mingw32_HOST_OS+import qualified System.FilePath.Posix as Posix+#else+import System.Posix.Files+#endif++import qualified "MissingH" System.Path as MissingH+import Utility.Monad+import Utility.UserInfo++{- Simplifies a path, removing any ".." or ".", and removing the trailing+ - path separator.+ -+ - On Windows, preserves whichever style of path separator might be used in+ - the input FilePaths. This is done because some programs in Windows+ - demand a particular path separator -- and which one actually varies!+ -+ - This does not guarantee that two paths that refer to the same location,+ - and are both relative to the same location (or both absolute) will+ - yeild the same result. Run both through normalise from System.FilePath+ - to ensure that.+ -}+simplifyPath :: FilePath -> FilePath+simplifyPath path = dropTrailingPathSeparator $ +	joinDrive drive $ joinPath $ norm [] $ splitPath path'+  where+	(drive, path') = splitDrive path++	norm c [] = reverse c+	norm c (p:ps)+		| p' == ".." = norm (drop 1 c) ps+		| p' == "." = norm c ps+		| otherwise = norm (p:c) ps+	  where+		p' = dropTrailingPathSeparator p++{- Makes a path absolute.+ -+ - The first parameter is a base directory (ie, the cwd) to use if the path+ - is not already absolute.+ -+ - Does not attempt to deal with edge cases or ensure security with+ - untrusted inputs.+ -}+absPathFrom :: FilePath -> FilePath -> FilePath+absPathFrom dir path = simplifyPath (combine dir path)++{- On Windows, this converts the paths to unix-style, in order to run+ - MissingH's absNormPath on them. Resulting path will use / separators. -}+absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath+#ifndef mingw32_HOST_OS+absNormPathUnix dir path = MissingH.absNormPath dir path+#else+absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)+  where+	fromdos = replace "\\" "/"+	todos = replace "/" "\\"+#endif++{- Returns the parent directory of a path.+ -+ - To allow this to be easily used in loops, which terminate upon reaching the+ - top, the parent of / is "" -}+parentDir :: FilePath -> FilePath+parentDir dir+	| null dirs = ""+	| otherwise = joinDrive drive (join s $ init dirs)+  where+	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""+	(drive, path) = splitDrive dir+	dirs = filter (not . null) $ split s path+	s = [pathSeparator]++prop_parentDir_basics :: FilePath -> Bool+prop_parentDir_basics dir+	| null dir = True+	| dir == "/" = parentDir dir == ""+	| otherwise = p /= dir+  where+	p = parentDir dir++{- Checks if the first FilePath is, or could be said to contain the second.+ - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc+ - are all equivilant.+ -}+dirContains :: FilePath -> FilePath -> Bool+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'+  where+	a' = norm a+	b' = norm b+	norm = normalise . simplifyPath++{- Converts a filename into an absolute path.+ -+ - Unlike Directory.canonicalizePath, this does not require the path+ - already exists. -}+absPath :: FilePath -> IO FilePath+absPath file = do+	cwd <- getCurrentDirectory+	return $ absPathFrom cwd file++{- Constructs a relative path from the CWD to a file.+ -+ - For example, assuming CWD is /tmp/foo/bar:+ -    relPathCwdToFile "/tmp/foo" == ".."+ -    relPathCwdToFile "/tmp/foo/bar" == "" + -}+relPathCwdToFile :: FilePath -> IO FilePath+relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f++{- Constructs a relative path from a directory to a file.+ -+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).+ -}+relPathDirToFile :: FilePath -> FilePath -> FilePath+relPathDirToFile from to = join s $ dotdots ++ uncommon+  where+	s = [pathSeparator]+	pfrom = split s from+	pto = split s to+	common = map fst $ takeWhile same $ zip pfrom pto+	same (c,d) = c == d+	uncommon = drop numcommon pto+	dotdots = replicate (length pfrom - numcommon) ".."+	numcommon = length common++prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool+prop_relPathDirToFile_basics from to+	| from == to = null r+	| otherwise = not (null r)+  where+	r = relPathDirToFile from to ++prop_relPathDirToFile_regressionTest :: Bool+prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference+  where+	{- Two paths have the same directory component at the same+	 - location, but it's not really the same directory.+	 - Code used to get this wrong. -}+	same_dir_shortcurcuits_at_difference =+		relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])+			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])+				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]++{- Given an original list of paths, and an expanded list derived from it,+ - generates a list of lists, where each sublist corresponds to one of the+ - original paths. When the original path is a directory, any items+ - in the expanded list that are contained in that directory will appear in+ - its segment.+ -}+segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]+segmentPaths [] new = [new]+segmentPaths [_] new = [new] -- optimisation+segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest+  where+	(found, rest)=partition (l `dirContains`) new++{- This assumes that it's cheaper to call segmentPaths on the result,+ - than it would be to run the action separately with each path. In+ - the case of git file list commands, that assumption tends to hold.+ -}+runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]+runSegmentPaths a paths = segmentPaths paths <$> a paths++{- Converts paths in the home directory to use ~/ -}+relHome :: FilePath -> IO String+relHome path = do+	home <- myHomeDir+	return $ if dirContains home path+		then "~/" ++ relPathDirToFile home path+		else path++{- Checks if a command is available in PATH.+ -+ - The command may be fully-qualified, in which case, this succeeds as+ - long as it exists. -}+inPath :: String -> IO Bool+inPath command = isJust <$> searchPath command++{- Finds a command in PATH and returns the full path to it.+ -+ - The command may be fully qualified already, in which case it will+ - be returned if it exists.+ -}+searchPath :: String -> IO (Maybe FilePath)+searchPath command+	| isAbsolute command = check command+	| otherwise = getSearchPath >>= getM indir+  where+	indir d = check $ d </> command+	check f = firstM doesFileExist+#ifdef mingw32_HOST_OS+		[f, f ++ ".exe"]+#else+		[f]+#endif++{- Checks if a filename is a unix dotfile. All files inside dotdirs+ - count as dotfiles. -}+dotfile :: FilePath -> Bool+dotfile file+	| f == "." = False+	| f == ".." = False+	| f == "" = False+	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)+  where+	f = takeFileName file++{- Converts a DOS style path to a Cygwin style path. Only on Windows.+ - Any trailing '\' is preserved as a trailing '/' -}+toCygPath :: FilePath -> FilePath+#ifndef mingw32_HOST_OS+toCygPath = id+#else+toCygPath p+	| null drive = recombine parts+	| otherwise = recombine $ "/cygdrive" : driveletter drive : parts+  where+  	(drive, p') = splitDrive p+	parts = splitDirectories p'+  	driveletter = map toLower . takeWhile (/= ':')+	recombine = fixtrailing . Posix.joinPath+  	fixtrailing s+		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s+		| otherwise = s+#endif++{- Maximum size to use for a file in a specified directory.+ -+ - Many systems have a 255 byte limit to the name of a file, + - so that's taken as the max if the system has a larger limit, or has no+ - limit.+ -}+fileNameLengthLimit :: FilePath -> IO Int+#ifdef mingw32_HOST_OS+fileNameLengthLimit _ = return 255+#else+fileNameLengthLimit dir = do+	l <- fromIntegral <$> getPathVar dir FileNameLimit+	if l <= 0+		then return 255+		else return $ minimum [l, 255]+  where+#endif++{- Given a string that we'd like to use as the basis for FilePath, but that+ - was provided by a third party and is not to be trusted, returns the closest+ - sane FilePath.+ -+ - All spaces and punctuation and other wacky stuff are replaced+ - with '_', except for '.' "../" will thus turn into ".._", which is safe.+ -}+sanitizeFilePath :: String -> FilePath+sanitizeFilePath = map sanitize+  where+  	sanitize c+		| c == '.' = c+		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'+		| otherwise = c++{- Similar to splitExtensions, but knows that some things in FilePaths+ - after a dot are too long to be extensions. -}+splitShortExtensions :: FilePath -> (FilePath, [String])+splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"+splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])+splitShortExtensions' maxextension = go []+  where+	go c f+		| len > 0 && len <= maxextension && not (null base) = +			go (ext:c) base+		| otherwise = (f, c)+	  where+		(base, ext) = splitExtension f+		len = length ext
+ src/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>+ -+ - License: BSD-2-clause+ -}++{-# 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
+ src/Utility/Process.hs view
@@ -0,0 +1,353 @@+{- System.Process enhancements, including additional ways of running+ - processes, and logging.+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# 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,+	processHandle,+	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)+processTranscript' cmd opts environ input = do+#ifndef mingw32_HOST_OS+{- This implementation interleves stdout and stderr in exactly the order+ - the process writes them. -}+	(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+	writeinput input p+	transcript <- get++	ok <- checkSuccessProcess pid+	return (transcript, ok)+#else+{- This implementation for Windows puts stderr after stdout. -}+	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)+	writeinput input p+	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++	writeinput (Just s) p = do+		let inh = stdinHandle p+		unless (null s) $ do+			hPutStr inh s+			hFlush inh+		hClose inh+	writeinput Nothing _ = return ()++{- 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"++processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle+processHandle (_, _, _, pid) = pid++{- 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
+ src/Utility/QuickCheck.hs view
@@ -0,0 +1,52 @@+{- QuickCheck with additional instances+ -+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Utility.QuickCheck+	( module X+	, module Utility.QuickCheck+	) where++import Test.QuickCheck as X+import Data.Time.Clock.POSIX+import System.Posix.Types+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Applicative++instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where+	arbitrary = M.fromList <$> arbitrary++instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where+	arbitrary = S.fromList <$> arbitrary++{- Times before the epoch are excluded. -}+instance Arbitrary POSIXTime where+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral++instance Arbitrary EpochTime where+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral++{- Pids are never negative, or 0. -}+instance Arbitrary ProcessID where+	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)++{- Inodes are never negative. -}+instance Arbitrary FileID where+	arbitrary = nonNegative arbitrarySizedIntegral++{- File sizes are never negative. -}+instance Arbitrary FileOffset where+	arbitrary = nonNegative arbitrarySizedIntegral++nonNegative :: (Num a, Ord a) => Gen a -> Gen a+nonNegative g = g `suchThat` (>= 0)++positive :: (Num a, Ord a) => Gen a -> Gen a+positive g = g `suchThat` (> 0)
+ src/Utility/SafeCommand.hs view
@@ -0,0 +1,120 @@+{- safely running shell commands+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++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
+ src/Utility/Scheduled.hs view
@@ -0,0 +1,396 @@+{- scheduled activities+ - + - Copyright 2013-2014 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++module Utility.Scheduled (+	Schedule(..),+	Recurrance(..),+	ScheduledTime(..),+	NextTime(..),+	WeekDay,+	MonthDay,+	YearDay,+	nextTime,+	calcNextTime,+	startTime,+	fromSchedule,+	fromScheduledTime,+	toScheduledTime,+	fromRecurrance,+	toRecurrance,+	toSchedule,+	parseSchedule,+	prop_schedule_roundtrips,+	prop_past_sane,+) where++import Utility.Data+import Utility.QuickCheck+import Utility.PartialPrelude+import Utility.Misc++import Control.Applicative+import Data.List+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.Calendar+import Data.Time.Calendar.WeekDate+import Data.Time.Calendar.OrdinalDate+import Data.Tuple.Utils+import Data.Char++{- Some sort of scheduled event. -}+data Schedule = Schedule Recurrance ScheduledTime+  deriving (Eq, Read, Show, Ord)++data Recurrance+	= Daily+	| Weekly (Maybe WeekDay)+	| Monthly (Maybe MonthDay)+	| Yearly (Maybe YearDay)+	| Divisible Int Recurrance+	-- ^ Days, Weeks, or Months of the year evenly divisible by a number.+	-- (Divisible Year is years evenly divisible by a number.)+  deriving (Eq, Read, Show, Ord)++type WeekDay = Int+type MonthDay = Int+type YearDay = Int++data ScheduledTime+	= AnyTime+	| SpecificTime Hour Minute+  deriving (Eq, Read, Show, Ord)++type Hour = Int+type Minute = Int++-- | Next time a Schedule should take effect. The NextTimeWindow is used+-- when a Schedule is allowed to start at some point within the window.+data NextTime+	= NextTimeExactly LocalTime+	| NextTimeWindow LocalTime LocalTime+  deriving (Eq, Read, Show)++startTime :: NextTime -> LocalTime+startTime (NextTimeExactly t) = t+startTime (NextTimeWindow t _) = t++nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)+nextTime schedule lasttime = do+	now <- getCurrentTime+	tz <- getTimeZone now+	return $ calcNextTime schedule lasttime $ utcToLocalTime tz now++-- | Calculate the next time that fits a Schedule, based on the+-- last time it occurred, and the current time.+calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime+calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime+	| scheduledtime == AnyTime = do+		next <- findfromtoday True+		return $ case next of+			NextTimeWindow _ _ -> next+			NextTimeExactly t -> window (localDay t) (localDay t)+	| otherwise = NextTimeExactly . startTime <$> findfromtoday False+  where+  	findfromtoday anytime = findfrom recurrance afterday today+	  where+	  	today = localDay currenttime+		afterday = sameaslastrun || toolatetoday+		toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime+		sameaslastrun = lastrun == Just today+	lastrun = localDay <$> lasttime+	nexttime = case scheduledtime of+		AnyTime -> TimeOfDay 0 0 0+		SpecificTime h m -> TimeOfDay h m 0+	exactly d = NextTimeExactly $ LocalTime d nexttime+	window startd endd = NextTimeWindow+		(LocalTime startd nexttime)+		(LocalTime endd (TimeOfDay 23 59 0))+	findfrom r afterday candidate+		| ynum candidate > (ynum (localDay currenttime)) + 100 =+			-- avoid possible infinite recusion+			error $ "bug: calcNextTime did not find a time within 100 years to run " +++			show (schedule, lasttime, currenttime)+		| otherwise = findfromChecked r afterday candidate+	findfromChecked r afterday candidate = case r of+		Daily+			| afterday -> Just $ exactly $ addDays 1 candidate+			| otherwise -> Just $ exactly candidate+		Weekly Nothing+			| afterday -> skip 1+			| otherwise -> case (wday <$> lastrun, wday candidate) of+				(Nothing, _) -> Just $ window candidate (addDays 6 candidate)+				(Just old, curr)+					| old == curr -> Just $ window candidate (addDays 6 candidate)+					| otherwise -> skip 1+		Monthly Nothing+			| afterday -> skip 1+			| maybe True (candidate `oneMonthPast`) lastrun ->+				Just $ window candidate (endOfMonth candidate)+			| otherwise -> skip 1+		Yearly Nothing+			| afterday -> skip 1+			| maybe True (candidate `oneYearPast`) lastrun ->+				Just $ window candidate (endOfYear candidate)+			| otherwise -> skip 1+		Weekly (Just w)+			| w < 0 || w > maxwday -> Nothing+			| w == wday candidate -> if afterday+				then Just $ exactly $ addDays 7 candidate+				else Just $ exactly candidate+			| otherwise -> Just $ exactly $+				addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate+		Monthly (Just m)+			| m < 0 || m > maxmday -> Nothing+			-- TODO can be done more efficiently than recursing+			| m == mday candidate -> if afterday+				then skip 1+				else Just $ exactly candidate+			| otherwise -> skip 1+		Yearly (Just y)+			| y < 0 || y > maxyday -> Nothing+			| y == yday candidate -> if afterday+				then skip 365+				else Just $ exactly candidate+			| otherwise -> skip 1+		Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)+		Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)+		Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)+		Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing+		Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate+	  where+	  	skip n = findfrom r False (addDays n candidate)+	  	handlediv n r' getval mmax+			| n > 0 && maybe True (n <=) mmax =+				findfromwhere r' (divisible n . getval) afterday candidate+			| otherwise = Nothing+	findfromwhere r p afterday candidate+		| maybe True (p . getday) next = next+		| otherwise = maybe Nothing (findfromwhere r p True . getday) next+	  where+		next = findfrom r afterday candidate+		getday = localDay . startTime+	divisible n v = v `rem` n == 0++-- Check if the new Day occurs one month or more past the old Day.+oneMonthPast :: Day -> Day -> Bool+new `oneMonthPast` old = fromGregorian y (m+1) d <= new+  where+	(y,m,d) = toGregorian old++-- Check if the new Day occurs one year or more past the old Day.+oneYearPast :: Day -> Day -> Bool+new `oneYearPast` old = fromGregorian (y+1) m d <= new+  where+	(y,m,d) = toGregorian old++endOfMonth :: Day -> Day+endOfMonth day =+	let (y,m,_d) = toGregorian day+	in fromGregorian y m (gregorianMonthLength y m)++endOfYear :: Day -> Day+endOfYear day =+	let (y,_m,_d) = toGregorian day+	in endOfMonth (fromGregorian y maxmnum 1)++-- extracting various quantities from a Day+wday :: Day -> Int+wday = thd3 . toWeekDate+wnum :: Day -> Int+wnum = snd3 . toWeekDate+mday :: Day -> Int+mday = thd3 . toGregorian+mnum :: Day -> Int+mnum = snd3 . toGregorian+yday :: Day -> Int+yday = snd . toOrdinalDate+ynum :: Day -> Int+ynum = fromIntegral . fst . toOrdinalDate++-- Calendar max values.+maxyday :: Int+maxyday = 366 -- with leap days+maxwnum :: Int+maxwnum = 53 -- some years have more than 52+maxmday :: Int+maxmday = 31+maxmnum :: Int+maxmnum = 12+maxwday :: Int+maxwday = 7++fromRecurrance :: Recurrance -> String+fromRecurrance (Divisible n r) =+	fromRecurrance' (++ "s divisible by " ++ show n) r+fromRecurrance r = fromRecurrance' ("every " ++) r++fromRecurrance' :: (String -> String) -> Recurrance -> String+fromRecurrance' a Daily = a "day"+fromRecurrance' a (Weekly n) = onday n (a "week")+fromRecurrance' a (Monthly n) = onday n (a "month")+fromRecurrance' a (Yearly n) = onday n (a "year")+fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used++onday :: Maybe Int -> String -> String+onday (Just n) s = "on day " ++ show n ++ " of " ++ s+onday Nothing s = s++toRecurrance :: String -> Maybe Recurrance+toRecurrance s = case words s of+	("every":"day":[]) -> Just Daily+	("on":"day":sd:"of":"every":something:[]) -> withday sd something+	("every":something:[]) -> noday something+	("days":"divisible":"by":sn:[]) -> +		Divisible <$> getdivisor sn <*> pure Daily+	("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> +		Divisible+			<$> getdivisor sn+			<*> withday sd something+	("every":something:"divisible":"by":sn:[]) -> +		Divisible+			<$> getdivisor sn+			<*> noday something+	(something:"divisible":"by":sn:[]) -> +		Divisible+			<$> getdivisor sn+			<*> noday something+	_ -> Nothing+  where+	constructor "week" = Just Weekly+	constructor "month" = Just Monthly+	constructor "year" = Just Yearly+	constructor u+		| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u+		| otherwise = Nothing+  	withday sd u = do+		c <- constructor u+		d <- readish sd+		Just $ c (Just d)+	noday u = do+		c <- constructor u+		Just $ c Nothing+	getdivisor sn = do+		n <- readish sn+		if n > 0+			then Just n+			else Nothing++fromScheduledTime :: ScheduledTime -> String+fromScheduledTime AnyTime = "any time"+fromScheduledTime (SpecificTime h m) = +	show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm+  where+  	pad n s = take (n - length s) (repeat '0') ++ s+	(h', ampm)+		| h == 0 = (12, "AM")+		| h < 12 = (h, "AM")+		| h == 12 = (h, "PM")+		| otherwise = (h - 12, "PM")++toScheduledTime :: String -> Maybe ScheduledTime+toScheduledTime "any time" = Just AnyTime+toScheduledTime v = case words v of+	(s:ampm:[])+		| map toUpper ampm == "AM" ->+			go s h0+		| map toUpper ampm == "PM" ->+			go s (\h -> (h0 h) + 12)+		| otherwise -> Nothing+	(s:[]) -> go s id+	_ -> Nothing+  where+  	h0 h+		| h == 12 = 0+		| otherwise = h+  	go :: String -> (Int -> Int) -> Maybe ScheduledTime+	go s adjust =+		let (h, m) = separate (== ':') s+		in SpecificTime+			<$> (adjust <$> readish h)+			<*> if null m then Just 0 else readish m++fromSchedule :: Schedule -> String+fromSchedule (Schedule recurrance scheduledtime) = unwords+	[ fromRecurrance recurrance+	, "at"+	, fromScheduledTime scheduledtime+	]++toSchedule :: String -> Maybe Schedule+toSchedule = eitherToMaybe . parseSchedule++parseSchedule :: String -> Either String Schedule+parseSchedule s = do+	r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right+		(toRecurrance recurrance)+	t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right+		(toScheduledTime scheduledtime)+	Right $ Schedule r t+  where+	(rws, tws) = separate (== "at") (words s)+	recurrance = unwords rws+	scheduledtime = unwords tws++instance Arbitrary Schedule where+	arbitrary = Schedule <$> arbitrary <*> arbitrary++instance Arbitrary ScheduledTime where+	arbitrary = oneof+		[ pure AnyTime+		, SpecificTime +			<$> choose (0, 23)+			<*> choose (1, 59)+		]++instance Arbitrary Recurrance where+	arbitrary = oneof+		[ pure Daily+		, Weekly <$> arbday+		, Monthly <$> arbday+		, Yearly <$> arbday+		, Divisible+			<$> positive arbitrary+			<*> oneof -- no nested Divisibles+				[ pure Daily+				, Weekly <$> arbday+				, Monthly <$> arbday+				, Yearly <$> arbday+				]+		]+	  where+	  	arbday = oneof+			[ Just <$> nonNegative arbitrary+			, pure Nothing+			]++prop_schedule_roundtrips :: Schedule -> Bool+prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s++prop_past_sane :: Bool+prop_past_sane = and+	[ all (checksout oneMonthPast) (mplus1 ++ yplus1)+	, all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))+	, all (checksout oneYearPast) yplus1+	, all (not . (checksout oneYearPast)) (map swap yplus1)+	]+  where+	mplus1 =   -- new date               old date, 1+ months before it+		[ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)+		, (fromGregorian 2014 01 15, fromGregorian 2013 02 15)+		, (fromGregorian 2014 02 15, fromGregorian 2013 01 15)+		, (fromGregorian 2014 03 01, fromGregorian 2013 01 15)+		, (fromGregorian 2014 03 01, fromGregorian 2013 12 15)+		, (fromGregorian 2015 01 01, fromGregorian 2010 01 01)+		]+	yplus1 =   -- new date               old date, 1+ years before it+		[ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)+		, (fromGregorian 2014 01 15, fromGregorian 2013 01 14)+		, (fromGregorian 2022 12 31, fromGregorian 2000 01 01)+		]+	checksout cmp (new, old) = new `cmp` old+	swap (a,b) = (b,a)
+ src/Utility/ThreadScheduler.hs view
@@ -0,0 +1,75 @@+{- thread scheduling+ -+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2011 Bas van Dijk & Roel van Dijk+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.ThreadScheduler where++import Control.Monad+import Control.Concurrent+#ifndef mingw32_HOST_OS+import Control.Monad.IfElse+import System.Posix.IO+#endif+#ifndef mingw32_HOST_OS+import System.Posix.Signals+#ifndef __ANDROID__+import System.Posix.Terminal+#endif+#endif++newtype Seconds = Seconds { fromSeconds :: Int }+	deriving (Eq, Ord, Show)++type Microseconds = Integer++{- Runs an action repeatedly forever, sleeping at least the specified number+ - of seconds in between. -}+runEvery :: Seconds -> IO a -> IO a+runEvery n a = forever $ do+	threadDelaySeconds n+	a++threadDelaySeconds :: Seconds -> IO ()+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)++{- Like threadDelay, but not bounded by an Int.+ -+ - There is no guarantee that the thread will be rescheduled promptly when the+ - delay has expired, but the thread will never continue to run earlier than+ - specified.+ - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines+ - of code.+ -}+unboundDelay :: Microseconds -> IO ()+unboundDelay time = do+	let maxWait = min time $ toInteger (maxBound :: Int)+	threadDelay $ fromInteger maxWait+	when (maxWait /= time) $ unboundDelay (time - maxWait)++{- Pauses the main thread, letting children run until program termination. -}+waitForTermination :: IO ()+waitForTermination = do+#ifdef mingw32_HOST_OS+	runEvery (Seconds 600) $+		void getLine+#else+	lock <- newEmptyMVar+	let check sig = void $+		installHandler sig (CatchOnce $ putMVar lock ()) Nothing+	check softwareTermination+#ifndef __ANDROID__+	whenM (queryTerminal stdInput) $+		check keyboardSignal+#endif+	takeMVar lock+#endif++oneSecond :: Microseconds+oneSecond = 1000000
+ src/Utility/Tmp.hs view
@@ -0,0 +1,100 @@+{- Temporary files and directories.+ -+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# 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
+ src/Utility/UserInfo.hs view
@@ -0,0 +1,55 @@+{- user info+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.UserInfo (+	myHomeDir,+	myUserName,+	myUserGecos,+) where++import Control.Applicative+import System.PosixCompat++import Utility.Env++{- Current user's home directory.+ -+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}+myHomeDir :: IO FilePath+myHomeDir = myVal env homeDirectory+  where+#ifndef mingw32_HOST_OS+	env = ["HOME"]+#else+	env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin+#endif++{- Current user's user name. -}+myUserName :: IO String+myUserName = myVal env userName+  where+#ifndef mingw32_HOST_OS+	env = ["USER", "LOGNAME"]+#else+	env = ["USERNAME", "USER", "LOGNAME"]+#endif++myUserGecos :: IO String+#ifdef __ANDROID__+myUserGecos = return "" -- userGecos crashes on Android+#else+myUserGecos = myVal [] userGecos+#endif++myVal :: [String] -> (UserEntry -> String) -> IO String+myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars+  where+	check [] = return Nothing+	check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v+	getpwent = getUserEntryForID =<< getEffectiveUserID
+ src/config.hs view
@@ -0,0 +1,46 @@+-- This is the main configuration file for Propellor, and is used to build+-- the propellor program.++import Propellor+import Propellor.CmdLine+import Propellor.Property.Scheduled+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.Cron as Cron+--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++main :: IO ()+main = defaultMain hosts++-- The hosts propellor knows about.+-- Edit this to configure propellor!+hosts :: [Host]+hosts =+	[ host "mybox.example.com"+		& Apt.stdSourcesList Unstable+		& Apt.unattendedUpgrades+		& Apt.installed ["etckeeper"]+		& Apt.installed ["ssh"]+		& User.hasSomePassword "root"+		& Network.ipv6to4+		& File.dirExists "/var/www"+		& Docker.docked hosts "webserver"+		& Docker.garbageCollected `period` Daily+		& Cron.runPropellor "30 * * * *"++	-- A generic webserver in a Docker container.+	, Docker.container "webserver" "joeyh/debian-unstable"+		& Docker.publish "80:80"+		& Docker.volume "/var/www:/var/www"+		& Apt.serviceInstalledRunning "apache2"++	-- add more hosts here...+	--, host "foo.example.com" = ...+	]
+ src/wrapper.hs view
@@ -0,0 +1,93 @@+-- | Wrapper program for propellor distribution.+--+-- Distributions should install this program into PATH.+-- (Cabal builds it as dist/build/propellor.+--+-- This is not the propellor main program (that's config.hs)+--+-- This installs propellor's source into ~/.propellor,+-- uses it to build the real propellor program (if not already built),+-- and runs it.+-- +-- The source is either copied from /usr/src/propellor, or is cloned from+-- git over the network.++module Main where++import Utility.UserInfo+import Utility.Monad+import Utility.Process+import Utility.SafeCommand+import Utility.Directory++import Control.Monad+import Control.Monad.IfElse+import System.Directory+import System.FilePath+import System.Environment (getArgs)+import System.Exit+import System.Posix.Directory++srcdir :: FilePath+srcdir = "/usr/src/propellor"++-- Using the github mirror of the main propellor repo because+-- it is accessible over https for better security.+srcrepo :: String+srcrepo = "https://github.com/joeyh/propellor.git"++main :: IO ()+main = do+	args <- getArgs+	home <- myHomeDir+	let propellordir = home </> ".propellor"+	let propellorbin = propellordir </> "propellor"+	wrapper args propellordir propellorbin++wrapper :: [String] -> FilePath -> FilePath -> IO ()+wrapper args propellordir propellorbin = do+	unlessM (doesDirectoryExist propellordir) $+		makeRepo+	buildruncfg+  where+	chain = do+		(_, _, _, pid) <- createProcess (proc propellorbin args) +		exitWith =<< waitForProcess pid+	makeRepo = do+		putStrLn $ "Setting up your propellor repo in " ++ propellordir+		putStrLn ""+		ifM (doesDirectoryExist srcdir)+			( do+				void $ boolSystem "cp" [Param "-a", File srcdir, File propellordir]+				changeWorkingDirectory propellordir+				void $ boolSystem "git" [Param "init"]+				void $ boolSystem "git" [Param "add", Param "."]+				setuprepo True+			, do+				void $ boolSystem "git" [Param "clone", Param srcrepo, File propellordir] +				void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"]+				setuprepo False+			)+	setuprepo fromsrcdir = do+		changeWorkingDirectory propellordir+		whenM (doesDirectoryExist "privdata") $+			mapM_ nukeFile =<< dirContents "privdata"+		void $ boolSystem "git" [Param "commit", Param "--allow-empty", Param "--quiet", Param "-m", Param "setting up propellor git repository"]+		void $ boolSystem "git" [Param "remote", Param "add", Param "upstream", Param srcrepo]+		-- Connect synthetic git repo with upstream history so+		-- merging with upstream will work going forward.+		-- Note -s ours is used to avoid getting any divergent+		-- changes from upstream.+		when fromsrcdir $ do+			void $ boolSystem "git" [Param "fetch", Param "upstream"]+			version <- readProcess "dpkg-query" ["--showformat", "${Version}", "--show", "propellor"]+			void $ boolSystem "git" [Param "merge", Param "-s", Param "ours", Param version]+	buildruncfg = do+		changeWorkingDirectory propellordir+		ifM (boolSystem "make" [Param "build"])+			( do+				putStrLn ""+				putStrLn ""+				chain+			, error "Propellor build failed."+			)