github-backup (empty) → 1.20120126

raw patch · 24 files changed

+2523/−0 lines, 24 filesdep +IfElsedep +MissingHdep +basesetup-changed

Dependencies added: IfElse, MissingH, base, bytestring, containers, directory, extensible-exceptions, filepath, github, hslogger, mtl, network, pretty-show, unix

Files

• Common.hs +29/−0
• GPL +674/−0
• Git.hs +116/−0
• Git/Branch.hs +87/−0
• Git/Command.hs +82/−0
• Git/Config.hs +73/−0
• Git/Construct.hs +262/−0
• Git/Queue.hs +93/−0
• Git/Ref.hs +65/−0
• Git/Sha.hs +39/−0
• Git/Types.hs +38/−0
• Git/Url.hs +70/−0
• Makefile +29/−0
• README.md +67/−0
• Setup.hs +2/−0
• Utility/Directory.hs +50/−0
• Utility/Misc.hs +58/−0
• Utility/Monad.hs +41/−0
• Utility/PartialPrelude.hs +68/−0
• Utility/Path.hs +150/−0
• Utility/SafeCommand.hs +114/−0
• Utility/TempFile.hs +41/−0
• github-backup.cabal +32/−0
• github-backup.hs +243/−0

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

@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.

@@ -0,0 +1,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 <joey@kitenet.net>+ -+ - 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"

@@ -0,0 +1,87 @@+{- git branch stuff+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,82 @@+{- running git commands+ -+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,73 @@+{- git repository configuration handling+ -+ - Copyright 2010,2011 Joey Hess <joey@kitenet.net>+ -+ - 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))

@@ -0,0 +1,262 @@+{- Construction of Git Repo objects+ -+ - Copyright 2010,2011 Joey Hess <joey@kitenet.net>+ -+ - 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+	}

@@ -0,0 +1,93 @@+{- git repository command queue+ -+ - Copyright 2010 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,65 @@+{- git ref stuff+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,39 @@+{- git SHA stuff+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - 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'

@@ -0,0 +1,38 @@+{- git data types+ -+ - Copyright 2010,2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,70 @@+{- git repository urls+ -+ - Copyright 2010, 2011 Joey Hess <joey@kitenet.net>+ -+ - 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+ - <http://trac.haskell.org/network/ticket/40> -}+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"

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

@@ -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 <joey@kitenet.net>++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. 

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks simpleUserHooks

@@ -0,0 +1,50 @@+{- directory manipulation+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,58 @@+{- misc utility functions+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,41 @@+{- monadic stuff+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,68 @@+{- Parts of the Prelude are partial functions, which are a common source of+ - bugs.+ -+ - This exports functions that conflict with the prelude, which avoids+ - them being accidentially used.+ -}++module Utility.PartialPrelude where++import qualified Data.Maybe++{- read should be avoided, as it throws an error+ - Instead, use: readish -}+read :: Read a => String -> a+read = Prelude.read++{- head is a partial function; head [] is an error+ - Instead, use: take 1 or headMaybe -}+head :: [a] -> a+head = Prelude.head++{- tail is also partial+ - Instead, use: drop 1 -}+tail :: [a] -> [a]+tail = Prelude.tail++{- init too+ - Instead, use: beginning -}+init :: [a] -> [a]+init = Prelude.init++{- last too+ - Instead, use: end or lastMaybe -}+last :: [a] -> a+last = Prelude.last++{- Attempts to read a value from a String.+ -+ - Ignores leading/trailing whitespace, and throws away any trailing+ - text after the part that can be read.+ -+ - readMaybe is available in Text.Read in new versions of GHC,+ - but that one requires the entire string to be consumed.+ -}+readish :: Read a => String -> Maybe a+readish s = case reads s of+	((x,_):_) -> Just x+	_ -> Nothing++{- Like head but Nothing on empty list. -}+headMaybe :: [a] -> Maybe a+headMaybe = Data.Maybe.listToMaybe++{- Like last but Nothing on empty list. -}+lastMaybe :: [a] -> Maybe a+lastMaybe [] = Nothing+lastMaybe v = Just $ Prelude.last v++{- All but the last element of a list.+ - (Like init, but no error on an empty list.) -}+beginning :: [a] -> [a]+beginning [] = []+beginning l = Prelude.init l++{- Like last, but no error on an empty list. -}+end :: [a] -> [a]+end [] = []+end l = [Prelude.last l]

@@ -0,0 +1,150 @@+{- path manipulation+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,114 @@+{- safely running shell commands+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,41 @@+{- temp file functions+ -+ - Copyright 2010-2011 Joey Hess <joey@kitenet.net>+ -+ - 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

@@ -0,0 +1,32 @@+Name: github-backup+Version: 1.20120126+Cabal-Version: >= 1.6+License: GPL+Maintainer: Joey Hess <joey@kitenet.net>+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

@@ -0,0 +1,243 @@+{- github-backup+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - 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