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
commit
be02ef96aa
|
|
@ -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>.
|
||||
|
|
@ -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
|
||||
|
|
@ -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"
|
||||
|
|
@ -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)
|
||||
|
|
@ -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"
|
||||
]
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 !
|
||||
|
|
@ -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]
|
||||
|
|
@ -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)
|
||||
|
|
@ -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"
|
||||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
]
|
||||
|
|
@ -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
|
||||
|
|
@ -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]
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
module Propellor.Property.Reboot where
|
||||
|
||||
import Propellor
|
||||
|
||||
now :: Property
|
||||
now = cmdProperty "reboot" []
|
||||
`describe` "reboot now"
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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"
|
||||
)
|
||||
]
|
||||
|
|
@ -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")
|
||||
|
|
@ -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"
|
||||
]
|
||||
|
|
@ -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"]
|
||||
|
|
@ -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]
|
||||
|
|
@ -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"]
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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/
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
{- cabal setup file -}
|
||||
|
||||
import Distribution.Simple
|
||||
|
||||
main = defaultMain
|
||||
|
|
@ -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.
|
||||
|
|
@ -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 <$$>
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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'"]
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ()
|
||||
|
|
@ -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]
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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]
|
||||
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
9
|
||||
|
|
@ -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.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
|
@ -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>
|
||||
|
|
@ -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
|
||||
|
|
@ -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-----
|
||||
|
|
@ -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-----
|
||||
|
|
@ -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-----
|
||||
Binary file not shown.
|
|
@ -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-----
|
||||
|
|
@ -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
|
||||
|
|
@ -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."
|
||||
)
|
||||
Loading…
Reference in New Issue