summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore9
l---------CHANGELOG1
-rw-r--r--GPL674
-rw-r--r--Makefile41
-rw-r--r--Propellor.hs77
-rw-r--r--Propellor/Attr.hs111
-rw-r--r--Propellor/CmdLine.hs359
-rw-r--r--Propellor/Engine.hs37
-rw-r--r--Propellor/Exception.hs18
-rw-r--r--Propellor/Message.hs51
-rw-r--r--Propellor/PrivData.hs91
-rw-r--r--Propellor/Property.hs163
-rw-r--r--Propellor/Property/Apache.hs62
-rw-r--r--Propellor/Property/Apt.hs244
-rw-r--r--Propellor/Property/Cmd.hs49
-rw-r--r--Propellor/Property/Cron.hs49
-rw-r--r--Propellor/Property/Dns.hs374
-rw-r--r--Propellor/Property/Docker.hs459
-rw-r--r--Propellor/Property/Docker/Shim.hs61
-rw-r--r--Propellor/Property/File.hs94
-rw-r--r--Propellor/Property/Git.hs89
-rw-r--r--Propellor/Property/Gpg.hs41
-rw-r--r--Propellor/Property/Hostname.hs33
-rw-r--r--Propellor/Property/Network.hs30
-rw-r--r--Propellor/Property/Obnam.hs155
-rw-r--r--Propellor/Property/OpenId.hs29
-rw-r--r--Propellor/Property/Postfix.hs25
-rw-r--r--Propellor/Property/Reboot.hs7
-rw-r--r--Propellor/Property/Scheduled.hs67
-rw-r--r--Propellor/Property/Service.hs31
-rw-r--r--Propellor/Property/SiteSpecific/GitAnnexBuilder.hs57
-rw-r--r--Propellor/Property/SiteSpecific/GitHome.hs34
-rw-r--r--Propellor/Property/SiteSpecific/JoeySites.hs270
-rw-r--r--Propellor/Property/Ssh.hs152
-rw-r--r--Propellor/Property/Sudo.hs32
-rw-r--r--Propellor/Property/Tor.hs19
-rw-r--r--Propellor/Property/User.hs61
-rw-r--r--Propellor/SimpleSh.hs97
-rw-r--r--Propellor/Types.hs153
-rw-r--r--Propellor/Types/Attr.hs48
-rw-r--r--Propellor/Types/Dns.hs80
-rw-r--r--Propellor/Types/OS.hs27
-rw-r--r--README.md105
-rw-r--r--Setup.hs5
-rw-r--r--TODO26
-rw-r--r--Utility/Applicative.hs16
-rw-r--r--Utility/Data.hs17
-rw-r--r--Utility/Directory.hs135
-rw-r--r--Utility/Env.hs81
-rw-r--r--Utility/Exception.hs59
-rw-r--r--Utility/FileMode.hs157
-rw-r--r--Utility/FileSystemEncoding.hs132
-rw-r--r--Utility/LinuxMkLibs.hs61
-rw-r--r--Utility/Misc.hs148
-rw-r--r--Utility/Monad.hs69
-rw-r--r--Utility/PartialPrelude.hs68
-rw-r--r--Utility/Path.hs293
-rw-r--r--Utility/PosixFiles.hs33
-rw-r--r--Utility/Process.hs360
-rw-r--r--Utility/QuickCheck.hs52
-rw-r--r--Utility/SafeCommand.hs120
-rw-r--r--Utility/Scheduled.hs396
-rw-r--r--Utility/ThreadScheduler.hs73
-rw-r--r--Utility/Tmp.hs100
-rw-r--r--Utility/UserInfo.hs55
-rw-r--r--config-joey.hs301
-rw-r--r--config-simple.hs47
l---------config.hs1
-rw-r--r--debian/README.Debian7
-rw-r--r--debian/changelog97
-rw-r--r--debian/compat1
-rw-r--r--debian/control40
-rw-r--r--debian/copyright11
-rw-r--r--debian/lintian-overrides3
-rw-r--r--debian/propellor.115
-rwxr-xr-xdebian/rules14
-rw-r--r--privdata/clam.kitenet.net.gpg33
-rw-r--r--privdata/darkstar.kitenet.net.gpg22
-rw-r--r--privdata/diatom.kitenet.net.gpg343
-rw-r--r--privdata/keyring.gpgbin0 -> 113014 bytes
-rw-r--r--privdata/orca.kitenet.net.gpg22
-rw-r--r--propellor.cabal131
-rw-r--r--propellor.hs91
83 files changed, 8301 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 00000000..e9925509
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,9 @@
+dist/*
+propellor
+tags
+privdata/local
+privdata/keyring.gpg~
+Setup
+Setup.hi
+Setup.o
+docker
diff --git a/CHANGELOG b/CHANGELOG
new file mode 120000
index 00000000..d526672c
--- /dev/null
+++ b/CHANGELOG
@@ -0,0 +1 @@
+debian/changelog \ No newline at end of file
diff --git a/GPL b/GPL
new file mode 100644
index 00000000..94a9ed02
--- /dev/null
+++ b/GPL
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ <program> Copyright (C) <year> <name of author>
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<http://www.gnu.org/licenses/>.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
diff --git a/Makefile b/Makefile
new file mode 100644
index 00000000..e53de8c5
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,41 @@
+CABAL?=cabal
+
+run: deps build
+ ./propellor
+
+dev: build tags
+
+build: dist/setup-config
+ if ! $(CABAL) build; then $(CABAL) configure; $(CABAL) build; fi
+ ln -sf dist/build/config/config propellor
+
+deps:
+ @if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-quickcheck2-dev libghc-mtl-dev libghc-monadcatchio-transformers-dev; fi || true
+ @if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install libghc-async-dev || cabal update; cabal install async; fi || true
+
+dist/setup-config: propellor.cabal
+ if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi
+ $(CABAL) configure
+
+install:
+ install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor
+ install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin
+ $(CABAL) sdist
+ cat dist/propellor-*.tar.gz | \
+ (cd $(DESTDIR)/usr/src/propellor && tar zx --strip-components=1)
+
+clean:
+ rm -rf dist Setup tags propellor propellor-wrapper privdata/local
+ find -name \*.o -exec rm {} \;
+ find -name \*.hi -exec rm {} \;
+
+# hothasktags chokes on some template haskell etc, so ignore errors
+tags:
+ find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null
+
+# Upload to hackage.
+hackage:
+ @cabal sdist
+ @cabal upload dist/*.tar.gz
+
+.PHONY: tags
diff --git a/Propellor.hs b/Propellor.hs
new file mode 100644
index 00000000..e6312248
--- /dev/null
+++ b/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 <git://git.kitenet.net/propellor>
+
+module Propellor (
+ module Propellor.Types
+ , module Propellor.Property
+ , module Propellor.Property.Cmd
+ , module Propellor.Attr
+ , module Propellor.PrivData
+ , module Propellor.Engine
+ , module Propellor.Exception
+ , module Propellor.Message
+ , localdir
+
+ , module X
+) where
+
+import Propellor.Types
+import Propellor.Property
+import Propellor.Engine
+import Propellor.Property.Cmd
+import Propellor.PrivData
+import Propellor.Message
+import Propellor.Exception
+import Propellor.Attr
+
+import Utility.PartialPrelude as X
+import Utility.Process as X
+import Utility.Exception as X
+import Utility.Env as X
+import Utility.Directory as X
+import Utility.Tmp as X
+import Utility.Monad as X
+import Utility.Misc as X
+
+import System.Directory as X
+import System.IO as X
+import System.FilePath as X
+import Data.Maybe as X
+import Data.Either as X
+import Control.Applicative as X
+import Control.Monad as X
+import Data.Monoid as X
+import Control.Monad.IfElse as X
+import "mtl" Control.Monad.Reader as X
+
+-- | This is where propellor installs itself when deploying a host.
+localdir :: FilePath
+localdir = "/usr/local/propellor"
diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
new file mode 100644
index 00000000..acaf28db
--- /dev/null
+++ b/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 (confType conf, confType <$> 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
new file mode 100644
index 00000000..5be91c4f
--- /dev/null
+++ b/Propellor/CmdLine.hs
@@ -0,0 +1,359 @@
+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 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.
+sshCachingParams :: HostName -> IO [CommandParam]
+sshCachingParams hn = do
+ home <- myHomeDir
+ let cachedir = home </> ".ssh" </> "propellor"
+ createDirectoryIfMissing False cachedir
+ let socketfile = cachedir </> hn ++ ".sock"
+ return
+ [ Param "-o", Param ("ControlPath=" ++ socketfile)
+ , Params "-o ControlMaster=auto -o ControlPersist=yes"
+ ]
diff --git a/Propellor/Engine.hs b/Propellor/Engine.hs
new file mode 100644
index 00000000..55ce7f77
--- /dev/null
+++ b/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/Propellor/Exception.hs b/Propellor/Exception.hs
new file mode 100644
index 00000000..f6fd15f1
--- /dev/null
+++ b/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/Propellor/Message.hs b/Propellor/Message.hs
new file mode 100644
index 00000000..780471c3
--- /dev/null
+++ b/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/Propellor/PrivData.hs b/Propellor/PrivData.hs
new file mode 100644
index 00000000..ad2c8d22
--- /dev/null
+++ b/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/Propellor/Property.hs b/Propellor/Property.hs
new file mode 100644
index 00000000..24494654
--- /dev/null
+++ b/Propellor/Property.hs
@@ -0,0 +1,163 @@
+{-# 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
new file mode 100644
index 00000000..cf3e62cc
--- /dev/null
+++ b/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/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
new file mode 100644
index 00000000..9234cbbf
--- /dev/null
+++ b/Propellor/Property/Apt.hs
@@ -0,0 +1,244 @@
+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"
+ 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"
+
+-- | 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
new file mode 100644
index 00000000..bcd08246
--- /dev/null
+++ b/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/Propellor/Property/Cron.hs b/Propellor/Property/Cron.hs
new file mode 100644
index 00000000..5b070eff
--- /dev/null
+++ b/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/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs
new file mode 100644
index 00000000..73d427c0
--- /dev/null
+++ b/Propellor/Property/Dns.hs
@@ -0,0 +1,374 @@
+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.
+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, warnings) = 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 warnings
+ satisfy
+ conf = NamedConf
+ { confDomain = domain
+ , confType = Master
+ , confFile = zonefile
+ , confMasters = []
+ , confLines = []
+ }
+ 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 masters hosts domain
+ where
+ masters = M.keys $ M.filter ismaster $ hostAttrMap hosts
+ ismaster attr = case M.lookup domain (_namedconf attr) of
+ Nothing -> False
+ Just conf -> confType conf == Master && confDomain conf == 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
+ , confType = Secondary
+ , confFile = "db." ++ domain
+ , confMasters = concatMap (\m -> hostAddresses m hosts) masters
+ , confLines = ["allow-transfer { }"]
+ }
+
+-- | 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
+ `requires` Apt.serviceInstalledRunning "bind9"
+ `onChange` Service.reloaded "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 confType c == Master then "master" else "slave")
+ , cfgline "file" ("\"" ++ confFile c ++ "\"")
+ ] ++
+ (if null (confMasters c) then [] else mastersblock) ++
+ (map (\l -> "\t" ++ l ++ ";") (confLines c)) ++
+ [ "};"
+ , ""
+ ]
+ where
+ cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
+ mastersblock =
+ [ "\tmasters {" ] ++
+ (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") (confMasters c)) ++
+ [ "\t};" ]
+
+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
new file mode 100644
index 00000000..e5b8d64a
--- /dev/null
+++ b/Propellor/Property/Docker.hs
@@ -0,0 +1,459 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | Docker support for propellor
+--
+-- The existance of a docker container is just another Property of a system,
+-- which propellor can set up. See config.hs for an example.
+
+module Propellor.Property.Docker where
+
+import Propellor
+import Propellor.SimpleSh
+import Propellor.Types.Attr
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Docker.Shim as Shim
+import Utility.SafeCommand
+import Utility.Path
+
+import Control.Concurrent.Async
+import System.Posix.Directory
+import System.Posix.Process
+import Data.List
+import Data.List.Utils
+
+-- | Configures docker with an authentication file, so that images can be
+-- pushed to index.docker.io.
+configured :: Property
+configured = property "docker configured" go `requires` installed
+ where
+ go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $
+ "/root/.dockercfg" `File.hasContent` (lines cfg)
+
+installed :: Property
+installed = Apt.installed ["docker.io"]
+
+-- | A short descriptive name for a container.
+-- Should not contain whitespace or other unusual characters,
+-- only [a-zA-Z0-9_-] are allowed
+type ContainerName = String
+
+-- | Starts accumulating the properties of a Docker container.
+--
+-- > container "web-server" "debian"
+-- > & publish "80:80"
+-- > & Apt.installed {"apache2"]
+-- > & ...
+container :: ContainerName -> Image -> Host
+container cn image = Host [] (\_ -> attr)
+ where
+ attr = (newAttr (cn2hn cn)) { _dockerImage = Just image }
+
+cn2hn :: ContainerName -> HostName
+cn2hn cn = cn ++ ".docker"
+
+-- | Ensures that a docker container is set up and running. The container
+-- has its own Properties which are handled by running propellor
+-- inside the container.
+--
+-- Reverting this property ensures that the container is stopped and
+-- removed.
+docked
+ :: [Host]
+ -> ContainerName
+ -> RevertableProperty
+docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
+ where
+ go desc a = property (desc ++ " " ++ cn) $ do
+ hn <- getHostName
+ let cid = ContainerId hn cn
+ ensureProperties [findContainer hosts cid cn $ a cid]
+
+ setup cid (Container image runparams) =
+ provisionContainer cid
+ `requires`
+ runningContainer cid image runparams
+ `requires`
+ installed
+
+ teardown cid (Container image _runparams) =
+ combineProperties ("undocked " ++ fromContainerId cid)
+ [ stoppedContainer cid
+ , property ("cleaned up " ++ fromContainerId cid) $
+ liftIO $ report <$> mapM id
+ [ removeContainer cid
+ , removeImage image
+ ]
+ ]
+
+findContainer
+ :: [Host]
+ -> ContainerId
+ -> ContainerName
+ -> (Container -> Property)
+ -> Property
+findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
+ Nothing -> cantfind
+ Just h -> maybe cantfind mk (mkContainer cid h)
+ where
+ cantfind = containerDesc cid $ property "" $ do
+ liftIO $ warningMessage $
+ "missing definition for docker container \"" ++ cn2hn cn
+ return FailedChange
+
+mkContainer :: ContainerId -> Host -> Maybe Container
+mkContainer cid@(ContainerId hn _cn) h = Container
+ <$> _dockerImage attr
+ <*> pure (map (\a -> a hn) (_dockerRunParams attr))
+ where
+ attr = hostAttr h'
+ h' = h
+ -- expose propellor directory inside the container
+ & volume (localdir++":"++localdir)
+ -- name the container in a predictable way so we
+ -- and the user can easily find it later
+ & name (fromContainerId cid)
+
+-- | Causes *any* docker images that are not in use by running containers to
+-- be deleted. And deletes any containers that propellor has set up
+-- before that are not currently running. Does not delete any containers
+-- that were not set up using propellor.
+--
+-- Generally, should come after the properties for the desired containers.
+garbageCollected :: Property
+garbageCollected = propertyList "docker garbage collected"
+ [ gccontainers
+ , gcimages
+ ]
+ where
+ gccontainers = property "docker containers garbage collected" $
+ liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
+ gcimages = property "docker images garbage collected" $ do
+ liftIO $ report <$> (mapM removeImage =<< listImages)
+
+data Container = Container Image [RunParam]
+
+-- | Parameters to pass to `docker run` when creating a container.
+type RunParam = String
+
+-- | A docker image, that can be used to run a container.
+type Image = String
+
+-- | Set custom dns server for container.
+dns :: String -> Property
+dns = runProp "dns"
+
+-- | Set container host name.
+hostname :: String -> Property
+hostname = runProp "hostname"
+
+-- | Set name for container. (Normally done automatically.)
+name :: String -> Property
+name = runProp "name"
+
+-- | Publish a container's port to the host
+-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
+publish :: String -> Property
+publish = runProp "publish"
+
+-- | Username or UID for container.
+user :: String -> Property
+user = runProp "user"
+
+-- | Mount a volume
+-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro]
+-- With just a directory, creates a volume in the container.
+volume :: String -> Property
+volume = runProp "volume"
+
+-- | Mount a volume from the specified container into the current
+-- container.
+volumes_from :: ContainerName -> Property
+volumes_from cn = genProp "volumes-from" $ \hn ->
+ fromContainerId (ContainerId hn cn)
+
+-- | Work dir inside the container.
+workdir :: String -> Property
+workdir = runProp "workdir"
+
+-- | Memory limit for container.
+--Format: <number><optional unit>, where unit = b, k, m or g
+memory :: String -> Property
+memory = runProp "memory"
+
+-- | Link with another container on the same host.
+link :: ContainerName -> ContainerAlias -> Property
+link linkwith calias = genProp "link" $ \hn ->
+ fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
+
+-- | A short alias for a linked container.
+-- Each container has its own alias namespace.
+type ContainerAlias = String
+
+-- | A container is identified by its name, and the host
+-- on which it's deployed.
+data ContainerId = ContainerId HostName ContainerName
+ deriving (Eq, Read, Show)
+
+-- | Two containers with the same ContainerIdent were started from
+-- the same base image (possibly a different version though), and
+-- with the same RunParams.
+data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam]
+ deriving (Read, Show, Eq)
+
+ident2id :: ContainerIdent -> ContainerId
+ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn
+
+toContainerId :: String -> Maybe ContainerId
+toContainerId s
+ | myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of
+ (cn, hn)
+ | null hn || null cn -> Nothing
+ | otherwise -> Just $ ContainerId hn cn
+ | otherwise = Nothing
+ where
+ desuffix = reverse . drop len . reverse
+ len = length myContainerSuffix
+
+fromContainerId :: ContainerId -> String
+fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
+
+containerHostName :: ContainerId -> HostName
+containerHostName (ContainerId _ cn) = cn2hn cn
+
+myContainerSuffix :: String
+myContainerSuffix = ".propellor"
+
+containerDesc :: ContainerId -> Property -> Property
+containerDesc cid p = p `describe` desc
+ where
+ desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p
+
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property
+runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
+ l <- liftIO $ listContainers RunningContainers
+ if cid `elem` l
+ then do
+ -- Check if the ident has changed; if so the
+ -- parameters of the container differ and it must
+ -- be restarted.
+ runningident <- liftIO $ getrunningident
+ if runningident == Just ident
+ then noChange
+ else do
+ void $ liftIO $ stopContainer cid
+ restartcontainer
+ else ifM (liftIO $ elem cid <$> listContainers AllContainers)
+ ( restartcontainer
+ , go image
+ )
+ where
+ ident = ContainerIdent image hn cn runps
+
+ restartcontainer = do
+ oldimage <- liftIO $ fromMaybe image <$> commitContainer cid
+ void $ liftIO $ removeContainer cid
+ go oldimage
+
+ getrunningident :: IO (Maybe ContainerIdent)
+ getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do
+ let !v = extractident rs
+ return v
+
+ extractident :: [Resp] -> Maybe ContainerIdent
+ extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout
+
+ go img = do
+ liftIO $ do
+ clearProvisionedFlag cid
+ createDirectoryIfMissing True (takeDirectory $ identFile cid)
+ shim <- liftIO $ Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)
+ liftIO $ writeFile (identFile cid) (show ident)
+ ensureProperty $ boolProperty "run" $ runContainer img
+ (runps ++ ["-i", "-d", "-t"])
+ [shim, "--docker", fromContainerId cid]
+
+-- | Called when propellor is running inside a docker container.
+-- The string should be the container's ContainerId.
+--
+-- This process is effectively init inside the container.
+-- It even needs to wait on zombie processes!
+--
+-- Fork a thread to run the SimpleSh server in the background.
+-- In the foreground, run an interactive bash (or sh) shell,
+-- so that the user can interact with it when attached to the container.
+--
+-- When the system reboots, docker restarts the container, and this is run
+-- again. So, to make the necessary services get started on boot, this needs
+-- to provision the container then. However, if the container is already
+-- being provisioned by the calling propellor, it would be redundant and
+-- problimatic to also provisoon it here.
+--
+-- The solution is a flag file. If the flag file exists, then the container
+-- was already provisioned. So, it must be a reboot, and time to provision
+-- again. If the flag file doesn't exist, don't provision here.
+chain :: String -> IO ()
+chain s = case toContainerId s of
+ Nothing -> error $ "Invalid ContainerId: " ++ s
+ Just cid -> do
+ changeWorkingDirectory localdir
+ writeFile propellorIdent . show =<< readIdentFile cid
+ -- Run boot provisioning before starting simpleSh,
+ -- to avoid ever provisioning twice at the same time.
+ whenM (checkProvisionedFlag cid) $ do
+ let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+ unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $
+ warningMessage "Boot provision failed!"
+ void $ async $ job reapzombies
+ void $ async $ job $ simpleSh $ namedPipe cid
+ job $ do
+ void $ tryIO $ ifM (inPath "bash")
+ ( boolSystem "bash" [Param "-l"]
+ , boolSystem "/bin/sh" []
+ )
+ putStrLn "Container is still running. Press ^P^Q to detach."
+ where
+ job = forever . void . tryIO
+ reapzombies = void $ getAnyProcessStatus True False
+
+-- | Once a container is running, propellor can be run inside
+-- it to provision it.
+--
+-- Note that there is a race here, between the simplesh
+-- server starting up in the container, and this property
+-- being run. So, retry connections to the client for up to
+-- 1 minute.
+provisionContainer :: ContainerId -> Property
+provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do
+ let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
+ r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
+ when (r /= FailedChange) $
+ setProvisionedFlag cid
+ return r
+ where
+ params = ["--continue", show $ Chain $ containerHostName cid]
+
+ go lastline (v:rest) = case v of
+ StdoutLine s -> do
+ debug ["stdout: ", show s]
+ maybe noop putStrLn lastline
+ hFlush stdout
+ go (Just s) rest
+ StderrLine s -> do
+ debug ["stderr: ", show s]
+ maybe noop putStrLn lastline
+ hFlush stdout
+ hPutStrLn stderr s
+ hFlush stderr
+ go Nothing rest
+ Done -> ret lastline
+ go lastline [] = ret lastline
+
+ ret lastline = return $ fromMaybe FailedChange $
+ readish =<< lastline
+
+stopContainer :: ContainerId -> IO Bool
+stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
+
+stoppedContainer :: ContainerId -> Property
+stoppedContainer cid = containerDesc cid $ property desc $
+ ifM (liftIO $ elem cid <$> listContainers RunningContainers)
+ ( liftIO cleanup `after` ensureProperty
+ (boolProperty desc $ stopContainer cid)
+ , return NoChange
+ )
+ where
+ desc = "stopped"
+ cleanup = do
+ nukeFile $ namedPipe cid
+ nukeFile $ identFile cid
+ removeDirectoryRecursive $ shimdir cid
+ clearProvisionedFlag cid
+
+removeContainer :: ContainerId -> IO Bool
+removeContainer cid = catchBoolIO $
+ snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing
+
+removeImage :: Image -> IO Bool
+removeImage image = catchBoolIO $
+ snd <$> processTranscript dockercmd ["rmi", image ] Nothing
+
+runContainer :: Image -> [RunParam] -> [String] -> IO Bool
+runContainer image ps cmd = boolSystem dockercmd $ map Param $
+ "run" : (ps ++ image : cmd)
+
+commitContainer :: ContainerId -> IO (Maybe Image)
+commitContainer cid = catchMaybeIO $
+ takeWhile (/= '\n')
+ <$> readProcess dockercmd ["commit", fromContainerId cid]
+
+data ContainerFilter = RunningContainers | AllContainers
+ deriving (Eq)
+
+-- | Only lists propellor managed containers.
+listContainers :: ContainerFilter -> IO [ContainerId]
+listContainers status =
+ catMaybes . map toContainerId . concat . map (split ",")
+ . catMaybes . map (lastMaybe . words) . lines
+ <$> readProcess dockercmd ps
+ where
+ ps
+ | status == AllContainers = baseps ++ ["--all"]
+ | otherwise = baseps
+ baseps = ["ps", "--no-trunc"]
+
+listImages :: IO [Image]
+listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
+
+runProp :: String -> RunParam -> Property
+runProp field val = pureAttrProperty (param) $ \attr ->
+ attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
+ where
+ param = field++"="++val
+
+genProp :: String -> (HostName -> RunParam) -> Property
+genProp field mkval = pureAttrProperty field $ \attr ->
+ attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
+
+-- | The ContainerIdent of a container is written to
+-- /.propellor-ident inside it. This can be checked to see if
+-- the container has the same ident later.
+propellorIdent :: FilePath
+propellorIdent = "/.propellor-ident"
+
+-- | Named pipe used for communication with the container.
+namedPipe :: ContainerId -> FilePath
+namedPipe cid = "docker" </> fromContainerId cid
+
+provisionedFlag :: ContainerId -> FilePath
+provisionedFlag cid = "docker" </> fromContainerId cid ++ ".provisioned"
+
+clearProvisionedFlag :: ContainerId -> IO ()
+clearProvisionedFlag = nukeFile . provisionedFlag
+
+setProvisionedFlag :: ContainerId -> IO ()
+setProvisionedFlag cid = do
+ createDirectoryIfMissing True (takeDirectory (provisionedFlag cid))
+ writeFile (provisionedFlag cid) "1"
+
+checkProvisionedFlag :: ContainerId -> IO Bool
+checkProvisionedFlag = doesFileExist . provisionedFlag
+
+shimdir :: ContainerId -> FilePath
+shimdir cid = "docker" </> fromContainerId cid ++ ".shim"
+
+identFile :: ContainerId -> FilePath
+identFile cid = "docker" </> fromContainerId cid ++ ".ident"
+
+readIdentFile :: ContainerId -> IO ContainerIdent
+readIdentFile cid = fromMaybe (error "bad ident in identFile")
+ . readish <$> readFile (identFile cid)
+
+dockercmd :: String
+dockercmd = "docker.io"
+
+report :: [Bool] -> Result
+report rmed
+ | or rmed = MadeChange
+ | otherwise = NoChange
+
diff --git a/Propellor/Property/Docker/Shim.hs b/Propellor/Property/Docker/Shim.hs
new file mode 100644
index 00000000..c2f35d0c
--- /dev/null
+++ b/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/Propellor/Property/File.hs b/Propellor/Property/File.hs
new file mode 100644
index 00000000..0b060177
--- /dev/null
+++ b/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/Propellor/Property/Git.hs b/Propellor/Property/Git.hs
new file mode 100644
index 00000000..ba370e51
--- /dev/null
+++ b/Propellor/Property/Git.hs
@@ -0,0 +1,89 @@
+module Propellor.Property.Git where
+
+import Propellor
+import Propellor.Property.File
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Service as Service
+import Utility.SafeCommand
+
+import Data.List
+
+-- | Exports all git repos in a directory (that user nobody can read)
+-- using git-daemon, run from inetd.
+--
+-- Note that reverting this property does not remove or stop inetd.
+daemonRunning :: FilePath -> RevertableProperty
+daemonRunning exportdir = RevertableProperty setup unsetup
+ where
+ setup = containsLine conf (mkl "tcp4")
+ `requires`
+ containsLine conf (mkl "tcp6")
+ `requires`
+ dirExists exportdir
+ `requires`
+ Apt.serviceInstalledRunning "openbsd-inetd"
+ `onChange`
+ Service.running "openbsd-inetd"
+ `describe` ("git-daemon exporting " ++ exportdir)
+ unsetup = lacksLine conf (mkl "tcp4")
+ `requires`
+ lacksLine conf (mkl "tcp6")
+ `onChange`
+ Service.reloaded "openbsd-inetd"
+
+ conf = "/etc/inetd.conf"
+
+ mkl tcpv = intercalate "\t"
+ [ "git"
+ , "stream"
+ , tcpv
+ , "nowait"
+ , "nobody"
+ , "/usr/bin/git"
+ , "git"
+ , "daemon"
+ , "--inetd"
+ , "--export-all"
+ , "--base-path=" ++ exportdir
+ , exportdir
+ ]
+
+installed :: Property
+installed = Apt.installed ["git"]
+
+type RepoUrl = String
+
+type Branch = String
+
+-- | Specified git repository is cloned to the specified directory.
+--
+-- If the firectory exists with some other content, it will be recursively
+-- deleted.
+--
+-- A branch can be specified, to check out.
+cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
+cloned owner url dir mbranch = check originurl (property desc checkout)
+ `requires` installed
+ where
+ desc = "git cloned " ++ url ++ " to " ++ dir
+ gitconfig = dir </> ".git/config"
+ originurl = ifM (doesFileExist gitconfig)
+ ( do
+ v <- catchDefaultIO Nothing $ headMaybe . lines <$>
+ readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"]
+ return (v /= Just url)
+ , return True
+ )
+ checkout = do
+ liftIO $ do
+ whenM (doesDirectoryExist dir) $
+ removeDirectoryRecursive dir
+ createDirectoryIfMissing True (takeDirectory dir)
+ ensureProperty $ userScriptProperty owner $ catMaybes
+ -- The </dev/null fixes an intermittent
+ -- "fatal: read error: Bad file descriptor"
+ -- when run across ssh with propellor --spin
+ [ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"
+ , Just $ "cd " ++ shellEscape dir
+ , ("git checkout " ++) <$> mbranch
+ ]
diff --git a/Propellor/Property/Gpg.hs b/Propellor/Property/Gpg.hs
new file mode 100644
index 00000000..64ea9fea
--- /dev/null
+++ b/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/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
new file mode 100644
index 00000000..031abb9d
--- /dev/null
+++ b/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
+ `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
new file mode 100644
index 00000000..6009778a
--- /dev/null
+++ b/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/Propellor/Property/Obnam.hs b/Propellor/Property/Obnam.hs
new file mode 100644
index 00000000..32374b57
--- /dev/null
+++ b/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/Propellor/Property/OpenId.hs b/Propellor/Property/OpenId.hs
new file mode 100644
index 00000000..051d6425
--- /dev/null
+++ b/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/Propellor/Property/Postfix.hs b/Propellor/Property/Postfix.hs
new file mode 100644
index 00000000..9fa4a2c3
--- /dev/null
+++ b/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/Propellor/Property/Reboot.hs b/Propellor/Property/Reboot.hs
new file mode 100644
index 00000000..25e53159
--- /dev/null
+++ b/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/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs
new file mode 100644
index 00000000..f2911e50
--- /dev/null
+++ b/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/Propellor/Property/Service.hs b/Propellor/Property/Service.hs
new file mode 100644
index 00000000..14e769d0
--- /dev/null
+++ b/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/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
new file mode 100644
index 00000000..677aa760
--- /dev/null
+++ b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -0,0 +1,57 @@
+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
new file mode 100644
index 00000000..6ed02146
--- /dev/null
+++ b/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/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs
new file mode 100644
index 00000000..b43d83f8
--- /dev/null
+++ b/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -0,0 +1,270 @@
+-- | Specific configuation for Joey Hess's sites. Probably not useful to
+-- others except as an example.
+
+module Propellor.Property.SiteSpecific.JoeySites where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Gpg as Gpg
+import qualified Propellor.Property.Ssh as Ssh
+import qualified Propellor.Property.Git as Git
+import qualified Propellor.Property.Cron as Cron
+import qualified Propellor.Property.Service as Service
+import qualified Propellor.Property.User as User
+import qualified Propellor.Property.Obnam as Obnam
+import qualified Propellor.Property.Apache as Apache
+import Utility.SafeCommand
+
+import Data.List
+import System.Posix.Files
+
+oldUseNetServer :: [Host] -> Property
+oldUseNetServer hosts = propertyList ("olduse.net server")
+ [ oldUseNetInstalled "oldusenet-server"
+ , Obnam.latestVersion
+ , Obnam.backup datadir "33 4 * * *"
+ [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
+ , "--client-name=spool"
+ ] Obnam.OnlyClient
+ `requires` Ssh.keyImported SshRsa "root"
+ `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
+ , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $
+ property "olduse.net spool in place" $ makeChange $ do
+ removeDirectoryRecursive newsspool
+ createSymbolicLink (datadir </> "news") newsspool
+ , Apt.installed ["leafnode"]
+ , "/etc/news/leafnode/config" `File.hasContent`
+ [ "# olduse.net configuration (deployed by propellor)"
+ , "expire = 1000000" -- no expiry via texpire
+ , "server = " -- no upstream server
+ , "debugmode = 1"
+ , "allowSTRANGERS = 42" -- lets anyone connect
+ , "nopost = 1" -- no new posting (just gather them)
+ ]
+ , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL"
+ , Apt.serviceInstalledRunning "openbsd-inetd"
+ , File.notPresent "/etc/cron.daily/leafnode"
+ , File.notPresent "/etc/cron.d/leafnode"
+ , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";"
+ [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm"
+ , "find -type d -empty | xargs --no-run-if-empty rmdir"
+ ]
+ , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $
+ "/usr/bin/uucp " ++ datadir
+ , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False
+ [ " DocumentRoot " ++ datadir ++ "/"
+ , " <Directory " ++ datadir ++ "/>"
+ , " Options Indexes FollowSymlinks"
+ , " AllowOverride None"
+ -- I had this in the file before.
+ -- This may be needed by a newer version of apache?
+ --, " Require all granted"
+ , " </Directory>"
+ ]
+ ]
+ where
+ newsspool = "/var/spool/news"
+ datadir = "/var/spool/oldusenet"
+
+oldUseNetShellBox :: Property
+oldUseNetShellBox = oldUseNetInstalled "oldusenet"
+
+oldUseNetInstalled :: Apt.Package -> Property
+oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
+ propertyList ("olduse.net " ++ pkg)
+ [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
+ `describe` "olduse.net build deps"
+ , scriptProperty
+ [ "rm -rf /root/tmp/oldusenet" -- idenpotency
+ , "git clone git://olduse.net/ /root/tmp/oldusenet/source"
+ , "cd /root/tmp/oldusenet/source/"
+ , "dpkg-buildpackage -us -uc"
+ , "dpkg -i ../" ++ pkg ++ "_*.deb || true"
+ , "apt-get -fy install" -- dependencies
+ , "rm -rf /root/tmp/oldusenet"
+ ] `describe` "olduse.net built"
+ ]
+
+
+kgbServer :: Property
+kgbServer = withOS desc $ \o -> case o of
+ (Just (System (Debian Unstable) _)) ->
+ ensureProperty $ propertyList desc
+ [ Apt.serviceInstalledRunning "kgb-bot"
+ , File.hasPrivContent "/etc/kgb-bot/kgb.conf"
+ `onChange` Service.restarted "kgb-bot"
+ , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
+ `describe` "kgb bot enabled"
+ `onChange` Service.running "kgb-bot"
+ ]
+ _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
+ where
+ desc = "kgb.kitenet.net setup"
+
+-- git.kitenet.net and git.joeyh.name
+gitServer :: [Host] -> Property
+gitServer hosts = propertyList "git.kitenet.net setup"
+ [ Obnam.latestVersion
+ , Obnam.backup "/srv/git" "33 3 * * *"
+ [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
+ , "--encrypt-with=1B169BE1"
+ , "--client-name=wren"
+ ] Obnam.OnlyClient
+ `requires` Gpg.keyImported "1B169BE1" "root"
+ `requires` Ssh.keyImported SshRsa "root"
+ `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
+ `requires` Ssh.authorizedKeys "family"
+ `requires` User.accountFor "family"
+ , Apt.installed ["git", "rsync", "kgb-client-git", "gitweb"]
+ , Apt.installedBackport ["git-annex"]
+ , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf"
+ , toProp $ Git.daemonRunning "/srv/git"
+ , "/etc/gitweb.conf" `File.containsLines`
+ [ "$projectroot = '/srv/git';"
+ , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"
+ , "# disable snapshot download; overloads server"
+ , "$feature{'snapshot'}{'default'} = [];"
+ ]
+ `describe` "gitweb configured"
+ -- Repos push on to github.
+ , Ssh.knownHost hosts "github.com" "joey"
+ -- I keep the website used for gitweb checked into git..
+ , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
+ , website "git.kitenet.net"
+ , website "git.joeyh.name"
+ , toProp $ Apache.modEnabled "cgi"
+ ]
+ where
+ website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True
+ [ " DocumentRoot /srv/web/git.kitenet.net/"
+ , " <Directory /srv/web/git.kitenet.net/>"
+ , " Options Indexes ExecCGI FollowSymlinks"
+ , " AllowOverride None"
+ , " AddHandler cgi-script .cgi"
+ , " DirectoryIndex index.cgi"
+ , " </Directory>"
+ , ""
+ , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"
+ , " <Directory /usr/lib/cgi-bin>"
+ , " SetHandler cgi-script"
+ , " Options ExecCGI"
+ , " </Directory>"
+ ]
+
+type AnnexUUID = String
+
+-- | A website, with files coming from a git-annex repository.
+annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property
+annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex")
+ [ Git.cloned "joey" origin dir Nothing
+ `onChange` setup
+ , setupapache
+ ]
+ where
+ dir = "/srv/web/" ++ hn
+ setup = userScriptProperty "joey" setupscript
+ `requires` Ssh.keyImported SshRsa "joey"
+ `requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey"
+ setupscript =
+ [ "cd " ++ shellEscape dir
+ , "git config annex.uuid " ++ shellEscape uuid
+ ] ++ map addremote remotes ++
+ [ "git annex get"
+ ]
+ addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url
+ setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $
+ [ " ServerAlias www."++hn
+ , ""
+ , " DocumentRoot /srv/web/"++hn
+ , " <Directory /srv/web/"++hn++">"
+ , " Options FollowSymLinks"
+ , " AllowOverride None"
+ , " </Directory>"
+ , " <Directory /srv/web/"++hn++">"
+ , " Options Indexes FollowSymLinks ExecCGI"
+ , " AllowOverride None"
+ , " AddHandler cgi-script .cgi"
+ , " DirectoryIndex index.html index.cgi"
+ , " Order allow,deny"
+ , " allow from all"
+ , " </Directory>"
+ ]
+
+apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
+apachecfg hn withssl middle
+ | withssl = vhost False ++ vhost True
+ | otherwise = vhost False
+ where
+ vhost ssl =
+ [ "<VirtualHost *:"++show port++">"
+ , " ServerAdmin grue@joeyh.name"
+ , " ServerName "++hn++":"++show port
+ ]
+ ++ mainhttpscert ssl
+ ++ middle ++
+ [ ""
+ , " ErrorLog /var/log/apache2/error.log"
+ , " LogLevel warn"
+ , " CustomLog /var/log/apache2/access.log combined"
+ , " ServerSignature On"
+ , " "
+ , " <Directory \"/usr/share/apache2/icons\">"
+ , " Options Indexes MultiViews"
+ , " AllowOverride None"
+ , " Order allow,deny"
+ , " Allow from all"
+ , " </Directory>"
+ , "</VirtualHost>"
+ ]
+ where
+ port = if ssl then 443 else 80 :: Int
+
+mainhttpscert :: Bool -> Apache.ConfigFile
+mainhttpscert False = []
+mainhttpscert True =
+ [ " SSLEngine on"
+ , " SSLCertificateFile /etc/ssl/certs/web.pem"
+ , " SSLCertificateKeyFile /etc/ssl/private/web.pem"
+ , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
+ ]
+
+
+annexRsyncServer :: Property
+annexRsyncServer = combineProperties "rsync server for git-annex autobuilders"
+ [ 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"
+ ]
+ 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
new file mode 100644
index 00000000..a4f87678
--- /dev/null
+++ b/Propellor/Property/Ssh.hs
@@ -0,0 +1,152 @@
+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
new file mode 100644
index 00000000..68b56608
--- /dev/null
+++ b/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/Propellor/Property/Tor.hs b/Propellor/Property/Tor.hs
new file mode 100644
index 00000000..78e35c89
--- /dev/null
+++ b/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/Propellor/Property/User.hs b/Propellor/Property/User.hs
new file mode 100644
index 00000000..eef2a57e
--- /dev/null
+++ b/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/Propellor/SimpleSh.hs b/Propellor/SimpleSh.hs
new file mode 100644
index 00000000..7e0f19ff
--- /dev/null
+++ b/Propellor/SimpleSh.hs
@@ -0,0 +1,97 @@
+-- | 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
+ hSetBuffering h LineBuffering
+ 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)
+ 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
+ hSetBuffering h LineBuffering
+ hPutStrLn h $ show $ Cmd cmd params
+ 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
new file mode 100644
index 00000000..22df9ddb
--- /dev/null
+++ b/Propellor/Types.hs
@@ -0,0 +1,153 @@
+{-# 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
new file mode 100644
index 00000000..8b7d3b09
--- /dev/null
+++ b/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/Propellor/Types/Dns.hs b/Propellor/Types/Dns.hs
new file mode 100644
index 00000000..9b2ad1e7
--- /dev/null
+++ b/Propellor/Types/Dns.hs
@@ -0,0 +1,80 @@
+module Propellor.Types.Dns where
+
+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
+ , confType :: Type
+ , confFile :: FilePath
+ , confMasters :: [IPAddr]
+ , confLines :: [String]
+ }
+ deriving (Show, Eq, Ord)
+
+data Type = 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
+
+-- | 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)
diff --git a/Propellor/Types/OS.hs b/Propellor/Types/OS.hs
new file mode 100644
index 00000000..23cc8a29
--- /dev/null
+++ b/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/README.md b/README.md
new file mode 100644
index 00000000..b870c9ec
--- /dev/null
+++ b/README.md
@@ -0,0 +1,105 @@
+This is a configuration management system using Haskell and Git.
+
+Propellor enures that the system it's run against satisfies a list of
+properties, taking action as necessary when a property is not yet met.
+
+Propellor is configured via a git repository, which typically lives
+in ~/.propellor/. The git repository contains a config.hs file,
+and also the entire source code to propellor.
+
+You typically want to have the repository checked out on a laptop, in order
+to make changes and push them out to hosts. Each host will also have a
+clone of the repository, and in that clone "make" can be used to build and
+run propellor. This can be done by a cron job (which propellor can set up),
+or a remote host can be triggered to update by running propellor on your
+laptop: propellor --spin $host
+
+Properties are defined using Haskell. Edit config.hs to get started.
+For API documentation, see <http://hackage.haskell.org/package/propellor/>
+
+There is no special language as used in puppet, chef, ansible, etc.. just
+the full power of Haskell. Hopefully that power can be put to good use in
+making declarative properties that are powerful, nicely idempotent, and
+easy to adapt to a system's special needs.
+
+Also avoided is any form of node classification. Ie, which hosts are part
+of which classes and share which configuration. It might be nice to use
+reclass[1], but then again a host is configured using simply haskell code,
+and so it's easy to factor out things like classes of hosts as desired.
+
+## quick start
+
+1. Get propellor installed
+ `cabal install propellor`
+ or
+ `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
+ 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`
+8. Now you have a simple propellor deployment, but it doesn't do
+ much to the host yet, besides installing propellor.
+
+ So, edit `~/.propellor/config.hs` to configure the host (maybe
+ start with a few simple properties), and re-run step 7.
+ Repeat until happy and move on to the next host. :)
+9. To move beyond manually running `propellor --spin` against hosts
+ when you change their properties, add a property to your hosts
+ like: `Cron.runPropellor "30 * * * *"`
+
+ Now they'll automatically update every 30 minutes, and you can
+ `git commit -S` and `git push` changes that affect any number of
+ hosts.
+10. Write some neat new properties and send patches to <propellor@joeyh.name>!
+
+## security
+
+Propellor's security model is that the hosts it's used to deploy are
+untrusted, and that the central git repository server is untrusted too.
+
+The only trusted machine is the laptop where you run `propellor --spin`
+to connect to a remote host. And that one only because you have a ssh key
+or login password to the host.
+
+Since the hosts propellor deploys are not trusted by the central git
+repository, they have to use git:// or http:// to pull from the central
+git repository, rather than ssh://.
+
+So, to avoid a MITM attack, propellor checks that any commit it fetches
+from origin is gpg signed by a trusted gpg key, and refuses to deploy it
+otherwise.
+
+That is only done when privdata/keyring.gpg exists. To set it up:
+
+ gpg --gen-key # only if you don't already have a gpg key
+ propellor --add-key $MYKEYID
+
+In order to be secure from the beginning, when `propellor --spin` is used
+to bootstrap propellor on a new host, it transfers the local git repositry
+to the remote host over ssh. After that, the remote host knows the
+gpg key, and will use it to verify git fetches.
+
+Since the propoellor git repository is public, you can't store
+in cleartext private data such as passwords, ssh private keys, etc.
+
+Instead, `propellor --spin $host` looks for a
+`~/.propellor/privdata/$host.gpg` file and if found decrypts it and sends
+it to the remote host using ssh. This lets a remote host know its own
+private data, without seeing all the rest.
+
+To securely store private data, use: `propellor --set $host $field`
+The field name will be something like 'Password "root"'; see PrivData.hs
+for available fields.
+
+## debugging
+
+Set `PROPELLOR_DEBUG=1` to make propellor print out all the commands it runs
+and any other debug messages that Properties choose to emit.
+
+[1] http://reclass.pantsfullofunix.net/
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 00000000..daf5717a
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,5 @@
+{- cabal setup file -}
+
+import Distribution.Simple
+
+main = defaultMain
diff --git a/TODO b/TODO
new file mode 100644
index 00000000..85875a9d
--- /dev/null
+++ b/TODO
@@ -0,0 +1,26 @@
+* Need a way to run an action when a property changes, but only
+ run it once for the whole. For example, may want to restart apache,
+ but only once despite many config changes being made to satisfy
+ properties. onChange is a poor substitute.
+* Display of docker container properties is a bit wonky. It always
+ says they are unchanged even when they changed and triggered a
+ reprovision.
+* Should properties be a tree rather than a list?
+* Need a way for a dns server host to look at the properties of
+ the other hosts and generate a zone file. For example, mapping
+ openid.kitenet.net to a CNAME to clam.kitenet.net, which is where
+ the docker container for that service is located. Moving containers
+ to a different host, or duplicating a container on multiple hosts
+ would then update DNS too
+* There is no way for a property of a docker container to require
+ some property be met outside the container. For example, some servers
+ need ntp installed for a good date source.
+* Docking a container in a host should add to the host any cnames that
+ are assigned to the container.
+* Either `Ssh.hostKey` should set the sshPubKey attr
+ (which seems hard, as attrs need to be able to be calculated without
+ running any IO code, and here IO is needed along with decrypting the
+ PrivData..), or the public key should not be stored in
+ the PrivData, and instead configured using the attr.
+ Getting the ssh host key into the attr will allow automatically
+ exporting it via DNS (SSHFP record)
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs
new file mode 100644
index 00000000..64400c80
--- /dev/null
+++ b/Utility/Applicative.hs
@@ -0,0 +1,16 @@
+{- applicative stuff
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Applicative where
+
+{- Like <$> , but supports one level of currying.
+ -
+ - foo v = bar <$> action v == foo = bar <$$> action
+ -}
+(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b
+f <$$> v = fmap f . v
+infixr 4 <$$>
diff --git a/Utility/Data.hs b/Utility/Data.hs
new file mode 100644
index 00000000..35925829
--- /dev/null
+++ b/Utility/Data.hs
@@ -0,0 +1,17 @@
+{- utilities for simple data types
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Data where
+
+{- First item in the list that is not Nothing. -}
+firstJust :: Eq a => [Maybe a] -> Maybe a
+firstJust ms = case dropWhile (== Nothing) ms of
+ [] -> Nothing
+ (md:_) -> md
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe = either (const Nothing) Just
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
new file mode 100644
index 00000000..f1bcfada
--- /dev/null
+++ b/Utility/Directory.hs
@@ -0,0 +1,135 @@
+{- directory manipulation
+ -
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Directory where
+
+import System.IO.Error
+import System.Directory
+import Control.Exception (throw)
+import Control.Monad
+import Control.Monad.IfElse
+import System.FilePath
+import Control.Applicative
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+import Utility.PosixFiles
+import Utility.SafeCommand
+import Utility.Tmp
+import Utility.Exception
+import Utility.Monad
+import Utility.Applicative
+
+dirCruft :: FilePath -> Bool
+dirCruft "." = True
+dirCruft ".." = True
+dirCruft _ = False
+
+{- Lists the contents of a directory.
+ - Unlike getDirectoryContents, paths are not relative to the directory. -}
+dirContents :: FilePath -> IO [FilePath]
+dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
+
+{- Gets files in a directory, and then its subdirectories, recursively,
+ - and lazily.
+ -
+ - Does not follow symlinks to other subdirectories.
+ -
+ - When the directory does not exist, no exception is thrown,
+ - instead, [] is returned. -}
+dirContentsRecursive :: FilePath -> IO [FilePath]
+dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir
+
+{- Skips directories whose basenames match the skipdir. -}
+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
+dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
+ where
+ go [] = return []
+ go (dir:dirs)
+ | skipdir (takeFileName dir) = go dirs
+ | otherwise = unsafeInterleaveIO $ do
+ (files, dirs') <- collect [] []
+ =<< catchDefaultIO [] (dirContents dir)
+ files' <- go (dirs' ++ dirs)
+ return (files ++ files')
+ collect files dirs' [] = return (reverse files, reverse dirs')
+ collect files dirs' (entry:entries)
+ | dirCruft entry = collect files dirs' entries
+ | otherwise = do
+ let skip = collect (entry:files) dirs' entries
+ let recurse = collect files (entry:dirs') entries
+ ms <- catchMaybeIO $ getSymbolicLinkStatus entry
+ case ms of
+ (Just s)
+ | isDirectory s -> recurse
+ | isSymbolicLink s && followsubdirsymlinks ->
+ ifM (doesDirectoryExist entry)
+ ( recurse
+ , skip
+ )
+ _ -> skip
+
+{- Gets the directory tree from a point, recursively and lazily,
+ - with leaf directories **first**, skipping any whose basenames
+ - match the skipdir. Does not follow symlinks. -}
+dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
+dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
+ where
+ go c [] = return c
+ go c (dir:dirs)
+ | skipdir (takeFileName dir) = go c dirs
+ | otherwise = unsafeInterleaveIO $ do
+ subdirs <- go c
+ =<< filterM (isDirectory <$$> getSymbolicLinkStatus)
+ =<< catchDefaultIO [] (dirContents dir)
+ go (subdirs++[dir]) dirs
+
+{- Moves one filename to another.
+ - First tries a rename, but falls back to moving across devices if needed. -}
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile src dest = tryIO (rename src dest) >>= onrename
+ where
+ onrename (Right _) = noop
+ onrename (Left e)
+ | isPermissionError e = rethrow
+ | isDoesNotExistError e = rethrow
+ | otherwise = do
+ -- copyFile is likely not as optimised as
+ -- the mv command, so we'll use the latter.
+ -- But, mv will move into a directory if
+ -- dest is one, which is not desired.
+ whenM (isdir dest) rethrow
+ viaTmp mv dest undefined
+ where
+ rethrow = throw e
+ mv tmp _ = do
+ ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
+ unless ok $ do
+ -- delete any partial
+ _ <- tryIO $ removeFile tmp
+ rethrow
+
+ isdir f = do
+ r <- tryIO $ getFileStatus f
+ case r of
+ (Left _) -> return False
+ (Right s) -> return $ isDirectory s
+
+{- Removes a file, which may or may not exist, and does not have to
+ - be a regular file.
+ -
+ - Note that an exception is thrown if the file exists but
+ - cannot be removed. -}
+nukeFile :: FilePath -> IO ()
+nukeFile file = void $ tryWhenExists go
+ where
+#ifndef mingw32_HOST_OS
+ go = removeLink file
+#else
+ go = removeFile file
+#endif
diff --git a/Utility/Env.hs b/Utility/Env.hs
new file mode 100644
index 00000000..90ed58f6
--- /dev/null
+++ b/Utility/Env.hs
@@ -0,0 +1,81 @@
+{- portable environment variables
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Env where
+
+#ifdef mingw32_HOST_OS
+import Utility.Exception
+import Control.Applicative
+import Data.Maybe
+import qualified System.Environment as E
+#else
+import qualified System.Posix.Env as PE
+#endif
+
+getEnv :: String -> IO (Maybe String)
+#ifndef mingw32_HOST_OS
+getEnv = PE.getEnv
+#else
+getEnv = catchMaybeIO . E.getEnv
+#endif
+
+getEnvDefault :: String -> String -> IO String
+#ifndef mingw32_HOST_OS
+getEnvDefault = PE.getEnvDefault
+#else
+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
+#endif
+
+getEnvironment :: IO [(String, String)]
+#ifndef mingw32_HOST_OS
+getEnvironment = PE.getEnvironment
+#else
+getEnvironment = E.getEnvironment
+#endif
+
+{- Returns True if it could successfully set the environment variable.
+ -
+ - There is, apparently, no way to do this in Windows. Instead,
+ - environment varuables must be provided when running a new process. -}
+setEnv :: String -> String -> Bool -> IO Bool
+#ifndef mingw32_HOST_OS
+setEnv var val overwrite = do
+ PE.setEnv var val overwrite
+ return True
+#else
+setEnv _ _ _ = return False
+#endif
+
+{- Returns True if it could successfully unset the environment variable. -}
+unsetEnv :: String -> IO Bool
+#ifndef mingw32_HOST_OS
+unsetEnv var = do
+ PE.unsetEnv var
+ return True
+#else
+unsetEnv _ = return False
+#endif
+
+{- Adds the environment variable to the input environment. If already
+ - present in the list, removes the old value.
+ -
+ - This does not really belong here, but Data.AssocList is for some reason
+ - buried inside hxt.
+ -}
+addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
+addEntry k v l = ( (k,v) : ) $! delEntry k l
+
+addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]
+addEntries = foldr (.) id . map (uncurry addEntry) . reverse
+
+delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]
+delEntry _ [] = []
+delEntry k (x@(k1,_) : rest)
+ | k == k1 = rest
+ | otherwise = ( x : ) $! delEntry k rest
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
new file mode 100644
index 00000000..cf2c615c
--- /dev/null
+++ b/Utility/Exception.hs
@@ -0,0 +1,59 @@
+{- Simple IO exception handling (and some more)
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Utility.Exception where
+
+import Control.Exception
+import qualified Control.Exception as E
+import Control.Applicative
+import Control.Monad
+import System.IO.Error (isDoesNotExistError)
+import Utility.Data
+
+{- Catches IO errors and returns a Bool -}
+catchBoolIO :: IO Bool -> IO Bool
+catchBoolIO a = catchDefaultIO False a
+
+{- Catches IO errors and returns a Maybe -}
+catchMaybeIO :: IO a -> IO (Maybe a)
+catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a
+
+{- Catches IO errors and returns a default value. -}
+catchDefaultIO :: a -> IO a -> IO a
+catchDefaultIO def a = catchIO a (const $ return def)
+
+{- Catches IO errors and returns the error message. -}
+catchMsgIO :: IO a -> IO (Either String a)
+catchMsgIO a = either (Left . show) Right <$> tryIO a
+
+{- catch specialized for IO errors only -}
+catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO = E.catch
+
+{- try specialized for IO errors only -}
+tryIO :: IO a -> IO (Either IOException a)
+tryIO = try
+
+{- Catches all exceptions except for async exceptions.
+ - This is often better to use than catching them all, so that
+ - ThreadKilled and UserInterrupt get through.
+ -}
+catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a
+catchNonAsync a onerr = a `catches`
+ [ Handler (\ (e :: AsyncException) -> throw e)
+ , Handler (\ (e :: SomeException) -> onerr e)
+ ]
+
+tryNonAsync :: IO a -> IO (Either SomeException a)
+tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)
+
+{- Catches only DoesNotExist exceptions, and lets all others through. -}
+tryWhenExists :: IO a -> IO (Maybe a)
+tryWhenExists a = eitherToMaybe <$>
+ tryJust (guard . isDoesNotExistError) a
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
new file mode 100644
index 00000000..4302f8bd
--- /dev/null
+++ b/Utility/FileMode.hs
@@ -0,0 +1,157 @@
+{- File mode utilities.
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.FileMode where
+
+import System.IO
+import Control.Monad
+import Control.Exception (bracket)
+import System.PosixCompat.Types
+#ifndef mingw32_HOST_OS
+import System.Posix.Files
+#endif
+import Foreign (complement)
+
+import Utility.Exception
+
+{- Applies a conversion function to a file's mode. -}
+modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
+modifyFileMode f convert = void $ modifyFileMode' f convert
+modifyFileMode' :: FilePath -> (FileMode -> FileMode) -> IO FileMode
+modifyFileMode' f convert = do
+ s <- getFileStatus f
+ let old = fileMode s
+ let new = convert old
+ when (new /= old) $
+ setFileMode f new
+ return old
+
+{- Adds the specified FileModes to the input mode, leaving the rest
+ - unchanged. -}
+addModes :: [FileMode] -> FileMode -> FileMode
+addModes ms m = combineModes (m:ms)
+
+{- Removes the specified FileModes from the input mode. -}
+removeModes :: [FileMode] -> FileMode -> FileMode
+removeModes ms m = m `intersectFileModes` complement (combineModes ms)
+
+{- Runs an action after changing a file's mode, then restores the old mode. -}
+withModifiedFileMode :: FilePath -> (FileMode -> FileMode) -> IO a -> IO a
+withModifiedFileMode file convert a = bracket setup cleanup go
+ where
+ setup = modifyFileMode' file convert
+ cleanup oldmode = modifyFileMode file (const oldmode)
+ go _ = a
+
+writeModes :: [FileMode]
+writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
+
+readModes :: [FileMode]
+readModes = [ownerReadMode, groupReadMode, otherReadMode]
+
+executeModes :: [FileMode]
+executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
+
+otherGroupModes :: [FileMode]
+otherGroupModes =
+ [ groupReadMode, otherReadMode
+ , groupWriteMode, otherWriteMode
+ ]
+
+{- Removes the write bits from a file. -}
+preventWrite :: FilePath -> IO ()
+preventWrite f = modifyFileMode f $ removeModes writeModes
+
+{- Turns a file's owner write bit back on. -}
+allowWrite :: FilePath -> IO ()
+allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
+
+{- Turns a file's owner read bit back on. -}
+allowRead :: FilePath -> IO ()
+allowRead f = modifyFileMode f $ addModes [ownerReadMode]
+
+{- Allows owner and group to read and write to a file. -}
+groupSharedModes :: [FileMode]
+groupSharedModes =
+ [ ownerWriteMode, groupWriteMode
+ , ownerReadMode, groupReadMode
+ ]
+
+groupWriteRead :: FilePath -> IO ()
+groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
+
+checkMode :: FileMode -> FileMode -> Bool
+checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
+
+{- Checks if a file mode indicates it's a symlink. -}
+isSymLink :: FileMode -> Bool
+#ifdef mingw32_HOST_OS
+isSymLink _ = False
+#else
+isSymLink = checkMode symbolicLinkMode
+#endif
+
+{- Checks if a file has any executable bits set. -}
+isExecutable :: FileMode -> Bool
+isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
+
+{- Runs an action without that pesky umask influencing it, unless the
+ - passed FileMode is the standard one. -}
+noUmask :: FileMode -> IO a -> IO a
+#ifndef mingw32_HOST_OS
+noUmask mode a
+ | mode == stdFileMode = a
+ | otherwise = withUmask nullFileMode a
+#else
+noUmask _ a = a
+#endif
+
+withUmask :: FileMode -> IO a -> IO a
+#ifndef mingw32_HOST_OS
+withUmask umask a = bracket setup cleanup go
+ where
+ setup = setFileCreationMask umask
+ cleanup = setFileCreationMask
+ go _ = a
+#else
+withUmask _ a = a
+#endif
+
+combineModes :: [FileMode] -> FileMode
+combineModes [] = undefined
+combineModes [m] = m
+combineModes (m:ms) = foldl unionFileModes m ms
+
+isSticky :: FileMode -> Bool
+#ifdef mingw32_HOST_OS
+isSticky _ = False
+#else
+isSticky = checkMode stickyMode
+
+stickyMode :: FileMode
+stickyMode = 512
+
+setSticky :: FilePath -> IO ()
+setSticky f = modifyFileMode f $ addModes [stickyMode]
+#endif
+
+{- Writes a file, ensuring that its modes do not allow it to be read
+ - or written by anyone other than the current user,
+ - before any content is written.
+ -
+ - When possible, this is done using the umask.
+ -
+ - On a filesystem that does not support file permissions, this is the same
+ - as writeFile.
+ -}
+writeFileProtected :: FilePath -> String -> IO ()
+writeFileProtected file content = withUmask 0o0077 $
+ withFile file WriteMode $ \h -> do
+ void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
+ hPutStr h content
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
new file mode 100644
index 00000000..690942cb
--- /dev/null
+++ b/Utility/FileSystemEncoding.hs
@@ -0,0 +1,132 @@
+{- GHC File system encoding handling.
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.FileSystemEncoding (
+ fileEncoding,
+ withFilePath,
+ md5FilePath,
+ decodeBS,
+ decodeW8,
+ encodeW8,
+ truncateFilePath,
+) where
+
+import qualified GHC.Foreign as GHC
+import qualified GHC.IO.Encoding as Encoding
+import Foreign.C
+import System.IO
+import System.IO.Unsafe
+import qualified Data.Hash.MD5 as MD5
+import Data.Word
+import Data.Bits.Utils
+import qualified Data.ByteString.Lazy as L
+#ifdef mingw32_HOST_OS
+import qualified Data.ByteString.Lazy.UTF8 as L8
+#endif
+
+{- Sets a Handle to use the filesystem encoding. This causes data
+ - written or read from it to be encoded/decoded the same
+ - as ghc 7.4 does to filenames etc. This special encoding
+ - allows "arbitrary undecodable bytes to be round-tripped through it".
+ -}
+fileEncoding :: Handle -> IO ()
+#ifndef mingw32_HOST_OS
+fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
+#else
+{- The file system encoding does not work well on Windows,
+ - and Windows only has utf FilePaths anyway. -}
+fileEncoding h = hSetEncoding h Encoding.utf8
+#endif
+
+{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
+ - storage. The FilePath is encoded using the filesystem encoding,
+ - reversing the decoding that should have been done when the FilePath
+ - was obtained. -}
+withFilePath :: FilePath -> (CString -> IO a) -> IO a
+withFilePath fp f = Encoding.getFileSystemEncoding
+ >>= \enc -> GHC.withCString enc fp f
+
+{- Encodes a FilePath into a String, applying the filesystem encoding.
+ -
+ - There are very few things it makes sense to do with such an encoded
+ - string. It's not a legal filename; it should not be displayed.
+ - So this function is not exported, but instead used by the few functions
+ - that can usefully consume it.
+ -
+ - This use of unsafePerformIO is belived to be safe; GHC's interface
+ - only allows doing this conversion with CStrings, and the CString buffer
+ - is allocated, used, and deallocated within the call, with no side
+ - effects.
+ -}
+{-# NOINLINE _encodeFilePath #-}
+_encodeFilePath :: FilePath -> String
+_encodeFilePath fp = unsafePerformIO $ do
+ enc <- Encoding.getFileSystemEncoding
+ GHC.withCString enc fp $ GHC.peekCString Encoding.char8
+
+{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}
+md5FilePath :: FilePath -> MD5.Str
+md5FilePath = MD5.Str . _encodeFilePath
+
+{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
+decodeBS :: L.ByteString -> FilePath
+#ifndef mingw32_HOST_OS
+decodeBS = encodeW8 . L.unpack
+#else
+{- On Windows, we assume that the ByteString is utf-8, since Windows
+ - only uses unicode for filenames. -}
+decodeBS = L8.toString
+#endif
+
+{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
+ -
+ - w82c produces a String, which may contain Chars that are invalid
+ - unicode. From there, this is really a simple matter of applying the
+ - file system encoding, only complicated by GHC's interface to doing so.
+ -}
+{-# NOINLINE encodeW8 #-}
+encodeW8 :: [Word8] -> FilePath
+encodeW8 w8 = unsafePerformIO $ do
+ enc <- Encoding.getFileSystemEncoding
+ GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
+
+{- Useful when you want the actual number of bytes that will be used to
+ - represent the FilePath on disk. -}
+decodeW8 :: FilePath -> [Word8]
+decodeW8 = s2w8 . _encodeFilePath
+
+{- Truncates a FilePath to the given number of bytes (or less),
+ - as represented on disk.
+ -
+ - Avoids returning an invalid part of a unicode byte sequence, at the
+ - cost of efficiency when running on a large FilePath.
+ -}
+truncateFilePath :: Int -> FilePath -> FilePath
+#ifndef mingw32_HOST_OS
+truncateFilePath n = go . reverse
+ where
+ go f =
+ let bytes = decodeW8 f
+ in if length bytes <= n
+ then reverse f
+ else go (drop 1 f)
+#else
+{- On Windows, count the number of bytes used by each utf8 character. -}
+truncateFilePath n = reverse . go [] n . L8.fromString
+ where
+ go coll cnt bs
+ | cnt <= 0 = coll
+ | otherwise = case L8.decode bs of
+ Just (c, x) | c /= L8.replacement_char ->
+ let x' = fromIntegral x
+ in if cnt - x' < 0
+ then coll
+ else go (c:coll) (cnt - x') (L8.drop 1 bs)
+ _ -> coll
+#endif
diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs
new file mode 100644
index 00000000..76e6266d
--- /dev/null
+++ b/Utility/LinuxMkLibs.hs
@@ -0,0 +1,61 @@
+{- Linux library copier and binary shimmer
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.LinuxMkLibs where
+
+import Control.Applicative
+import Data.Maybe
+import System.Directory
+import Data.List.Utils
+import System.Posix.Files
+import Data.Char
+import Control.Monad.IfElse
+
+import Utility.PartialPrelude
+import Utility.Directory
+import Utility.Process
+import Utility.Monad
+import Utility.Path
+
+{- Installs a library. If the library is a symlink to another file,
+ - install the file it links to, and update the symlink to be relative. -}
+installLib :: (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO (Maybe FilePath)
+installLib installfile top lib = ifM (doesFileExist lib)
+ ( do
+ installfile top lib
+ checksymlink lib
+ return $ Just $ parentDir lib
+ , return Nothing
+ )
+ where
+ checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
+ l <- readSymbolicLink (inTop top f)
+ let absl = absPathFrom (parentDir f) l
+ let target = relPathDirToFile (parentDir f) absl
+ installfile top absl
+ nukeFile (top ++ f)
+ createSymbolicLink target (inTop top f)
+ checksymlink absl
+
+-- Note that f is not relative, so cannot use </>
+inTop :: FilePath -> FilePath -> FilePath
+inTop top f = top ++ f
+
+{- Parse ldd output, getting all the libraries that the input files
+ - link to. Note that some of the libraries may not exist
+ - (eg, linux-vdso.so) -}
+parseLdd :: String -> [FilePath]
+parseLdd = catMaybes . map (getlib . dropWhile isSpace) . lines
+ where
+ getlib l = headMaybe . words =<< lastMaybe (split " => " l)
+
+{- Get all glibc libs and other support files, including gconv files
+ -
+ - XXX Debian specific. -}
+glibcLibs :: IO [FilePath]
+glibcLibs = lines <$> readProcess "sh"
+ ["-c", "dpkg -L libc6:$(dpkg --print-architecture) libgcc1:$(dpkg --print-architecture) | egrep '\\.so|gconv'"]
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
new file mode 100644
index 00000000..9c19df83
--- /dev/null
+++ b/Utility/Misc.hs
@@ -0,0 +1,148 @@
+{- misc utility functions
+ -
+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Misc where
+
+import System.IO
+import Control.Monad
+import Foreign
+import Data.Char
+import Data.List
+import Control.Applicative
+import System.Exit
+#ifndef mingw32_HOST_OS
+import System.Posix.Process (getAnyProcessStatus)
+import Utility.Exception
+#endif
+
+import Utility.FileSystemEncoding
+import Utility.Monad
+
+{- A version of hgetContents that is not lazy. Ensures file is
+ - all read before it gets closed. -}
+hGetContentsStrict :: Handle -> IO String
+hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
+
+{- A version of readFile that is not lazy. -}
+readFileStrict :: FilePath -> IO String
+readFileStrict = readFile >=> \s -> length s `seq` return s
+
+{- Reads a file strictly, and using the FileSystemEncoding, so it will
+ - never crash on a badly encoded file. -}
+readFileStrictAnyEncoding :: FilePath -> IO String
+readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
+ fileEncoding h
+ hClose h `after` hGetContentsStrict h
+
+{- Writes a file, using the FileSystemEncoding so it will never crash
+ - on a badly encoded content string. -}
+writeFileAnyEncoding :: FilePath -> String -> IO ()
+writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
+ fileEncoding h
+ hPutStr h content
+
+{- Like break, but the item matching the condition is not included
+ - in the second result list.
+ -
+ - separate (== ':') "foo:bar" = ("foo", "bar")
+ - separate (== ':') "foobar" = ("foobar", "")
+ -}
+separate :: (a -> Bool) -> [a] -> ([a], [a])
+separate c l = unbreak $ break c l
+ where
+ unbreak r@(a, b)
+ | null b = r
+ | otherwise = (a, tail b)
+
+{- Breaks out the first line. -}
+firstLine :: String -> String
+firstLine = takeWhile (/= '\n')
+
+{- Splits a list into segments that are delimited by items matching
+ - a predicate. (The delimiters are not included in the segments.)
+ - Segments may be empty. -}
+segment :: (a -> Bool) -> [a] -> [[a]]
+segment p l = map reverse $ go [] [] l
+ where
+ go c r [] = reverse $ c:r
+ go c r (i:is)
+ | p i = go [] (c:r) is
+ | otherwise = go (i:c) r is
+
+prop_segment_regressionTest :: Bool
+prop_segment_regressionTest = all id
+ -- Even an empty list is a segment.
+ [ segment (== "--") [] == [[]]
+ -- There are two segements in this list, even though the first is empty.
+ , segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]
+ ]
+
+{- Includes the delimiters as segments of their own. -}
+segmentDelim :: (a -> Bool) -> [a] -> [[a]]
+segmentDelim p l = map reverse $ go [] [] l
+ where
+ go c r [] = reverse $ c:r
+ go c r (i:is)
+ | p i = go [] ([i]:c:r) is
+ | otherwise = go (i:c) r is
+
+{- Replaces multiple values in a string.
+ -
+ - Takes care to skip over just-replaced values, so that they are not
+ - mangled. For example, massReplace [("foo", "new foo")] does not
+ - replace the "new foo" with "new new foo".
+ -}
+massReplace :: [(String, String)] -> String -> String
+massReplace vs = go [] vs
+ where
+
+ go acc _ [] = concat $ reverse acc
+ go acc [] (c:cs) = go ([c]:acc) vs cs
+ go acc ((val, replacement):rest) s
+ | val `isPrefixOf` s =
+ go (replacement:acc) vs (drop (length val) s)
+ | otherwise = go acc rest s
+
+{- Wrapper around hGetBufSome that returns a String.
+ -
+ - The null string is returned on eof, otherwise returns whatever
+ - data is currently available to read from the handle, or waits for
+ - data to be written to it if none is currently available.
+ -
+ - Note on encodings: The normal encoding of the Handle is ignored;
+ - each byte is converted to a Char. Not unicode clean!
+ -}
+hGetSomeString :: Handle -> Int -> IO String
+hGetSomeString h sz = do
+ fp <- mallocForeignPtrBytes sz
+ len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
+ map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
+ where
+ peekbytes :: Int -> Ptr Word8 -> IO [Word8]
+ peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
+
+{- Reaps any zombie git processes.
+ -
+ - Warning: Not thread safe. Anything that was expecting to wait
+ - on a process and get back an exit status is going to be confused
+ - if this reap gets there first. -}
+reapZombies :: IO ()
+#ifndef mingw32_HOST_OS
+reapZombies = do
+ -- throws an exception when there are no child processes
+ catchDefaultIO Nothing (getAnyProcessStatus False True)
+ >>= maybe (return ()) (const reapZombies)
+
+#else
+reapZombies = return ()
+#endif
+
+exitBool :: Bool -> IO a
+exitBool False = exitFailure
+exitBool True = exitSuccess
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
new file mode 100644
index 00000000..1ba43c5f
--- /dev/null
+++ b/Utility/Monad.hs
@@ -0,0 +1,69 @@
+{- monadic stuff
+ -
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Monad where
+
+import Data.Maybe
+import Control.Monad
+
+{- Return the first value from a list, if any, satisfying the given
+ - predicate -}
+firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
+firstM _ [] = return Nothing
+firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)
+
+{- Runs the action on values from the list until it succeeds, returning
+ - its result. -}
+getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
+getM _ [] = return Nothing
+getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x
+
+{- Returns true if any value in the list satisfies the predicate,
+ - stopping once one is found. -}
+anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+anyM p = liftM isJust . firstM p
+
+allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+allM _ [] = return True
+allM p (x:xs) = p x <&&> allM p xs
+
+{- Runs an action on values from a list until it succeeds. -}
+untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
+untilTrue = flip anyM
+
+{- if with a monadic conditional. -}
+ifM :: Monad m => m Bool -> (m a, m a) -> m a
+ifM cond (thenclause, elseclause) = do
+ c <- cond
+ if c then thenclause else elseclause
+
+{- short-circuiting monadic || -}
+(<||>) :: Monad m => m Bool -> m Bool -> m Bool
+ma <||> mb = ifM ma ( return True , mb )
+
+{- short-circuiting monadic && -}
+(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
+ma <&&> mb = ifM ma ( mb , return False )
+
+{- Same fixity as && and || -}
+infixr 3 <&&>
+infixr 2 <||>
+
+{- Runs an action, passing its value to an observer before returning it. -}
+observe :: Monad m => (a -> m b) -> m a -> m a
+observe observer a = do
+ r <- a
+ _ <- observer r
+ return r
+
+{- b `after` a runs first a, then b, and returns the value of a -}
+after :: Monad m => m b -> m a -> m a
+after = observe . const
+
+{- do nothing -}
+noop :: Monad m => m ()
+noop = return ()
diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs
new file mode 100644
index 00000000..6efa093f
--- /dev/null
+++ b/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/Utility/Path.hs b/Utility/Path.hs
new file mode 100644
index 00000000..570350d6
--- /dev/null
+++ b/Utility/Path.hs
@@ -0,0 +1,293 @@
+{- path manipulation
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE PackageImports, CPP #-}
+
+module Utility.Path where
+
+import Data.String.Utils
+import System.FilePath
+import System.Directory
+import Data.List
+import Data.Maybe
+import Data.Char
+import Control.Applicative
+
+#ifdef mingw32_HOST_OS
+import qualified System.FilePath.Posix as Posix
+#else
+import System.Posix.Files
+#endif
+
+import qualified "MissingH" System.Path as MissingH
+import Utility.Monad
+import Utility.UserInfo
+
+{- Simplifies a path, removing any ".." or ".", and removing the trailing
+ - path separator.
+ -
+ - On Windows, preserves whichever style of path separator might be used in
+ - the input FilePaths. This is done because some programs in Windows
+ - demand a particular path separator -- and which one actually varies!
+ -
+ - This does not guarantee that two paths that refer to the same location,
+ - and are both relative to the same location (or both absolute) will
+ - yeild the same result. Run both through normalise from System.FilePath
+ - to ensure that.
+ -}
+simplifyPath :: FilePath -> FilePath
+simplifyPath path = dropTrailingPathSeparator $
+ joinDrive drive $ joinPath $ norm [] $ splitPath path'
+ where
+ (drive, path') = splitDrive path
+
+ norm c [] = reverse c
+ norm c (p:ps)
+ | p' == ".." = norm (drop 1 c) ps
+ | p' == "." = norm c ps
+ | otherwise = norm (p:c) ps
+ where
+ p' = dropTrailingPathSeparator p
+
+{- Makes a path absolute.
+ -
+ - The first parameter is a base directory (ie, the cwd) to use if the path
+ - is not already absolute.
+ -
+ - Does not attempt to deal with edge cases or ensure security with
+ - untrusted inputs.
+ -}
+absPathFrom :: FilePath -> FilePath -> FilePath
+absPathFrom dir path = simplifyPath (combine dir path)
+
+{- On Windows, this converts the paths to unix-style, in order to run
+ - MissingH's absNormPath on them. Resulting path will use / separators. -}
+absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
+#ifndef mingw32_HOST_OS
+absNormPathUnix dir path = MissingH.absNormPath dir path
+#else
+absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
+ where
+ fromdos = replace "\\" "/"
+ todos = replace "/" "\\"
+#endif
+
+{- Returns the parent directory of a path.
+ -
+ - To allow this to be easily used in loops, which terminate upon reaching the
+ - top, the parent of / is "" -}
+parentDir :: FilePath -> FilePath
+parentDir dir
+ | null dirs = ""
+ | otherwise = joinDrive drive (join s $ init dirs)
+ where
+ -- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
+ (drive, path) = splitDrive dir
+ dirs = filter (not . null) $ split s path
+ s = [pathSeparator]
+
+prop_parentDir_basics :: FilePath -> Bool
+prop_parentDir_basics dir
+ | null dir = True
+ | dir == "/" = parentDir dir == ""
+ | otherwise = p /= dir
+ where
+ p = parentDir dir
+
+{- Checks if the first FilePath is, or could be said to contain the second.
+ - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
+ - are all equivilant.
+ -}
+dirContains :: FilePath -> FilePath -> Bool
+dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
+ where
+ a' = norm a
+ b' = norm b
+ norm = normalise . simplifyPath
+
+{- Converts a filename into an absolute path.
+ -
+ - Unlike Directory.canonicalizePath, this does not require the path
+ - already exists. -}
+absPath :: FilePath -> IO FilePath
+absPath file = do
+ cwd <- getCurrentDirectory
+ return $ absPathFrom cwd file
+
+{- Constructs a relative path from the CWD to a file.
+ -
+ - For example, assuming CWD is /tmp/foo/bar:
+ - relPathCwdToFile "/tmp/foo" == ".."
+ - relPathCwdToFile "/tmp/foo/bar" == ""
+ -}
+relPathCwdToFile :: FilePath -> IO FilePath
+relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f
+
+{- Constructs a relative path from a directory to a file.
+ -
+ - Both must be absolute, and cannot contain .. etc. (eg use absPath first).
+ -}
+relPathDirToFile :: FilePath -> FilePath -> FilePath
+relPathDirToFile from to = join s $ dotdots ++ uncommon
+ where
+ s = [pathSeparator]
+ pfrom = split s from
+ pto = split s to
+ common = map fst $ takeWhile same $ zip pfrom pto
+ same (c,d) = c == d
+ uncommon = drop numcommon pto
+ dotdots = replicate (length pfrom - numcommon) ".."
+ numcommon = length common
+
+prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
+prop_relPathDirToFile_basics from to
+ | from == to = null r
+ | otherwise = not (null r)
+ where
+ r = relPathDirToFile from to
+
+prop_relPathDirToFile_regressionTest :: Bool
+prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
+ where
+ {- Two paths have the same directory component at the same
+ - location, but it's not really the same directory.
+ - Code used to get this wrong. -}
+ same_dir_shortcurcuits_at_difference =
+ relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
+ (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
+ == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
+
+{- Given an original list of paths, and an expanded list derived from it,
+ - generates a list of lists, where each sublist corresponds to one of the
+ - original paths. When the original path is a directory, any items
+ - in the expanded list that are contained in that directory will appear in
+ - its segment.
+ -}
+segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
+segmentPaths [] new = [new]
+segmentPaths [_] new = [new] -- optimisation
+segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest
+ where
+ (found, rest)=partition (l `dirContains`) new
+
+{- This assumes that it's cheaper to call segmentPaths on the result,
+ - than it would be to run the action separately with each path. In
+ - the case of git file list commands, that assumption tends to hold.
+ -}
+runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
+runSegmentPaths a paths = segmentPaths paths <$> a paths
+
+{- Converts paths in the home directory to use ~/ -}
+relHome :: FilePath -> IO String
+relHome path = do
+ home <- myHomeDir
+ return $ if dirContains home path
+ then "~/" ++ relPathDirToFile home path
+ else path
+
+{- Checks if a command is available in PATH.
+ -
+ - The command may be fully-qualified, in which case, this succeeds as
+ - long as it exists. -}
+inPath :: String -> IO Bool
+inPath command = isJust <$> searchPath command
+
+{- Finds a command in PATH and returns the full path to it.
+ -
+ - The command may be fully qualified already, in which case it will
+ - be returned if it exists.
+ -}
+searchPath :: String -> IO (Maybe FilePath)
+searchPath command
+ | isAbsolute command = check command
+ | otherwise = getSearchPath >>= getM indir
+ where
+ indir d = check $ d </> command
+ check f = firstM doesFileExist
+#ifdef mingw32_HOST_OS
+ [f, f ++ ".exe"]
+#else
+ [f]
+#endif
+
+{- Checks if a filename is a unix dotfile. All files inside dotdirs
+ - count as dotfiles. -}
+dotfile :: FilePath -> Bool
+dotfile file
+ | f == "." = False
+ | f == ".." = False
+ | f == "" = False
+ | otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
+ where
+ f = takeFileName file
+
+{- Converts a DOS style path to a Cygwin style path. Only on Windows.
+ - Any trailing '\' is preserved as a trailing '/' -}
+toCygPath :: FilePath -> FilePath
+#ifndef mingw32_HOST_OS
+toCygPath = id
+#else
+toCygPath p
+ | null drive = recombine parts
+ | otherwise = recombine $ "/cygdrive" : driveletter drive : parts
+ where
+ (drive, p') = splitDrive p
+ parts = splitDirectories p'
+ driveletter = map toLower . takeWhile (/= ':')
+ recombine = fixtrailing . Posix.joinPath
+ fixtrailing s
+ | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
+ | otherwise = s
+#endif
+
+{- Maximum size to use for a file in a specified directory.
+ -
+ - Many systems have a 255 byte limit to the name of a file,
+ - so that's taken as the max if the system has a larger limit, or has no
+ - limit.
+ -}
+fileNameLengthLimit :: FilePath -> IO Int
+#ifdef mingw32_HOST_OS
+fileNameLengthLimit _ = return 255
+#else
+fileNameLengthLimit dir = do
+ l <- fromIntegral <$> getPathVar dir FileNameLimit
+ if l <= 0
+ then return 255
+ else return $ minimum [l, 255]
+ where
+#endif
+
+{- Given a string that we'd like to use as the basis for FilePath, but that
+ - was provided by a third party and is not to be trusted, returns the closest
+ - sane FilePath.
+ -
+ - All spaces and punctuation and other wacky stuff are replaced
+ - with '_', except for '.' "../" will thus turn into ".._", which is safe.
+ -}
+sanitizeFilePath :: String -> FilePath
+sanitizeFilePath = map sanitize
+ where
+ sanitize c
+ | c == '.' = c
+ | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
+ | otherwise = c
+
+{- Similar to splitExtensions, but knows that some things in FilePaths
+ - after a dot are too long to be extensions. -}
+splitShortExtensions :: FilePath -> (FilePath, [String])
+splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
+splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
+splitShortExtensions' maxextension = go []
+ where
+ go c f
+ | len > 0 && len <= maxextension && not (null base) =
+ go (ext:c) base
+ | otherwise = (f, c)
+ where
+ (base, ext) = splitExtension f
+ len = length ext
diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs
new file mode 100644
index 00000000..23edc25c
--- /dev/null
+++ b/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 <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.PosixFiles (
+ module X,
+ rename
+) where
+
+import System.PosixCompat.Files as X hiding (rename)
+
+#ifndef mingw32_HOST_OS
+import System.Posix.Files (rename)
+#else
+import qualified System.Win32.File as Win32
+#endif
+
+{- System.PosixCompat.Files.rename on Windows calls renameFile,
+ - so cannot rename directories.
+ -
+ - Instead, use Win32 moveFile, which can. It needs to be told to overwrite
+ - any existing file. -}
+#ifdef mingw32_HOST_OS
+rename :: FilePath -> FilePath -> IO ()
+rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
+#endif
diff --git a/Utility/Process.hs b/Utility/Process.hs
new file mode 100644
index 00000000..1945e4b9
--- /dev/null
+++ b/Utility/Process.hs
@@ -0,0 +1,360 @@
+{- System.Process enhancements, including additional ways of running
+ - processes, and logging.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, Rank2Types #-}
+
+module Utility.Process (
+ module X,
+ CreateProcess,
+ StdHandle(..),
+ readProcess,
+ readProcessEnv,
+ writeReadProcessEnv,
+ forceSuccessProcess,
+ checkSuccessProcess,
+ ignoreFailureProcess,
+ createProcessSuccess,
+ createProcessChecked,
+ createBackgroundProcess,
+ processTranscript,
+ processTranscript',
+ withHandle,
+ withBothHandles,
+ withQuietOutput,
+ createProcess,
+ startInteractiveProcess,
+ stdinHandle,
+ stdoutHandle,
+ stderrHandle,
+ devNull,
+) where
+
+import qualified System.Process
+import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
+import System.Process hiding (createProcess, readProcess)
+import System.Exit
+import System.IO
+import System.Log.Logger
+import Control.Concurrent
+import qualified Control.Exception as E
+import Control.Monad
+#ifndef mingw32_HOST_OS
+import System.Posix.IO
+#else
+import Control.Applicative
+#endif
+import Data.Maybe
+
+import Utility.Misc
+import Utility.Exception
+
+type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
+
+data StdHandle = StdinHandle | StdoutHandle | StderrHandle
+ deriving (Eq)
+
+{- Normally, when reading from a process, it does not need to be fed any
+ - standard input. -}
+readProcess :: FilePath -> [String] -> IO String
+readProcess cmd args = readProcessEnv cmd args Nothing
+
+readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
+readProcessEnv cmd args environ =
+ withHandle StdoutHandle createProcessSuccess p $ \h -> do
+ output <- hGetContentsStrict h
+ hClose h
+ return output
+ where
+ p = (proc cmd args)
+ { std_out = CreatePipe
+ , env = environ
+ }
+
+{- Runs an action to write to a process on its stdin,
+ - returns its output, and also allows specifying the environment.
+ -}
+writeReadProcessEnv
+ :: FilePath
+ -> [String]
+ -> Maybe [(String, String)]
+ -> (Maybe (Handle -> IO ()))
+ -> (Maybe (Handle -> IO ()))
+ -> IO String
+writeReadProcessEnv cmd args environ writestdin adjusthandle = do
+ (Just inh, Just outh, _, pid) <- createProcess p
+
+ maybe (return ()) (\a -> a inh) adjusthandle
+ maybe (return ()) (\a -> a outh) adjusthandle
+
+ -- fork off a thread to start consuming the output
+ output <- hGetContents outh
+ outMVar <- newEmptyMVar
+ _ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
+
+ -- now write and flush any input
+ maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
+ hClose inh -- done with stdin
+
+ -- wait on the output
+ takeMVar outMVar
+ hClose outh
+
+ -- wait on the process
+ forceSuccessProcess p pid
+
+ return output
+
+ where
+ p = (proc cmd args)
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ , env = environ
+ }
+
+{- Waits for a ProcessHandle, and throws an IOError if the process
+ - did not exit successfully. -}
+forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
+forceSuccessProcess p pid = do
+ code <- waitForProcess pid
+ case code of
+ ExitSuccess -> return ()
+ ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
+
+{- Waits for a ProcessHandle and returns True if it exited successfully.
+ - Note that using this with createProcessChecked will throw away
+ - the Bool, and is only useful to ignore the exit code of a process,
+ - while still waiting for it. -}
+checkSuccessProcess :: ProcessHandle -> IO Bool
+checkSuccessProcess pid = do
+ code <- waitForProcess pid
+ return $ code == ExitSuccess
+
+ignoreFailureProcess :: ProcessHandle -> IO Bool
+ignoreFailureProcess pid = do
+ void $ waitForProcess pid
+ return True
+
+{- Runs createProcess, then an action on its handles, and then
+ - forceSuccessProcess. -}
+createProcessSuccess :: CreateProcessRunner
+createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
+
+{- Runs createProcess, then an action on its handles, and then
+ - a checker action on its exit code, which must wait for the process. -}
+createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
+createProcessChecked checker p a = do
+ t@(_, _, _, pid) <- createProcess p
+ r <- tryNonAsync $ a t
+ _ <- checker pid
+ either E.throw return r
+
+{- Leaves the process running, suitable for lazy streaming.
+ - Note: Zombies will result, and must be waited on. -}
+createBackgroundProcess :: CreateProcessRunner
+createBackgroundProcess p a = a =<< createProcess p
+
+{- Runs a process, optionally feeding it some input, and
+ - returns a transcript combining its stdout and stderr, and
+ - whether it succeeded or failed. -}
+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
+processTranscript cmd opts input = processTranscript' cmd opts Nothing input
+
+processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
+#ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
+processTranscript' cmd opts environ input = do
+ (readf, writef) <- createPipe
+ readh <- fdToHandle readf
+ writeh <- fdToHandle writef
+ p@(_, _, _, pid) <- createProcess $
+ (proc cmd opts)
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = UseHandle writeh
+ , std_err = UseHandle writeh
+ , env = environ
+ }
+ hClose writeh
+
+ get <- mkreader readh
+
+ -- now write and flush any input
+ case input of
+ Just s -> do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ Nothing -> return ()
+
+ transcript <- get
+
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#else
+{- This implementation for Windows puts stderr after stdout. -}
+processTranscript' cmd opts environ input = do
+ p@(_, _, _, pid) <- createProcess $
+ (proc cmd opts)
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ , env = environ
+ }
+
+ getout <- mkreader (stdoutHandle p)
+ geterr <- mkreader (stderrHandle p)
+
+ case input of
+ Just s -> do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ Nothing -> return ()
+
+ transcript <- (++) <$> getout <*> geterr
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#endif
+ where
+ mkreader h = do
+ s <- hGetContents h
+ v <- newEmptyMVar
+ void $ forkIO $ do
+ void $ E.evaluate (length s)
+ putMVar v ()
+ return $ do
+ takeMVar v
+ return s
+
+{- Runs a CreateProcessRunner, on a CreateProcess structure, that
+ - is adjusted to pipe only from/to a single StdHandle, and passes
+ - the resulting Handle to an action. -}
+withHandle
+ :: StdHandle
+ -> CreateProcessRunner
+ -> CreateProcess
+ -> (Handle -> IO a)
+ -> IO a
+withHandle h creator p a = creator p' $ a . select
+ where
+ base = p
+ { std_in = Inherit
+ , std_out = Inherit
+ , std_err = Inherit
+ }
+ (select, p')
+ | h == StdinHandle =
+ (stdinHandle, base { std_in = CreatePipe })
+ | h == StdoutHandle =
+ (stdoutHandle, base { std_out = CreatePipe })
+ | h == StderrHandle =
+ (stderrHandle, base { std_err = CreatePipe })
+
+{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
+withBothHandles
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> ((Handle, Handle) -> IO a)
+ -> IO a
+withBothHandles creator p a = creator p' $ a . bothHandles
+ where
+ p' = p
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ }
+
+{- Forces the CreateProcessRunner to run quietly;
+ - both stdout and stderr are discarded. -}
+withQuietOutput
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> IO ()
+withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
+ let p' = p
+ { std_out = UseHandle nullh
+ , std_err = UseHandle nullh
+ }
+ creator p' $ const $ return ()
+
+devNull :: FilePath
+#ifndef mingw32_HOST_OS
+devNull = "/dev/null"
+#else
+devNull = "NUL"
+#endif
+
+{- Extract a desired handle from createProcess's tuple.
+ - These partial functions are safe as long as createProcess is run
+ - with appropriate parameters to set up the desired handle.
+ - Get it wrong and the runtime crash will always happen, so should be
+ - easily noticed. -}
+type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
+stdinHandle :: HandleExtractor
+stdinHandle (Just h, _, _, _) = h
+stdinHandle _ = error "expected stdinHandle"
+stdoutHandle :: HandleExtractor
+stdoutHandle (_, Just h, _, _) = h
+stdoutHandle _ = error "expected stdoutHandle"
+stderrHandle :: HandleExtractor
+stderrHandle (_, _, Just h, _) = h
+stderrHandle _ = error "expected stderrHandle"
+bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+bothHandles (Just hin, Just hout, _, _) = (hin, hout)
+bothHandles _ = error "expected bothHandles"
+
+{- Debugging trace for a CreateProcess. -}
+debugProcess :: CreateProcess -> IO ()
+debugProcess p = do
+ debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ ]
+ where
+ action
+ | piped (std_in p) && piped (std_out p) = "chat"
+ | piped (std_in p) = "feed"
+ | piped (std_out p) = "read"
+ | otherwise = "call"
+ piped Inherit = False
+ piped _ = True
+
+{- Shows the command that a CreateProcess will run. -}
+showCmd :: CreateProcess -> String
+showCmd = go . cmdspec
+ where
+ go (ShellCommand s) = s
+ go (RawCommand c ps) = c ++ " " ++ show ps
+
+{- Starts an interactive process. Unlike runInteractiveProcess in
+ - System.Process, stderr is inherited. -}
+startInteractiveProcess
+ :: FilePath
+ -> [String]
+ -> Maybe [(String, String)]
+ -> IO (ProcessHandle, Handle, Handle)
+startInteractiveProcess cmd args environ = do
+ let p = (proc cmd args)
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = Inherit
+ , env = environ
+ }
+ (Just from, Just to, _, pid) <- createProcess p
+ return (pid, to, from)
+
+{- Wrapper around System.Process function that does debug logging. -}
+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+createProcess p = do
+ debugProcess p
+ System.Process.createProcess p
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
new file mode 100644
index 00000000..7f7234c7
--- /dev/null
+++ b/Utility/QuickCheck.hs
@@ -0,0 +1,52 @@
+{- QuickCheck with additional instances
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Utility.QuickCheck
+ ( module X
+ , module Utility.QuickCheck
+ ) where
+
+import Test.QuickCheck as X
+import Data.Time.Clock.POSIX
+import System.Posix.Types
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Control.Applicative
+
+instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where
+ arbitrary = M.fromList <$> arbitrary
+
+instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where
+ arbitrary = S.fromList <$> arbitrary
+
+{- Times before the epoch are excluded. -}
+instance Arbitrary POSIXTime where
+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+instance Arbitrary EpochTime where
+ arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+
+{- Pids are never negative, or 0. -}
+instance Arbitrary ProcessID where
+ arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+
+{- Inodes are never negative. -}
+instance Arbitrary FileID where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+{- File sizes are never negative. -}
+instance Arbitrary FileOffset where
+ arbitrary = nonNegative arbitrarySizedIntegral
+
+nonNegative :: (Num a, Ord a) => Gen a -> Gen a
+nonNegative g = g `suchThat` (>= 0)
+
+positive :: (Num a, Ord a) => Gen a -> Gen a
+positive g = g `suchThat` (> 0)
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
new file mode 100644
index 00000000..c8318ec2
--- /dev/null
+++ b/Utility/SafeCommand.hs
@@ -0,0 +1,120 @@
+{- safely running shell commands
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.SafeCommand where
+
+import System.Exit
+import Utility.Process
+import System.Process (env)
+import Data.String.Utils
+import Control.Applicative
+import System.FilePath
+import Data.Char
+
+{- A type for parameters passed to a shell command. A command can
+ - be passed either some Params (multiple parameters can be included,
+ - whitespace-separated, or a single Param (for when parameters contain
+ - whitespace), or a File.
+ -}
+data CommandParam = Params String | Param String | File FilePath
+ deriving (Eq, Show, Ord)
+
+{- Used to pass a list of CommandParams to a function that runs
+ - a command and expects Strings. -}
+toCommand :: [CommandParam] -> [String]
+toCommand = concatMap unwrap
+ where
+ unwrap (Param s) = [s]
+ unwrap (Params s) = filter (not . null) (split " " s)
+ -- Files that start with a non-alphanumeric that is not a path
+ -- separator are modified to avoid the command interpreting them as
+ -- options or other special constructs.
+ unwrap (File s@(h:_))
+ | isAlphaNum h || h `elem` pathseps = [s]
+ | otherwise = ["./" ++ s]
+ unwrap (File s) = [s]
+ -- '/' is explicitly included because it's an alternative
+ -- path separator on Windows.
+ pathseps = pathSeparator:"./"
+
+{- Run a system command, and returns True or False
+ - if it succeeded or failed.
+ -}
+boolSystem :: FilePath -> [CommandParam] -> IO Bool
+boolSystem command params = boolSystemEnv command params Nothing
+
+boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ
+ where
+ dispatch ExitSuccess = True
+ dispatch _ = False
+
+{- Runs a system command, returning the exit status. -}
+safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
+safeSystem command params = safeSystemEnv command params Nothing
+
+safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
+safeSystemEnv command params environ = do
+ (_, _, _, pid) <- createProcess (proc command $ toCommand params)
+ { env = environ }
+ waitForProcess pid
+
+{- Wraps a shell command line inside sh -c, allowing it to be run in a
+ - login shell that may not support POSIX shell, eg csh. -}
+shellWrap :: String -> String
+shellWrap cmdline = "sh -c " ++ shellEscape cmdline
+
+{- Escapes a filename or other parameter to be safely able to be exposed to
+ - the shell.
+ -
+ - This method works for POSIX shells, as well as other shells like csh.
+ -}
+shellEscape :: String -> String
+shellEscape f = "'" ++ escaped ++ "'"
+ where
+ -- replace ' with '"'"'
+ escaped = join "'\"'\"'" $ split "'" f
+
+{- Unescapes a set of shellEscaped words or filenames. -}
+shellUnEscape :: String -> [String]
+shellUnEscape [] = []
+shellUnEscape s = word : shellUnEscape rest
+ where
+ (word, rest) = findword "" s
+ findword w [] = (w, "")
+ findword w (c:cs)
+ | c == ' ' = (w, cs)
+ | c == '\'' = inquote c w cs
+ | c == '"' = inquote c w cs
+ | otherwise = findword (w++[c]) cs
+ inquote _ w [] = (w, "")
+ inquote q w (c:cs)
+ | c == q = findword w cs
+ | otherwise = inquote q (w++[c]) cs
+
+{- For quickcheck. -}
+prop_idempotent_shellEscape :: String -> Bool
+prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
+prop_idempotent_shellEscape_multiword :: [String] -> Bool
+prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
+
+{- Segements a list of filenames into groups that are all below the manximum
+ - command-line length limit. Does not preserve order. -}
+segmentXargs :: [FilePath] -> [[FilePath]]
+segmentXargs l = go l [] 0 []
+ where
+ go [] c _ r = c:r
+ go (f:fs) c accumlen r
+ | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r)
+ | otherwise = go fs (f:c) newlen r
+ where
+ len = length f
+ newlen = accumlen + len
+
+ {- 10k of filenames per command, well under Linux's 20k limit;
+ - allows room for other parameters etc. -}
+ maxlen = 10240
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
new file mode 100644
index 00000000..d3ae0620
--- /dev/null
+++ b/Utility/Scheduled.hs
@@ -0,0 +1,396 @@
+{- scheduled activities
+ -
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.Scheduled (
+ Schedule(..),
+ Recurrance(..),
+ ScheduledTime(..),
+ NextTime(..),
+ WeekDay,
+ MonthDay,
+ YearDay,
+ nextTime,
+ calcNextTime,
+ startTime,
+ fromSchedule,
+ fromScheduledTime,
+ toScheduledTime,
+ fromRecurrance,
+ toRecurrance,
+ toSchedule,
+ parseSchedule,
+ prop_schedule_roundtrips,
+ prop_past_sane,
+) where
+
+import Utility.Data
+import Utility.QuickCheck
+import Utility.PartialPrelude
+import Utility.Misc
+
+import Control.Applicative
+import Data.List
+import Data.Time.Clock
+import Data.Time.LocalTime
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate
+import Data.Time.Calendar.OrdinalDate
+import Data.Tuple.Utils
+import Data.Char
+
+{- Some sort of scheduled event. -}
+data Schedule = Schedule Recurrance ScheduledTime
+ deriving (Eq, Read, Show, Ord)
+
+data Recurrance
+ = Daily
+ | Weekly (Maybe WeekDay)
+ | Monthly (Maybe MonthDay)
+ | Yearly (Maybe YearDay)
+ | Divisible Int Recurrance
+ -- ^ Days, Weeks, or Months of the year evenly divisible by a number.
+ -- (Divisible Year is years evenly divisible by a number.)
+ deriving (Eq, Read, Show, Ord)
+
+type WeekDay = Int
+type MonthDay = Int
+type YearDay = Int
+
+data ScheduledTime
+ = AnyTime
+ | SpecificTime Hour Minute
+ deriving (Eq, Read, Show, Ord)
+
+type Hour = Int
+type Minute = Int
+
+-- | Next time a Schedule should take effect. The NextTimeWindow is used
+-- when a Schedule is allowed to start at some point within the window.
+data NextTime
+ = NextTimeExactly LocalTime
+ | NextTimeWindow LocalTime LocalTime
+ deriving (Eq, Read, Show)
+
+startTime :: NextTime -> LocalTime
+startTime (NextTimeExactly t) = t
+startTime (NextTimeWindow t _) = t
+
+nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
+nextTime schedule lasttime = do
+ now <- getCurrentTime
+ tz <- getTimeZone now
+ return $ calcNextTime schedule lasttime $ utcToLocalTime tz now
+
+-- | Calculate the next time that fits a Schedule, based on the
+-- last time it occurred, and the current time.
+calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
+calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
+ | scheduledtime == AnyTime = do
+ next <- findfromtoday True
+ return $ case next of
+ NextTimeWindow _ _ -> next
+ NextTimeExactly t -> window (localDay t) (localDay t)
+ | otherwise = NextTimeExactly . startTime <$> findfromtoday False
+ where
+ findfromtoday anytime = findfrom recurrance afterday today
+ where
+ today = localDay currenttime
+ afterday = sameaslastrun || toolatetoday
+ toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
+ sameaslastrun = lastrun == Just today
+ lastrun = localDay <$> lasttime
+ nexttime = case scheduledtime of
+ AnyTime -> TimeOfDay 0 0 0
+ SpecificTime h m -> TimeOfDay h m 0
+ exactly d = NextTimeExactly $ LocalTime d nexttime
+ window startd endd = NextTimeWindow
+ (LocalTime startd nexttime)
+ (LocalTime endd (TimeOfDay 23 59 0))
+ findfrom r afterday candidate
+ | ynum candidate > (ynum (localDay currenttime)) + 100 =
+ -- avoid possible infinite recusion
+ error $ "bug: calcNextTime did not find a time within 100 years to run " ++
+ show (schedule, lasttime, currenttime)
+ | otherwise = findfromChecked r afterday candidate
+ findfromChecked r afterday candidate = case r of
+ Daily
+ | afterday -> Just $ exactly $ addDays 1 candidate
+ | otherwise -> Just $ exactly candidate
+ Weekly Nothing
+ | afterday -> skip 1
+ | otherwise -> case (wday <$> lastrun, wday candidate) of
+ (Nothing, _) -> Just $ window candidate (addDays 6 candidate)
+ (Just old, curr)
+ | old == curr -> Just $ window candidate (addDays 6 candidate)
+ | otherwise -> skip 1
+ Monthly Nothing
+ | afterday -> skip 1
+ | maybe True (candidate `oneMonthPast`) lastrun ->
+ Just $ window candidate (endOfMonth candidate)
+ | otherwise -> skip 1
+ Yearly Nothing
+ | afterday -> skip 1
+ | maybe True (candidate `oneYearPast`) lastrun ->
+ Just $ window candidate (endOfYear candidate)
+ | otherwise -> skip 1
+ Weekly (Just w)
+ | w < 0 || w > maxwday -> Nothing
+ | w == wday candidate -> if afterday
+ then Just $ exactly $ addDays 7 candidate
+ else Just $ exactly candidate
+ | otherwise -> Just $ exactly $
+ addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate
+ Monthly (Just m)
+ | m < 0 || m > maxmday -> Nothing
+ -- TODO can be done more efficiently than recursing
+ | m == mday candidate -> if afterday
+ then skip 1
+ else Just $ exactly candidate
+ | otherwise -> skip 1
+ Yearly (Just y)
+ | y < 0 || y > maxyday -> Nothing
+ | y == yday candidate -> if afterday
+ then skip 365
+ else Just $ exactly candidate
+ | otherwise -> skip 1
+ Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
+ Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
+ Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
+ Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
+ Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate
+ where
+ skip n = findfrom r False (addDays n candidate)
+ handlediv n r' getval mmax
+ | n > 0 && maybe True (n <=) mmax =
+ findfromwhere r' (divisible n . getval) afterday candidate
+ | otherwise = Nothing
+ findfromwhere r p afterday candidate
+ | maybe True (p . getday) next = next
+ | otherwise = maybe Nothing (findfromwhere r p True . getday) next
+ where
+ next = findfrom r afterday candidate
+ getday = localDay . startTime
+ divisible n v = v `rem` n == 0
+
+-- Check if the new Day occurs one month or more past the old Day.
+oneMonthPast :: Day -> Day -> Bool
+new `oneMonthPast` old = fromGregorian y (m+1) d <= new
+ where
+ (y,m,d) = toGregorian old
+
+-- Check if the new Day occurs one year or more past the old Day.
+oneYearPast :: Day -> Day -> Bool
+new `oneYearPast` old = fromGregorian (y+1) m d <= new
+ where
+ (y,m,d) = toGregorian old
+
+endOfMonth :: Day -> Day
+endOfMonth day =
+ let (y,m,_d) = toGregorian day
+ in fromGregorian y m (gregorianMonthLength y m)
+
+endOfYear :: Day -> Day
+endOfYear day =
+ let (y,_m,_d) = toGregorian day
+ in endOfMonth (fromGregorian y maxmnum 1)
+
+-- extracting various quantities from a Day
+wday :: Day -> Int
+wday = thd3 . toWeekDate
+wnum :: Day -> Int
+wnum = snd3 . toWeekDate
+mday :: Day -> Int
+mday = thd3 . toGregorian
+mnum :: Day -> Int
+mnum = snd3 . toGregorian
+yday :: Day -> Int
+yday = snd . toOrdinalDate
+ynum :: Day -> Int
+ynum = fromIntegral . fst . toOrdinalDate
+
+-- Calendar max values.
+maxyday :: Int
+maxyday = 366 -- with leap days
+maxwnum :: Int
+maxwnum = 53 -- some years have more than 52
+maxmday :: Int
+maxmday = 31
+maxmnum :: Int
+maxmnum = 12
+maxwday :: Int
+maxwday = 7
+
+fromRecurrance :: Recurrance -> String
+fromRecurrance (Divisible n r) =
+ fromRecurrance' (++ "s divisible by " ++ show n) r
+fromRecurrance r = fromRecurrance' ("every " ++) r
+
+fromRecurrance' :: (String -> String) -> Recurrance -> String
+fromRecurrance' a Daily = a "day"
+fromRecurrance' a (Weekly n) = onday n (a "week")
+fromRecurrance' a (Monthly n) = onday n (a "month")
+fromRecurrance' a (Yearly n) = onday n (a "year")
+fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used
+
+onday :: Maybe Int -> String -> String
+onday (Just n) s = "on day " ++ show n ++ " of " ++ s
+onday Nothing s = s
+
+toRecurrance :: String -> Maybe Recurrance
+toRecurrance s = case words s of
+ ("every":"day":[]) -> Just Daily
+ ("on":"day":sd:"of":"every":something:[]) -> withday sd something
+ ("every":something:[]) -> noday something
+ ("days":"divisible":"by":sn:[]) ->
+ Divisible <$> getdivisor sn <*> pure Daily
+ ("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> withday sd something
+ ("every":something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> noday something
+ (something:"divisible":"by":sn:[]) ->
+ Divisible
+ <$> getdivisor sn
+ <*> noday something
+ _ -> Nothing
+ where
+ constructor "week" = Just Weekly
+ constructor "month" = Just Monthly
+ constructor "year" = Just Yearly
+ constructor u
+ | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
+ | otherwise = Nothing
+ withday sd u = do
+ c <- constructor u
+ d <- readish sd
+ Just $ c (Just d)
+ noday u = do
+ c <- constructor u
+ Just $ c Nothing
+ getdivisor sn = do
+ n <- readish sn
+ if n > 0
+ then Just n
+ else Nothing
+
+fromScheduledTime :: ScheduledTime -> String
+fromScheduledTime AnyTime = "any time"
+fromScheduledTime (SpecificTime h m) =
+ show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
+ where
+ pad n s = take (n - length s) (repeat '0') ++ s
+ (h', ampm)
+ | h == 0 = (12, "AM")
+ | h < 12 = (h, "AM")
+ | h == 12 = (h, "PM")
+ | otherwise = (h - 12, "PM")
+
+toScheduledTime :: String -> Maybe ScheduledTime
+toScheduledTime "any time" = Just AnyTime
+toScheduledTime v = case words v of
+ (s:ampm:[])
+ | map toUpper ampm == "AM" ->
+ go s h0
+ | map toUpper ampm == "PM" ->
+ go s (\h -> (h0 h) + 12)
+ | otherwise -> Nothing
+ (s:[]) -> go s id
+ _ -> Nothing
+ where
+ h0 h
+ | h == 12 = 0
+ | otherwise = h
+ go :: String -> (Int -> Int) -> Maybe ScheduledTime
+ go s adjust =
+ let (h, m) = separate (== ':') s
+ in SpecificTime
+ <$> (adjust <$> readish h)
+ <*> if null m then Just 0 else readish m
+
+fromSchedule :: Schedule -> String
+fromSchedule (Schedule recurrance scheduledtime) = unwords
+ [ fromRecurrance recurrance
+ , "at"
+ , fromScheduledTime scheduledtime
+ ]
+
+toSchedule :: String -> Maybe Schedule
+toSchedule = eitherToMaybe . parseSchedule
+
+parseSchedule :: String -> Either String Schedule
+parseSchedule s = do
+ r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
+ (toRecurrance recurrance)
+ t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
+ (toScheduledTime scheduledtime)
+ Right $ Schedule r t
+ where
+ (rws, tws) = separate (== "at") (words s)
+ recurrance = unwords rws
+ scheduledtime = unwords tws
+
+instance Arbitrary Schedule where
+ arbitrary = Schedule <$> arbitrary <*> arbitrary
+
+instance Arbitrary ScheduledTime where
+ arbitrary = oneof
+ [ pure AnyTime
+ , SpecificTime
+ <$> choose (0, 23)
+ <*> choose (1, 59)
+ ]
+
+instance Arbitrary Recurrance where
+ arbitrary = oneof
+ [ pure Daily
+ , Weekly <$> arbday
+ , Monthly <$> arbday
+ , Yearly <$> arbday
+ , Divisible
+ <$> positive arbitrary
+ <*> oneof -- no nested Divisibles
+ [ pure Daily
+ , Weekly <$> arbday
+ , Monthly <$> arbday
+ , Yearly <$> arbday
+ ]
+ ]
+ where
+ arbday = oneof
+ [ Just <$> nonNegative arbitrary
+ , pure Nothing
+ ]
+
+prop_schedule_roundtrips :: Schedule -> Bool
+prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s
+
+prop_past_sane :: Bool
+prop_past_sane = and
+ [ all (checksout oneMonthPast) (mplus1 ++ yplus1)
+ , all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))
+ , all (checksout oneYearPast) yplus1
+ , all (not . (checksout oneYearPast)) (map swap yplus1)
+ ]
+ where
+ mplus1 = -- new date old date, 1+ months before it
+ [ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)
+ , (fromGregorian 2014 01 15, fromGregorian 2013 02 15)
+ , (fromGregorian 2014 02 15, fromGregorian 2013 01 15)
+ , (fromGregorian 2014 03 01, fromGregorian 2013 01 15)
+ , (fromGregorian 2014 03 01, fromGregorian 2013 12 15)
+ , (fromGregorian 2015 01 01, fromGregorian 2010 01 01)
+ ]
+ yplus1 = -- new date old date, 1+ years before it
+ [ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)
+ , (fromGregorian 2014 01 15, fromGregorian 2013 01 14)
+ , (fromGregorian 2022 12 31, fromGregorian 2000 01 01)
+ ]
+ checksout cmp (new, old) = new `cmp` old
+ swap (a,b) = (b,a)
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
new file mode 100644
index 00000000..9d4cfd0a
--- /dev/null
+++ b/Utility/ThreadScheduler.hs
@@ -0,0 +1,73 @@
+{- thread scheduling
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2011 Bas van Dijk & Roel van Dijk
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.ThreadScheduler where
+
+import Control.Monad
+import Control.Monad.IfElse
+import System.Posix.IO
+import Control.Concurrent
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+#ifndef __ANDROID__
+import System.Posix.Terminal
+#endif
+#endif
+
+newtype Seconds = Seconds { fromSeconds :: Int }
+ deriving (Eq, Ord, Show)
+
+type Microseconds = Integer
+
+{- Runs an action repeatedly forever, sleeping at least the specified number
+ - of seconds in between. -}
+runEvery :: Seconds -> IO a -> IO a
+runEvery n a = forever $ do
+ threadDelaySeconds n
+ a
+
+threadDelaySeconds :: Seconds -> IO ()
+threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond)
+
+{- Like threadDelay, but not bounded by an Int.
+ -
+ - There is no guarantee that the thread will be rescheduled promptly when the
+ - delay has expired, but the thread will never continue to run earlier than
+ - specified.
+ -
+ - Taken from the unbounded-delay package to avoid a dependency for 4 lines
+ - of code.
+ -}
+unboundDelay :: Microseconds -> IO ()
+unboundDelay time = do
+ let maxWait = min time $ toInteger (maxBound :: Int)
+ threadDelay $ fromInteger maxWait
+ when (maxWait /= time) $ unboundDelay (time - maxWait)
+
+{- Pauses the main thread, letting children run until program termination. -}
+waitForTermination :: IO ()
+waitForTermination = do
+#ifdef mingw32_HOST_OS
+ runEvery (Seconds 600) $
+ void getLine
+#else
+ lock <- newEmptyMVar
+ let check sig = void $
+ installHandler sig (CatchOnce $ putMVar lock ()) Nothing
+ check softwareTermination
+#ifndef __ANDROID__
+ whenM (queryTerminal stdInput) $
+ check keyboardSignal
+#endif
+ takeMVar lock
+#endif
+
+oneSecond :: Microseconds
+oneSecond = 1000000
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
new file mode 100644
index 00000000..f46e1a5e
--- /dev/null
+++ b/Utility/Tmp.hs
@@ -0,0 +1,100 @@
+{- Temporary files and directories.
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Tmp where
+
+import Control.Exception (bracket)
+import System.IO
+import System.Directory
+import Control.Monad.IfElse
+import System.FilePath
+
+import Utility.Exception
+import Utility.FileSystemEncoding
+import Utility.PosixFiles
+
+type Template = String
+
+{- Runs an action like writeFile, writing to a temp file first and
+ - then moving it into place. The temp file is stored in the same
+ - directory as the final file to avoid cross-device renames. -}
+viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO ()
+viaTmp a file content = do
+ let (dir, base) = splitFileName file
+ createDirectoryIfMissing True dir
+ (tmpfile, handle) <- openTempFile dir (base ++ ".tmp")
+ hClose handle
+ a tmpfile content
+ rename tmpfile file
+
+{- Runs an action with a tmp file located in the system's tmp directory
+ - (or in "." if there is none) then removes the file. -}
+withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a
+withTmpFile template a = do
+ tmpdir <- catchDefaultIO "." getTemporaryDirectory
+ withTmpFileIn tmpdir template a
+
+{- Runs an action with a tmp file located in the specified directory,
+ - then removes the file. -}
+withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a
+withTmpFileIn tmpdir template a = bracket create remove use
+ where
+ create = openTempFile tmpdir template
+ remove (name, handle) = do
+ hClose handle
+ catchBoolIO (removeFile name >> return True)
+ use (name, handle) = a name handle
+
+{- Runs an action with a tmp directory located within the system's tmp
+ - directory (or within "." if there is none), then removes the tmp
+ - directory and all its contents. -}
+withTmpDir :: Template -> (FilePath -> IO a) -> IO a
+withTmpDir template a = do
+ tmpdir <- catchDefaultIO "." getTemporaryDirectory
+ withTmpDirIn tmpdir template a
+
+{- Runs an action with a tmp directory located within a specified directory,
+ - then removes the tmp directory and all its contents. -}
+withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a
+withTmpDirIn tmpdir template = bracket create remove
+ where
+ remove d = whenM (doesDirectoryExist d) $ do
+#if mingw32_HOST_OS
+ -- Windows will often refuse to delete a file
+ -- after a process has just written to it and exited.
+ -- Because it's crap, presumably. So, ignore failure
+ -- to delete the temp directory.
+ _ <- tryIO $ removeDirectoryRecursive d
+ return ()
+#else
+ removeDirectoryRecursive d
+#endif
+ create = do
+ createDirectoryIfMissing True tmpdir
+ makenewdir (tmpdir </> template) (0 :: Int)
+ makenewdir t n = do
+ let dir = t ++ "." ++ show n
+ either (const $ makenewdir t $ n + 1) (const $ return dir)
+ =<< tryIO (createDirectory dir)
+
+{- It's not safe to use a FilePath of an existing file as the template
+ - for openTempFile, because if the FilePath is really long, the tmpfile
+ - will be longer, and may exceed the maximum filename length.
+ -
+ - This generates a template that is never too long.
+ - (Well, it allocates 20 characters for use in making a unique temp file,
+ - anyway, which is enough for the current implementation and any
+ - likely implementation.)
+ -}
+relatedTemplate :: FilePath -> FilePath
+relatedTemplate f
+ | len > 20 = truncateFilePath (len - 20) f
+ | otherwise = f
+ where
+ len = length f
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
new file mode 100644
index 00000000..9c3bfd42
--- /dev/null
+++ b/Utility/UserInfo.hs
@@ -0,0 +1,55 @@
+{- user info
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.UserInfo (
+ myHomeDir,
+ myUserName,
+ myUserGecos,
+) where
+
+import Control.Applicative
+import System.PosixCompat
+
+import Utility.Env
+
+{- Current user's home directory.
+ -
+ - getpwent will fail on LDAP or NIS, so use HOME if set. -}
+myHomeDir :: IO FilePath
+myHomeDir = myVal env homeDirectory
+ where
+#ifndef mingw32_HOST_OS
+ env = ["HOME"]
+#else
+ env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin
+#endif
+
+{- Current user's user name. -}
+myUserName :: IO String
+myUserName = myVal env userName
+ where
+#ifndef mingw32_HOST_OS
+ env = ["USER", "LOGNAME"]
+#else
+ env = ["USERNAME", "USER", "LOGNAME"]
+#endif
+
+myUserGecos :: IO String
+#ifdef __ANDROID__
+myUserGecos = return "" -- userGecos crashes on Android
+#else
+myUserGecos = myVal [] userGecos
+#endif
+
+myVal :: [String] -> (UserEntry -> String) -> IO String
+myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars
+ where
+ check [] = return Nothing
+ check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v
+ getpwent = getUserEntryForID =<< getEffectiveUserID
diff --git a/config-joey.hs b/config-joey.hs
new file mode 100644
index 00000000..dd848646
--- /dev/null
+++ b/config-joey.hs
@@ -0,0 +1,301 @@
+-- | This is the live config file used by propellor's author.
+
+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.Dns as Dns
+import qualified Propellor.Property.OpenId as OpenId
+import qualified Propellor.Property.Docker as Docker
+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.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) `
+ -- My laptop
+ [ host "darkstar.kitenet.net"
+ & ipv6 "2001:4830:1600:187::2" -- sixxs tunnel
+ & Docker.configured
+ & Apt.buildDep ["git-annex"] `period` Daily
+
+ -- Nothing super-important lives here.
+ , standardSystem "clam.kitenet.net" Unstable "amd64"
+ & ipv4 "162.248.143.249"
+ & ipv6 "2002:5044:5531::1"
+
+ & cleanCloudAtCost
+ & Apt.unattendedUpgrades
+ & Network.ipv6to4
+ & Tor.isBridge
+ & Postfix.satellite
+ & Docker.configured
+
+ & alias "shell.olduse.net"
+ & JoeySites.oldUseNetShellBox
+
+ & alias "openid.kitenet.net"
+ & Docker.docked hosts "openid-provider"
+ `requires` Apt.installed ["ntp"]
+
+ & alias "ancient.kitenet.net"
+ & Docker.docked hosts "ancient-kitenet"
+
+ -- I'd rather this were on diatom, but it needs unstable.
+ & alias "kgb.kitenet.net"
+ & JoeySites.kgbServer
+
+ & alias "ns9.kitenet.net"
+ & myDnsSecondary
+
+ & Docker.garbageCollected `period` Daily
+ & Apt.installed ["git-annex", "mtr", "screen"]
+
+ -- Orca is the main git-annex build box.
+ , standardSystem "orca.kitenet.net" Unstable "amd64"
+ & ipv4 "138.38.108.179"
+
+ & Hostname.sane
+ & Apt.unattendedUpgrades
+ & Postfix.satellite
+ & 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.garbageCollected `period` Daily
+ & Apt.buildDep ["git-annex"] `period` Daily
+
+ -- Important stuff that needs not too much memory or CPU.
+ , standardSystem "diatom.kitenet.net" Stable "amd64"
+ & ipv4 "107.170.31.195"
+
+ & Hostname.sane
+ & Ssh.hostKey SshDsa
+ & Ssh.hostKey SshRsa
+ & Ssh.hostKey SshEcdsa
+ & Apt.unattendedUpgrades
+ & Apt.serviceInstalledRunning "ntp"
+ & Postfix.satellite
+
+ & Apt.serviceInstalledRunning "apache2"
+ & File.hasPrivContent "/etc/ssl/certs/web.pem"
+ & File.hasPrivContent "/etc/ssl/private/web.pem"
+ & File.hasPrivContent "/etc/ssl/certs/startssl.pem"
+ & Apache.modEnabled "ssl"
+ & Apache.multiSSL
+ & File.ownerGroup "/srv/web" "joey" "joey"
+
+ & alias "git.kitenet.net"
+ & alias "git.joeyh.name"
+ & JoeySites.gitServer hosts
+
+ & alias "downloads.kitenet.net"
+ & JoeySites.annexWebSite hosts "/srv/git/downloads.git"
+ "downloads.kitenet.net"
+ "840760dc-08f0-11e2-8c61-576b7e66acfd"
+ [("turtle", "ssh://turtle.kitenet.net/~/lib/downloads/")]
+ & JoeySites.annexRsyncServer
+
+ & alias "tmp.kitenet.net"
+ & JoeySites.annexWebSite hosts "/srv/git/joey/tmp.git"
+ "tmp.kitenet.net"
+ "26fd6e38-1226-11e2-a75f-ff007033bdba"
+ []
+ & JoeySites.twitRss
+
+ & alias "nntp.olduse.net"
+ & alias "resources.olduse.net"
+ & JoeySites.oldUseNetServer hosts
+
+ & alias "ns2.kitenet.net"
+ & myDnsSecondary
+ & Dns.primary hosts "olduse.net"
+ (Dns.mkSOA "ns2.kitenet.net" 100)
+ [ (RootDomain, NS $ AbsDomain "ns2.kitenet.net")
+ , (RootDomain, NS $ AbsDomain "ns6.gandi.net")
+ , (RootDomain, NS $ AbsDomain "ns9.kitenet.net")
+ , (RootDomain, MX 0 $ AbsDomain "kitenet.net")
+ , (RootDomain, TXT "v=spf1 a -all")
+ , (RelDomain "article", CNAME $ AbsDomain "virgil.koldfront.dk")
+ ]
+
+ & Apt.installed ["ntop"]
+
+
+ --' __|II| ,.
+ ---- __|II|II|__ ( \_,/\
+ ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-
+ ----------------------- | [Docker] / ----------------------
+ ----------------------- : / -----------------------
+ ------------------------ \____, o ,' ------------------------
+ ------------------------- '--,___________,' -------------------------
+
+ -- Simple web server, publishing the outside host's /var/www
+ , standardContainer "webserver" Stable "amd64"
+ & Docker.publish "8080:80"
+ & Docker.volume "/var/www:/var/www"
+ & Apt.serviceInstalledRunning "apache2"
+
+ -- My own openid provider. Uses php, so containerized for security
+ -- and administrative sanity.
+ , standardContainer "openid-provider" Stable "amd64"
+ & Docker.publish "8081:80"
+ & OpenId.providerFor ["joey", "liw"]
+ "openid.kitenet.net:8081"
+
+ -- Exhibit: kite's 90's website.
+ , standardContainer "ancient-kitenet" Stable "amd64"
+ & Docker.publish "1994:80"
+ & Apt.serviceInstalledRunning "apache2"
+ & Git.cloned "root" "git://git.kitenet.net/kitewiki" "/var/www"
+ (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 :: 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
+
+-- This is my standard system setup.
+standardSystem :: HostName -> DebianSuite -> Architecture -> Host
+standardSystem hn suite arch = host hn
+ & os (System (Debian suite) arch)
+ & Apt.stdSourcesList suite
+ `onChange` Apt.upgrade
+ & Apt.installed ["etckeeper"]
+ & Apt.installed ["ssh"]
+ & GitHome.installedFor "root"
+ & User.hasSomePassword "root"
+ -- Harden the system, but only once root's authorized_keys
+ -- is safely in place.
+ & check (Ssh.hasAuthorizedKeys "root")
+ (Ssh.passwordAuthentication False)
+ & User.accountFor "joey"
+ & User.hasSomePassword "joey"
+ & Sudo.enabledFor "joey"
+ & GitHome.installedFor "joey"
+ & Apt.installed ["vim", "screen", "less"]
+ & Cron.runPropellor "30 * * * *"
+ -- I use postfix, or no MTA.
+ & Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
+ `onChange` Apt.autoRemove
+
+-- This is my standard container setup, featuring automatic upgrades.
+standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host
+standardContainer name suite arch = Docker.container name (image system)
+ & os (System (Debian suite) arch)
+ & Apt.stdSourcesList suite
+ & Apt.unattendedUpgrades
+ where
+ 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
+ ]
+ ]
+
+myDnsSecondary :: Property
+myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp
+ [ Dns.secondaryFor wren hosts "kitenet.net"
+ , Dns.secondaryFor wren hosts "joeyh.name"
+ , Dns.secondaryFor wren hosts "ikiwiki.info"
+ , Dns.secondary hosts "olduse.net"
+ , Dns.secondaryFor branchable hosts "branchable.com"
+ ]
+ where
+ wren = ["wren.kitenet.net"]
+ branchable = ["branchable.com"]
+
+
+
+ -- o
+ -- ___ o o
+ {-----\ / o \ ___o o
+ { \ __ \ / _ (X___>-- __o
+ _____________________{ ______\___ \__/ | \__/ \____ |X__>
+ < \___//|\\___/\ \____________ _
+ \ ___/ | \___ # # \ (-)
+ \ O O O # | \ # >=)
+ \______________________________# # / #__________________/ (-}
+
+
+monsters :: [Host] -- Systems I don't manage with propellor,
+monsters = -- but do want to track their public keys etc.
+ [ host "usw-s002.rsync.net"
+ & sshPubKey "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ=="
+ , host "github.com"
+ & sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ=="
+ , host "turtle.kitenet.net"
+ & ipv4 "67.223.19.96"
+ & ipv6 "2001:4978:f:2d9::2"
+ & sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAokMXQiX/NZjA1UbhMdgAscnS5dsmy+Q7bWrQ6tsTZ/o+6N/T5cbjoBHOdpypXJI3y/PiJTDJaQtXIhLa8gFg/EvxMnMz/KG9skADW1361JmfCc4BxicQIO2IOOe6eilPr+YsnOwiHwL0vpUnuty39cppuMWVD25GzxXlS6KQsLCvXLzxLLuNnGC43UAM0q4UwQxDtAZEK1dH2o3HMWhgMP2qEQupc24dbhpO3ecxh2C9678a3oGDuDuNf7mLp3s7ptj5qF3onitpJ82U5o7VajaHoygMaSRFeWxP2c13eM57j3bLdLwxVXFhePcKXARu1iuFTLS5uUf3hN6MkQcOGw=="
+ , host "wren.kitenet.net"
+ & ipv4 "80.68.85.49"
+ & ipv6 "2001:41c8:125:49::10"
+ & alias "kite.kitenet.net"
+ & alias "kitenet.net"
+ & alias "ns1.kitenet.net"
+ , host "branchable.com"
+ & ipv4 "66.228.46.55"
+ & ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"
+ & alias "olduse.net"
+ & alias "www.olduse.net"
+ & alias "git.olduse.net"
+ ]
diff --git a/config-simple.hs b/config-simple.hs
new file mode 100644
index 00000000..23a760c8
--- /dev/null
+++ b/config-simple.hs
@@ -0,0 +1,47 @@
+-- | 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
+
+-- The hosts propellor knows about.
+-- Edit this to configure propellor!
+hosts :: [Host]
+hosts =
+ [ host "mybox.example.com"
+ & Apt.stdSourcesList Unstable
+ `onChange` Apt.upgrade
+ & 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" = ...
+ ]
+
+main :: IO ()
+main = defaultMain hosts
diff --git a/config.hs b/config.hs
new file mode 120000
index 00000000..ec313725
--- /dev/null
+++ b/config.hs
@@ -0,0 +1 @@
+config-simple.hs \ No newline at end of file
diff --git a/debian/README.Debian b/debian/README.Debian
new file mode 100644
index 00000000..e32a0ee3
--- /dev/null
+++ b/debian/README.Debian
@@ -0,0 +1,7 @@
+The Debian package of propellor ships its full source code because
+propellor is configured by rebuilding it, and embraces modification of any
+of the source code.
+
+/usr/bin/propellor is a wrapper which will set up a propellor git
+repository in ~/.propellor/, and run ~/.propellor/propellor if it exists.
+Edit ~/.propellor/config.hs to configure it.
diff --git a/debian/changelog b/debian/changelog
new file mode 100644
index 00000000..8f1e5f55
--- /dev/null
+++ b/debian/changelog
@@ -0,0 +1,97 @@
+propellor (0.5.0) UNRELEASED; urgency=medium
+
+ * Removed root domain records from SOA. Instead, use RootDomain
+ when calling Dns.primary.
+ * Dns primary and secondary properties are now revertable.
+
+ -- Joey Hess <joeyh@debian.org> Sat, 19 Apr 2014 10:46:35 -0400
+
+propellor (0.4.0) unstable; urgency=medium
+
+ * Propellor can configure primary DNS servers, including generating
+ zone files, which is done by looking at the properties of hosts
+ in a domain.
+ * The `cname` property was renamed to `alias` as it does not always
+ generate CNAME in the DNS.
+ * Constructor of Property has changed (use `property` function instead).
+ * All Property combinators now combine together their Attr settings.
+ So Attr settings can be made inside a propertyList, for example.
+ * Run all cron jobs under chronic from moreutils to avoid unnecessary
+ mails.
+
+ -- Joey Hess <joeyh@debian.org> Sat, 19 Apr 2014 02:09:56 -0400
+
+propellor (0.3.1) unstable; urgency=medium
+
+ * Merge scheduler bug fix from git-annex.
+ * Support for provisioning hosts with ssh and gpg keys.
+ * Obnam support.
+ * Apache support.
+ * Postfix satellite system support.
+ * Properties can now be satisfied differently on different operating
+ systems.
+ * Standard apt configuration for stable now includes backports.
+ * Cron jobs generated by propellor use flock(1) to avoid multiple
+ instances running at a time.
+ * Add support for SSH ed25519 keys.
+ (Thanks, Franz Pletz.)
+
+ -- Joey Hess <joeyh@debian.org> Thu, 17 Apr 2014 20:07:33 -0400
+
+propellor (0.3.0) unstable; urgency=medium
+
+ * ipv6to4: Ensure interface is brought up automatically on boot.
+ * Enabling unattended upgrades now ensures that cron is installed and
+ running to perform them.
+ * Properties can be scheduled to only be checked after a given time period.
+ * Fix bootstrapping of dependencies.
+ * Fix compilation on Debian stable.
+ * Include security updates in sources.list for stable and testing.
+ * Use ssh connection caching, especially when bootstrapping.
+ * Properties now run in a Propellor monad, which provides access to
+ attributes of the host.
+
+ -- Joey Hess <joeyh@debian.org> Fri, 11 Apr 2014 01:19:05 -0400
+
+propellor (0.2.3) unstable; urgency=medium
+
+ * docker: Fix laziness bug that caused running containers to be
+ unnecessarily stopped and committed.
+ * Add locking so only one propellor can run at a time on a host.
+ * docker: When running as effective init inside container, wait on zombies.
+ * docker: Added support for configuring shared volumes and linked
+ containers.
+
+ -- Joey Hess <joeyh@debian.org> Tue, 08 Apr 2014 02:07:37 -0400
+
+propellor (0.2.2) unstable; urgency=medium
+
+ * Now supports provisioning docker containers with architecture/libraries
+ that do not match the host.
+ * Fixed a bug that caused file modes to be set to 600 when propellor
+ modified the file (did not affect newly created files).
+
+ -- Joey Hess <joeyh@debian.org> Fri, 04 Apr 2014 01:07:32 -0400
+
+propellor (0.2.1) unstable; urgency=medium
+
+ * First release with Debian package.
+
+ -- Joey Hess <joeyh@debian.org> Thu, 03 Apr 2014 01:43:14 -0400
+
+propellor (0.2.0) unstable; urgency=low
+
+ * Added support for provisioning Docker containers.
+ * Bootstrap deployment now pushes the git repo to the remote host
+ over ssh, securely.
+ * propellor --add-key configures a gpg key, and makes propellor refuse
+ to pull commits from git repositories not signed with that key.
+ This allows propellor to be securely used with public, non-encrypted
+ git repositories without the possibility of MITM.
+ * Added support for type-safe reversions. Only some properties can be
+ reverted; the type checker will tell you if you try something that won't
+ work.
+ * New syntactic sugar for building a list of properties, including
+ revertable properties.
+
+ -- Joey Hess <joeyh@debian.org> Wed, 02 Apr 2014 13:57:42 -0400
diff --git a/debian/compat b/debian/compat
new file mode 100644
index 00000000..ec635144
--- /dev/null
+++ b/debian/compat
@@ -0,0 +1 @@
+9
diff --git a/debian/control b/debian/control
new file mode 100644
index 00000000..bfdc5880
--- /dev/null
+++ b/debian/control
@@ -0,0 +1,40 @@
+Source: propellor
+Section: admin
+Priority: optional
+Build-Depends:
+ debhelper (>= 9),
+ ghc (>= 7.4),
+ cabal-install,
+ libghc-async-dev,
+ libghc-missingh-dev,
+ libghc-hslogger-dev,
+ libghc-unix-compat-dev,
+ libghc-ansi-terminal-dev,
+ libghc-ifelse-dev,
+ libghc-mtl-dev,
+ libghc-monadcatchio-transformers-dev,
+Maintainer: Joey Hess <joeyh@debian.org>
+Standards-Version: 3.9.5
+Vcs-Git: git://git.kitenet.net/propellor
+Homepage: http://joeyh.name/code/propellor/
+
+Package: propellor
+Architecture: any
+Section: admin
+Depends: ${misc:Depends}, ${shlibs:Depends},
+ ghc (>= 7.4),
+ cabal-install,
+ libghc-async-dev,
+ libghc-missingh-dev,
+ libghc-hslogger-dev,
+ libghc-unix-compat-dev,
+ libghc-ansi-terminal-dev,
+ libghc-ifelse-dev,
+ libghc-mtl-dev,
+ libghc-monadcatchio-transformers-dev,
+ git,
+Description: property-based host configuration management in haskell
+ Propellor enures that the system it's run in satisfies a list of
+ properties, taking action as necessary when a property is not yet met.
+ .
+ It is configured using haskell.
diff --git a/debian/copyright b/debian/copyright
new file mode 100644
index 00000000..690a9af8
--- /dev/null
+++ b/debian/copyright
@@ -0,0 +1,11 @@
+Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
+Source: native package
+
+Files: *
+Copyright: © 2010-2014 Joey Hess <joey@kitenet.net>
+License: GPL-3+
+
+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.
diff --git a/debian/lintian-overrides b/debian/lintian-overrides
new file mode 100644
index 00000000..9071fe0f
--- /dev/null
+++ b/debian/lintian-overrides
@@ -0,0 +1,3 @@
+# 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/debian/propellor.1 b/debian/propellor.1
new file mode 100644
index 00000000..3ee3bf4a
--- /dev/null
+++ b/debian/propellor.1
@@ -0,0 +1,15 @@
+.\" -*- nroff -*-
+.TH propellor 1 "Commands"
+.SH NAME
+propellor \- property-based host configuration management in haskell
+.SH SYNOPSIS
+.B propellor [options] host
+.SH DESCRIPTION
+.I propellor
+is a property-based host configuration management program written
+and configured in haskell.
+.PP
+The first time you run propellor, it will set up a ~/.propellor/
+repository. Edit ~/.propellor/config.hs to configure it.
+.SH AUTHOR
+Joey Hess <joey@kitenet.net>
diff --git a/debian/rules b/debian/rules
new file mode 100755
index 00000000..dafe10f6
--- /dev/null
+++ b/debian/rules
@@ -0,0 +1,14 @@
+#!/usr/bin/make -f
+
+# Avoid using cabal, as it writes to $HOME
+export CABAL=./Setup
+
+%:
+ dh $@
+
+override_dh_auto_build:
+ $(MAKE) build
+override_dh_installdocs:
+ dh_installdocs README.md TODO
+override_dh_installman:
+ dh_installman debian/propellor.1
diff --git a/privdata/clam.kitenet.net.gpg b/privdata/clam.kitenet.net.gpg
new file mode 100644
index 00000000..a486e828
--- /dev/null
+++ b/privdata/clam.kitenet.net.gpg
@@ -0,0 +1,33 @@
+-----BEGIN PGP MESSAGE-----
+Version: GnuPG v1
+
+hQIMA7ODiaEXBlRZARAAwRCedlPz0UfWaS+CXyFA/LEFNoLlGhYsDSHaNcxC6Y9x
+0APA5VjbsAPagOOgHXLLpJrSOtGoA42amKvpsNpUf8XOwMb/AkQKEgfQ2bMeEMrf
+PHPOQxU79ouXBkEn2DXcrG4txSky0C/kEt2JmuHI6LJk0phnLs9NvrL4XaE2Dspz
+R8ZfTxPHzmt/yJr9allDokFGSoNOiapcOisyRW9F1sqGAS4C0WDCOFqiGtdXOdVN
+wvhkompsHUnxLHg3oNVgh2WHGjjgos2CKHNF7KpD/vzfEV9++7yH2Y9094M2Dn2m
+buj1XIORSlmxBKTVpw2PN0uI01QgX6hQ9YpDvozMFdQPvZwbBVDBa5rvdJg9nv6Z
+usy38x9C/Ry7RL2EFR0jJ32WQCAbMDR5hTZ9owjg1adUTlj8wWgBqP3NOWsEQBit
+aaqTmsuXKva7IBldLR357DSCGFefkTdyKzxY36J26lrbco2mhm83k7Z+JaSo7myN
+8x/Rm86Y5J4iICWjzqtdpg2hjlJAJAYcLFLe5r26t4VaCeDPWM0nQetZzDR/vb0B
+hisNPJm6NoTt71lTvHZA/+4xk5pH+ua3EnTA+u1qC6OAh9eoGZSeLI7VCsCVL8U/
+Tvo/mXknfN7VmpUNSmRiePBfshyi4Ckd+Pgc2XJFa/8tiPPRqyXkEercDZI4I+DS
+6QHX0cfvNgK7f9nDJkFx5T9kP/l0OlACLnMbnUjoe4l3uFoIb02akrM9+Q+2KW6L
+vzies7WuKNDNlnb08M1u9pB3ShDfs6SfHntSzVBdnCdWwgLveBoqwx8NXP5jTr8j
+TrP9H0Bp9uh63EkbBlcUThjkMob9mxHtk6y0pz/xvzNukELvQtfsIBiLde7A7ymV
+mmnRkfS7QKf/EUnw6C+DtT0JsXRgpDy1YS+l5rrzuqL+9AyRIJzbTH0MAkkqnvCI
+bNH3ogPI657J50AXCPZbFfDiU3k0RYuXbY9yDaxLJi/3+TEdOEGcVdbu4pOO5D2f
+OcbJrWq5vk/ifQuoMpqNCHnWzHuVIeARCOmd3tOC5wV5Ae73C80oh36lYVYxyu9U
+s1mHN+PyUFS2F4MBDWu9DhxGlzO5MJIQYiBy1SMEkrWj71ngpAqii33F2B+vIQmx
+VObBZs8upPrIswGzc9Xa2eYKkd2xASNmynqGo/tsTn3j4vKXSPdRUuPFUxNXuTt4
+ClLyf12P8Kgbd5tB/Jm9r1c+yHjowg0d6u9zhyhi9Aklg1jgFTRYauiwQLxOWZ4H
+yuhPSgI91ySKJBqH+YJg9Bzb7dYVX8UNOZSBRz9U18RCUxMzpsmhcHC2tFrr9FRN
+FOyD7kX1O7DUkLTFPDjZZTbO5LmYaEqHi+ptriJyX9/2wE2qiDUWCbIji/1vqCmT
+2saPIS/UdIoNR9c6q9ws3XRKHhkRI8QZTQd+Jcx0xwzqOMnHnnRw8jselfSHtTL4
+1GV/K5SQp0+ZzYnC67Qu0nJrqfM7eH7e6n1j+dgV1LkLKwunZ5sQU9KF84+NncA7
+QhED0ppL4bClg1N/VLVOhPlzorUHds4np2wIorCVoS2XqjPUIFNlmfWlwZRd5P/p
+Po70TktbtifqNBrl5KU2SmM/lRjJeU/RJl4NSsnvA8m3A7mvIuB9fWmVkjmoepi6
+r+HhYXFdkcz6w3BYOJjNM18zKEuxSffcgwjtxPO7a+RvyreRhPxuBXYCsLn1FeDT
+gdM492sCouTWKUpECPJEjw==
+=2knt
+-----END PGP MESSAGE-----
diff --git a/privdata/darkstar.kitenet.net.gpg b/privdata/darkstar.kitenet.net.gpg
new file mode 100644
index 00000000..9a6de1cf
--- /dev/null
+++ b/privdata/darkstar.kitenet.net.gpg
@@ -0,0 +1,22 @@
+-----BEGIN PGP MESSAGE-----
+Version: GnuPG v1
+
+hQIMA7ODiaEXBlRZAQ/9HdpfvTbfOnyqLlEK1WC9QO3HrF9w9yrEH8hCrVFJ/86r
+xHK62+7I6wrV2W1UAHRx1b4H9qEkbD8+MAmjB2JYVmJUqvdzNv1jhsWwPpAcTQN1
+RVWR95Auc2rjXXSiZRudLaWdxZdDBg5PWApH5+NW5grtNRKsTbYB1/No2iYJvDuv
+WcbBkuFyEa0WbRiqUaUIyO9XAGyj4hqVDQSXH2Gzei8oB3PZh9+Lwv7i05lvSup+
+dtbtEsEdDiJbCTzIakV6vEQT1BDVMpe6jRQbv7c+LXLeM65Tpl+2hnTPSTy1zcr0
+bjfkFa6A75sHmIf0WGKAZj+jmNchp4AMdjmoMiXkHacDsBw623NgiMgzUnfWVkFm
+BIrdk5AGBi50nqPxwtY7nWd0cbApvNvT1zlx8MlRBSZQ2zcijo5AjiCwb+eLLVhv
+6oiKqpYGC1XpdNFFsaKHnHBCgsPIIetwx4ng0+lvRgBO+DEQ4RvvdKMhy/3nXrpz
+NVdr/gG+HMBW1BjyCd9ArmTtSITQWDT8vnLmyFbc0aJ88c2rEjv2BpXmhKjxEoEn
+IMxc3/9cLrVVRocnlq7YvKDZpfuwjgDs86D3e03Up7hQZhLU4+r8Wq7azxk3wE06
+lAQIS0OwCe75EZvVWYHwhZ3vEoBE/TeqeaRyhKpofFS5GvtIJsZBjenmRcdOJTPS
+wDQB/c3XkjuIrJErMBx/KrNQc2mAjcUpvW4+Ukj5vtpusi3qmSfsyaVJ4ZS9SwVv
+7RPqLsH5Iz3Ga6u4of/mg+iG/wqJPJy2A9A/XOnsNVCVR3a+NxjPqevEjW1Pr6RL
+SOMQSK6OuwuT1H13M1Z7R6dbg+pCcbc+hek9/6KzeZS9q4Di7aqq7+XeDr4c51+Q
+2ojS4DG0/vAJmOO+E8ZatGiwdI8kmELrzAF8zzGz+ZujXSuiPXVd2kw/JdfUaTRq
+KrtNhiGWWM44YWS43TYuYCoVgokrdVXzsZyKyhHzgXKCits3R5+QcUgUx2vESuOs
++FdM8fAd
+=a0dr
+-----END PGP MESSAGE-----
diff --git a/privdata/diatom.kitenet.net.gpg b/privdata/diatom.kitenet.net.gpg
new file mode 100644
index 00000000..99be63bc
--- /dev/null
+++ b/privdata/diatom.kitenet.net.gpg
@@ -0,0 +1,343 @@
+-----BEGIN PGP MESSAGE-----
+Version: GnuPG v1
+
+hQIMA7ODiaEXBlRZAQ//R6uE3yJ4Ee6XFgCB0Q179gbYsBgmFi03i+RmrmCnPdmX
+muLZQxqIOzMc7YwOxJt+ks5Birl8rQPC/avYOCJbWWI3D7sj3JFnet5/bSK6nX1v
+HoTYTxF/UZLgq1AOBOEjGZD7k9jx+O0ZsqKpielgxe3s17Dkz+V0adSbNiXEk0JA
+okZCHEOKyX+i5qpyjOyM0FLwv6d/hnuLOs6LFQyugrMbomns/QXtPxYh++ly8b5A
+Gc+qX0S6LGi+QCmPBsh7Bs/j8hVqVFX8CYwOAMoEvxf1ETehaXLnvk9AlRJ1r9rk
+T2zLped3Jm0ua4DKkenfwE8ZG/qfdIWfWo0t5cP3Qg+RNmqCIEP+lPtroKiKt9D2
+b3GBb5G/4uExceCAbvQb1jz1HLSpaeGoJL4rnYAzAORR/sKw1O4T53cj/DlmMpD6
+efhiLR0XVimeYDsVfAihYDkPQ9iHNlLRK/LXWy1sxwQ5JSgsmHjEqGrUP+JCSSTV
+goJgkHLFZP/0o6Ha55Ru3ixDvZ2nHtnPyj+CdHuEMnl4mgOq5yffmRnWpt63dLyJ
+010wFx1gOcmUoFIReeSaxoNnp412drWMiCfOqnxhLRy3hJOEuS2COWVU07fIQ4QQ
+LqZxTaJjw3ZqETKUuSf5KRn3sJt6n9g62cRtQQIa09SOYLBwG/FjzaMdrlFQG8TS
+7QGJhheW3/SoG/WQYSFTU2fF9qaQFB8jwfgqZT2YwfpEVmL/Ho4pOmz1WhzVFhUA
+Z8kYl8oLNmkrL8E1mwoDQdgLsas4keiMbtLIIVGwKm13MQi54nQt9FbKbHMWng7X
+m20YrqO2cwflCnmRwKaqx3Tfv2BtrSAdmJxkhIt9cQx50pccRG+gzUfPLvL2j/Ed
+sWXRL+wAZYzH+lup0nBixHDAJTv5TXhxLxL7e4jJmWt6RnS8cv2mUG9LhyFYxNO1
+4CS+jYQp58bNP5Dj+fk//tDNhQ14LN4QQlZwQR78PSprDxIMuaNehrfrYJm8MlXu
+ntj4NiHcumBDSI0POPKHdYsodkeafeKWBAXAHThmsC7xJSFvTWHpqZxXwmz8Ag2O
+lRpeptIu+T1/fPSqaOev4m1Uise73VolTTUGj0z3LQPaYxOcWDfFmdi8Tar8IUNN
+P8zF6Bgk9h5wUH7xSer0nFxpyB+VrHQyzkczR/eR/zyLnNJgU3GrkL9GZum3mOoi
+WTLp67JEpFNfJg9AK89z0FasBtJa2javgpcU3SEzN2Hmexeg64uea6eomosybaJE
+Ep1wUNH4M4ZwHruqMIo1Zp+cLtl0F0NF9gWDKslsY5c3l0X4Q2WgwnDtWNbCyxJg
+UfEXW8GhwcduFQiaq3W7IBuuNnS+tX+V9q9eoQtDKpukiLhupH+ftKloJgP/+/LD
+FQQJqZzi3HuYiJj5o2vfVgClFsAsaacmeZ7P83t2WJMEv9F30oSvI06ipjDl2ZXK
+coRVMT9gQS8q6CkHjb8em10i14jfJ9cwZTOWUoOzKJjUnrcY5P5+pUkqA4NJLMf9
+c6l2WMxp0J8oTQ+8J4oWsMtkSD/P9rIe23GEFXAwiV5saU55IkTL7JVUDmudxIU8
+GZ3gKgr3PC/5Mo2tcQZ+zvyjUW0OtlykX9wfhpjkGp+4ROmHABRtjZTbcFFgdKBn
+8DqJInYr2vs1DScW2KWThQ/be5XCTdi3MtiAdYONt2LzbvLDCQ++JEn4quEHnDkH
+NwF9YR6IIjKbeKu1r+MudlUKrgPJSsa8WJ1KjOWg2mmRpYGQTBuDnViMAeKvzeVD
+dcIkwHAm1YqkebvqqheHt+3AXfYnLqQuLYWAMG7LG+J8q+gbocL+C2hCT604Pe0O
+UJdSLX5s2mYPYMJ5zixaZWIbNF1MntA8keVAurRe7wAXzqfIxzBwwFxYxUiIqkao
+E+U4e52BXkqzzwUojuKezot+VhPA0dyT4NJVfQhGFdJa0u7yglvyN3KQXCq10GIz
+k0MpbN/lwMIiuOlLc6wTiWc4qDC7NUcrZuc/oYkOAvwvjEeT+93bLxKM+mmAFnQb
+Q1/5gyTY52zf3JvgltZBp3ODbX17aXC4gOB69id+cjloM77JKMgF5lzB+iOcVQnR
+SaT+EJq6HILIRgZM35jvpB+KyfnJ3wsFBXYTOCa4A3V3L0WJnF3WIy47QTP99tvX
+XRw3ykBwPVusMPiNuUyGmXXzK1XDjqQd1AzxF8Tv18Ed6CrW5BqL7cpsXX9snhTY
+20wDFHeIERMV6V/7z9Vap6wkh7kZE+1TV7YDohyxDUUY62uyjCYGePaFtR1Tch/z
+QbIqYzXeIUsKFVM3vMj232013zS8F364nHTdKk37HeZ9pTcVHElp5ybJg6nsdSqU
+ixow7YEm8301qtb/liutQzWN4YTc0yhK2Mgpy4lbvU0iYCemggDCDRH3ogmmi/dI
+ZBitWoKenYuTIkqwJ6a6GEJ82baTYs+bF2x2LHNN9s4GVuai9tnsPU1VUkguWjMo
+sD1fVC/0TH3U05u+fcZxcXRr/i9PX6SdC04rJN+GAOehZ/pG9n5iYBAJJ8JRWfiV
+6A+cYVHhiRYhanbdDatUzg9eh31SHkwiVB3uN88G7/4/rmw0U32b7/qFPyDTcwmV
+yzbouKzqQsbZPUiIZPoQ3zrAP0i4CabyBcZHNsUCat+C50sAPN6d5Gn1VevAtl0P
+6Lz+qmeqsPGMwZaAxvnQIohGPsc/3bVaC9s44/dzDNAYJUCRYiggCd2rRdYIlJKp
+A5pWW4cxeNr8v7I4/tzAB0YjED7iApdzjKChEpzl+DKt6Y/qU5wZqKY+sByb94Q2
+87lrohBxbDi2JUHiS/XtOBrWtt/K0vYkQpktmLCUz7qniOFc9/KP0HVgg1xCZGa2
+84s6CvTh8ug7cTA2Q2qhs4uZ9NooJrAHkMIqet/AHB/Ytn3aPdM0l50J0MNRbs10
+xTRgwVgt+KyzFpJRQ3EAymk3Os2F6WMVLcLpkp4ityGOxryg289CiC6noeMuRmlh
+vOoKjH61RHnJoUwCN91F26EUwOwhGfHX3Om8nn7Jq0uOc558vRvIwzT2QDw9/UPP
+UTv4lAV3ZAnZio1uct418Wch9NFmdZKyVW+PN1+U8XtMaR0zbf833hkCRXLX5Pt1
+pdYV4LtSrerQBr2KVRl+oG4V4iW+ZA3z33BAP+c5vPq6yQbll76/mh9eTsYKCL94
+UfEBsNdiCGvAHNZxMBzKtQosJwOXVj3u4lHBlNJGbKgJBrT79e16s4RDXmJmdbMF
+0Te/EWtGU+0gL8hpNo/MlOle2chYnDP2lZYdCHMC2tAoYQwHN0DPcE7jKlM49Ngp
+OyWKlewX3wdcRsVIhJer4W0vHOOBNNt++jykT9NL9v87tsLc1S5x0BFssmlxOalO
+rahYpc8zXFnuIDlNYRBLkwX7vkodxfzc+IKD/o8rSzmaykMzhaXpu2wW9WY6aAhj
+v6U/+JhJOc/qS07s8vnpKGf3pBQnB0cOF6rPTSHsiss1cN4I16zYfEtIHs7xrSB2
+oBwF4PFHZG1SN8RZ/0HEY8N982HcFee6rF4zuCK/YiOwnCAZWHdACANnkTle2UYl
+fLy62sowNU4yTPMgj9AOUmGl8gqqTDDsrTyGuhOk2FG5TH4dkt9ZPU9pMEDxtgYx
+cBFVC92gUcYHLlEU6d/c9NF8D4o85i9JE8ikvKK5CymZgVvb0NLPI8iKtblGrvL+
+K7uuUqAsmTzQQxFozvY5Id50QgOKpqhwgRiCMbG6JGJ3nYmA1KTQWNGJSXW8VJH1
++WZYf0+aCobwk/xEHWgFObsycyMtrY8xK7PSA2c5nQX0zsJY486J63DRplmEddQg
+CW5JrsbjnRXGTDEpQ9rtMC+EzkNkyKJTfBu/OIFmkemKybXYf7+V0L+BWDOYh+yt
+dPszbKopfVpvHHfTCUFzuv9Tyv6HsVP/aWcgQXPzZqVTxTr8FThvFx7dNuIsSUiZ
+o795QOavi9DFxk+4+26ExefxS72H8GlAOVVekfi+FkiIkTAdYkbjLrlrGbZy8Y21
+Oy9zzcKu6ojY4zfI+7hM/DNmNLxSaF1+xQM5rgaCvAtcX4YWyMe5XdTrUS0c/hDL
+ogSt7tFZ0nG1jKOVpckTHgoUAO+3mr2x6nyfoZL4hXDkXWCEVlsjfLRIP1D1TPbs
+e/bK/0OO8HlV7da+u+Et27WcCtTXNZ7BawC8Ow7NavQKRfFEZbGjupDUsPu1qVlp
+ThZt4jTv6REpGrzOTuJ/iycDhUwlM34UZeNSG6Jf+PXjuKZ5HKxD+3QJowt+jo+B
+QfPuJ5aHcSXi1FlL7+ypy/MqUANFkxaW65G9gxRD3aW6+WiPHxiuuRcaG1eo0iWX
+WHK/N8FaFmKs2vDvlVT5ll+Mt9pceZiplG2mK42HohgHZQ2mJDi77610KI98rfoA
+OvNbLDbwqpTirfIFwgzd1Lk1o8xOzLF/B0W2SrzyN5AoD19zmT3QGHGQwPgpadBA
+4VtQiTmIdOojEbheJFaMUfI2FkdCwkdQqvCxGCEQDh7CQ4Bep7elwbZT+Qw0sSx2
+7UbTZxmJ3v62ujZ7whs0lnW5DrSjw7tIWhX8GCryXJjETVxgwgYONXCQzr2+5YXf
+E+fLOR6zLekgpEg28ERZFgv5S4aMJCWiFnrOJxcKdOMhyUJiDI4OUcKcdqRYws2c
+zW5gTRlaVvP5tCpjkQr9zNwaWuwm+LLVwgeSJqqdDvfrxwJlmCXFQ9etBCQe4A8w
+oCHY7H1MFaDUHUn8hHfn9O4Ju44OVEbODC/aCa9kNl3uPrIohj0w5IyCqj3/I8Z+
+BcBn6+YsuU9x41q/fFM2yHZTpb5LeMJXjHcquPqyaxWT8ZP+TTZKvCm+/QEsuCtO
+1UNxAz2voET4gYswlZyAaOdf/IFXuh/rV+ITqu4cia3+EMmVpj2T/1sgVkC+iFVJ
+0rZDl0sv4Ezhq8s+agi8XJ5l1GzDW2ejs2VYucCeakkl1PKnFTr3P8a6seHIC7We
+VMRtqkCtWRoSiPkwzs5R3xUFsmon+3XFyaq1CevAMxneahDYNmxrStQoO00dHa8f
+8YMw+VrSfRy2LzYh+X/zxvf0bGSGESgZ/Cu3vBTXp/MzRjrgjR4pKsmM7GzRv2SO
+y/bgP8Hyk/yn8Bnh9OCQo32tlg+mqbsOBd+gVoB+3DMtHasIaOvtqfElnlS4a+mp
+Y+026GT+TbPpaIHmXtpmU54Clj/1gErh6gWd44rXktLPHEMgQrBcRpPpGUFTXdAP
+7DdDO7ovfFeieErW1dmUJbQIV8D3tVV66QOsKlJBK0LpZvnzsoPhFvTgxYr1Qr5L
+VRpHe2cZpVup7AkpU29aLRWYZJvAX7iCBtUCx7Y8O7SRoVxkiue5WhLe0JAMDE9E
+oUqfXVH25kaFZ++YlVFwVYvT5eFJqbQ4HRIjPrR0kvYei2PGyf132kAVKwBCXX7Y
+HrXnGiirzP7/lSnNQKbU6UfB/LsXKjR8RNDdgYadZAz+i6ZhwHE1OevhfiaBOs/J
+/M1YP5LuVDFBxeeLWmAeMhqCeJXtVsBJ06FWIIP8GgC0UYD2aWxzyZc5OQiv6eTB
+TdO8TmpZWBK+pwJ1JaY531IQMS7U4eTtMotZCmiCf181YxuKIq24wBgb0pHvFRD4
+Pl1jAs5qWbICxxttYECXI8hD8i6in3SKP3c5sP8tHQ0rBR3G+vJ3cjdnE9prkJZe
+BoTIBrQqueAMmkEffAZi1vdYH8BvEYiVygY66eN5K+DxjGUVhf0yicm6qkKbnxt3
+WKWxHem9HI7yBjQHRhiMVcF2uX8oAZZN0HzJf8yYQjfkx4L6528PDrKSHqVow0rX
+VnnJ1GVcQiU2ULpAc53Fg4lcZaTJ+wtTKQ6m1nJEJmus5QRgaEGsZFZl70BF0fGo
+6i5HlUHQdr9YAOuLko7M1JajBg1hCQ8zNB2g+mySfol5W/Vh+K80Dj98rikrhrQd
+MouaO6Vht6jPGmbaoPtS8nBUM82FxWrTlIjcf8PQwvHoWmoTuyQ42OeAbNxOexBj
+6eseQEst/BM0+/fP/W3FllzEC/9zc3qZ+pM5zedfkhemb50bfVfAZi8P+K8zEiT1
+8U154CeyKlegVrp0SNsQbxi32r1kpNtzrbMORsHJIJh7dEma9BsEXaFImXR6Cvmg
+y1uhBw4UkDkqavkwGBbpPMlzYXu1rU4Jl0Ve1eDsefnMwBeTJuLLqUum/tOGyhJR
+B8dNMqiKOMY0JGiYuXwztj+uOmo4NjoIwGys0DF46Uz8oP6z+26yI0oA/PbZYzW4
+xBbaSQvigykVOun7CkCO3/p1BlbBmLg5dSBwiACeDKvcsD2V3o5tCP9BMxCEoThc
+VnQYVyCssfY83FbW5NVYQyM7MOj2QFKlWS27WgxwbEy9l7cjkQ5vcZcGa2/EbCTu
+fI+YX5ed2QJJuKhozlwnQcABuKjtGblqO1SYr/du+RSDBYtl9vT7jt7e8UKgnRoc
+9t+dDv4W6KqjC8IPw9jre4QHqPJf9acSj8uz3kxme8TEPgt5AdkITqQu9Gn+XmA5
+LPbTEuZ4L6XLjCfbRpO0gJJ2EoMR8kUc8uUPGwNcpQZAVfyNngmMBjpxF11Rxs9P
+bv09+cJEbUUdArjZNyILRsARUVPaoRQQ3jL3oiU+l96fUUZ6Me/c26grpS0Vakm2
+ubtJJvBBZatLGOQOzwi7lxhF2Vs78Q2SJ9O9ID453DFgoeKfUZCm5FcvBDrb/lYo
+EcWbhLqUafHe1uy1pklFhJBzB6P6Mqz8DMt1Hq8E6UNoMFYCKOTrcSCbSmM2nZwY
+aMCBeIKyD82n7Jkywt2jVnuCV63ZhTv+Y9kTXZm7VjuswI4vhfgICDZup+Oeax+O
+lL/5R+5tB/CbuLrzk85RpvZT3R/vPDoVfyTibFzZu5g2S/pEVwU5aucmZnGY9eqP
+f8cOq9SsL8r03zSxqjEgjnaICrfWplq0BuxXzrlggPA5co+cWHwwOt7IrW89XRQC
+Jsm/PHKlCTKuAxlXGLGRjFvhP++CYv8G344PYxAM1GAQ5pL0nrXKel0IN/5mt74J
+iLt9Bs08aKpkcek0GaZTaSYaG1iosRfNX4vbIlCJuOCL3lyGUfMwEh7wdVU3k+PQ
+myAyijJGPy9BNGaymPqcTKW7hZGN64VD+YIXi1991Chnss0BSIasmHbHsplNxsc6
+e20kBmNq1KnaIZGgzWmFPwneDNY30cMfsziCIYIno1AIV/HnwZBwfwMU0XEiaZFH
+QBbm+Yjmgb8mgxDdm+kZuaDUtOlkjhdmXqcRwixlcEymP8MxGmjefhhHBhup0vD0
+MTDyi1plGY7My0acA7HWnDJG2dqpRFmBtS57Zr6gAsHyhyXi877KCnAsuHuDtiTQ
+Nq52qW87QhDjyDEuwAu+RlDbgXTUVuhvMdF6yFFfvry1oTyDBW8BJBkALqDeXLhF
+qxdiufOWuGY4jbsoQGd+QVoT8vhfRUKNK0L5bcTVC1r2Ai+L53Z4KvYzp/DGqHSy
+3yi+h8CY1Ik90X6+EV4QTh7qzuG/h4TMZyJptaIAg0V76r9yxpMNF+v16dWsvTCS
+bnFb6duhED21sXoU9qFYwz6Qo+Clv4ak8bmo1eaD+vU+ogFGFqNb0gsPgtHdWqIS
+UQYI4jJe7Px1KQlogxSz72us/aefdsebsiHcXFOQD6y2N3Ac+roDrusecQQg5PV/
+73rc7SWUU7nY6OdmEGHBrP0YDwnCZR6wPNj7mot2JoXiJFj5mxL9poJQfkvTyniU
+QfvRXfCR3lzGHjOkUXlOBcYI7SSZ+VXXyA4U1LjZ09kqNILTktNa3qNQEgKDfxbi
+WHRocGJUG7PF/6W32dcIRJNvRrJEQVbWAVeoYLEls3YU+1m7rexqGsimHXrayp60
+K/CsGqVhdrvhMXFzq0dDMtel+UZxIuE3jzcU8mjcIZ/jKfQsnTXPjl8yTxBh23sx
+uCrsZYwuVj3XS0H9FoolCo00/y8yRvQfWDXhu8qCaDzPIJyueQs6ypTUY/p9OUHE
+eAxCflmMQhtgc8FcAOZNJXkHzcEJJWrQKbKVNjmAayRd6xFrLSZ2/vydKw6eHjcH
+8A1tf6CV3xLvI2vZV98tJ8QMFozmqtZE3GPZ8WqX1IIh1xWmtwLEJ7x8FBZ6QMXS
+gOqYg9J6W/aZPEqeJFhF+I/DYD5vCaRShAniI6cjRrS/dJWCiwxvD2/S/6NsTbqt
+XYHKJ6YKV2G5fWM9mfoY2AF73SBsU4RuFaZM/IQZvk3kCSDOUcuJXJRhQ4JO27AW
+O6RTaW/9s8RJf+PRk6rpkGJ/70MSobF5mLAByuiLmUyzHUfVw98KwzC1NZZIwTSg
+d4eXp4TD1N/M4TM3rk8E2TSAGH8oLaUIV9OfrzZMLJ3SVxLcux8Sc8iYu4DQ8fie
+B1KuWrMvQcsM87s153pdz/VlJTj62VsZx0OA657o5ZMAff6VmNwyiw7sFYbmhw7i
+txOI6UOjb/7azIohb6TE/68uxt3PSc5uuEBeCxYMereOmtpGTvtOWzM+o3RxX9AV
+MAUmAYCDCueqPOP1qmNAaZlzn/pN8x4ZOGtAIa1imGr6LH23KHdP4Vxt5qj9EKiW
+sL5eAqDeLuD+iL/eGv6LZWxh76ceiR/P0N9X75SvtNCeZHBYBiL33sYyEvB0+X2L
+dqh+T8OyTjZTCgKKgMwRcOKwx74ohbseAKrRtVbqCK7wF5O/NUKzaZ2jEC9iI26J
+3h4afTfVaWQW+TLZ4szKQ3N0hNCKNLTPVVORgPm0L6Dr63lHwq87PZtOpMD4jFAR
+cufflkJqwhNBztQrwuyHAmzrsD5n1W0N4dGao26rPvgEBZkOlWXwfwNgNzGldKsu
+KWq0NVo7+/iHsrLg6hoy12ZRS7WsCjwDCbhmqjfHO8x5+svhaP94nxseXXZj7kOF
+jaf/uiVJheXboqT+5Akgx2MYRwoQZPANcKyXABg7Rfivb/DlSY3/aD+UWRr6OLHf
+zxOx8oe2nCfHkc5/FSrXKQhOuj2ssdcpF5YPC2XmikRSkEJ6xclKw4viS+k8NgXI
+jawi5atbZ12KQwejhgpZ1WTN3dcru8YFmYA6oWatc7QTw1hwBTW6yC1K+puAJdeS
+X+bNLhAp6g/lYDRnMtyrF3w/IxDDieeSnv55S37wtqWxDOfw2WrhdQ0g4iGt3MKE
+jglFpYA0ARA/L1jquRnIdAD4cUw146gdy159qiR0vbxmaM9yvRidLKNHqPN0NOiq
+KR7ArDd1tfqtK2OkRd9y+z1wNWhbUGHng8DNChlc1uZ3zpySenfBVKzyvH5BPe7j
+B57JbLVuHRSJz9Cy820sGAhyb7j7MsM7YZ9A2+1vsozW6zcI6gffsehf2hzt7Vid
+DkfnEdXcApjJX1n6bAu/cjF58qktwzwOmcuJlZaa/OICAGL4RXXbi75GgcXHZhxN
+HPCo8HULQLEejlgWQYYoKPZd1mRDnJJonBZXEAmMKJE0bBqQd5ECkP4RX2qiBG+r
+YWck0ZLWyNLo8Sx8/zBQoKzp2lesbwQMpyiPcnIE/ojfOq81zfMnu6F2Hff7lXhW
+Krb8wCylzRL8Hy4JTawAUJBKjavi3+zTYH+0xujCGoNuq9/AL9n7rccVMZXSxmlT
+uIJMjH2/LtXamND//msjCl4iyIPEfmNNnKpTuDaw/g1zo/ReF4/BbznEod2ScDtQ
+NQxNZC+ucmgBYE+07fiUDbq5J/OCU2sQuz5z4h5ykwBDKD7AZ4zUTAP8KcvgHspv
+bEOTruMbB6LR3XSqocQ5nh3Rm5fiHfFhddox+CBb3DhklXR5vxas2Owo7W77qwwK
+kwxB+2+J4QUESzumbYRlMIcbZwRmhj90pCaIzwluaPm/kTJal02yidr2sZl9E1Xz
+9vVKXwDw8Po5i+Cm4qJ3/6LTKOFRr6IRcp5cx3vYBnt8Izd/jJcmi5URsdUN+Ruh
+1Zg23Cz4K3E7wD3pehdP0/7+HjaQ4hKF/82bljRexaf9Mv55G6ez9QhOPox3fLVB
+qvhQVEDMTog9wTaAkieSthjQiefXk72r+Csj66gB7J7cOY97Vt+PwWcBQjn0MzGR
+I6D4Y8t1jNsT/6vbVzA13I5fEfhG57F8+vL721GIozYIwpzdoYosTojmiG8igieC
+HHlhEyO5/J1CmmAc6zaiNaP4XFrM5XYxH8b2ja6tVQtZfRNzvLgMjwxvlUmClfGu
+VMWdiVH3lg0oIFSQiRArpFE2Oaw43rHwJBdC1S/GZ0t92S/ZJ8wmo/PoUCo/s7Jp
+R+AmJy7C9V+uBDXmYFsse5dLD63u/o2gww84I+hzACjeODOWl0SX/4H7DLZlW9yK
+cO2XVKyrddzGiMjH/EK7l8Bzs0do9hEIkxcam1p8lAHXfqgCwHJSJDxNxSjkdyug
+BVqfHQSkt9kc14eCj/qPnP9TMPLBHocKLVcYMlywwQ0pUDw8oqxxiaHMYXhHxmDj
+2i4e+MbMrc1/Ffr2h0FnEtANcwIOBmWMQRWGMyOq3pce6F61LuOOhMuvYTTtmB6D
+Ov4U60RuPS/aWmsUyv/JnBU3SaF96wl1Khwo/kYP2E+aXyQz5yLui3TFeDTEJI8p
+A7l+qIfxIXbOEDlWn3gm3HrboAbXCYO8UxTV7zmEBJ1FzlnUCgKcVtRdg4lsXcFT
+xbW5mT1tw1o/b3Hu/FPJ1xWFfbyQMfrqyCzD+lKkAf4ASDoMpZilkqMqxf64V+Kz
+ErDDJgiWbLETyWKooS3Wz74dy1qSZTcgcT903t7/e+exLLZ8HJwgHMMP9Klp8vrO
+EQCHVrKUUcoTE1ZWXYQ/MXIPSU9tDBciD3OMSqpsB0zfL4MDUJOKkm6Ztf/JvEhd
+slMsG9ywrPHZ4aVQS5Z50bMO+CnER6dJCmz/ivQTMI964mqeRgXiQ0gZHdRkggJz
+WpSlDnbgBnzTN+w/U45lr/H9rhjgbakLpvEg5ntYNIAXrZVuD+upc//tJIIyJB06
+yDLNc2f2Oo0p1Fh3OyhKz9wbt5SmsgSrjPNcEuDziINtNU1EyaD1NRMoY2P0eBhH
+2W4JYdDczX2eZpsn0XX9+pSRLEbA4lV5pN/IJpud/nyqWyXS7bKO0lMZfIy0uubi
+0606skpp8VJVivLBkVPml10BF0KosLv7xrSWPM9tzLIHdcHnx2Xo4HLvLQarLuza
+gm7Nlf277Hp8uuJNa5dZ+zRnTrzQvMh0HOmG9c/Iur80Qomgdu94VErx/cv4DPEA
+tyaOkw6PYfVAPkXYmcCtuJpegozF+DBTKqwlH242oaz9wdv2l1Y9l4d9mSy6cR95
+/n9MTQL11hV80rjh3xd0r/wWdwKiyVu1xI1+RJoWzP7gwegn6XMjUrsVSy2Rroti
+E1ABEAd+bAxdKzpDzDiYks9o+ha/FvvUEBwIY8cw3Fl78KuaiYkrlFtiQnaHvE4N
+qh/OGU8y6V9/tiLH8ksbIsDxmBnu4l9919pmCmmz454zJFIq4iorJ7WrbS3aOzPr
+06OJU4Q6s9S2lcJgIllh8MUrfRKk6AKA5NcF6CZxdTEBiANZ8EmHNbyBxpszOMva
+HaqtSFCTLVv5de8Deh60nWGnRT8EWYPyik9X1fx+Xj8SYfPIF96UsG17t2SRqlOc
+iYt44rPUJ+6hBvcEtIH7gSlOsZgxjDLlj63C4vWZhkVy7Fh6+fkpEmGCjN5/VnxD
+gOTCEnKDYz3PSCRFR7G2f9sN0LuY674vx/oIfOkKTmlLl8phdV9GfM3ck7pw4JYP
+FgW7mhrW0m4WChpEVWPKBqtjveuX/66iWNi+ggPy0gozKROW89qzI8VQVHdQ0Wwa
+7pCqaXlL4IhdAAPPTjPyiq05PLJuVS1SC3gFK5pfVj2XrwuBzBhAlK/CZ8Z7JFLQ
+vA2o4RjolN3WRWwxf4nAA9IIDTTIqqB/dkZ+QuloI714MUMWwIMpREtwS/ZP5xNB
+jwN+oZTL8znRkF9tt29ILJo689hBoatVTWW2ZJ70JdkRkzcSELHIb+Bedmul03ul
+8WIfsf+5RaArNs1TEFTHwFlD6eCTpgsCX8nEYcJJgvHj1VMOV3TQHB2tQYpkf6Jj
+W+SDE/S8eEHXOvOaCeZ8CFYH2l5yGqqfCvar955ue1t7BFLIbdqmqv8lG/9/JKGF
+fDkle5O2gz9K+1TmmQ6XvzVAG2fi98se8cMoY5HxYVXx2+ocMEZke1ixv0bHbMkD
+aSvnYZzkS75K3qjsmyJS7DJMJO4+cWp//3iFaUhRk9755H3oWVrPCvsmCX8I7x3b
+hSKSWXFYNJmzuxNrGasdehJMWJ5sUIvFdK6t7qGxoGmGvFtwJ9GrL+h/ETAk414V
+KwWnMR5VsvpXzFhtdPqH1SYQE49p/xUQWoyHEp6dDkwUC0mG19mTf7ge7x/GrsRk
+piF6W+0naKC0y5s+kYsID1gIoHNOGJQmsNLOwXQ+2lfg9d3XaBAe3Zd56oN1LEnX
+w1PoobgcLkR5ffjqacsZs7FJzrggGXJmdEwoDYsLI7xphatkZc5lhOsxIUqWydOL
+S+nBLpFdymzVsN0BQ3iZSt6Nm5KVtqO4cS3YKQOcdGt0VV5Cy8f56CD9Pj9Tq79B
+euVsxneiZqWKt6OBV0TqbXGYHgWc6eSuOztXZSHkAFg+2158WpS19dpQoZEV7gxk
+4i8rHbjZTzdFkPhpCKE6tkzdzsCxuvYqMQujfKhgmsIe8j1AQMj9VLDJG1lqk+tn
+yd+WjIYSVnLZiW5Jsht689vcQCtGoauqG81apUdD9jALAdACmObjsWhlw2cTZ3T6
+OHG9YF+T5jZZu1MX4fDEeox6klD+N8pmxS+qOam0BxPpEMP8ET4KaekSEvdyf1tw
+mlj+EBUzDSD3xSSB+BO3OhFuLf5NdhnpX5mZtRCp/7Z+3sf8Zlp7/AkQyJgh09DG
+AgyzGc7Zw4Jami1nCojXdFp0wqW6bDqJsjOyf01qMAyDWilACnBvHdDro4NDhffm
+AGmUHs5L41FQC0LsGLj+vP/oiruq3zwIeaBg4HRJCJKoS0L2j46ZKTM+cGdpzNOp
+g8uu2tWQxcKHW58AlFQr78Y9lFdZUOLGuzN0vqmp2N58V9svxD68+2dnNmApX6Yp
+LOG433W8tgBXItH+DMeh1aqbkeRDmrPKjXdl4Ez+a3411W8SLGSp09mslqK+Kr0j
+JdJE49jjAh8NtPvJ32BBJnTLZugZawognwN0YzZkv8KReCyQ2zVLgIWku0/lidnT
+moOaeHJx6rw8Ym/eoFL9T0gVmGhgyCbUa6itNERQiGgNlK/SOZL0sfbgllSxIMzW
+/unwWOshx43g2dhXNwPpPv9AX9Qy3+8OB2aLEFs80Yd0DI1RveRT07HU7PDdddUz
+JcM+xMlPSVTcoxNtDzc+3qkHc9Zy2PBp3KHsymseZ7cw5Mi8gMACo4vI22TcHWZ0
+P88JM83LI8Cq5H1NUJv7DKmej/CV/wkJOjypUZ+1r3ie+YUihUgmud/CHkk2TDo1
+jgN0hN92hfLRY42MDHtEm3yONzNSTpCywwKbQJIu+lTFcCnRJNvnRHxmfODMs5+j
+BjPTrdPUE2fB2VFN3ZxjMBCLCj6Vs4ukkZ8qZPyVyw8gwgz6wSY+iOf+t/W6TYLI
+WZ8faemWwYyeGidyOxZUlxos+TKltM12w8oPnvSG4ymbsVQo9J09UXMmBzuIOoPi
+7dp/6/RSNIRRZybUpNVAtQEv8paeYYIuSCysZh/w4B0AYa5ZaUsolk2n76bPIfbH
+20nctTpY1ms7IMfIatEeUmoLf56u1L4fEtV1/NM9FcarLIW9ni9yv+DweHICSSbq
+AKzb+PUkSgqZH0lBN6cJbqvaZgU20rwOyZOSPQvBuKXdv5SzQUPRJlSCTdWVpXco
+EQ+pazJYnjAYjLdF06IkmgtwExQsJVSjZT/ATJT01cYQViqp6XSjPIld6G/mHDS1
+Qo1qO6y9he+ZqWWGUQEZc3jyVklNKSJ1nmwb/GTLsNl6JkSkV6lU2a9RK+vKsC/d
+g9D7vpU3jXZ1aLOYDo8ZKUwsNTslm1/7qbtmlBkRJDRKhTkvD6Tx+nERD1tByJdB
+QpZBT7zp5bDgr+QMzyiBf0RVeY0I0BXobPIhY6yALzSjqy93XWgNgtUnt864xhEW
+kxN8codcZArooWivmod2MesbePwBf0QDovOSHhO7szmmfs+kWJr6bc5zwz0Nx66o
+CxApsMXv2NFjTuO3D+3OojEJiKW4vDbEWS8+PsApfQNkkdVQfSqYFsPbTLlNUYdK
+r7nn+84lVqLFVza2Wiix4xdwa9vcKH0B9VZDKB6IVqAt8QlNWQdXp6lwavet4x/2
++G2sSpbPjjxI4/8p3KP5fOYHfstY2oqsSe80ApXtNN9LIPfGTmiHFipwbIzmaEOx
+9szPnOaCxkeeX/Y+5B1vWgJi2te4GEoulco0e1iD/6MzBxBhp7B18nrx1T/rwKQ0
+m0QtO5CInv08hX1knxB+3ieViIdbW2jUijn4tkMDm79Io/nA/N6XWGlPDbZg2oNC
+UlKJ4tMZJMog1kb4I6xuXgvyyKycJ+JwKSrRrF+GC97aqN/9jSdnGUXU43bYzt+y
+4y0emXNgj5Eg7CWmZGClATjgm/bnw2AjJxtDiJl5w3Kl5vtZrpUuxKsD3CAx2anZ
+4tguQ8JP5qAeXjp/Prujs4EwMHI+xH0D+vVpQIdto8/GJ8ECog2M4muFlL2bHLj5
+8h7+rHyPXw7AyE52KeR7xEXu7ll/YUre1TJBQUSjJwCbD74bXVLK7M/yRVrKnXVs
+cHBaQky7Qwu21fzte68liP2F8LOK4jG/saXSmCItkVZZbdAuRtJEzJX80h9KuAIT
+SBTa7YIe86nX6ZACuvwJ176fTMzhLJDgnsTibfIMpx8Pzyg+sMsu/Uy4gRT0MRyO
+gSfY2TnzOjrx/n8dwp30FOoqHJSmWixyAHXKQCvh6+PysQjj8XHfd01YiUT25xAf
+Ul+SVLLyL/iKkqlCLmwRnzuxLYlwMCgmFiWdj4QMr1BNvZa1ZhWP/nKV6/gyz46T
+R+eQLoO8i1BYpcVJxMgtPv1gpuBwyFkVuZZGM2gNGb5APMkc6vDBLw7/2jYGu+pR
+nTIgCG/B/fcqmCsqivUAaI4tcz2spTqCbiVlL6/8C22jS04wydXVWwfLt3PeliqV
+9BJNw8bE5TrZTvQst7aBD37+R8bAcFIC3WSF6dTrjajI1srxnPL6cUpibbMvCId0
+HI/jYiHWrsejE3Swe/gHrBpiDTSxj5Bue210IdAMIcW5rrsjj+1QHNBLN/UGBbh9
+mO9pMP4FjBt1g0921zmoX5BDbPT2ShylbxQg+734EXUD8zbVOKMLyaFn3qe5vxt3
+8VrxphgttZDbu3GNfR0Fw3tNJGshHPcMwDkAhaQWQCL1R3rNY9HmxCsov5ZqCXBc
+tDnZB32AdHLBxxCJPZPR7KdEbIXAPJedgdrn0UVRVi/M/XeCW39gcdA3lq3h/4qh
+jQm01ZZl0mydPM+YUwcwSe/KU5uSaxHfjhD35DweiDv1USNyCfp04JJ4Z94rc3JH
+iOXjxtAWgs6Mk+/7KOePCW28Iwu410IV1ls3Ayf4FT0QAKC6OgQ2NNmOdYD7lPtB
+1lFqy+0OCSdwaTA+MeS7moQWklkSpO9J5G9ZKICAnm5XBCZM8Kb8KFuwUADK5C57
+Xiqxu5YkRgoFRGYmmsDVXLSSsQuNXfp0vE30GXcRdDYzyLQ82tkUQZ9iaYddNU2o
+M4/DnXU0FgeeM9VhStZsicYOlr89k3l+KBLr6LiKuNrMkfEw4kQsZvcXHRlX8xBE
+3pkQnLQnxnDyc11dYHXaCnXaAvY13HrRY22jFBGSCkng+BvHn5IB6JLN4DeC4kVD
+vJ7+O4s55FsI8o/VU1KG9rEQ0cxb0SS09LDxnLVa64GMnO/SWbXCdHa/cCkNsyPE
+223+bUhCdpcKw4pifTh03XSwPuBaDNPRvNGScO6OIqys0lpquol0h+Q6E65KZ9tc
+2lsEi6jIQUTHUhW+NeIglQzYNlGTskNPNR590XFDzZqeDzF1KLRMnM63DNCHVGd3
+pDvTFGCU3AavJ1kjNGGD+zWlKA3WxjvSYH2w3WenYJ3S5PSHCpKaK1d1lMZPFsHG
+DqEW1BNy27FMtk7VrafN2Ost5WJUQD1dI/fovWa4E54Jas9k4K+aprD/QP1FhWyo
+FNKvKPv+WzSQsdVHNA+8ZbFewXSlb8MkibL7S07vDpDXE98syO7k8M9qf1IogHF2
+TZc89zo65y6xSQ22Pp+S+hC2D8FNABlRcucKijodm5PSVtC8EvCJnctKQsoH6XjO
+m5lMhMp9pi7SOde31W7N5NC8Zytr0er++BpGOL0jt/DyxfNPON//rfaOeiInJQkb
+2GZcTde2MkZ1zK3bQXDfLNLK+zJstiZd8jXnCkBMgiLn8HBFF5wmQrw9XuBsFhLL
+JPXgq2KCJOgd8f/i4MlPngSeUkQzJQfXpproTwQI9dGKX33yhY5DBGg1JxlURWhd
+bAayRhucKFlpi/MPiOfIarsYrwPesUcVyjPGcGezTEvo9q5AGErbqOKg0cIkAF+g
+8PuR8h8GZ6cLnJ3g+CuO96sUlvyo4hIG3ZgS0EdtayxlxjdDirT41JdEgN2m8yYj
+npLrf5PhcAxLoZ4xj9bm2Wh9ZtdgCUDoOXlgl87ec3PHHmQ40K0uaTkQ5/TpsbWP
+rBF3Tnj3E5Y9S7ii1h6BIDBL4MExfrtB7BW/T88QLAmFUCLAkllfFsCu02duJrTW
+xYt4lagHw9DNAht61ZCJZpIdDE2i+thubRGilR1REqc8GKS78GT0ux49fw4rVo39
+AexF9Z8NCZtwZJ5pGPPC9Nn+4GqfjUC62FUCH2hxBKMw1l5i7si/D85U2fpO5PXZ
+Qlr7PrqMplv05UknlBbYP9l6xURyE8A06OpSFfdMd+QD6LUOBkbZD0Qf508x7UZS
+rFqwEuzjSrgDFHyHJ1Fhfh+nzmI/cl8rew+4DrkGm0OFy+pHgi3nbIYK50CoxOFo
+kDAOdlbK/1hAN3T3RrTZmQTTQUZZJH0De2g9yLzgfl/kFRVSckpr30a8yIjSho9o
+SBUMlUor40Qteqmc9MI1prYGTe4TlHwUCrIGLtaGUqDwsPpLkshFGiWA39znrxlf
+q7XrJ2x5k3PqBkdw/saoxivCBB43eeKYYa8s/VskoN+lM4YUUUBXuapV1EnVkZjx
+dW8OPYVG4FQHqQkyhZ2+jdDOK/BQYK9b6e1lsCBnp40KuiNgheVY+4In7sqMeS0h
+Yev3yYvcnqAWt25ha2uK3Nzv3XQHzf1cGjNFq0JZRLbkhYIjz2SqcXuDz0g7g0jX
++eCJLmW17PE7SbmJnZBDcyzwu4p/r5kNKk3oatss76DkefKt41zBoGvPUWktEQhu
+ZWijRDL/opoyRwxUUVZZxpSSD1AYUYR0Yre0YIYvmsEw19cwHql96m/aQG5oUhK0
++qOqJXC4YuP+7hpcjw6PjE4IrXc0Hfm7zbF/LE2dFFAZWE9bEerSoptLFnrpZlgI
+RosgTD/MNRBQksXzcnK1DdpaCYqFIYHGDUhPBE9lh0w8SxWkdWToe47/PfXCmnLr
+Iud8Hnw4IqOVZ23hrZrh6Wo2vshDyHaJgXTBKyQMZqaGCljbHGDRMXcrXIqd0Zct
+wtnUGEQ1RINm4JqVyvPIt7ZO4PRIbzfV8cmEW4Z6U+sH4p7SmUd5muVnJbiKDbtA
+0kszNPgG9OvLazeb3OVcFSudMiJS49VHEisqFCGS2G1EHdcvsLZcFLbujh3wVqua
+98Bg0tpwVRO6MaUsA1RD0juIPQV+w9iYnEHmS2+N06IUAh1vNS3YSoABSuFj03on
+Jd1eKp4o4dGGiCDTWqxfggykL+L7KlI0ZudqZHV5yEoE12a6ABbV41SQBSJapacI
+asRhh1/oB8vn3sT1XUTIT2j2nbPHOt204z+Usk2MBlMSZNbu9zX2IuS/g+EU1b2P
+eoJUnkrDtis0zIUqjX9kN0e+1d7WUTOFP0qrO7RmOxrc87bzmL/5KQQNfhbGV0KV
+YzGahTkvL6BQ+LfU/IHfrfhPTZc5lAmcDRQmNu4LL2L01PKQh8Up1hSNiG6eAcIO
+pvaWdLaDtAcSxszaiGXR57x3Ac3prCOByVYe0cBAmY0hcsX/xtAAvLugT51esAIL
+5Ula9hu/VmBrGQAYiA4iorpHID5AHYOhwTvkKrpEzPeHicL3WT4tetCx2pCKcoUU
+Jeos/i/Jub95zJsE5qb42um+QSteT9/UsFPh038SvlMuzTyOprI8nswyD90pHre6
+nR1q0ZWnxZaaZvbsMVUDu0nC8w7CfsGaiubKxJycf5GWfZpLtg7+Gw4C95oKVt9Q
+u1h3lCItsteI7+W5wVqjaE8wvAieU1MouY7z0gnZS4jgUXN4e/4ziGCD58X8/pSs
+aTczPsGB7px7MwRuEulO+coG+alpqXH+9S0V9V9ibHlBkG8h3zzXzRqfkViJxg9y
+Q9RNNCj3jtKnpry+rZ9j0Tu++Eb9JlYSV+eCTw9a4QaXU5gWe5kuIjN+Fkd5jLv3
+ndIKNitSEFRG/+KToNoHlKMzhJixyVU5wvQhh+npujh9y+Z8iKiaoTqvGXyXvAah
+EBfGgqXYK6NdR91GS4dQfTpVADO9rk7oNlHB1c23jy5djuRdg/YL3sBkduFVPg1q
+V+IyjIKnoMtpXZZjM1uv+uMzBVIHkwHEd7Wv0RHCV/8AWkzltdv+VJBFCQqPvZAU
+wxmgy5CxfYf7o07Z40OdojMpyoazyH7pealf66rYsNhqw+unvR9NtCe+UobLw84X
+YELcwVMuKM6p7HOdcbBYonldxBnMyLrLowzO4hoIGFMGfqwFQuJ5f6otF1Z2NNFy
+YV2IF56LJcqp6ldfG2+vhHeLXJv0s9ycTCnQnC5geq4EJehtoCNGbSVvCHDK7eBu
+PCxxyL4mjfXf9lYBgVQ0XqSxzWH5sA0/FMvvaNM35EZ4AuV91XFdlm4S3F53meC2
+g13UIqJ7cd0QkBZtEh+6JHl6WVmIfh3XYzR8f0p2E8+uqlGp2GeXawBgTbnyH67p
+1AdBD3cJ8dXDQ8ZiFS7zzZpZ+AUJuf9D/Z2U6CDIGJ8eOVz7eFOrSSgUoAEVcCx+
+5WAO8XVuaBJLZAns3bWi21Vr+8DjqnRcm4fQNVJWhUOFL2QCoJIh4aXWHMhCLHP2
+uqQIpbBFxgRUJ3zv9u/zzc015R85paSX5yHnWllvCeM47L05jzBXoM5dinvqfif6
+j22YJzoxFv/0xIB/DsKT7Qj//0hkoH0T2ryAFaNDepZ1czKJNWHlub5z8dAfAa9i
+TSobNNPSdFGvSJ0Yo5ay3LBux1S3dB0yPXGieJnZ2Ynvs42QPWmXVxHtCu7yB60q
+v2PZbfi0yOdEEIRrTlKZxMz/JW1/GNuaKfUzIs3Zt25otLhyIe97zF9U7VaJoP+W
+bIuMWG8JrlSwY1CmXur96F4bbOv8MGraVZpructcQ2Pns9bVA/Tt0Kaz/YfoKo2Q
+agoLrvFcH/NsBnG2+psUT8KYVNCnexI0aeBlQQ3Ihh+VcZ1R9wtmN9oB5cygyQPy
+UNa/2CRj1O0HRfm6X6G2I/vbnQW7ges2mWwblscAOhZgFtN/rSS9YXYNacGhLz9Q
+5TOPG1oeqcgj+3LNLNqdGPzsZGb1dsHgRql/KWJjA2KZj3R+T0KQBInOp91PVgmJ
+/p0LuEjwt2JN72bE9XvMPY6lB/QpI8v4yOD2AxIiHf3HPoEchfC6WqSCIeoKA1JD
+MpuMFFfD/IazZ0A33JAJiBgs44GbzaQ3+Thq3fBEu5mWenuRD+XfZfARZzIKti5o
++3aiBXYqlS3AIKwOzDEkBu3/WWkP2CnDLW5LRghV5CIVet/qm3Pz1BJOgPkwb22W
+Wo0rynewxJe9qDoTdwz9DgFbcupApCszqYuinyD6f/Ulfu9tGs8zZ50RV5F0IVJL
+n2VmxUZbUqB5RxEbLh46RsxfSIaiwCcNAsoSQueBJWpRn15zzch8JpKmuk0FRatm
+CROdT21P6uJaK6iDQDSG88g2rYUc5TjsbuVX2tLNMJn/lOaVcCacREwOmuO+BzjE
+ucdNkB6T4ohx76aQ3IP37hvMhG5qKONgQAcrnPHlO1OK8oa3M7/KCGLcMNk6eTCH
+9FRdPwEpnryPaNAIR0p3XQK7n3jgRxvaoHAMg1t9ReKtVTuCmkA+k88TByVdYvWC
+eDIGBgaQQ5gMK5jod8uEZk8wyMXuh5t7WAQhJmWIwaKYZIGeJbFh6seaxkIb4R1f
+Y9XyuYwH/wl0StbCtHGp6L7ipu3qy+MHXj7vbuT8XIiWr9Bng8+wkyeKwL19P1LD
+JCPFWg8FbwJ9sf0WOoWBCj5sZfBzUehko+i85+4JeXzIhEPhajhC8h+RlL02Zco+
+6UuZjZdmqtAcGpgd8Y8aDexQTlXK/xrxu9Bd2NJ4CkGrbxadsPpnIFKvpFuN/OUf
+n5PQvWp5F/O+J2xY7SFxoZX2CKfa3wMfc6Fdej2CIAudPGaOl/lM1TMl/uuEQmBJ
+xNh4kjnl7M2c36XwPZSKG58Vh+2w8MiI6VgdDE4GaktN6RLYeo4LpWCMQaM61Ukw
+1W92UGpBgSdGEXJhEOQ1AptmKvosPJklG70ss2lwWEw0F0K3Wi60+dvU3YDNVY+U
+9N/SrCL+KGua4X3ZV5yc41XAUala40iDMoAkpnXDip9WY46kldaBHzflLZk38VAT
+lcxsARnxgFxNm1iAHxVtLp9DZvbrAKvGlgMd6sI/R7Nlh3OKG0uERrpyMnyt7V+N
+i38PopDFs5kbZH2EwClLwNE1Zf2VH26pTyElVGQGE9ksN1u9WDSrsGK8YGpYK86/
+wY3vasmQOPDOWTj27lk3oZZDWbpF6IchHYkbiS5Z/st8Tqhp9h5s/bEKMeBcO3jY
+hDqA19vYSkYh8YgUIplO3U83GC8IcVgspRbgrv/YgQlwQVdUlWvd59ivBjvKkzoh
+YBpv8K1MBsZFSnJfTbxJqTZLltOutydUuIdwd+d8hLjRYYheyUyDNnIt4fEsrTCg
+8LRoBAZ1g9atm2CNthwjbyLw881UTFu/DfdeTTbmGqtV/yA7DbJVMkuax9l8ybC4
+ZbbF1U73ZDtAONuQX8o42QtiZE2c0YH6JfRHny//k89IkeCKt8+DnvgmWkqndcGK
+oaARbxR1NjUqCKyb+cw+/HkpUtDbR5nNw0aV4rynhtHejhwKciWSjqBlC7NKA5o3
+vilcI8CHVHQp2qMAR5l+KI/SW+iB5d5+BIr/SWoJ2AP4xk+Yua/Gb4+kDZuFwCyI
+W9sVx6Wh/K86HXGICsMZwAK5G6WAMudHfiSvFxMD4q2srCxVw1Rdy1hHarSIIeaL
+jsniL/GLzu5JI/8qb5EDv/CwGAACvmE4k/wjReNYa8VfjQUH1NHcop9ml0glwMp8
+Qkr/nq03Jg20GXXsL86Q2WD6mHgZ0qjcpmPsupnOETpMcnzBjE1ch0ado45mShRy
+KV8D2ukibWtNJU1Bs8KOGom9xkJLqa7kjnmll/4dLSFfTW2036wJQeu7VqsLnArR
+sTNW2bIDgEia7aptmJm6JVA1ue8JSBtPEJd/s5TLcowXs8nP0VN3QNJi/kvI1KTV
+Eewv5Iqm2GnQfQufAfoxLJhNSRZGk+LNpDvoA2DOa2Ua90aJdnD1HBiRwhiC
+=GAmO
+-----END PGP MESSAGE-----
diff --git a/privdata/keyring.gpg b/privdata/keyring.gpg
new file mode 100644
index 00000000..01dd24e7
--- /dev/null
+++ b/privdata/keyring.gpg
Binary files differ
diff --git a/privdata/orca.kitenet.net.gpg b/privdata/orca.kitenet.net.gpg
new file mode 100644
index 00000000..c1a2e9f8
--- /dev/null
+++ b/privdata/orca.kitenet.net.gpg
@@ -0,0 +1,22 @@
+-----BEGIN PGP MESSAGE-----
+Version: GnuPG v1
+
+hQIMA7ODiaEXBlRZARAAvqd3qX/p4dXrvDxK49gUGydT2/47k9f3BQQTWDtG1uUq
+3QBbJbBAx2LXyRtfsioxDgMx6hdg/pHSjrcIsdd6SeaOzU9NJ8TQe2OsnSg6SY2h
+GCc4bxFcMnyOWpWkr0FcuQ6uiGZvStYq7HPMPdeRR2BETkU4ONVgdZOo1QiUU+85
+AM/slTKRLp7syX00aFZVXQydSAekvTaJgwbo6n4pdPhDq+ztUsrwhFKzveOvJAKe
+36tjzaqN/XUa3v1X7eqZUwAw2lwPro02jYnkYTGtl1SPd2iFNcOb1GO9rCq0lKjH
+pqqkhFSMKZcvvgghZgUga6HnLo/IHSP7lzCxmsznMy5ns2Qrh64Z9vf40LElILPY
+/hFN4Bsi5DTFgSsxydS8EL7H2MY3hUgWuBxo5Xj0e/3txv87QGMPM6PDW7OzMOl0
+1qB8pqe7oCnBq+yyd0ftdrhbMtz5JsifFN4/KLlAm9XOzysX0GylZ9Iy3QKbLQUp
+hQBXX8XE2mCCbOwpzC9Z1eMUksL6YOiSIz/EVwLbqr6AulicNxTf488gJGj+vf6D
+ihFj477BYQPkZ3S6nIEyKi6r/vLZkLMgwni0axBD9yzoVk0O/e4WAJMyJWhVXRzF
+OQipN+vnp6HlqwBuUTezFzdwtimy0phBLd5x22qN2WooAaUExXpHgnc/M6WmqRrS
+wF4BIvJBD5gLq9GKT5bdENpO1+W5zj4af5fT7LSgobiCSgpjz1/mbfN5QVBUB2z1
+FqQVv7gN1AIbcorx1ke4BOwpvZA3iaU+9Cd51ME04x75uSyFc7Xb7wtcGPymEgXI
+X7ZO1mtJJ48BY1vYN3ER0h+MK/d27v0JASFfCwuLSA8M8FAoQLPpEG/7qiAxoQtP
+EshdoeZZhK0bsG2+Uf1ixNnRy1/SazrUXTo/e+IVN/BOL7qINjkI+2hPGz3r2gLP
+EavegXtJ5RGdqvBD+C4ph85bOvjOlR8klZ1nGnlAnGu1OEYv8zv/yJ6dq6/HaLkB
+p8MqZXY1qH0ywoPnkW34TN83k9YncyS4Bj2gNN2iggU+/LQViitsVxLkQ9sxdjlS
+=usce
+-----END PGP MESSAGE-----
diff --git a/propellor.cabal b/propellor.cabal
new file mode 100644
index 00000000..bc9f7732
--- /dev/null
+++ b/propellor.cabal
@@ -0,0 +1,131 @@
+Name: propellor
+Version: 0.5.0
+Cabal-Version: >= 1.6
+License: GPL
+Maintainer: Joey Hess <joey@kitenet.net>
+Author: Joey Hess
+Stability: Stable
+Copyright: 2014 Joey Hess
+License-File: GPL
+Build-Type: Simple
+Homepage: http://joeyh.name/code/propellor/
+Category: Utility
+Extra-Source-Files:
+ README.md
+ TODO
+ CHANGELOG
+ Makefile
+ config-simple.hs
+ config-joey.hs
+ debian/changelog
+ debian/README.Debian
+ debian/propellor.1
+ debian/compat
+ debian/control
+ debian/copyright
+ debian/rules
+ debian/lintian-overrides
+ .gitignore
+Synopsis: property-based host configuration management in haskell
+Description:
+ Propellor enures that the system it's run in satisfies a list of
+ properties, taking action as necessary when a property is not yet met.
+ .
+ It is configured using haskell.
+
+Executable propellor
+ Main-Is: propellor.hs
+ GHC-Options: -Wall
+ Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
+ IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
+ containers, network, async, time, QuickCheck, mtl,
+ MonadCatchIO-transformers
+
+ if (! os(windows))
+ Build-Depends: unix
+
+Executable config
+ Main-Is: config.hs
+ GHC-Options: -Wall -threaded
+ Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
+ IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
+ containers, network, async, time, QuickCheck, mtl,
+ MonadCatchIO-transformers
+
+ if (! os(windows))
+ Build-Depends: unix
+
+Library
+ GHC-Options: -Wall
+ Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
+ IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
+ containers, network, async, time, QuickCheck, mtl,
+ MonadCatchIO-transformers
+
+ if (! os(windows))
+ Build-Depends: unix
+
+ Exposed-Modules:
+ Propellor
+ Propellor.Property
+ Propellor.Property.Apache
+ Propellor.Property.Apt
+ Propellor.Property.Cmd
+ Propellor.Property.Hostname
+ Propellor.Property.Cron
+ Propellor.Property.Dns
+ Propellor.Property.Docker
+ Propellor.Property.File
+ Propellor.Property.Git
+ Propellor.Property.Gpg
+ Propellor.Property.Network
+ Propellor.Property.Obnam
+ Propellor.Property.OpenId
+ Propellor.Property.Postfix
+ Propellor.Property.Reboot
+ Propellor.Property.Scheduled
+ Propellor.Property.Service
+ Propellor.Property.Ssh
+ Propellor.Property.Sudo
+ Propellor.Property.Tor
+ Propellor.Property.User
+ Propellor.Property.SiteSpecific.GitHome
+ Propellor.Property.SiteSpecific.JoeySites
+ Propellor.Property.SiteSpecific.GitAnnexBuilder
+ Propellor.Attr
+ Propellor.Message
+ Propellor.PrivData
+ Propellor.Engine
+ Propellor.Exception
+ Propellor.Types
+ Propellor.Types.OS
+ Propellor.Types.Dns
+ Other-Modules:
+ Propellor.Types.Attr
+ Propellor.CmdLine
+ Propellor.SimpleSh
+ Propellor.Property.Docker.Shim
+ Utility.Applicative
+ Utility.Data
+ Utility.Directory
+ Utility.Env
+ Utility.Exception
+ Utility.FileMode
+ Utility.FileSystemEncoding
+ Utility.LinuxMkLibs
+ Utility.Misc
+ Utility.Monad
+ Utility.Path
+ Utility.PartialPrelude
+ Utility.PosixFiles
+ Utility.Process
+ Utility.SafeCommand
+ Utility.Scheduled
+ Utility.ThreadScheduler
+ Utility.Tmp
+ Utility.UserInfo
+ Utility.QuickCheck
+
+source-repository head
+ type: git
+ location: git://git.kitenet.net/propellor.git
diff --git a/propellor.hs b/propellor.hs
new file mode 100644
index 00000000..e4653f30
--- /dev/null
+++ b/propellor.hs
@@ -0,0 +1,91 @@
+-- | 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 outs 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."
+ )