diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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 Sat, 17 May 2014 16:42:55 -0400 + propellor (0.5.1) unstable; urgency=medium * Primary DNS servers now have allow-transfer automatically populated diff --git a/GPL b/GPL deleted file mode 100644 --- a/GPL +++ /dev/null @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - 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. - - - Copyright (C) - - 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 . - -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: - - Copyright (C) - 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 -. - - 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 -. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright 2014 Joey Hess 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. diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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: diff --git a/Propellor.hs b/Propellor.hs deleted file mode 100644 --- a/Propellor.hs +++ /dev/null @@ -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 - -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" diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs deleted file mode 100644 --- a/Propellor/Attr.hs +++ /dev/null @@ -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) diff --git a/Propellor/CmdLine.hs b/Propellor/CmdLine.hs deleted file mode 100644 --- a/Propellor/CmdLine.hs +++ /dev/null @@ -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 diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs deleted file mode 100644 --- a/Propellor/Engine.hs +++ /dev/null @@ -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 diff --git a/Propellor/Exception.hs b/Propellor/Exception.hs deleted file mode 100644 --- a/Propellor/Exception.hs +++ /dev/null @@ -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 diff --git a/Propellor/Message.hs b/Propellor/Message.hs deleted file mode 100644 --- a/Propellor/Message.hs +++ /dev/null @@ -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 diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs deleted file mode 100644 --- a/Propellor/PrivData.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property.hs b/Propellor/Property.hs deleted file mode 100644 --- a/Propellor/Property.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/Apache.hs b/Propellor/Property/Apache.hs deleted file mode 100644 --- a/Propellor/Property/Apache.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs deleted file mode 100644 --- a/Propellor/Property/Apt.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs deleted file mode 100644 --- a/Propellor/Property/Cmd.hs +++ /dev/null @@ -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) diff --git a/Propellor/Property/Cron.hs b/Propellor/Property/Cron.hs deleted file mode 100644 --- a/Propellor/Property/Cron.hs +++ /dev/null @@ -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" diff --git a/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs deleted file mode 100644 --- a/Propellor/Property/Dns.hs +++ /dev/null @@ -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 - diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs deleted file mode 100644 --- a/Propellor/Property/Docker.hs +++ /dev/null @@ -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: , 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 - diff --git a/Propellor/Property/Docker/Shim.hs b/Propellor/Property/Docker/Shim.hs deleted file mode 100644 --- a/Propellor/Property/Docker/Shim.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs deleted file mode 100644 --- a/Propellor/Property/File.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs deleted file mode 100644 --- a/Propellor/Property/Git.hs +++ /dev/null @@ -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 mbranch - ] diff --git a/Propellor/Property/Gpg.hs b/Propellor/Property/Gpg.hs deleted file mode 100644 --- a/Propellor/Property/Gpg.hs +++ /dev/null @@ -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" diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs deleted file mode 100644 --- a/Propellor/Property/Hostname.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/Network.hs b/Propellor/Property/Network.hs deleted file mode 100644 --- a/Propellor/Property/Network.hs +++ /dev/null @@ -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] diff --git a/Propellor/Property/Obnam.hs b/Propellor/Property/Obnam.hs deleted file mode 100644 --- a/Propellor/Property/Obnam.hs +++ /dev/null @@ -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-----" - ] diff --git a/Propellor/Property/OpenId.hs b/Propellor/Property/OpenId.hs deleted file mode 100644 --- a/Propellor/Property/OpenId.hs +++ /dev/null @@ -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" ] diff --git a/Propellor/Property/Postfix.hs b/Propellor/Property/Postfix.hs deleted file mode 100644 --- a/Propellor/Property/Postfix.hs +++ /dev/null @@ -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) - ] diff --git a/Propellor/Property/Reboot.hs b/Propellor/Property/Reboot.hs deleted file mode 100644 --- a/Propellor/Property/Reboot.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Propellor.Property.Reboot where - -import Propellor - -now :: Property -now = cmdProperty "reboot" [] - `describe` "reboot now" diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs deleted file mode 100644 --- a/Propellor/Property/Scheduled.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/Service.hs b/Propellor/Property/Service.hs deleted file mode 100644 --- a/Propellor/Property/Service.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs deleted file mode 100644 --- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ /dev/null @@ -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" - ) - ] diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs deleted file mode 100644 --- a/Propellor/Property/SiteSpecific/GitHome.hs +++ /dev/null @@ -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") diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs deleted file mode 100644 --- a/Propellor/Property/SiteSpecific/JoeySites.hs +++ /dev/null @@ -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 ++ "/" - , " " - , " 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" - , " " - ] - ] - 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/" - , " " - , " Options Indexes ExecCGI FollowSymlinks" - , " AllowOverride None" - , " AddHandler cgi-script .cgi" - , " DirectoryIndex index.cgi" - , " " - , "" - , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/" - , " " - , " SetHandler cgi-script" - , " Options ExecCGI" - , " " - ] - -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 - , " " - , " Options FollowSymLinks" - , " AllowOverride None" - , " " - , " " - , " Options Indexes FollowSymLinks ExecCGI" - , " AllowOverride None" - , " AddHandler cgi-script .cgi" - , " DirectoryIndex index.html index.cgi" - , " Order allow,deny" - , " allow from all" - , " " - ] - -apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile -apachecfg hn withssl middle - | withssl = vhost False ++ vhost True - | otherwise = vhost False - where - vhost ssl = - [ "" - , " 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" - , " " - , " " - , " Options Indexes MultiViews" - , " AllowOverride None" - , " Order allow,deny" - , " Allow from all" - , " " - , "" - ] - 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") diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs deleted file mode 100644 --- a/Propellor/Property/Ssh.hs +++ /dev/null @@ -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 diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs deleted file mode 100644 --- a/Propellor/Property/Sudo.hs +++ /dev/null @@ -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] diff --git a/Propellor/Property/Tor.hs b/Propellor/Property/Tor.hs deleted file mode 100644 --- a/Propellor/Property/Tor.hs +++ /dev/null @@ -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"] diff --git a/Propellor/Property/User.hs b/Propellor/Property/User.hs deleted file mode 100644 --- a/Propellor/Property/User.hs +++ /dev/null @@ -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 diff --git a/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs deleted file mode 100644 --- a/Propellor/SimpleSh.hs +++ /dev/null @@ -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 diff --git a/Propellor/Types.hs b/Propellor/Types.hs deleted file mode 100644 --- a/Propellor/Types.hs +++ /dev/null @@ -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) diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs deleted file mode 100644 --- a/Propellor/Types/Attr.hs +++ /dev/null @@ -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 diff --git a/Propellor/Types/Dns.hs b/Propellor/Types/Dns.hs deleted file mode 100644 --- a/Propellor/Types/Dns.hs +++ /dev/null @@ -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 diff --git a/Propellor/Types/OS.hs b/Propellor/Types/OS.hs deleted file mode 100644 --- a/Propellor/Types/OS.hs +++ /dev/null @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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` diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs deleted file mode 100644 --- a/Utility/Applicative.hs +++ /dev/null @@ -1,16 +0,0 @@ -{- applicative stuff - - - - Copyright 2012 Joey Hess - - - - 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 <$$> diff --git a/Utility/Data.hs b/Utility/Data.hs deleted file mode 100644 --- a/Utility/Data.hs +++ /dev/null @@ -1,17 +0,0 @@ -{- utilities for simple data types - - - - Copyright 2013 Joey Hess - - - - 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 diff --git a/Utility/Directory.hs b/Utility/Directory.hs deleted file mode 100644 --- a/Utility/Directory.hs +++ /dev/null @@ -1,135 +0,0 @@ -{- directory manipulation - - - - Copyright 2011-2014 Joey Hess - - - - 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 diff --git a/Utility/Env.hs b/Utility/Env.hs deleted file mode 100644 --- a/Utility/Env.hs +++ /dev/null @@ -1,81 +0,0 @@ -{- portable environment variables - - - - Copyright 2013 Joey Hess - - - - 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 diff --git a/Utility/Exception.hs b/Utility/Exception.hs deleted file mode 100644 --- a/Utility/Exception.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- Simple IO exception handling (and some more) - - - - Copyright 2011-2012 Joey Hess - - - - 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 diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs deleted file mode 100644 --- a/Utility/FileMode.hs +++ /dev/null @@ -1,157 +0,0 @@ -{- File mode utilities. - - - - Copyright 2010-2012 Joey Hess - - - - 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 diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs deleted file mode 100644 --- a/Utility/FileSystemEncoding.hs +++ /dev/null @@ -1,132 +0,0 @@ -{- GHC File system encoding handling. - - - - Copyright 2012-2014 Joey Hess - - - - 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 diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs deleted file mode 100644 --- a/Utility/LinuxMkLibs.hs +++ /dev/null @@ -1,61 +0,0 @@ -{- Linux library copier and binary shimmer - - - - Copyright 2013 Joey Hess - - - - 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'"] diff --git a/Utility/Misc.hs b/Utility/Misc.hs deleted file mode 100644 --- a/Utility/Misc.hs +++ /dev/null @@ -1,148 +0,0 @@ -{- misc utility functions - - - - Copyright 2010-2011 Joey Hess - - - - 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 diff --git a/Utility/Monad.hs b/Utility/Monad.hs deleted file mode 100644 --- a/Utility/Monad.hs +++ /dev/null @@ -1,69 +0,0 @@ -{- monadic stuff - - - - Copyright 2010-2012 Joey Hess - - - - 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 () diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs deleted file mode 100644 --- a/Utility/PartialPrelude.hs +++ /dev/null @@ -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] diff --git a/Utility/Path.hs b/Utility/Path.hs deleted file mode 100644 --- a/Utility/Path.hs +++ /dev/null @@ -1,293 +0,0 @@ -{- path manipulation - - - - Copyright 2010-2014 Joey Hess - - - - 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 diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs deleted file mode 100644 --- a/Utility/PosixFiles.hs +++ /dev/null @@ -1,33 +0,0 @@ -{- POSIX files (and compatablity wrappers). - - - - This is like System.PosixCompat.Files, except with a fixed rename. - - - - Copyright 2014 Joey Hess - - - - 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 diff --git a/Utility/Process.hs b/Utility/Process.hs deleted file mode 100644 --- a/Utility/Process.hs +++ /dev/null @@ -1,360 +0,0 @@ -{- System.Process enhancements, including additional ways of running - - processes, and logging. - - - - Copyright 2012 Joey Hess - - - - 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 diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs deleted file mode 100644 --- a/Utility/QuickCheck.hs +++ /dev/null @@ -1,52 +0,0 @@ -{- QuickCheck with additional instances - - - - Copyright 2012-2014 Joey Hess - - - - 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) diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs deleted file mode 100644 --- a/Utility/SafeCommand.hs +++ /dev/null @@ -1,120 +0,0 @@ -{- safely running shell commands - - - - Copyright 2010-2013 Joey Hess - - - - 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 diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs deleted file mode 100644 --- a/Utility/Scheduled.hs +++ /dev/null @@ -1,396 +0,0 @@ -{- scheduled activities - - - - Copyright 2013-2014 Joey Hess - - - - 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) diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs deleted file mode 100644 --- a/Utility/ThreadScheduler.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- thread scheduling - - - - Copyright 2012, 2013 Joey Hess - - 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 diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs deleted file mode 100644 --- a/Utility/Tmp.hs +++ /dev/null @@ -1,100 +0,0 @@ -{- Temporary files and directories. - - - - Copyright 2010-2013 Joey Hess - - - - 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 diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs deleted file mode 100644 --- a/Utility/UserInfo.hs +++ /dev/null @@ -1,55 +0,0 @@ -{- user info - - - - Copyright 2012 Joey Hess - - - - 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 diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -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" diff --git a/config.hs b/config.hs deleted file mode 100644 --- a/config.hs +++ /dev/null @@ -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" = ... - ] diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -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 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 Sat, 17 May 2014 16:42:55 -0400 + propellor (0.5.1) unstable; urgency=medium * Primary DNS servers now have allow-transfer automatically populated diff --git a/debian/copyright b/debian/copyright --- a/debian/copyright +++ b/debian/copyright @@ -3,9 +3,26 @@ Files: * Copyright: © 2010-2014 Joey Hess -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. diff --git a/debian/lintian-overrides b/debian/lintian-overrides --- a/debian/lintian-overrides +++ b/debian/lintian-overrides @@ -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 diff --git a/doc/README.mdwn b/doc/README.mdwn --- a/doc/README.mdwn +++ b/doc/README.mdwn @@ -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` diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -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 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 diff --git a/propellor.hs b/propellor.hs deleted file mode 100644 --- a/propellor.hs +++ /dev/null @@ -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." - ) diff --git a/src/Propellor.hs b/src/Propellor.hs new file mode 100644 --- /dev/null +++ b/src/Propellor.hs @@ -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 + +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" diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Attr.hs @@ -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) diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/CmdLine.hs @@ -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 diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Engine.hs @@ -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 diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Exception.hs @@ -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 diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Message.hs @@ -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 diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/PrivData.hs @@ -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 diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property.hs @@ -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 diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Apache.hs @@ -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 diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Apt.hs @@ -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 diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Cmd.hs @@ -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) diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Cron.hs @@ -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" diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Dns.hs @@ -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 + diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Docker.hs @@ -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: , 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 + diff --git a/src/Propellor/Property/Docker/Shim.hs b/src/Propellor/Property/Docker/Shim.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Docker/Shim.hs @@ -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 diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/File.hs @@ -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 diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Git.hs @@ -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 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" + ] diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Gpg.hs @@ -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" diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -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 + ] + ] + diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -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" + ] diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Hostname.hs @@ -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 diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Network.hs @@ -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] diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Obnam.hs @@ -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-----" + ] diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/OpenId.hs @@ -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" ] diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Postfix.hs @@ -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) + ] diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Reboot.hs @@ -0,0 +1,7 @@ +module Propellor.Property.Reboot where + +import Propellor + +now :: Property +now = cmdProperty "reboot" [] + `describe` "reboot now" diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Scheduled.hs @@ -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 diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Service.hs @@ -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 diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -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" diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -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") diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -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 ++ "/" + , " " + , " 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" + , " " + ] + ] + 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/" + , " " + , " Options Indexes ExecCGI FollowSymlinks" + , " AllowOverride None" + , " AddHandler cgi-script .cgi" + , " DirectoryIndex index.cgi" + , " " + , "" + , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/" + , " " + , " SetHandler cgi-script" + , " Options ExecCGI" + , " " + ] + +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 + , " " + , " Options FollowSymLinks" + , " AllowOverride None" + , " " + , " " + , " Options Indexes FollowSymLinks ExecCGI" + , " AllowOverride None" + , " AddHandler cgi-script .cgi" + , " DirectoryIndex index.html index.cgi" + , " Order allow,deny" + , " allow from all" + , " " + ] + +apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile +apachecfg hn withssl middle + | withssl = vhost False ++ vhost True + | otherwise = vhost False + where + vhost ssl = + [ "" + , " 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" + , " " + , " " + , " Options Indexes MultiViews" + , " AllowOverride None" + , " Order allow,deny" + , " Allow from all" + , " " + , "" + ] + 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" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Ssh.hs @@ -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 + ] diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Sudo.hs @@ -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] diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Tor.hs @@ -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"] diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/User.hs @@ -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 diff --git a/src/Propellor/SimpleSh.hs b/src/Propellor/SimpleSh.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/SimpleSh.hs @@ -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 diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types.hs @@ -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) diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/Attr.hs @@ -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 diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/Dns.hs @@ -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 diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Types/OS.hs @@ -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 diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Applicative.hs @@ -0,0 +1,16 @@ +{- applicative stuff + - + - Copyright 2012 Joey Hess + - + - 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 <$$> diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Data.hs @@ -0,0 +1,17 @@ +{- utilities for simple data types + - + - Copyright 2013 Joey Hess + - + - 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 diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Directory.hs @@ -0,0 +1,135 @@ +{- directory manipulation + - + - Copyright 2011-2014 Joey Hess + - + - 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 diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Env.hs @@ -0,0 +1,81 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess + - + - 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 diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Exception.hs @@ -0,0 +1,59 @@ +{- Simple IO exception handling (and some more) + - + - Copyright 2011-2012 Joey Hess + - + - 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 diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs new file mode 100644 --- /dev/null +++ b/src/Utility/FileMode.hs @@ -0,0 +1,158 @@ +{- File mode utilities. + - + - Copyright 2010-2012 Joey Hess + - + - 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 diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Utility/FileSystemEncoding.hs @@ -0,0 +1,132 @@ +{- GHC File system encoding handling. + - + - Copyright 2012-2014 Joey Hess + - + - 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 diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs new file mode 100644 --- /dev/null +++ b/src/Utility/LinuxMkLibs.hs @@ -0,0 +1,61 @@ +{- Linux library copier and binary shimmer + - + - Copyright 2013 Joey Hess + - + - 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'"] diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Misc.hs @@ -0,0 +1,148 @@ +{- misc utility functions + - + - Copyright 2010-2011 Joey Hess + - + - 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 diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Monad.hs @@ -0,0 +1,69 @@ +{- monadic stuff + - + - Copyright 2010-2012 Joey Hess + - + - 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 () diff --git a/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs new file mode 100644 --- /dev/null +++ b/src/Utility/PartialPrelude.hs @@ -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] diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Path.hs @@ -0,0 +1,293 @@ +{- path manipulation + - + - Copyright 2010-2014 Joey Hess + - + - 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 diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs new file mode 100644 --- /dev/null +++ b/src/Utility/PosixFiles.hs @@ -0,0 +1,33 @@ +{- POSIX files (and compatablity wrappers). + - + - This is like System.PosixCompat.Files, except with a fixed rename. + - + - Copyright 2014 Joey Hess + - + - 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 diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Process.hs @@ -0,0 +1,353 @@ +{- System.Process enhancements, including additional ways of running + - processes, and logging. + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Utility/QuickCheck.hs @@ -0,0 +1,52 @@ +{- QuickCheck with additional instances + - + - Copyright 2012-2014 Joey Hess + - + - 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) diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs new file mode 100644 --- /dev/null +++ b/src/Utility/SafeCommand.hs @@ -0,0 +1,120 @@ +{- safely running shell commands + - + - Copyright 2010-2013 Joey Hess + - + - 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 diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Scheduled.hs @@ -0,0 +1,396 @@ +{- scheduled activities + - + - Copyright 2013-2014 Joey Hess + - + - 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) diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs new file mode 100644 --- /dev/null +++ b/src/Utility/ThreadScheduler.hs @@ -0,0 +1,75 @@ +{- thread scheduling + - + - Copyright 2012, 2013 Joey Hess + - 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 diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Tmp.hs @@ -0,0 +1,100 @@ +{- Temporary files and directories. + - + - Copyright 2010-2013 Joey Hess + - + - 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 diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs new file mode 100644 --- /dev/null +++ b/src/Utility/UserInfo.hs @@ -0,0 +1,55 @@ +{- user info + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/src/config.hs b/src/config.hs new file mode 100644 --- /dev/null +++ b/src/config.hs @@ -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" = ... + ] diff --git a/src/wrapper.hs b/src/wrapper.hs new file mode 100644 --- /dev/null +++ b/src/wrapper.hs @@ -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." + )