diff --git a/Common.hs b/Common.hs new file mode 100644 --- /dev/null +++ b/Common.hs @@ -0,0 +1,29 @@ +module Common (module X) where + +import Control.Monad as X hiding (join) +import Control.Monad.IfElse as X +import Control.Applicative as X +import Control.Monad.State as X (liftIO) +import Control.Exception.Extensible as X (IOException) + +import Data.Maybe as X +import Data.List as X hiding (head, tail, init, last) +import Data.String.Utils as X + +import System.Path as X +import System.FilePath as X +import System.Directory as X +import System.Cmd.Utils as X hiding (safeSystem) +import System.IO as X hiding (FilePath) +import System.Posix.Files as X +import System.Posix.IO as X +import System.Posix.Process as X hiding (executeFile) +import System.Exit as X + +import Utility.Misc as X +import Utility.SafeCommand as X +import Utility.Path as X +import Utility.Directory as X +import Utility.Monad as X + +import Utility.PartialPrelude as X diff --git a/GPL b/GPL new file mode 100644 --- /dev/null +++ b/GPL @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Git.hs b/Git.hs new file mode 100644 --- /dev/null +++ b/Git.hs @@ -0,0 +1,116 @@ +{- git repository handling + - + - This is written to be completely independant of git-annex and should be + - suitable for other uses. + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git ( + Repo(..), + Ref(..), + Branch, + Sha, + Tag, + repoIsUrl, + repoIsSsh, + repoIsHttp, + repoIsLocalBare, + repoDescribe, + repoLocation, + workTree, + gitDir, + configTrue, + attributes, + assertLocal, +) where + +import qualified Data.Map as M +import Data.Char +import Network.URI (uriPath, uriScheme, unEscapeString) + +import Common +import Git.Types + +{- User-visible description of a git repo. -} +repoDescribe :: Repo -> String +repoDescribe Repo { remoteName = Just name } = name +repoDescribe Repo { location = Url url } = show url +repoDescribe Repo { location = Dir dir } = dir +repoDescribe Repo { location = Unknown } = "UNKNOWN" + +{- Location of the repo, either as a path or url. -} +repoLocation :: Repo -> String +repoLocation Repo { location = Url url } = show url +repoLocation Repo { location = Dir dir } = dir +repoLocation Repo { location = Unknown } = undefined + +{- Some code needs to vary between URL and normal repos, + - or bare and non-bare, these functions help with that. -} +repoIsUrl :: Repo -> Bool +repoIsUrl Repo { location = Url _ } = True +repoIsUrl _ = False + +repoIsSsh :: Repo -> Bool +repoIsSsh Repo { location = Url url } + | scheme == "ssh:" = True + -- git treats these the same as ssh + | scheme == "git+ssh:" = True + | scheme == "ssh+git:" = True + | otherwise = False + where + scheme = uriScheme url +repoIsSsh _ = False + +repoIsHttp :: Repo -> Bool +repoIsHttp Repo { location = Url url } + | uriScheme url == "http:" = True + | uriScheme url == "https:" = True + | otherwise = False +repoIsHttp _ = False + +configAvail ::Repo -> Bool +configAvail Repo { config = c } = c /= M.empty + +repoIsLocalBare :: Repo -> Bool +repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r +repoIsLocalBare _ = False + +assertLocal :: Repo -> a -> a +assertLocal repo action = + if not $ repoIsUrl repo + then action + else error $ "acting on non-local git repo " ++ repoDescribe repo ++ + " not supported" +configBare :: Repo -> Bool +configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo + where + unknown = error $ "it is not known if git repo " ++ + repoDescribe repo ++ + " is a bare repository; config not read" + +{- Path to a repository's gitattributes file. -} +attributes :: Repo -> String +attributes repo + | configBare repo = workTree repo ++ "/info/.gitattributes" + | otherwise = workTree repo ++ "/.gitattributes" + +{- Path to a repository's .git directory. -} +gitDir :: Repo -> String +gitDir repo + | configBare repo = workTree repo + | otherwise = workTree repo ".git" + +{- Path to a repository's --work-tree, that is, its top. + - + - Note that for URL repositories, this is the path on the remote host. -} +workTree :: Repo -> FilePath +workTree Repo { location = Url u } = unEscapeString $ uriPath u +workTree Repo { location = Dir d } = d +workTree Repo { location = Unknown } = undefined + +{- Checks if a string from git config is a true value. -} +configTrue :: String -> Bool +configTrue s = map toLower s == "true" diff --git a/Git/Branch.hs b/Git/Branch.hs new file mode 100644 --- /dev/null +++ b/Git/Branch.hs @@ -0,0 +1,87 @@ +{- git branch stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Branch where + +import qualified Data.ByteString.Lazy.Char8 as L + +import Common +import Git +import Git.Sha +import Git.Command + +{- The currently checked out branch. -} +current :: Repo -> IO (Maybe Git.Ref) +current r = parse <$> pipeRead [Param "symbolic-ref", Param "HEAD"] r + where + parse v + | L.null v = Nothing + | otherwise = Just $ Git.Ref $ firstLine $ L.unpack v + +{- Checks if the second branch has any commits not present on the first + - branch. -} +changed :: Branch -> Branch -> Repo -> IO Bool +changed origbranch newbranch repo + | origbranch == newbranch = return False + | otherwise = not . L.null <$> diffs + where + diffs = pipeRead + [ Param "log" + , Param (show origbranch ++ ".." ++ show newbranch) + , Params "--oneline -n1" + ] repo + +{- Given a set of refs that are all known to have commits not + - on the branch, tries to update the branch by a fast-forward. + - + - In order for that to be possible, one of the refs must contain + - every commit present in all the other refs. + -} +fastForward :: Branch -> [Ref] -> Repo -> IO Bool +fastForward _ [] _ = return True +fastForward branch (first:rest) repo = do + -- First, check that the branch does not contain any + -- new commits that are not in the first ref. If it does, + -- cannot fast-forward. + diverged <- changed first branch repo + if diverged + then no_ff + else maybe no_ff do_ff =<< findbest first rest + where + no_ff = return False + do_ff to = do + run "update-ref" + [Param $ show branch, Param $ show to] repo + return True + findbest c [] = return $ Just c + findbest c (r:rs) + | c == r = findbest c rs + | otherwise = do + better <- changed c r repo + worse <- changed r c repo + case (better, worse) of + (True, True) -> return Nothing -- divergent fail + (True, False) -> findbest r rs -- better + (False, True) -> findbest c rs -- worse + (False, False) -> findbest c rs -- same + +{- Commits the index into the specified branch (or other ref), + - with the specified parent refs, and returns the committed sha -} +commit :: String -> Branch -> [Ref] -> Repo -> IO Sha +commit message branch parentrefs repo = do + tree <- getSha "write-tree" $ asString $ + pipeRead [Param "write-tree"] repo + sha <- getSha "commit-tree" $ asString $ + ignorehandle $ pipeWriteRead + (map Param $ ["commit-tree", show tree] ++ ps) + (L.pack message) repo + run "update-ref" [Param $ show branch, Param $ show sha] repo + return sha + where + ignorehandle a = snd <$> a + asString a = L.unpack <$> a + ps = concatMap (\r -> ["-p", show r]) parentrefs diff --git a/Git/Command.hs b/Git/Command.hs new file mode 100644 --- /dev/null +++ b/Git/Command.hs @@ -0,0 +1,82 @@ +{- running git commands + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Command where + +import qualified Data.ByteString.Lazy.Char8 as L + +import Common +import Git +import Git.Types + +{- Constructs a git command line operating on the specified repo. -} +gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] +gitCommandLine params repo@(Repo { location = Dir _ } ) = + -- force use of specified repo via --git-dir and --work-tree + [ Param ("--git-dir=" ++ gitDir repo) + , Param ("--work-tree=" ++ workTree repo) + ] ++ params +gitCommandLine _ repo = assertLocal repo $ error "internal" + +{- Runs git in the specified repo. -} +runBool :: String -> [CommandParam] -> Repo -> IO Bool +runBool subcommand params repo = assertLocal repo $ + boolSystem "git" $ gitCommandLine (Param subcommand : params) repo + +{- Runs git in the specified repo, throwing an error if it fails. -} +run :: String -> [CommandParam] -> Repo -> IO () +run subcommand params repo = assertLocal repo $ + unlessM (runBool subcommand params repo) $ + error $ "git " ++ show params ++ " failed" + +{- Runs a git subcommand and returns its output, lazily. + - + - Note that this leaves the git process running, and so zombies will + - result unless reap is called. + -} +pipeRead :: [CommandParam] -> Repo -> IO L.ByteString +pipeRead params repo = assertLocal repo $ do + (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo + hSetBinaryMode h True + L.hGetContents h + +{- Runs a git subcommand, feeding it input. + - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} +pipeWrite :: [CommandParam] -> L.ByteString -> Repo -> IO PipeHandle +pipeWrite params s repo = assertLocal repo $ do + (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) + L.hPut h s + hClose h + return p + +{- Runs a git subcommand, feeding it input, and returning its output. + - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} +pipeWriteRead :: [CommandParam] -> L.ByteString -> Repo -> IO (PipeHandle, L.ByteString) +pipeWriteRead params s repo = assertLocal repo $ do + (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo) + hSetBinaryMode from True + L.hPut to s + hClose to + c <- L.hGetContents from + return (p, c) + +{- Reads null terminated output of a git command (as enabled by the -z + - parameter), and splits it. -} +pipeNullSplit :: [CommandParam] -> Repo -> IO [String] +pipeNullSplit params repo = map L.unpack <$> pipeNullSplitB params repo + +{- For when Strings are not needed. -} +pipeNullSplitB ::[CommandParam] -> Repo -> IO [L.ByteString] +pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$> + pipeRead params repo + +{- Reaps any zombie git processes. -} +reap :: IO () +reap = do + -- throws an exception when there are no child processes + r <- catchDefaultIO (getAnyProcessStatus False True) Nothing + maybe (return ()) (const reap) r diff --git a/Git/Config.hs b/Git/Config.hs new file mode 100644 --- /dev/null +++ b/Git/Config.hs @@ -0,0 +1,73 @@ +{- git repository configuration handling + - + - Copyright 2010,2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Config where + +import System.Posix.Directory +import Control.Exception (bracket_) +import qualified Data.Map as M + +import Common +import Git +import Git.Types +import qualified Git.Construct + +{- Returns a single git config setting, or a default value if not set. -} +get :: String -> String -> Repo -> String +get key defaultValue repo = M.findWithDefault defaultValue key (config repo) + +{- Returns a single git config setting, if set. -} +getMaybe :: String -> Repo -> Maybe String +getMaybe key repo = M.lookup key (config repo) + +{- Runs git config and populates a repo with its config. -} +read :: Repo -> IO Repo +read repo@(Repo { location = Dir d }) = do + {- Cannot use pipeRead because it relies on the config having + been already read. Instead, chdir to the repo. -} + cwd <- getCurrentDirectory + if dirContains d cwd + then go + else bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) go + where + go = pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ + hRead repo +read r = assertLocal r $ + error $ "internal error; trying to read config of " ++ show r + +{- Reads git config from a handle and populates a repo with it. -} +hRead :: Repo -> Handle -> IO Repo +hRead repo h = do + val <- hGetContentsStrict h + store val repo + +{- Stores a git config into a repo, returning the new version of the repo. + - The git config may be multiple lines, or a single line. Config settings + - can be updated inrementally. -} +store :: String -> Repo -> IO Repo +store s repo = do + let c = parse s + let repo' = repo + { config = (M.map Prelude.head c) `M.union` config repo + , fullconfig = M.unionWith (++) c (fullconfig repo) + } + rs <- Git.Construct.fromRemotes repo' + return $ repo' { remotes = rs } + +{- Parses git config --list or git config --null --list output into a + - config map. -} +parse :: String -> M.Map String [String] +parse [] = M.empty +parse s + -- --list output will have an = in the first line + | all ('=' `elem`) (take 1 ls) = sep '=' ls + -- --null --list output separates keys from values with newlines + | otherwise = sep '\n' $ split "\0" s + where + ls = lines s + sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . + map (separate (== c)) diff --git a/Git/Construct.hs b/Git/Construct.hs new file mode 100644 --- /dev/null +++ b/Git/Construct.hs @@ -0,0 +1,262 @@ +{- Construction of Git Repo objects + - + - Copyright 2010,2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Construct ( + fromCurrent, + fromCwd, + fromAbsPath, + fromPath, + fromUrl, + fromUnknown, + localToUrl, + remoteNamed, + remoteNamedFromKey, + fromRemotes, + fromRemoteLocation, + repoAbsPath, +) where + +import System.Posix.User +import System.Posix.Env (getEnv, unsetEnv) +import System.Posix.Directory (changeWorkingDirectory) +import qualified Data.Map as M hiding (map, split) +import Network.URI + +import Common +import Git.Types +import Git +import qualified Git.Url as Url + +{- Finds the current git repository. + - + - GIT_DIR can override the location of the .git directory. + - + - When GIT_WORK_TREE is set, chdir to it, so that anything using + - this repository runs in the right location. However, this chdir is + - done after determining GIT_DIR; git does not let GIT_WORK_TREE + - influence the git directory. + - + - Both environment variables are unset, to avoid confusing other git + - commands that also look at them. This would particularly be a problem + - when GIT_DIR is relative and we chdir for GIT_WORK_TREE. Instead, + - the Git module passes --work-tree and --git-dir to git commands it runs. + -} +fromCurrent :: IO Repo +fromCurrent = do + r <- maybe fromCwd fromPath =<< getEnv "GIT_DIR" + maybe (return ()) changeWorkingDirectory =<< getEnv "GIT_WORK_TREE" + unsetEnv "GIT_DIR" + unsetEnv "GIT_WORK_TREE" + return r + +{- Finds the git repository used for the Cwd, which may be in a parent + - directory. -} +fromCwd :: IO Repo +fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo + where + makerepo = newFrom . Dir + norepo = error "Not in a git repository." + +{- Local Repo constructor, accepts a relative or absolute path. -} +fromPath :: FilePath -> IO Repo +fromPath dir = fromAbsPath =<< absPath dir + +{- Local Repo constructor, requires an absolute path to the repo be + - specified. -} +fromAbsPath :: FilePath -> IO Repo +fromAbsPath dir + | "/" `isPrefixOf` dir = do + -- Git always looks for "dir.git" in preference to + -- to "dir", even if dir ends in a "/". + let canondir = dropTrailingPathSeparator dir + let dir' = canondir ++ ".git" + e <- doesDirectoryExist dir' + if e + then ret dir' + else if "/.git" `isSuffixOf` canondir + then do + -- When dir == "foo/.git", git looks + -- for "foo/.git/.git", and failing + -- that, uses "foo" as the repository. + e' <- doesDirectoryExist $ dir ".git" + if e' + then ret dir + else ret $ takeDirectory canondir + else ret dir + | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" + where + ret = newFrom . Dir + +{- Remote Repo constructor. Throws exception on invalid url. + - + - Git is somewhat forgiving about urls to repositories, allowing + - eg spaces that are not normally allowed unescaped in urls. + -} +fromUrl :: String -> IO Repo +fromUrl url + | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url + | otherwise = fromUrlStrict url + +fromUrlStrict :: String -> IO Repo +fromUrlStrict url + | startswith "file://" url = fromAbsPath $ uriPath u + | otherwise = newFrom $ Url u + where + u = fromMaybe bad $ parseURI url + bad = error $ "bad url " ++ url + +{- Creates a repo that has an unknown location. -} +fromUnknown :: IO Repo +fromUnknown = newFrom Unknown + +{- Converts a local Repo into a remote repo, using the reference repo + - which is assumed to be on the same host. -} +localToUrl :: Repo -> Repo -> Repo +localToUrl reference r + | not $ repoIsUrl reference = error "internal error; reference repo not url" + | repoIsUrl r = r + | otherwise = r { location = Url $ fromJust $ parseURI absurl } + where + absurl = + Url.scheme reference ++ "//" ++ + Url.authority reference ++ + workTree r + +{- Calculates a list of a repo's configured remotes, by parsing its config. -} +fromRemotes :: Repo -> IO [Repo] +fromRemotes repo = mapM construct remotepairs + where + filterconfig f = filter f $ M.toList $ config repo + filterkeys f = filterconfig (\(k,_) -> f k) + remotepairs = filterkeys isremote + isremote k = startswith "remote." k && endswith ".url" k + construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + +{- Sets the name of a remote when constructing the Repo to represent it. -} +remoteNamed :: String -> IO Repo -> IO Repo +remoteNamed n constructor = do + r <- constructor + return $ r { remoteName = Just n } + +{- Sets the name of a remote based on the git config key, such as + "remote.foo.url". -} +remoteNamedFromKey :: String -> IO Repo -> IO Repo +remoteNamedFromKey k = remoteNamed basename + where + basename = join "." $ reverse $ drop 1 $ + reverse $ drop 1 $ split "." k + +{- Constructs a new Repo for one of a Repo's remotes using a given + - location (ie, an url). -} +fromRemoteLocation :: String -> Repo -> IO Repo +fromRemoteLocation s repo = gen $ calcloc s + where + gen v + | scpstyle v = fromUrl $ scptourl v + | urlstyle v = fromUrl v + | otherwise = fromRemotePath v repo + -- insteadof config can rewrite remote location + calcloc l + | null insteadofs = l + | otherwise = replacement ++ drop (length bestvalue) l + where + replacement = drop (length prefix) $ + take (length bestkey - length suffix) bestkey + (bestkey, bestvalue) = maximumBy longestvalue insteadofs + longestvalue (_, a) (_, b) = compare b a + insteadofs = filterconfig $ \(k, v) -> + startswith prefix k && + endswith suffix k && + startswith v l + filterconfig f = filter f $ + concatMap splitconfigs $ + M.toList $ fullconfig repo + splitconfigs (k, vs) = map (\v -> (k, v)) vs + (prefix, suffix) = ("url." , ".insteadof") + urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v + -- git remotes can be written scp style -- [user@]host:dir + scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v) + scptourl v = "ssh://" ++ host ++ slash dir + where + (host, dir) = separate (== ':') v + slash d | d == "" = "/~/" ++ d + | "/" `isPrefixOf` d = d + | "~" `isPrefixOf` d = '/':d + | otherwise = "/~/" ++ d + +{- Constructs a Repo from the path specified in the git remotes of + - another Repo. -} +fromRemotePath :: FilePath -> Repo -> IO Repo +fromRemotePath dir repo = do + dir' <- expandTilde dir + fromAbsPath $ workTree repo dir' + +{- Git remotes can have a directory that is specified relative + - to the user's home directory, or that contains tilde expansions. + - This converts such a directory to an absolute path. + - Note that it has to run on the system where the remote is. + -} +repoAbsPath :: FilePath -> IO FilePath +repoAbsPath d = do + d' <- expandTilde d + h <- myHomeDir + return $ h d' + +expandTilde :: FilePath -> IO FilePath +expandTilde = expandt True + where + expandt _ [] = return "" + expandt _ ('/':cs) = do + v <- expandt True cs + return ('/':v) + expandt True ('~':'/':cs) = do + h <- myHomeDir + return $ h cs + expandt True ('~':cs) = do + let (name, rest) = findname "" cs + u <- getUserEntryForName name + return $ homeDirectory u rest + expandt _ (c:cs) = do + v <- expandt False cs + return (c:v) + findname n [] = (n, "") + findname n (c:cs) + | c == '/' = (n, cs) + | otherwise = findname (n++[c]) cs + +seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath) +seekUp want dir = do + ok <- want dir + if ok + then return $ Just dir + else case parentDir dir of + "" -> return Nothing + d -> seekUp want d + +isRepoTop :: FilePath -> IO Bool +isRepoTop dir = do + r <- isRepo + if r + then return r + else isBareRepo + where + isRepo = gitSignature (".git" "config") + isBareRepo = do + e <- doesDirectoryExist (dir "objects") + if not e + then return e + else gitSignature "config" + gitSignature file = doesFileExist (dir file) + +newFrom :: RepoLocation -> IO Repo +newFrom l = return Repo + { location = l + , config = M.empty + , fullconfig = M.empty + , remotes = [] + , remoteName = Nothing + } diff --git a/Git/Queue.hs b/Git/Queue.hs new file mode 100644 --- /dev/null +++ b/Git/Queue.hs @@ -0,0 +1,93 @@ +{- git repository command queue + - + - Copyright 2010 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Queue ( + Queue, + new, + add, + size, + full, + flush +) where + +import qualified Data.Map as M +import System.IO +import System.Cmd.Utils +import Data.String.Utils +import Utility.SafeCommand + +import Common +import Git +import Git.Command + +{- An action to perform in a git repository. The file to act on + - is not included, and must be able to be appended after the params. -} +data Action = Action + { getSubcommand :: String + , getParams :: [CommandParam] + } deriving (Show, Eq, Ord) + +{- A queue of actions to perform (in any order) on a git repository, + - with lists of files to perform them on. This allows coalescing + - similar git commands. -} +data Queue = Queue Int (M.Map Action [FilePath]) + deriving (Show, Eq) + +{- A recommended maximum size for the queue, after which it should be + - run. + - + - 10240 is semi-arbitrary. If we assume git filenames are between 10 and + - 255 characters long, then the queue will build up between 100kb and + - 2550kb long commands. The max command line length on linux is somewhere + - above 20k, so this is a fairly good balance -- the queue will buffer + - only a few megabytes of stuff and a minimal number of commands will be + - run by xargs. -} +maxSize :: Int +maxSize = 10240 + +{- Constructor for empty queue. -} +new :: Queue +new = Queue 0 M.empty + +{- Adds an action to a queue. -} +add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue +add (Queue n m) subcommand params files = Queue (n + 1) m' + where + action = Action subcommand params + -- There are probably few items in the map, but there + -- can be a lot of files per item. So, optimise adding + -- files. + m' = M.insertWith' const action fs m + fs = files ++ M.findWithDefault [] action m + +{- Number of items in a queue. -} +size :: Queue -> Int +size (Queue n _) = n + +{- Is a queue large enough that it should be flushed? -} +full :: Queue -> Bool +full (Queue n _) = n > maxSize + +{- Runs a queue on a git repository. -} +flush :: Queue -> Repo -> IO Queue +flush (Queue _ m) repo = do + forM_ (M.toList m) $ uncurry $ runAction repo + return new + +{- Runs an Action on a list of files in a git repository. + - + - Complicated by commandline length limits. + - + - Intentionally runs the command even if the list of files is empty; + - this allows queueing commands that do not need a list of files. -} +runAction :: Repo -> Action -> [FilePath] -> IO () +runAction repo action files = + pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs + where + params = toCommand $ gitCommandLine + (Param (getSubcommand action):getParams action) repo + feedxargs h = hPutStr h $ join "\0" files diff --git a/Git/Ref.hs b/Git/Ref.hs new file mode 100644 --- /dev/null +++ b/Git/Ref.hs @@ -0,0 +1,65 @@ +{- git ref stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Ref where + +import qualified Data.ByteString.Lazy.Char8 as L + +import Common +import Git +import Git.Command + +{- Converts a fully qualified git ref into a user-visible string. -} +describe :: Ref -> String +describe = show . base + +{- Often git refs are fully qualified (eg: refs/heads/master). + - Converts such a fully qualified ref into a base ref (eg: master). -} +base :: Ref -> Ref +base = Ref . remove "refs/heads/" . remove "refs/remotes/" . show + where + remove prefix s + | prefix `isPrefixOf` s = drop (length prefix) s + | otherwise = s + + +{- Given a directory such as "refs/remotes/origin", and a ref such as + - refs/heads/master, yields a version of that ref under the directory, + - such as refs/remotes/origin/master. -} +under :: String -> Ref -> Ref +under dir r = Ref $ dir show (base r) + +{- Checks if a ref exists. -} +exists :: Ref -> Repo -> IO Bool +exists ref = runBool "show-ref" + [Param "--verify", Param "-q", Param $ show ref] + +{- Get the sha of a fully qualified git ref, if it exists. -} +sha :: Branch -> Repo -> IO (Maybe Sha) +sha branch repo = process . L.unpack <$> showref repo + where + showref = pipeRead [Param "show-ref", + Param "--hash", -- get the hash + Param $ show branch] + process [] = Nothing + process s = Just $ Ref $ firstLine s + +{- List of (refs, branches) matching a given ref spec. -} +matching :: Ref -> Repo -> IO [(Ref, Branch)] +matching ref repo = do + r <- pipeRead [Param "show-ref", Param $ show ref] repo + return $ map (gen . L.unpack) (L.lines r) + where + gen l = let (r, b) = separate (== ' ') l in + (Ref r, Ref b) + +{- List of (refs, branches) matching a given ref spec. + - Duplicate refs are filtered out. -} +matchingUniq :: Ref -> Repo -> IO [(Ref, Branch)] +matchingUniq ref repo = nubBy uniqref <$> matching ref repo + where + uniqref (a, _) (b, _) = a == b diff --git a/Git/Sha.hs b/Git/Sha.hs new file mode 100644 --- /dev/null +++ b/Git/Sha.hs @@ -0,0 +1,39 @@ +{- git SHA stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Sha where + +import Common +import Git.Types + +{- Runs an action that causes a git subcommand to emit a Sha, and strips + any trailing newline, returning the sha. -} +getSha :: String -> IO String -> IO Sha +getSha subcommand a = maybe bad return =<< extractSha <$> a + where + bad = error $ "failed to read sha from git " ++ subcommand + +{- Extracts the Sha from a string. There can be a trailing newline after + - it, but nothing else. -} +extractSha :: String -> Maybe Sha +extractSha s + | len == shaSize = val s + | len == shaSize + 1 && length s' == shaSize = val s' + | otherwise = Nothing + where + len = length s + s' = firstLine s + val v + | all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v + | otherwise = Nothing + +{- Size of a git sha. -} +shaSize :: Int +shaSize = 40 + +nullSha :: Ref +nullSha = Ref $ replicate shaSize '0' diff --git a/Git/Types.hs b/Git/Types.hs new file mode 100644 --- /dev/null +++ b/Git/Types.hs @@ -0,0 +1,38 @@ +{- git data types + - + - Copyright 2010,2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Types where + +import Network.URI +import qualified Data.Map as M + +{- There are two types of repositories; those on local disk and those + - accessed via an URL. -} +data RepoLocation = Dir FilePath | Url URI | Unknown + deriving (Show, Eq) + +data Repo = Repo { + location :: RepoLocation, + config :: M.Map String String, + -- a given git config key can actually have multiple values + fullconfig :: M.Map String [String], + remotes :: [Repo], + -- remoteName holds the name used for this repo in remotes + remoteName :: Maybe String +} deriving (Show, Eq) + +{- A git ref. Can be a sha1, or a branch or tag name. -} +newtype Ref = Ref String + deriving (Eq) + +instance Show Ref where + show (Ref v) = v + +{- Aliases for Ref. -} +type Branch = Ref +type Sha = Ref +type Tag = Ref diff --git a/Git/Url.hs b/Git/Url.hs new file mode 100644 --- /dev/null +++ b/Git/Url.hs @@ -0,0 +1,70 @@ +{- git repository urls + - + - Copyright 2010, 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Url ( + scheme, + host, + port, + hostuser, + authority, +) where + +import Network.URI hiding (scheme, authority) + +import Common +import Git.Types +import Git + +{- Scheme of an URL repo. -} +scheme :: Repo -> String +scheme Repo { location = Url u } = uriScheme u +scheme repo = notUrl repo + +{- Work around a bug in the real uriRegName + - -} +uriRegName' :: URIAuth -> String +uriRegName' a = fixup $ uriRegName a + where + fixup x@('[':rest) + | rest !! len == ']' = take len rest + | otherwise = x + where + len = length rest - 1 + fixup x = x + +{- Hostname of an URL repo. -} +host :: Repo -> String +host = authpart uriRegName' + +{- Port of an URL repo, if it has a nonstandard one. -} +port :: Repo -> Maybe Integer +port r = + case authpart uriPort r of + ":" -> Nothing + (':':p) -> readish p + _ -> Nothing + +{- Hostname of an URL repo, including any username (ie, "user@host") -} +hostuser :: Repo -> String +hostuser r = authpart uriUserInfo r ++ authpart uriRegName' r + +{- The full authority portion an URL repo. (ie, "user@host:port") -} +authority :: Repo -> String +authority = authpart assemble + where + assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a + +{- Applies a function to extract part of the uriAuthority of an URL repo. -} +authpart :: (URIAuth -> a) -> Repo -> a +authpart a Repo { location = Url u } = a auth + where + auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u) +authpart _ repo = notUrl repo + +notUrl :: Repo -> a +notUrl repo = error $ + "acting on local git repo " ++ repoDescribe repo ++ " not supported" diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,29 @@ +GHCFLAGS=-O2 -Wall +bins=github-backup +all=$(bins) + +ifdef PROFILE +GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp +endif + +GHCMAKE=ghc $(GHCFLAGS) --make + +# Am I typing :make in vim? Do a fast build. +ifdef VIM +all=fast +endif + +all: $(all) + +# Disables optimisation. Not for production use. +fast: GHCFLAGS=-Wall +fast: $(bins) + +$(bins): + $(GHCMAKE) $@ + +clean: + rm -f $(bins) + find . \( -name \*.o -or -name \*.hi \) -exec rm {} \; + +.PHONY: $(bins) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,67 @@ +github-backup is a simple tool you run in a git repository you cloned from +Github. It backs up everything Github knows about the repository, including +other forks, issues, comments, milestones, pull requests, and watchers. + +## Installation + + git clone git://github.com/joeyh/github-backup + cd github-backup + make + ./github-backup + +Or use cabal: + + cabal install github-backup --bindir=$HOME/bin + +## Why backup Github + +There are a couple of reasons to want to back this stuff up: + +* In case something happens to Github. More generally because + keeping your data in the cloud *and* relying on the cloud to + back it up is foolish. + +* So you can keep working on your repository while on a plane, or + on a remote beach or mountiaintop. Just like Linus intended. + +## What to expect + +Each time you run github-backup, it will find any new forks of your project +on github. It will add remotes to your repository for the forks, using names +like `github_linus_divemonitor`. It will fetch from every fork. + +Then the next pass will download metadata from each fork. This is stored +into a branch named "github". Each fork gets a directory in there, +like `linus_divemonitor`. Inside the directory there will be some +files, like `linus_divemonitor/watchers`. There maybe be further +directories, like for comments: `linus_divemonitor/comments/1`. + +You can follow the commits to the github branch to see what information +changed on github over time. + +The format of the files in the github branch is currently Haskell +serialized data types. This is plain text, and readable, if you squint. + +## Limitations + +github-backup is repository-focused. It does not try to back up other +information from Github. In particular, social network stuff, like +users who are following you, is not backed up. + +github-backup will find and backup all forks of a repository, and all forks +of those forks, etc. However, it cannot go *up* the fork tree. So if +your Github repositoriy is a fork of something else, the something else +won't be backed up. There is an easy solution though. Just add the +parent as a git remote. Then github-backup will find it, and back it up. + +Currently, github-backup re-downloads all issues, comments, and so on +each time it's run. This may be slow if your repo has a lot of them. + +## Author + +github-backup was written by Joey Hess + +It is made possible thanks to: + +* Mike Burns's [haskell github library](http://hackage.haskell.org/package/github) +* Github, for providing an API exposing this data. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMainWithHooks simpleUserHooks diff --git a/Utility/Directory.hs b/Utility/Directory.hs new file mode 100644 --- /dev/null +++ b/Utility/Directory.hs @@ -0,0 +1,50 @@ +{- directory manipulation + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Directory where + +import System.IO.Error +import System.Posix.Files +import System.Directory +import Control.Exception (throw) +import Control.Monad +import Control.Monad.IfElse + +import Utility.SafeCommand +import Utility.TempFile + +{- 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 = try (rename src dest) >>= onrename + where + onrename (Right _) = return () + 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 + _ <- try $ + removeFile tmp + rethrow + isdir f = do + r <- try (getFileStatus f) + case r of + (Left _) -> return False + (Right s) -> return $ isDirectory s diff --git a/Utility/Misc.hs b/Utility/Misc.hs new file mode 100644 --- /dev/null +++ b/Utility/Misc.hs @@ -0,0 +1,58 @@ +{- misc utility functions + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Misc where + +import System.IO +import System.IO.Error (try) +import Control.Monad +import Control.Applicative + +{- 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 + +{- Like break, but the character 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') + +{- Catches IO errors and returns a Bool -} +catchBoolIO :: IO Bool -> IO Bool +catchBoolIO a = catchDefaultIO a False + +{- Catches IO errors and returns a Maybe -} +catchMaybeIO :: IO a -> IO (Maybe a) +catchMaybeIO a = catchDefaultIO (Just <$> a) Nothing + +{- Catches IO errors and returns a default value. -} +catchDefaultIO :: IO a -> a -> IO a +catchDefaultIO a def = catch a (const $ return def) + +{- Catches IO errors and returns the error message. -} +catchMsgIO :: IO a -> IO (Either String a) +catchMsgIO a = dispatch <$> try a + where + dispatch (Left e) = Left $ show e + dispatch (Right v) = Right v diff --git a/Utility/Monad.hs b/Utility/Monad.hs new file mode 100644 --- /dev/null +++ b/Utility/Monad.hs @@ -0,0 +1,41 @@ +{- monadic stuff + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Monad where + +import Data.Maybe +import Control.Monad (liftM) + +{- 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) = do + q <- p x + if q + then return (Just x) + else firstM p xs + +{- 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 + +{- Runs an action on values from a list until it succeeds. -} +untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool +untilTrue = flip anyM + +{- 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 diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs new file mode 100644 --- /dev/null +++ b/Utility/PartialPrelude.hs @@ -0,0 +1,68 @@ +{- Parts of the Prelude are partial functions, which are a common source of + - bugs. + - + - This exports functions that conflict with the prelude, which avoids + - them being accidentially used. + -} + +module Utility.PartialPrelude where + +import qualified Data.Maybe + +{- read should be avoided, as it throws an error + - Instead, use: readish -} +read :: Read a => String -> a +read = Prelude.read + +{- head is a partial function; head [] is an error + - Instead, use: take 1 or headMaybe -} +head :: [a] -> a +head = Prelude.head + +{- tail is also partial + - Instead, use: drop 1 -} +tail :: [a] -> [a] +tail = Prelude.tail + +{- init too + - Instead, use: beginning -} +init :: [a] -> [a] +init = Prelude.init + +{- last too + - Instead, use: end or lastMaybe -} +last :: [a] -> a +last = Prelude.last + +{- Attempts to read a value from a String. + - + - Ignores leading/trailing whitespace, and throws away any trailing + - text after the part that can be read. + - + - readMaybe is available in Text.Read in new versions of GHC, + - but that one requires the entire string to be consumed. + -} +readish :: Read a => String -> Maybe a +readish s = case reads s of + ((x,_):_) -> Just x + _ -> Nothing + +{- Like head but Nothing on empty list. -} +headMaybe :: [a] -> Maybe a +headMaybe = Data.Maybe.listToMaybe + +{- Like last but Nothing on empty list. -} +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe v = Just $ Prelude.last v + +{- All but the last element of a list. + - (Like init, but no error on an empty list.) -} +beginning :: [a] -> [a] +beginning [] = [] +beginning l = Prelude.init l + +{- Like last, but no error on an empty list. -} +end :: [a] -> [a] +end [] = [] +end l = [Prelude.last l] diff --git a/Utility/Path.hs b/Utility/Path.hs new file mode 100644 --- /dev/null +++ b/Utility/Path.hs @@ -0,0 +1,150 @@ +{- path manipulation + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Path where + +import Data.String.Utils +import System.Path +import System.FilePath +import System.Directory +import Data.List +import Data.Maybe +import Control.Applicative +import System.Posix.User + +import Utility.Monad + +{- Returns the parent directory of a path. Parent of / is "" -} +parentDir :: FilePath -> FilePath +parentDir dir + | not $ null dirs = slash ++ join s (init dirs) + | otherwise = "" + where + dirs = filter (not . null) $ split s dir + slash = if isAbsolute dir then s else "" + 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' || (a'++"/") `isPrefixOf` b' + where + norm p = fromMaybe "" $ absNormPath p "." + a' = norm a + b' = norm b + +{- Converts a filename into a normalized, 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 + +{- Converts a filename into a normalized, absolute path + - from the specified cwd. -} +absPathFrom :: FilePath -> FilePath -> FilePath +absPathFrom cwd file = fromMaybe bad $ absNormPath cwd file + where + bad = error $ "unable to normalize " ++ 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 normalized (eg with absNormpath). + -} +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 $ filter 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 + +{- Given an original list of files, and an expanded list derived from it, + - ensures that the original list's ordering is preserved. + - + - The input list may contain a directory, like "dir" or "dir/". Any + - items in the expanded list that are contained in that directory will + - appear at the same position as it did in the input list. + -} +preserveOrder :: [FilePath] -> [FilePath] -> [FilePath] +preserveOrder [] new = new +preserveOrder [_] new = new -- optimisation +preserveOrder (l:ls) new = found ++ preserveOrder ls rest + where + (found, rest)=partition (l `dirContains`) new + +{- Runs an action that takes a list of FilePaths, and ensures that + - its return list preserves order. + - + - This assumes that it's cheaper to call preserveOrder on the result, + - than it would be to run the action separately with each param. In the case + - of git file list commands, that assumption tends to hold. + -} +runPreserveOrder :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath] +runPreserveOrder a files = preserveOrder files <$> a files + +{- Lists the contents of a directory. + - Unlike getDirectoryContents, paths are not relative to the directory. -} +dirContents :: FilePath -> IO [FilePath] +dirContents d = map (d ) . filter notcruft <$> getDirectoryContents d + where + notcruft "." = False + notcruft ".." = False + notcruft _ = True + +{- Current user's home directory. -} +myHomeDir :: IO FilePath +myHomeDir = homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID) + +{- Checks if a command is available in PATH. -} +inPath :: String -> IO Bool +inPath command = getSearchPath >>= anyM indir + where + indir d = doesFileExist $ d command + +{- 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 diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs new file mode 100644 --- /dev/null +++ b/Utility/SafeCommand.hs @@ -0,0 +1,114 @@ +{- safely running shell commands + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.SafeCommand where + +import System.Exit +import qualified System.Posix.Process +import System.Posix.Process hiding (executeFile) +import System.Posix.Signals +import Data.String.Utils +import System.Log.Logger +import Control.Applicative + +{- 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 = (>>= unwrap) + where + unwrap (Param s) = [s] + unwrap (Params s) = filter (not . null) (split " " s) + -- Files that start with a dash are modified to avoid + -- the command interpreting them as options. + unwrap (File s@('-':_)) = ["./" ++ s] + unwrap (File s) = [s] + +{- 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 env = dispatch <$> safeSystemEnv command params env + 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 + +{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -} +safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode +safeSystemEnv command params env = do + -- Going low-level because all the high-level system functions + -- block SIGINT etc. We need to block SIGCHLD, but allow + -- SIGINT to do its default program termination. + let sigset = addSignal sigCHLD emptySignalSet + oldint <- installHandler sigINT Default Nothing + oldset <- getSignalMask + blockSignals sigset + childpid <- forkProcess $ childaction oldint oldset + mps <- getProcessStatus True False childpid + restoresignals oldint oldset + case mps of + Just (Exited code) -> return code + _ -> error $ "unknown error running " ++ command + where + restoresignals oldint oldset = do + _ <- installHandler sigINT oldint Nothing + setSignalMask oldset + childaction oldint oldset = do + restoresignals oldint oldset + executeFile command True (toCommand params) env + +{- executeFile with debug logging -} +executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO () +executeFile c path p e = do + debugM "Utility.SafeCommand.executeFile" $ + "Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e + System.Posix.Process.executeFile c path p e + +{- Escapes a filename or other parameter to be safely able to be exposed to + - the shell. -} +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 diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs new file mode 100644 --- /dev/null +++ b/Utility/TempFile.hs @@ -0,0 +1,41 @@ +{- temp file functions + - + - Copyright 2010-2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.TempFile where + +import Control.Exception (bracket) +import System.IO +import System.Posix.Process hiding (executeFile) +import System.Directory + +import Utility.Misc +import Utility.Path + +{- 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 + pid <- getProcessID + let tmpfile = file ++ ".tmp" ++ show pid + createDirectoryIfMissing True (parentDir file) + a tmpfile content + renameFile tmpfile file + +type Template = String + +{- Runs an action with a temp file, then removes the file. -} +withTempFile :: Template -> (FilePath -> Handle -> IO a) -> IO a +withTempFile template a = bracket create remove use + where + create = do + tmpdir <- catchDefaultIO getTemporaryDirectory "." + openTempFile tmpdir template + remove (name, handle) = do + hClose handle + catchBoolIO (removeFile name >> return True) + use (name, handle) = a name handle diff --git a/github-backup.cabal b/github-backup.cabal new file mode 100644 --- /dev/null +++ b/github-backup.cabal @@ -0,0 +1,32 @@ +Name: github-backup +Version: 1.20120126 +Cabal-Version: >= 1.6 +License: GPL +Maintainer: Joey Hess +Author: Joey Hess +Stability: Stable +Copyright: 2012 Joey Hess +License-File: GPL +Build-Type: Simple +Extra-Source-Files: README.md Makefile Git/Construct.hs Git/Command.hs + Git/Branch.hs Git/Url.hs Git/Ref.hs Git/Sha.hs Git/Types.hs + Git/Config.hs Git/Queue.hs Utility/Misc.hs Common.hs + Utility/TempFile.hs Utility/Monad.hs Utility/PartialPrelude.hs + Utility/Path.hs Utility/Directory.hs Utility/SafeCommand.hs Git.hs +Homepage: https://github.com/joeyh/github-backup +Category: Utility +Synopsis: backs up everything github knows about a repository, to the repository +Description: + github-backup is a simple tool you run in a git repository you cloned from + Github. It backs up everything Github knows about the repository, including + other forks, issues, comments, milestones, pull requests, and watchers. + +Executable github-backup + Main-Is: github-backup.hs + Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, + network, extensible-exceptions, unix, bytestring, base < 5, + IfElse, pretty-show, github + +source-repository head + type: git + location: git://github.com/joeyh/github-backup.git diff --git a/github-backup.hs b/github-backup.hs new file mode 100644 --- /dev/null +++ b/github-backup.hs @@ -0,0 +1,243 @@ +{- github-backup + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Main where + +import System.Environment +import Control.Exception (bracket) +import System.Posix.Directory (changeWorkingDirectory) +import Text.Show.Pretty +import qualified Github.Data.Definitions as Github +import qualified Github.Repos as Github +import qualified Github.Repos.Forks as Github +import qualified Github.PullRequests as Github +import qualified Github.Repos.Watching as Github +import qualified Github.Issues as Github +import qualified Github.Issues.Comments +import qualified Github.Issues.Milestones + +import Common +import qualified Git +import qualified Git.Construct +import qualified Git.Config +import qualified Git.Types +import qualified Git.Command +import qualified Git.Ref +import qualified Git.Branch +import qualified Git.Queue + +usage :: String +usage = "usage: github-backup [directory]" + +getLocalRepo :: [String] -> IO Git.Repo +getLocalRepo [] = Git.Construct.fromCwd +getLocalRepo (d:[]) = Git.Construct.fromPath d +getLocalRepo _ = error usage + +-- A github user and repo. +data GithubUserRepo = GithubUserRepo String String + +instance Show (GithubUserRepo) where + show (GithubUserRepo user remote) = "git://github.com/" ++ user ++ "/" ++ remote ++ ".git" + +toGithubUserRepo :: Github.Repo -> GithubUserRepo +toGithubUserRepo r = GithubUserRepo + (Github.githubUserLogin $ Github.repoOwner r) + (Github.repoName r) + +remoteFor :: Github.Repo -> String +remoteFor r = "github_" ++ + (Github.githubUserLogin $ Github.repoOwner r) ++ "_" ++ + (Github.repoName r) + +showRepo :: Github.Repo -> String +showRepo = show . toGithubUserRepo + +runRepoWith :: (String -> String -> b -> IO (Either Github.Error v)) -> b -> Github.Repo -> IO (Maybe v) +runRepoWith a b = run (\user repo -> a user repo b) . toGithubUserRepo + +runRepo :: (String -> String -> IO (Either Github.Error v)) -> Github.Repo -> IO (Maybe v) +runRepo a = run a . toGithubUserRepo + +run :: (String -> String -> IO (Either Github.Error v)) -> GithubUserRepo -> IO (Maybe v) +run a r@(GithubUserRepo user repo) = handle =<< a user repo + where + handle (Right v) = return $ Just v + handle (Left e) = do + hPutStrLn stderr $ "problem accessing API for " ++ show r ++ ": " ++ show e + return Nothing + +{- Finds already configured remotes that use github. + - Fetches from them because it would be surprising if a github backup + - didn't do so, and this is the only place the remote names are available. -} +gitHubRemotes :: Git.Repo -> IO [Github.Repo] +gitHubRemotes r = do + let (repos, remotes) = unzip $ gitHubUserRepos r + when (null remotes) $ error "no github remotes found" + forM_ repos $ \repo -> + Git.Command.runBool "fetch" [Param $ fromJust $ Git.Types.remoteName repo] r + catMaybes <$> mapM (run Github.userRepo) remotes + +gitHubUserRepos :: Git.Repo -> [(Git.Repo, GithubUserRepo)] +gitHubUserRepos = mapMaybe check . Git.Types.remotes + where + check r@Git.Repo { Git.Types.location = Git.Types.Url u } = + headMaybe $ mapMaybe (checkurl r $ show u) gitHubUrlPrefixes + check _ = Nothing + checkurl r u prefix + | prefix `isPrefixOf` u && length bits == 2 = + Just $ (r, + GithubUserRepo (bits !! 0) + (dropdotgit $ bits !! 1)) + | otherwise = Nothing + where + rest = drop (length prefix) u + bits = split "/" rest + dropdotgit s + | ".git" `isSuffixOf` s = take (length s - length ".git") s + | otherwise = s + +{- All known prefixes for urls to github repos. -} +gitHubUrlPrefixes :: [String] +gitHubUrlPrefixes = + [ "git@github.com:" + , "git://github.com/" + , "https://github.com/" + , "http://github.com/" + , "ssh://git@github.com/~/" + ] + +{- Recursively look for forks, and forks of forks, of the repos. + - Note that this guards against cycles in the fork tree, although + - presumably that should never happen. -} +findForks :: [Github.Repo] -> IO [Github.Repo] +findForks = findForks' [] +findForks' :: [Github.Repo] -> [Github.Repo] -> IO [Github.Repo] +findForks' _ [] = return [] +findForks' done rs = do + forks <- filter new . concat . catMaybes <$> + mapM (runRepo Github.forksFor) rs + forks' <- findForks' (done++rs) forks + return $ nub $ forks ++ forks' + where + new r = not $ r `elem` rs || r `elem` done + +{- Adds new forks, fetching from them. -} +addForks :: Git.Repo -> [Github.Repo] -> IO () +addForks _ [] = putStrLn "no new forks" +addForks r forks = do + putStrLn $ "new forks: " ++ unwords (map showRepo forks) + forM_ forks $ \fork -> do + Git.Command.runBool "remote" + [ Param "add" + , Param "-f" + , Param $ remoteFor fork + , Param $ Github.repoGitUrl fork + ] r + +onGithubBranch :: Git.Repo -> IO () -> IO () +onGithubBranch r a = bracket prep cleanup (const a) + where + prep = do + oldbranch <- Git.Branch.current r + exists <- Git.Ref.matching (Git.Ref $ "refs/heads/" ++ branchname) r + if null exists + then Git.Command.run "checkout" + [Param "--orphan", Param branchname] r + else Git.Command.run "checkout" + [Param branchname] r + return oldbranch + cleanup Nothing = return () + cleanup (Just oldbranch) + | name == branchname = return () + | otherwise = Git.Command.run "checkout" [Param name] r + where + name = show $ Git.Ref.base oldbranch + branchname = "github" + +commitFiles :: Git.Repo -> [FilePath] -> IO () +commitFiles _ [] = return () +commitFiles r files = do + mass "add" [Param "-f"] + mass "commit" [Param "-m", Param "github-backup"] + where + mass subcommand params = do + let q = Git.Queue.add Git.Queue.new subcommand params files + _ <- Git.Queue.flush q r + return () + +saveMetaData :: Show a => Github.Repo -> String -> a -> IO FilePath +saveMetaData repo file val = do + let file' = remoteFor repo file + createDirectoryIfMissing True (parentDir file') + writeFile file' (ppShow val) + return file' + +gatherMetaData :: Github.Repo -> IO [FilePath] +gatherMetaData repo = do + putStrLn $ "gathering metadata for " ++ showRepo repo + concat <$> mapM (\a -> a repo) + [ pullRequests + , watchers + , issues + , milestones + ] + +pullRequests :: Github.Repo -> IO [FilePath] +pullRequests repo = runRepo Github.pullRequestsFor repo >>= collect + where + collect Nothing = return [] + collect (Just rs) = forM rs $ \r -> do + let n = Github.pullRequestNumber r + details <- runRepoWith Github.pullRequest n repo + saveMetaData repo ("pullrequest" show n) details + +watchers :: Github.Repo -> IO [FilePath] +watchers repo = runRepo Github.watchersFor repo >>= collect + where + collect Nothing = return [] + collect (Just ws) = do + f <- saveMetaData repo "watchers" $ sort ws + return [f] + +issues :: Github.Repo -> IO [FilePath] +issues repo = runRepoWith Github.issuesForRepo [] repo >>= collect + where + collect Nothing = return [] + collect (Just is) = concat <$> forM is get + get i = do + let n = Github.issueNumber i + f <- saveMetaData repo ("issue" show n) i + fs <- issueComments n repo + return $ f:fs + +issueComments :: Int -> Github.Repo -> IO [FilePath] +issueComments n repo = runRepoWith Github.Issues.Comments.comments n repo >>= collect + where + collect Nothing = return [] + collect (Just cs) = forM cs $ \c -> do + let i = Github.issueCommentId c + saveMetaData repo ("issue" show n ++ "_comment" show i) c + +milestones :: Github.Repo -> IO [FilePath] +milestones repo = runRepo Github.Issues.Milestones.milestones repo >>= collect + where + collect Nothing = return [] + collect (Just ms) = forM ms $ \m -> do + let n = Github.milestoneNumber m + saveMetaData repo ("milestone" show n) m + +main :: IO () +main = do + r <- Git.Config.read =<< getLocalRepo =<< getArgs + changeWorkingDirectory $ Git.repoLocation r + remotes <- gitHubRemotes r + forks <- findForks remotes + addForks r forks + onGithubBranch r $ + concat <$> forM (forks ++ remotes) gatherMetaData + >>= commitFiles r