cadey
/
propellor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.

# imported from the archive
This commit is contained in:
Joey Hess 2014-04-11 01:19:05 -04:00
commit be02ef96aa
76 changed files with 6491 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG Symbolic link
View File

@ -0,0 +1 @@
debian/changelog

674
GPL Normal file
View File

@ -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>.

41
Makefile Normal file
View File

@ -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

77
Propellor.hs Normal file
View File

@ -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"

47
Propellor/Attr.hs Normal file
View File

@ -0,0 +1,47 @@
{-# 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
pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty
pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
(return NoChange)
hostname :: HostName -> AttrProperty
hostname name = pureAttrProperty ("hostname " ++ name) $
\d -> d { _hostname = name }
getHostName :: Propellor HostName
getHostName = asks _hostname
cname :: Domain -> AttrProperty
cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty
cnameFor domain mkp =
let p = mkp domain
in AttrProperty p (addCName domain)
addCName :: HostName -> Attr -> Attr
addCName domain d = d { _cnames = S.insert domain (_cnames d) }
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
findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = M.lookup hn (hostMap l)

359
Propellor/CmdLine.hs Normal file
View File

@ -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"
]

37
Propellor/Engine.hs Normal file
View File

@ -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]
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

16
Propellor/Exception.hs Normal file
View File

@ -0,0 +1,16 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Exception where
import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
import Control.Exception
import Control.Applicative
import Propellor.Types
-- | Catches IO exceptions and returns FailedChange.
catchPropellor :: Propellor Result -> Propellor Result
catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a
tryPropellor :: Propellor a -> Propellor (Either IOException a)
tryPropellor = M.try

51
Propellor/Message.hs Normal file
View File

@ -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 Red $ "** 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
warningMessage s
error "Cannot continue!"
-- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
debug :: [String] -> IO ()
debug = debugM "propellor" . unwords

84
Propellor/PrivData.hs Normal file
View File

@ -0,0 +1,84 @@
{-# 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 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
withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result
withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
where
missing = do
host <- getHostName
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

120
Propellor/Property.hs Normal file
View File

@ -0,0 +1,120 @@
{-# LANGUAGE PackageImports #-}
module Propellor.Property where
import System.Directory
import Control.Monad
import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
import Propellor.Types
import Propellor.Types.Attr
import Propellor.Engine
import Utility.Monad
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
noChange :: Propellor Result
noChange = return NoChange
-- | Combines a list of properties, resulting in a single property
-- that when run will run each property in the list in turn,
-- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure.
propertyList :: Desc -> [Property] -> Property
propertyList desc ps = Property desc $ ensureProperties ps
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn, stopping on failure.
combineProperties :: Desc -> [Property] -> Property
combineProperties desc ps = Property desc $ go ps NoChange
where
go [] rs = return rs
go (l:ls) rs = do
r <- ensureProperty l
case r of
FailedChange -> return FailedChange
_ -> go ls (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 = Property (propertyDesc p1) $ do
r <- ensureProperty p1
case r of
FailedChange -> return FailedChange
_ -> ensureProperty p2
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
-- Use with caution.
flagFile :: Property -> FilePath -> Property
flagFile property flagfile = Property (propertyDesc property) $
go =<< liftIO (doesFileExist flagfile)
where
go True = return NoChange
go False = do
r <- ensureProperty property
when (r == MadeChange) $ liftIO $
unlessM (doesFileExist 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
property `onChange` hook = Property (propertyDesc property) $ do
r <- ensureProperty property
case r of
MadeChange -> do
r' <- ensureProperty hook
return $ r <> r'
_ -> return r
(==>) :: Desc -> Property -> Property
(==>) = flip describe
infixl 1 ==>
-- | Makes a Property only be performed when a test succeeds.
check :: IO Bool -> Property -> Property
check c property = Property (propertyDesc property) $ ifM (liftIO c)
( ensureProperty property
, return NoChange
)
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, RevertableProperties, and AttrProperties
(&) :: IsProp p => Host -> p -> Host
(Host ps as) & p = Host (ps ++ [toProp p]) (getAttr p . as)
infixl 1 &
-- | Adds a property to the Host in reverted form.
(!) :: Host -> RevertableProperty -> Host
(Host ps as) ! p = Host (ps ++ [toProp q]) (getAttr q . as)
where
q = revert p
infixl 1 !

193
Propellor/Property/Apt.hs Normal file
View File

@ -0,0 +1,193 @@
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
showSuite :: DebianSuite -> String
showSuite Stable = "stable"
showSuite Testing = "testing"
showSuite Unstable = "unstable"
showSuite Experimental = "experimental"
showSuite (DebianRelease r) = r
debLine :: DebianSuite -> Url -> [Section] -> Line
debLine suite mirror sections = unwords $
["deb", mirror, showSuite suite] ++ sections
srcLine :: Line -> Line
srcLine l = case words l of
("deb":rest) -> unwords $ "deb-src" : rest
_ -> ""
stdSections :: [Section]
stdSections = ["main", "contrib", "non-free"]
binandsrc :: String -> DebianSuite -> [Line]
binandsrc url suite = [l, srcLine l]
where
l = debLine suite url stdSections
debCdn :: DebianSuite -> [Line]
debCdn = binandsrc "http://cdn.debian.net/debian"
kernelOrg :: DebianSuite -> [Line]
kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
-- | Only available for Stable and Testing
securityUpdates :: DebianSuite -> [Line]
securityUpdates suite
| suite == Stable || 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 = setSourcesList
(debCdn suite ++ kernelOrg suite ++ securityUpdates suite)
`describe` ("standard sources.list for " ++ show suite)
setSourcesList :: [Line] -> Property
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
runApt :: [String] -> Property
runApt ps = cmdProperty' "apt-get" ps 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
-- | 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 = Property (propertyDesc p) $ do
r <- ensureProperty p
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]
-- | 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]

48
Propellor/Property/Cmd.hs Normal file
View File

@ -0,0 +1,48 @@
{-# 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 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)

32
Propellor/Property/Cron.hs Normal file
View File

@ -0,0 +1,32 @@
module Propellor.Property.Cron where
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
type CronTimes = String
-- | Installs a cron job, run as a specificed user, in a particular
--directory. Note that the Desc must be unique, as it is used for the
--cron.d/ filename.
job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
job desc times user cddir command = ("/etc/cron.d/" ++ desc) `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" ++ "cd " ++ cddir ++ " && " ++ command
]
`requires` Apt.serviceInstalledRunning "cron"
`describe` ("cronned " ++ desc)
-- | 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)
`requires` Apt.installed ["util-linux", "moreutils"]
-- | Installs a cron job to run propellor.
runPropellor :: CronTimes -> Property
runPropellor times = niceJob "propellor" times "root" localdir "chronic make"

63
Propellor/Property/Dns.hs Normal file
View File

@ -0,0 +1,63 @@
module Propellor.Property.Dns where
import Propellor
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
namedconf :: FilePath
namedconf = "/etc/bind/named.conf.local"
data Zone = Zone
{ zdomain :: Domain
, ztype :: Type
, zfile :: FilePath
, zmasters :: [IPAddr]
, zconfiglines :: [String]
}
zoneDesc :: Zone -> String
zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")"
type IPAddr = String
type Domain = String
data Type = Master | Secondary
deriving (Show, Eq)
secondary :: Domain -> [IPAddr] -> Zone
secondary domain masters = Zone
{ zdomain = domain
, ztype = Secondary
, zfile = "db." ++ domain
, zmasters = masters
, zconfiglines = ["allow-transfer { }"]
}
zoneStanza :: Zone -> [Line]
zoneStanza z =
[ "// automatically generated by propellor"
, "zone \"" ++ zdomain z ++ "\" {"
, cfgline "type" (if ztype z == Master then "master" else "slave")
, cfgline "file" ("\"" ++ zfile z ++ "\"")
] ++
(if null (zmasters z) then [] else mastersblock) ++
(map (\l -> "\t" ++ l ++ ";") (zconfiglines z)) ++
[ "};"
, ""
]
where
cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
mastersblock =
[ "\tmasters {" ] ++
(map (\ip -> "\t\t" ++ ip ++ ";") (zmasters z)) ++
[ "\t};" ]
-- | Rewrites the whole named.conf.local file to serve the specificed
-- zones.
zones :: [Zone] -> Property
zones zs = hasContent namedconf (concatMap zoneStanza zs)
`describe` ("dns server for zones: " ++ unwords (map zoneDesc zs))
`requires` Apt.serviceInstalledRunning "bind9"
`onChange` Service.reloaded "bind9"

462
Propellor/Property/Docker.hs Normal file
View File

@ -0,0 +1,462 @@
{-# 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 -> AttrProperty
dns = runProp "dns"
-- | Set container host name.
hostname :: String -> AttrProperty
hostname = runProp "hostname"
-- | Set name for container. (Normally done automatically.)
name :: String -> AttrProperty
name = runProp "name"
-- | Publish a container's port to the host
-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)
publish :: String -> AttrProperty
publish = runProp "publish"
-- | Username or UID for container.
user :: String -> AttrProperty
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 -> AttrProperty
volume = runProp "volume"
-- | Mount a volume from the specified container into the current
-- container.
volumes_from :: ContainerName -> AttrProperty
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
workdir :: String -> AttrProperty
workdir = runProp "workdir"
-- | Memory limit for container.
--Format: <number><optional unit>, where unit = b, k, m or g
memory :: String -> AttrProperty
memory = runProp "memory"
-- | Link with another container on the same host.
link :: ContainerName -> ContainerAlias -> AttrProperty
link linkwith alias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias
-- | 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 -> AttrProperty
runProp field val = AttrProperty prop $ \attr ->
attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }
where
param = field++"="++val
prop = Property (param) (return NoChange)
genProp :: String -> (HostName -> RunParam) -> AttrProperty
genProp field mkval = AttrProperty prop $ \attr ->
attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }
where
prop = Property field (return NoChange)
-- | 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

61
Propellor/Property/Docker/Shim.hs Normal file
View File

@ -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

70
Propellor/Property/File.hs Normal file
View File

@ -0,0 +1,70 @@
module Propellor.Property.File where
import Propellor
import System.Posix.Files
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.
-- Note: Does not do anything with the permissions of the file to prevent
-- it from being seen.
hasPrivContent :: FilePath -> Property
hasPrivContent f = Property ("privcontent " ++ f) $
withPrivData (PrivFile f) (\v -> ensureProperty $ f `hasContent` lines v)
-- | Ensures that a line is present in a file, adding it to the end if not.
containsLine :: FilePath -> Line -> Property
f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f
where
go ls
| l `elem` ls = ls
| otherwise = ls++[l]
-- | Ensures that a line is not present in a file.
-- Note that the file is ensured to exist, so if it doesn't, an empty
-- file will be written.
lacksLine :: FilePath -> Line -> Property
f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property
notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $
makeChange $ nukeFile f
fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
fileProperty desc a f = Property desc $ go =<< 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 $ writeFile f (unlines $ a [])
-- viaTmp makes the temp file mode 600.
-- Replicate the original file mode before moving it into place.
updatefile f' content = do
writeFile f' content
getFileStatus f >>= setFileMode f' . fileMode
-- | 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

48
Propellor/Property/Git.hs Normal file
View File

@ -0,0 +1,48 @@
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 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
]

34
Propellor/Property/Hostname.hs Normal file
View File

@ -0,0 +1,34 @@
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 both /etc/hostname and the current hostname.
--
-- When the hostname is 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

30
Propellor/Property/Network.hs Normal file
View File

@ -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]

26
Propellor/Property/OpenId.hs Normal file
View File

@ -0,0 +1,26 @@
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
(map setbaseurl) "/etc/simpleid/config.inc"
] ++ map identfile users
where
identfile u = File.hasPrivContent $ concat
[ "/var/lib/simpleid/identities/", u, ".identity" ]
url = "http://"++baseurl++"/simpleid"
desc = "openid provider " ++ url
setbaseurl l
| "SIMPLEID_BASE_URL" `isInfixOf` l =
"define('SIMPLEID_BASE_URL', '"++url++"');"
| otherwise = l

7
Propellor/Property/Reboot.hs Normal file
View File

@ -0,0 +1,7 @@
module Propellor.Property.Reboot where
import Propellor
now :: Property
now = cmdProperty "reboot" []
`describe` "reboot now"

67
Propellor/Property/Scheduled.hs Normal file
View File

@ -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 = Property desc $ do
lasttime <- liftIO $ getLastChecked (propertyDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
if Just t >= nexttime
then do
r <- ensureProperty prop
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 <$> readFile lastCheckedFile
writeLastChecked :: M.Map Desc LocalTime -> IO ()
writeLastChecked = writeFile lastCheckedFile . show

31
Propellor/Property/Service.hs Normal file
View File

@ -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

57
Propellor/Property/SiteSpecific/GitAnnexBuilder.hs Normal file
View File

@ -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"
)
]

36
Propellor/Property/SiteSpecific/GitHome.hs Normal file
View File

@ -0,0 +1,36 @@
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 Nothing = noChange
go (Just 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 Nothing = return False
go (Just home) = doesDirectoryExist (home </> ".git")

23
Propellor/Property/SiteSpecific/JoeySites.hs Normal file
View File

@ -0,0 +1,23 @@
-- | 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
oldUseNetShellBox :: Property
oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $
propertyList ("olduse.net shellbox")
[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
`describe` "olduse.net build deps"
, scriptProperty
[ "rm -rf /root/tmp/oldusenet" -- idenpotency
, "git clone git://olduse.net/ /root/tmp/oldusenet/source"
, "cd /root/tmp/oldusenet/source/"
, "dpkg-buildpackage -us -uc"
, "dpkg -i ../oldusenet*.deb || true"
, "apt-get -fy install" -- dependencies
, "rm -rf /root/tmp/oldusenet"
] `describe` "olduse.net built"
]

62
Propellor/Property/Ssh.hs Normal file
View File

@ -0,0 +1,62 @@
module Propellor.Property.Ssh (
setSshdConfig,
permitRootLogin,
passwordAuthentication,
hasAuthorizedKeys,
restartSshd,
uniqueHostKeys
) where
import Propellor
import qualified Propellor.Property.File as File
import Propellor.Property.User
import Utility.SafeCommand
sshBool :: Bool -> String
sshBool True = "yes"
sshBool False = "no"
sshdConfig :: FilePath
sshdConfig = "/etc/ssh/sshd_config"
setSshdConfig :: String -> Bool -> Property
setSshdConfig setting allowed = combineProperties "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"
hasAuthorizedKeys :: UserName -> IO Bool
hasAuthorizedKeys = go <=< homedir
where
go Nothing = return False
go (Just home) = not . null <$> catchDefaultIO ""
(readFile $ home </> ".ssh" </> "authorized_keys")
restartSshd :: Property
restartSshd = cmdProperty "service" ["ssh", "restart"]
-- | 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.
uniqueHostKeys :: Property
uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restartSshd
where
prop = Property "ssh unique 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"]

32
Propellor/Property/Sudo.hs Normal file
View File

@ -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]

19
Propellor/Property/Tor.hs Normal file
View File

@ -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"]

61
Propellor/Property/User.hs Normal file
View File

@ -0,0 +1,61 @@
module Propellor.Property.User where
import System.Posix
import Propellor
data Eep = YesReallyDeleteHome
accountFor :: UserName -> Property
accountFor user = check (isNothing <$> 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 <$> homedir user) $ cmdProperty "userdel"
[ "-r"
, user
]
`describe` ("nuked user " ++ user)
-- | Only ensures that the user has some password set. It may or may
-- not be the password from the PrivData.
hasSomePassword :: UserName -> Property
hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $
hasPassword user
hasPassword :: UserName -> Property
hasPassword user = Property (user ++ " has password") $
withPrivData (Password user) $ \password -> makeChange $
withHandle StdinHandle createProcessSuccess
(proc "chpasswd" []) $ \h -> do
hPutStrLn h $ user ++ ":" ++ password
hClose h
lockedPassword :: UserName -> Property
lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd"
[ "--lock"
, user
]
`describe` ("locked " ++ user ++ " password")
data PasswordStatus = NoPassword | LockedPassword | HasPassword
deriving (Eq)
getPasswordStatus :: UserName -> IO PasswordStatus
getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user]
where
parse (_:"L":_) = LockedPassword
parse (_:"NP":_) = NoPassword
parse (_:"P":_) = HasPassword
parse _ = NoPassword
isLockedPassword :: UserName -> IO Bool
isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
homedir :: UserName -> IO (Maybe FilePath)
homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user

97
Propellor/SimpleSh.hs Normal file
View File

@ -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

170
Propellor/Types.hs Normal file
View File

@ -0,0 +1,170 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
module Propellor.Types
( Host(..)
, Attr
, HostName
, UserName
, GroupName
, Propellor(..)
, Property(..)
, RevertableProperty(..)
, AttrProperty(..)
, IsProp
, describe
, toProp
, getAttr
, requires
, Desc
, Result(..)
, System(..)
, Distribution(..)
, DebianSuite(..)
, Release
, Architecture
, ActionResult(..)
, CmdLine(..)
, PrivDataField(..)
) 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
data Host = Host [Property] (Attr -> Attr)
type UserName = String
type GroupName = String
-- | 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
-- | must be idempotent; may run repeatedly
, propertySatisfy :: Propellor Result
}
-- | A property that can be reverted.
data RevertableProperty = RevertableProperty Property Property
-- | A property that affects the Attr.
data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
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
getAttr :: p -> (Attr -> Attr)
instance IsProp Property where
describe p d = p { propertyDesc = d }
toProp p = p
x `requires` y = Property (propertyDesc x) $ do
r <- propertySatisfy y
case r of
FailedChange -> return FailedChange
_ -> propertySatisfy x
getAttr _ = id
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
getAttr _ = id
instance IsProp AttrProperty where
describe (AttrProperty p a) d = AttrProperty (describe p d) a
toProp (AttrProperty p _) = toProp p
(AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a
getAttr (AttrProperty _ a) = a
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
-- | High level descritption of a operating system.
data System = System Distribution Architecture
deriving (Show)
data Distribution
= Debian DebianSuite
| Ubuntu Release
deriving (Show)
data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release
deriving (Show, Eq)
type Release = String
type Architecture = String
-- | 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
| SshPrivKey UserName
| Password UserName
| PrivFile FilePath
deriving (Read, Show, Ord, Eq)

36
Propellor/Types/Attr.hs Normal file
View File

@ -0,0 +1,36 @@
module Propellor.Types.Attr where
import qualified Data.Set as S
-- | The attributes of a host. For example, its hostname.
data Attr = Attr
{ _hostname :: HostName
, _cnames :: S.Set Domain
, _dockerImage :: Maybe String
, _dockerRunParams :: [HostName -> String]
}
instance Eq Attr where
x == y = and
[ _hostname x == _hostname y
, _cnames x == _cnames 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
, "cnames " ++ show (_cnames a)
, "docker image " ++ show (_dockerImage a)
, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
]
newAttr :: HostName -> Attr
newAttr hn = Attr hn S.empty Nothing []
type HostName = String
type Domain = String

105
README.md Normal file
View File

@ -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/

5
Setup.hs Normal file
View File

@ -0,0 +1,5 @@
{- cabal setup file -}
import Distribution.Simple
main = defaultMain

20
TODO Normal file
View File

@ -0,0 +1,20 @@
* 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.
* Currently only Debian and derivatives are supported by most Properties.
This could be improved by making the Distribution of the system part
of its HostAttr.
* 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.

16
Utility/Applicative.hs Normal file
View File

@ -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 <$$>

17
Utility/Data.hs Normal file
View File

@ -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

135
Utility/Directory.hs Normal file
View File

@ -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

81
Utility/Env.hs Normal file
View File

@ -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

59
Utility/Exception.hs Normal file
View File

@ -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

157
Utility/FileMode.hs Normal file
View File

@ -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

132
Utility/FileSystemEncoding.hs Normal file
View File

@ -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

61
Utility/LinuxMkLibs.hs Normal file
View File

@ -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'"]

148
Utility/Misc.hs Normal file
View File

@ -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

69
Utility/Monad.hs Normal file
View File

@ -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 ()

68
Utility/PartialPrelude.hs Normal file
View File

@ -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]

293
Utility/Path.hs Normal file
View File

@ -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

33
Utility/PosixFiles.hs Normal file
View File

@ -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

360
Utility/Process.hs Normal file
View File

@ -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

52
Utility/QuickCheck.hs Normal file
View File

@ -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)

120
Utility/SafeCommand.hs Normal file
View File

@ -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

358
Utility/Scheduled.hs Normal file
View File

@ -0,0 +1,358 @@
{- scheduled activities
-
- Copyright 2013 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,
startTime,
fromSchedule,
fromScheduledTime,
toScheduledTime,
fromRecurrance,
toRecurrance,
toSchedule,
parseSchedule,
prop_schedule_roundtrips
) 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 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 = sameaslastday || toolatetoday
toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
sameaslastday = lastday == Just today
lastday = 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 day = case r of
Daily
| afterday -> Just $ exactly $ addDays 1 day
| otherwise -> Just $ exactly day
Weekly Nothing
| afterday -> skip 1
| otherwise -> case (wday <$> lastday, wday day) of
(Nothing, _) -> Just $ window day (addDays 6 day)
(Just old, curr)
| old == curr -> Just $ window day (addDays 6 day)
| otherwise -> skip 1
Monthly Nothing
| afterday -> skip 1
| maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday ->
-- Window only covers current month,
-- in case there is a Divisible requirement.
Just $ window day (endOfMonth day)
| otherwise -> skip 1
Yearly Nothing
| afterday -> skip 1
| maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday ->
Just $ window day (endOfYear day)
| otherwise -> skip 1
Weekly (Just w)
| w < 0 || w > maxwday -> Nothing
| w == wday day -> if afterday
then Just $ exactly $ addDays 7 day
else Just $ exactly day
| otherwise -> Just $ exactly $
addDays (fromIntegral $ (w - wday day) `mod` 7) day
Monthly (Just m)
| m < 0 || m > maxmday -> Nothing
-- TODO can be done more efficiently than recursing
| m == mday day -> if afterday
then skip 1
else Just $ exactly day
| otherwise -> skip 1
Yearly (Just y)
| y < 0 || y > maxyday -> Nothing
| y == yday day -> if afterday
then skip 365
else Just $ exactly day
| 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 day
where
skip n = findfrom r False (addDays n day)
handlediv n r' getval mmax
| n > 0 && maybe True (n <=) mmax =
findfromwhere r' (divisible n . getval) afterday day
| otherwise = Nothing
findfromwhere r p afterday day
| maybe True (p . getday) next = next
| otherwise = maybe Nothing (findfromwhere r p True . getday) next
where
next = findfrom r afterday day
getday = localDay . startTime
divisible n v = v `rem` n == 0
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 and mins. -}
maxyday :: Int
maxyday = 366 -- with leap days
minyday :: Int
minyday = 365
maxwnum :: Int
maxwnum = 53 -- some years have more than 52
maxmday :: Int
maxmday = 31
minmday :: Int
minmday = 28
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

73
Utility/ThreadScheduler.hs Normal file
View File

@ -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

100
Utility/Tmp.hs Normal file
View File

@ -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

55
Utility/UserInfo.hs Normal file
View File

@ -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

202
config-joey.hs Normal file
View File

@ -0,0 +1,202 @@
-- | 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.SiteSpecific.GitHome as GitHome
import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
hosts :: [Host]
hosts =
-- My laptop
[ host "darkstar.kitenet.net"
& Docker.configured
& Apt.buildDep ["git-annex"] `period` Daily
-- Nothing super-important lives here.
, standardSystem "clam.kitenet.net" Unstable
& cleanCloudAtCost
& Apt.unattendedUpgrades
& Network.ipv6to4
& Tor.isBridge
& Docker.configured
& cname "shell.olduse.net"
& JoeySites.oldUseNetShellBox
& cname "openid.kitenet.net"
& Docker.docked hosts "openid-provider"
`requires` Apt.installed ["ntp"]
& cname "ancient.kitenet.net"
& Docker.docked hosts "ancient-kitenet"
& Docker.garbageCollected `period` Daily
& Apt.installed ["git-annex", "mtr", "screen"]
-- Orca is the main git-annex build box.
, standardSystem "orca.kitenet.net" Unstable
& Hostname.sane
& Apt.unattendedUpgrades
& 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
& Hostname.sane
& Apt.unattendedUpgrades
& Apt.serviceInstalledRunning "ntp"
& Dns.zones myDnsSecondary
& Apt.serviceInstalledRunning "apache2"
& Apt.installed ["git", "git-annex", "rsync"]
& Apt.buildDep ["git-annex"] `period` Daily
& Git.daemonRunning "/srv/git"
& File.ownerGroup "/srv/git" "joey" "joey"
-- git repos restore (how?)
-- family annex needs family members to have accounts,
-- ssh host key etc.. finesse?
-- (also should upgrade git-annex-shell for it..)
-- kgb installation and setup
-- ssh keys for branchable and github repo hooks
-- gitweb
-- downloads.kitenet.net setup (including ssh key to turtle)
--------------------------------------------------------------------
-- Docker Containers ----------------------------------- \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"
, standardContainer "ancient-kitenet" Stable "amd64"
& Docker.publish "1994:80"
& Apt.serviceInstalledRunning "apache2"
& Apt.installed ["git"]
& scriptProperty
[ "cd /var/"
, "rm -rf www"
, "git clone git://git.kitenet.net/kitewiki www"
, "cd www"
, "git checkout remotes/origin/old-kitenet.net"
] `flagFile` "/var/www/blastfromthepast.html"
-- 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
]
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 -> Host
standardSystem hn suite = host hn
& 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)
& 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.uniqueHostKeys
, "worked around grub/lvm boot bug #743126" ==>
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
`onChange` cmdProperty "update-grub" []
`onChange` cmdProperty "update-initramfs" ["-u"]
, combineProperties "nuked cloudatcost cruft"
[ File.notPresent "/etc/rc.local"
, File.notPresent "/etc/init.d/S97-setup.sh"
, User.nuked "user" User.YesReallyDeleteHome
]
]
myDnsSecondary :: [Dns.Zone]
myDnsSecondary =
[ Dns.secondary "kitenet.net" master
, Dns.secondary "joeyh.name" master
, Dns.secondary "ikiwiki.info" master
, Dns.secondary "olduse.net" master
, Dns.secondary "branchable.com" branchablemaster
]
where
master = ["80.68.85.49", "2001:41c8:125:49::10"] -- wren
branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"]
main :: IO ()
main = defaultMain hosts --, Docker.containerProperties container]

47
config-simple.hs Normal file
View File

@ -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

1
config.hs Symbolic link
View File

@ -0,0 +1 @@
config-simple.hs

7
debian/README.Debian vendored Normal file
View File

@ -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.

57
debian/changelog vendored Normal file
View File

@ -0,0 +1,57 @@
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

1
debian/compat vendored Normal file
View File

@ -0,0 +1 @@
9

40
debian/control vendored Normal file
View File

@ -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.

11
debian/copyright vendored Normal file
View File

@ -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.

3
debian/lintian-overrides vendored Normal file
View File

@ -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

15
debian/propellor.1 vendored Normal file
View File

@ -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>

14
debian/rules vendored Executable file
View File

@ -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

25
privdata/clam.kitenet.net.gpg Normal file
View File

@ -0,0 +1,25 @@
-----BEGIN PGP MESSAGE-----
Version: GnuPG v1
hQIMA7ODiaEXBlRZARAAuRttWmrr3tFgQnbnaQpWxiAQToL94e0SctFiYqiEGRNa
D63/ZaBhBkvKSx57+SyOloqfBaeWM63vd4Yacocypl2zOjC4aEN7/MKyQRl+xhmk
EwQ4kFfJ3dmYrgXt7NAdIarjHsK5/Bv7PGVIrcwD3zqV+FUyuxt2L2ETG61kYo+m
xNWl1NCvHDZ1QOfvw4ldBo7+LO2odzoZAxBF0ZgQFqo/r/6RZaqFNJRLdVTLERTq
E4igjtgfq6blrpyeupKpFu6oy8/7WeBXthnyoduftk+aBTkXWzb+i30zIzNNsc4+
GE68a5tM0XE8nGwKp4yz0AZHhEYzv+BZXI7HQMAZ+m0srVn637SDHeAgOBU8NjrA
SbZt0ubQ28Qaux7C7awLJ5SjvlQyLT61jLaN6SMcpeLmgkjRVN+eiVOE/qmXzhHv
AobUwJgBOktiN6+WtRcxq7WduNf6Jtxw8UB5gVWiEeg6o+29ZBfIKVMT/Jly4rTO
M13HbmSVzwdGcUL1D7Gf3oY2R7eS4VR8ShCQmF8aB8TXdsw4mo71HnUa7u5N4hCP
jLtJG24+f39TWWRjMQjtFXi5hkep4OG5CBViWdCWOjlfn4Kmr5zCXaunkO9cgDAd
s8UZdmALu2MPoVdcVm+KLq2JQi1jBWEqRu5krx/nSi+eRRX2/y95CKPEPqZoU+rS
wM0BzlW+pEDc7aFlcYCrWTiwO0BWT2iBmbse9/r2NyJPpuFf7GOMI2v65jXQ+avy
1r69zPdAXNgJ19Gid/q1CXCYnYLLVHqigd8XNs12ANaVvkOnBi3gAf309SIPJtCa
uFVBxNasLTMQ3Ta7v7TLa0PopdBuFqfcy9d3BBiOKqokvhWFJobaG/WhF85ercRJ
F8lse9fgo5xfrDoCFk7u9rzhHl8xKLl24thKFTDzwm+yuzXOoLq8+Km/xYuzQXZK
JCjPvIUDaCCc1E/Yeoc3RafAiOuNwnjHW15TRdlohmgXzYlTCYF491WVKQfpL2Sd
VO8Uar094M1d52Rv8/1HCTBKJ0hnK259l4dguzw4sl2BcrFPBz9SJ0f6V/eAHE0h
la5QtLdwDDRI2giMXKfmzRiRA/5kBW01YaK7tt0om6L7Ri4Rs3JAhVgjcWDtH6fI
w807PpsIHaK8r3yDJoeqUnDYOsImuNgdctQkeroPsFYmV3fu5Hb5tYDkKzm5lE0z
C6mz09PD0M5hsnqmZXaw
=UFa1
-----END PGP MESSAGE-----

22
privdata/darkstar.kitenet.net.gpg Normal file
View File

@ -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-----

19
privdata/diatom.kitenet.net.gpg Normal file
View File

@ -0,0 +1,19 @@
-----BEGIN PGP MESSAGE-----
Version: GnuPG v1
hQIMA7ODiaEXBlRZAQ//Qsi46/S4X9qWNSCqFUuUOdoKnuOro0SIKfR19Z0SlseL
AH5cPWUX2eIFA3tzku5Psm8enxGc2jyMhfS5KQkVMLoV/SdgLTEfbsF2TkOGUIFf
AMEt+HOPercftwzU+KnwyNJ6kfCinlgmehLwAHLvD8HfzsL9lD59dJGkYQ61cDZ8
NQSOJwbLVzlXGoMjUcQ6ihmg7gOEGptO7F+p4oamOYwpzibaFGX2BsczMRDcjlGY
B+ufxINqj2bV17lHchNs/Je8uF5Owe+5zoK2cf6TTCdtlIcWjuw6YIMUPWHhIx3C
DCrEFS/rOJCyY+M8CwIfqS0JTJVNIKJfhP8LbbaoyRyXB2XF2eLM1bQ25p//fpav
+MRQ/0SqnGXYV7ZQE/a+/dESi8/u2yua1m1DBwXzAp468pCTaZCm9gwV+D9Ggsbr
uCU5K/cTa7wPyzfYtki0jkM+R1uk1HqWuHHt0/CD1VnDM3Zrj2JVkoE+pR1LhiSH
qKj8/zF935QmGrCUUjo+1bBn20BDiiFPiiPo4KN3At2uK4qQo1F0c+JUQUHGKV9r
O/c4v0dhPj/Qq5kSp5higO8n2Afv68wAfCWBkBo6SpCS7nuR7xvLWD7pWBTS/0BG
BcL4recUTckQHPo+VUNMYlSNeUhnlv/2TK7/qsfPMYTi0Xu/Fr+bnKn3QOPbgITS
cgHrplzueGhsVhhy+Cpn31FptA7txwcAWuWcZmT7ych0APt/PdkZ1CdeQ3gQop0p
BXaUlY7N4PacFyrC8Jha4p8THbbmfg6zTwaPggH8HonOIL5iA2yZz78uvZwqUd5i
QD0LMQZ3ZgNiqlwLxA8e6heSNA==
=V6He
-----END PGP MESSAGE-----

BIN
privdata/keyring.gpg Normal file
View File

Binary file not shown.

22
privdata/orca.kitenet.net.gpg Normal file
View File

@ -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-----

125
propellor.cabal Normal file
View File

@ -0,0 +1,125 @@
Name: propellor
Version: 0.3.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.Apt
Propellor.Property.Cmd
Propellor.Property.Hostname
Propellor.Property.Cron
Propellor.Property.Dns
Propellor.Property.Docker
Propellor.Property.File
Propellor.Property.Git
Propellor.Property.Network
Propellor.Property.OpenId
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
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

91
propellor.hs Normal file
View File

@ -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."
)