packages feed

git-repair 1.20170626 → 1.20200102

raw patch · 68 files changed

+2246/−1696 lines, 68 filesdep +attoparsecdep +deepseqdep +filepath-bytestringdep ~basedep ~networkdep ~optparse-applicative

Dependencies added: attoparsec, deepseq, filepath-bytestring

Dependency ranges changed: base, network, optparse-applicative, unix, unix-compat

Files

Build/Configure.hs view
@@ -1,12 +1,13 @@-{- Checks system configuration and generates SysConfig.hs. -}+{- Checks system configuration and generates SysConfig. -}  {-# OPTIONS_GHC -fno-warn-tabs #-}  module Build.Configure where  import System.Environment-import Control.Applicative import Control.Monad.IfElse+import Control.Applicative+import Prelude  import Build.TestConfig import Build.Version@@ -15,7 +16,7 @@ tests :: [TestCase] tests = 	[ TestCase "version" (Config "packageversion" . StringConfig <$> getVersion)-	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"+	, TestCase "git" $ testCmd "git" "git --version >/dev/null" 	, TestCase "git version" getGitVersion 	] @@ -25,7 +26,6 @@  run :: [TestCase] -> IO () run ts = do-	args <- getArgs 	config <- runTests ts 	writeSysConfig config 	whenM (isReleaseBuild) $
Build/TestConfig.hs view
@@ -1,4 +1,4 @@-{- Tests the system and generates Build.SysConfig.hs. -}+{- Tests the system and generates SysConfig. -}  {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -42,12 +42,11 @@ 		valuetype (MaybeBoolConfig _) = "Maybe Bool"  writeSysConfig :: [Config] -> IO ()-writeSysConfig config = writeFile "Build/SysConfig.hs" body+writeSysConfig config = writeFile "Build/SysConfig" body   where 	body = unlines $ header ++ map show config ++ footer 	header = [ 		  "{- Automatically generated. -}"-		, "module Build.SysConfig where" 		, "" 		] 	footer = []@@ -60,18 +59,6 @@ 	testEnd c 	rest <- runTests ts 	return $ c:rest--{- Tests that a command is available, aborting if not. -}-requireCmd :: ConfigKey -> String -> Test-requireCmd k cmdline = do-	ret <- testCmd k cmdline-	handle ret-  where-	handle r@(Config _ (BoolConfig True)) = return r-	handle r = do-		testEnd r-		error $ "** the " ++ c ++ " command is required"-	c = head $ words cmdline  {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test
+ BuildInfo.hs view
@@ -0,0 +1,12 @@+{- build info+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module BuildInfo where++#include "Build/SysConfig"
CHANGELOG view
@@ -1,3 +1,13 @@+git-repair (1.20200102) unstable; urgency=medium++  * Relicensed AGPL.+  * Merge from git-annex.+  * Removed the network-uri build flag.+  * Increased required version of several dependencies.+  * Added dependencies on deepseq, attoparsec and filepath-bytestring.++ -- Joey Hess <id@joeyh.name>  Thu, 02 Jan 2020 12:39:13 -0400+ git-repair (1.20170626) unstable; urgency=medium    * Merge from git-annex.
@@ -0,0 +1,695 @@+Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/+Source: native package++Files: *+Copyright: © 2013-2019 Joey Hess <joey@kitenet.net>+License: AGPL-3+++Files: Utility/*+Copyright: 2012-2019 Joey Hess <joey@kitenet.net>+License: BSD-2-clause++License: BSD-2-clause+ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:+ 1. Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+ 2. Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.+ .+ THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS ``AS IS'' AND+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ SUCH DAMAGE.++License: AGPL-3++                      GNU AFFERO GENERAL PUBLIC LICENSE+                         Version 3, 19 November 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 Affero General Public License is a free, copyleft license for+  software and other kinds of works, specifically designed to ensure+  cooperation with the community in the case of network server software.+ .+    The licenses for most software and other practical works are designed+  to take away your freedom to share and change the works.  By contrast,+  our General Public Licenses are 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.+ .+    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.+ .+    Developers that use our General Public Licenses protect your rights+  with two steps: (1) assert copyright on the software, and (2) offer+  you this License which gives you legal permission to copy, distribute+  and/or modify the software.+ .+    A secondary benefit of defending all users' freedom is that+  improvements made in alternate versions of the program, if they+  receive widespread use, become available for other developers to+  incorporate.  Many developers of free software are heartened and+  encouraged by the resulting cooperation.  However, in the case of+  software used on network servers, this result may fail to come about.+  The GNU General Public License permits making a modified version and+  letting the public access it on a server without ever releasing its+  source code to the public.+ .+    The GNU Affero General Public License is designed specifically to+  ensure that, in such cases, the modified source code becomes available+  to the community.  It requires the operator of a network server to+  provide the source code of the modified version running there to the+  users of that server.  Therefore, public use of a modified version, on+  a publicly accessible server, gives the public access to the source+  code of the modified version.+ .+    An older license, called the Affero General Public License and+  published by Affero, was designed to accomplish similar goals.  This is+  a different license, not a version of the Affero GPL, but Affero has+  released a new version of the Affero GPL which permits relicensing under+  this license.+ .+    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 Affero 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. Remote Network Interaction; Use with the GNU General Public License.+ .+    Notwithstanding any other provision of this License, if you modify the+  Program, your modified version must prominently offer all users+  interacting with it remotely through a computer network (if your version+  supports such interaction) an opportunity to receive the Corresponding+  Source of your version by providing access to the Corresponding Source+  from a network server at no charge, through some standard or customary+  means of facilitating copying of software.  This Corresponding Source+  shall include the Corresponding Source for any work covered by version 3+  of the GNU General Public License that is incorporated pursuant to the+  following paragraph.+ .+    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 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 work with which it is combined will remain governed by version+  3 of the GNU General Public License.+ .+    14. Revised Versions of this License.+ .+    The Free Software Foundation may publish revised and/or new versions of+  the GNU Affero 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 Affero 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 Affero 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 Affero 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 Affero 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 Affero General Public License for more details.+ .+      You should have received a copy of the GNU Affero 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 your software can interact with users remotely through a computer+  network, you should also make sure that it provides a way for users to+  get its source.  For example, if your program is a web application, its+  interface could display a "Source" link that leads users to an archive+  of the code.  There are many ways you could offer source, and different+  solutions will be better for different programs; see section 13 for the+  specific requirements.+ .+    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 AGPL, see+  <http://www.gnu.org/licenses/>.
Common.hs view
@@ -18,6 +18,7 @@ import System.Posix.IO as X hiding (createPipe) #endif import System.Exit as X+import System.PosixCompat.Files as X  import Utility.Misc as X import Utility.Exception as X@@ -28,8 +29,8 @@ import Utility.Monad as X import Utility.Data as X import Utility.Applicative as X-import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Split as X+import Utility.FileSystemEncoding as X  import Utility.PartialPrelude as X
− GPL 
@@ -1,674 +0,0 @@-                    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>.
Git.hs view
@@ -5,7 +5,7 @@  -  - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}@@ -51,35 +51,35 @@ repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url-repoDescribe Repo { location = Local { worktree = Just dir } } = dir-repoDescribe Repo { location = Local { gitdir = dir } } = dir-repoDescribe Repo { location = LocalUnknown dir } = dir+repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir+repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir+repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath 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 = Local { worktree = Just dir } } = dir-repoLocation Repo { location = Local { gitdir = dir } } = dir-repoLocation Repo { location = LocalUnknown dir } = dir+repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir+repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir+repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir repoLocation Repo { location = Unknown } = error "unknown repoLocation"  {- Path to a repository. For non-bare, this is the worktree, for bare,   - it's the gitdir, and for URL repositories, is the path on the remote  - host. -}-repoPath :: Repo -> FilePath-repoPath Repo { location = Url u } = unEscapeString $ uriPath u+repoPath :: Repo -> RawFilePath+repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" -repoWorkTree :: Repo -> Maybe FilePath+repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d repoWorkTree _ = Nothing  {- Path to a local repository's .git directory. -}-localGitDir :: Repo -> FilePath+localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d localGitDir _ = error "unknown localGitDir" @@ -132,16 +132,17 @@ attributes :: Repo -> FilePath attributes repo 	| repoIsLocalBare repo = attributesLocal repo-	| otherwise = repoPath repo </> ".gitattributes"+	| otherwise = fromRawFilePath (repoPath repo) </> ".gitattributes"  attributesLocal :: Repo -> FilePath-attributesLocal repo = localGitDir repo </> "info" </> "attributes"+attributesLocal repo = fromRawFilePath (localGitDir repo)+	</> "info" </> "attributes"  {- Path to a given hook script in a repository, only if the hook exists  - and is executable. -} hookPath :: String -> Repo -> IO (Maybe FilePath) hookPath script repo = do-	let hook = localGitDir repo </> "hooks" </> script+	let hook = fromRawFilePath (localGitDir repo) </> "hooks" </> script 	ifM (catchBoolIO $ isexecutable hook) 		( return $ Just hook , return Nothing )   where@@ -157,22 +158,22 @@   where 	torel p = do 		p' <- relPathCwdToFile p-		if null p'-			then return "."-			else return p'+		return $ if null p' then "." else p'  {- Adusts the path to a local Repo using the provided function. -} adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do-	d' <- f d-	w' <- maybe (pure Nothing) (Just <$$> f) w+	d' <- f' d+	w' <- maybe (pure Nothing) (Just <$$> f') w 	return $ r  		{ location = l  			{ gitdir = d' 			, worktree = w' 			} 		}+  where+	f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do-	d' <- f d+	d' <- toRawFilePath <$> f (fromRawFilePath d) 	return $ r { location = LocalUnknown d' } adjustPath _ r = pure r
Git/Branch.hs view
@@ -2,10 +2,11 @@  -  - Copyright 2011 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}  module Git.Branch where @@ -15,13 +16,14 @@ import Git.Command import qualified Git.Config import qualified Git.Ref-import qualified Git.BuildVersion +import qualified Data.ByteString as B+ {- The currently checked out branch.  -  - In a just initialized git repo before the first commit,  - symbolic-ref will show the master branch, even though that- - branch is not created yet. So, this also looks at show-ref HEAD+ - branch is not created yet. So, this also looks at show-ref  - to double-check.  -} current :: Repo -> IO (Maybe Branch)@@ -30,19 +32,19 @@ 	case v of 		Nothing -> return Nothing 		Just branch -> -			ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)+			ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r) 				( return Nothing 				, return v 				)  {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch)-currentUnsafe r = parse . firstLine+currentUnsafe r = parse . firstLine' 	<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r   where-	parse l-		| null l = Nothing-		| otherwise = Just $ Git.Ref l+	parse b+		| B.null b = Nothing+		| otherwise = Just $ Git.Ref $ decodeBS b  {- Checks if the second branch has any commits not present on the first  - branch. -}@@ -54,7 +56,8 @@   where  changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String-changed' origbranch newbranch extraps repo = pipeReadStrict ps repo+changed' origbranch newbranch extraps repo =+	decodeBS <$> pipeReadStrict ps repo   where 	ps = 		[ Param "log"@@ -73,7 +76,7 @@  -  - This requires there to be a path from the old to the new. -} fastForwardable :: Ref -> Ref -> Repo -> IO Bool-fastForwardable old new repo = not . null <$>+fastForwardable old new repo = not . B.null <$> 	pipeReadStrict 		[ Param "log" 		, Param $ fromRef old ++ ".." ++ fromRef new@@ -125,8 +128,7 @@ {- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps-	| commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =-		Param "--no-gpg-sign" : ps+	| commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps 	| otherwise = ps  {- Some versions of git commit-tree honor commit.gpgsign themselves,@@ -134,8 +136,8 @@ applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] applyCommitModeForCommitTree commitmode ps r 	| commitmode == ManualCommit =-		case (Git.Config.getMaybe "commit.gpgsign" r) of-			Just s | Git.Config.isTrue s == Just True ->+		case Git.Config.getMaybe "commit.gpgsign" r of+			Just s | Git.Config.isTrueFalse' s == Just True -> 				Param "-S":ps 			_ -> ps' 	| otherwise = ps'@@ -162,7 +164,7 @@ commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do 	tree <- getSha "write-tree" $-		pipeReadStrict [Param "write-tree"] repo+		decodeBS' <$> pipeReadStrict [Param "write-tree"] repo 	ifM (cancommit tree) 		( do 			sha <- commitTree commitmode message parentrefs tree repo
Git/BuildVersion.hs view
@@ -2,20 +2,20 @@  -  - Copyright 2011 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.BuildVersion where  import Git.Version-import qualified Build.SysConfig+import qualified BuildInfo  {- Using the version it was configured for avoids running git to check its  - version, at the cost that upgrading git won't be noticed.  - This is only acceptable because it's rare that git's version influences  - code's behavior. -} buildVersion :: GitVersion-buildVersion = normalize Build.SysConfig.gitversion+buildVersion = normalize BuildInfo.gitversion  older :: String -> Bool older n = buildVersion < normalize n
Git/CatFile.hs view
@@ -1,8 +1,8 @@ {- git cat-file interface  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.CatFile (@@ -28,20 +28,23 @@ import Data.Char import Numeric import System.Posix.Types+import Text.Read  import Common import Git import Git.Sha+import qualified Git.Ref import Git.Command import Git.Types import Git.FilePath+import Git.HashObject import qualified Utility.CoProcess as CoProcess-import Utility.FileSystemEncoding import Utility.Tuple  data CatFileHandle = CatFileHandle  	{ catFileProcess :: CoProcess.CoProcessHandle 	, checkFileProcess :: CoProcess.CoProcessHandle+	, gitRepo :: Repo 	}  catFileStart :: Repo -> IO CatFileHandle@@ -51,6 +54,7 @@ catFileStart' restartable repo = CatFileHandle 	<$> startp "--batch" 	<*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"+	<*> pure repo   where 	startp p = gitCoProcessStart restartable 		[ Param "cat-file"@@ -63,13 +67,13 @@ 	CoProcess.stop (checkFileProcess h)  {- Reads a file from a specified branch. -}-catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString+catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $-	fromRef branch ++ ":" ++ toInternalGitPath file+	fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file) -catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))+catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) catFileDetails h branch file = catObjectDetails h $ Ref $-	fromRef branch ++ ":" ++ toInternalGitPath file+	fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)  {- Uses a running git cat-file read the content of an object.  - Objects that do not exist will have "" returned. -}@@ -77,7 +81,7 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object  catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))-catObjectDetails h object = query (catFileProcess h) object $ \from -> do+catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do 	header <- hGetLine from 	case parseResp object header of 		Just (ParsedResp sha size objtype) -> do@@ -91,23 +95,53 @@ 		c <- hGetChar from 		when (c /= expected) $ 			error $ "missing " ++ (show expected) ++ " from git cat-file"+	+	-- Slow fallback path for filenames containing newlines.+	newlinefallback = queryObjectType object (gitRepo h) >>= \case+		Nothing -> return Nothing+		Just objtype -> queryContent object (gitRepo h) >>= \case+			Nothing -> return Nothing+			Just content -> do+				-- only the --batch interface allows getting+				-- the sha, so have to re-hash the object+				sha <- hashObject' objtype+					(flip L.hPut content)+					(gitRepo h)+				return (Just (content, sha, objtype))  {- Gets the size and type of an object, without reading its content. -}-catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType))-catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do+catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))+catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do 	resp <- hGetLine from 	case parseResp object resp of-		Just (ParsedResp _ size objtype) ->-			return $ Just (size, objtype)+		Just (ParsedResp sha size objtype) ->+			return $ Just (sha, size, objtype) 		Just DNE -> return Nothing 		Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)+  where+	-- Slow fallback path for filenames containing newlines.+	newlinefallback = do+		sha <- Git.Ref.sha object (gitRepo h)+		sz <- querySize object (gitRepo h)+		objtype <- queryObjectType object (gitRepo h)+		return $ (,,) <$> sha <*> sz <*> objtype -data ParsedResp = ParsedResp Sha Integer ObjectType | DNE+data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE -query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a-query hdl object receive = CoProcess.query hdl send receive+query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a+query hdl object newlinefallback receive+	-- git cat-file --batch uses a line based protocol, so when the+	-- filename itself contains a newline, have to fall back to another+	-- method of getting the information.+	| '\n' `elem` s = newlinefallback+	-- git strips carriage return from the end of a line, out of some+	-- misplaced desire to support windows, so also use the newline+	-- fallback for those.+	| "\r" `isSuffixOf` s = newlinefallback+	| otherwise = CoProcess.query hdl send receive   where-	send to = hPutStrLn to (fromRef object)+	send to = hPutStrLn to s+	s = fromRef object  parseResp :: Ref -> String -> Maybe ParsedResp parseResp object l @@ -116,13 +150,50 @@ 	| otherwise = case words l of 		[sha, objtype, size] 			| length sha == shaSize ->-				case (readObjectType objtype, reads size) of+				case (readObjectType (encodeBS objtype), reads size) of 					(Just t, [(bytes, "")]) ->  						Just $ ParsedResp (Ref sha) bytes t 					_ -> Nothing 			| otherwise -> Nothing 		_ -> Nothing +querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a)+querySingle o r repo reader = assertLocal repo $+	-- In non-batch mode, git cat-file warns on stderr when+	-- asked for an object that does not exist.+	-- Squelch that warning to behave the same as batch mode.+	withNullHandle $ \nullh -> do+		let p = gitCreateProcess +			[ Param "cat-file"+			, o+			, Param (fromRef r)+			] repo+		let p' = p+			{ std_err = UseHandle nullh+			, std_in = Inherit+			, std_out = CreatePipe+			}+		pid <- createProcess p'+		let h = stdoutHandle pid+		output <- reader h+		hClose h+		ifM (checkSuccessProcess (processHandle pid))+			( return (Just output)+			, return Nothing+			)++querySize :: Ref -> Repo -> IO (Maybe FileSize)+querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))+	<$> querySingle (Param "-s") r repo hGetContentsStrict++queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType)+queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n'))+	<$> querySingle (Param "-t") r repo hGetContentsStrict++queryContent :: Ref -> Repo -> IO (Maybe L.ByteString)+queryContent r repo = fmap (\b -> L.fromChunks [b])+	<$> querySingle (Param "-p") r repo S.hGetContents+ {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] catTree h treeref = go <$> catObjectDetails h treeref@@ -141,7 +212,7 @@ 	dropsha = L.drop 21  	parsemodefile b = -		let (modestr, file) = separate (== ' ') (decodeBS b)+		let (modestr, file) = separate (== ' ') (decodeBL b) 		in (file, readmode modestr) 	readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
Git/Command.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}@@ -14,6 +14,9 @@ import Git.Types import qualified Utility.CoProcess as CoProcess +import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as S+ {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] gitCommandLine params r@(Repo { location = l@(Local { } ) }) =@@ -21,10 +24,10 @@   where 	setdir 		| gitEnvOverridesGitDir r = []-		| otherwise = [Param $ "--git-dir=" ++ gitdir l]+		| otherwise = [Param $ "--git-dir=" ++ fromRawFilePath (gitdir l)] 	settree = case worktree l of 		Nothing -> []-		Just t -> [Param $ "--work-tree=" ++ t]+		Just t -> [Param $ "--work-tree=" ++ fromRawFilePath t] gitCommandLine _ repo = assertLocal repo $ error "internal"  {- Runs git in the specified repo. -}@@ -47,13 +50,13 @@ {- Runs a git command and returns its output, lazily.  -  - Also returns an action that should be used when the output is all- - read (or no more is needed), that will wait on the command, and+ - read, that will wait on the command, and  - return True if it succeeded. Failure to wait will result in zombies.  -}-pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)+pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do 	(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }-	c <- hGetContents h+	c <- L.hGetContents h 	return (c, checkSuccessProcess pid)   where 	p  = gitCreateProcess params repo@@ -62,10 +65,14 @@  -  - Nonzero exit status is ignored.  -}-pipeReadStrict :: [CommandParam] -> Repo -> IO String-pipeReadStrict params repo = assertLocal repo $+pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString+pipeReadStrict = pipeReadStrict' S.hGetContents++{- The reader action must be strict. -}+pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a+pipeReadStrict' reader params repo = assertLocal repo $ 	withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do-		output <- hGetContentsStrict h+		output <- reader h 		hClose h 		return output   where@@ -83,27 +90,35 @@  {- Runs a git command, feeding it input on a handle with an action. -} pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()-pipeWrite params repo = withHandle StdinHandle createProcessSuccess $-	gitCreateProcess params repo+pipeWrite params repo = assertLocal repo $ +	withHandle StdinHandle createProcessSuccess $+		gitCreateProcess params repo  {- Reads null terminated output of a git command (as enabled by the -z   - parameter), and splits it. -}-pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool)+pipeNullSplit :: [CommandParam] -> Repo -> IO ([L.ByteString], IO Bool) pipeNullSplit params repo = do 	(s, cleanup) <- pipeReadLazy params repo-	return (filter (not . null) $ splitc sep s, cleanup)-  where-	sep = '\0'+	return (filter (not . L.null) $ L.split 0 s, cleanup) -pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]+{- Reads lazily, but copies each part to a strict ByteString for+ - convenience.+ -}+pipeNullSplit' :: [CommandParam] -> Repo -> IO ([S.ByteString], IO Bool)+pipeNullSplit' params repo = do+	(s, cleanup) <- pipeNullSplit params repo+	return (map L.toStrict s, cleanup)++pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [S.ByteString] pipeNullSplitStrict params repo = do 	s <- pipeReadStrict params repo-	return $ filter (not . null) $ splitc sep s-  where-	sep = '\0'+	return $ filter (not . S.null) $ S.split 0 s -pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]+pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo++pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString]+pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo  {- Doesn't run the cleanup action. A zombie results. -} leaveZombie :: (a, IO Bool) -> a
Git/Config.hs view
@@ -1,32 +1,37 @@ {- git repository configuration handling  -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.Config where  import qualified Data.Map as M+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import Data.Char+import qualified System.FilePath.ByteString as P  import Common import Git import Git.Types-import qualified Git.Construct import qualified Git.Command+import qualified Git.Construct import Utility.UserInfo -{- 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, or a fallback value if not set. -}+get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue+get key fallback repo = M.findWithDefault fallback key (config repo) -{- Returns a list with each line of a multiline config setting. -}-getList :: String -> Repo -> [String]+{- Returns a list of values. -}+getList :: ConfigKey -> Repo -> [ConfigValue] getList key repo = M.findWithDefault [] key (fullconfig repo)  {- Returns a single git config setting, if set. -}-getMaybe :: String -> Repo -> Maybe String+getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue getMaybe key repo = M.lookup key (config repo)  {- Runs git config and populates a repo with its config.@@ -57,7 +62,7 @@ 	  where 		params = ["config", "--null", "--list"] 		p = (proc "git" params)-			{ cwd = Just d+			{ cwd = Just (fromRawFilePath d) 			, env = gitEnv repo 			} @@ -79,23 +84,29 @@ {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo hRead repo h = do-	val <- hGetContentsStrict h+	val <- S.hGetContents 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 incrementally.  -}-store :: String -> Repo -> IO Repo+store :: S.ByteString -> Repo -> IO Repo store s repo = do 	let c = parse s-	repo' <- updateLocation $ repo+	updateLocation $ 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 } +{- Stores a single config setting in a Repo, returning the new version of+ - the Repo. Config settings can be updated incrementally. -}+store' :: ConfigKey -> ConfigValue -> Repo -> Repo+store' k v repo = repo+	{ config = M.singleton k v `M.union` config repo+	, fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)+	}+ {- Updates the location of a repo, based on its configuration.  -  - Git.Construct makes LocalUknown repos, of which only a directory is@@ -104,13 +115,13 @@  -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d })-	| isBare r = ifM (doesDirectoryExist dotgit)+	| isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit)) 			( updateLocation' r $ Local dotgit Nothing 			, updateLocation' r $ Local d Nothing 			) 	| otherwise = updateLocation' r $ Local dotgit (Just d)   where-	dotgit = (d </> ".git")+	dotgit = d P.</> ".git" updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r @@ -118,52 +129,66 @@ updateLocation' r l = do 	l' <- case getMaybe "core.worktree" r of 		Nothing -> return l-		Just d -> do+		Just (ConfigValue d) -> do 			{- core.worktree is relative to the gitdir -}-			top <- absPath $ gitdir l-			return $ l { worktree = Just $ absPathFrom top d }+			top <- absPath $ fromRawFilePath (gitdir l)+			let p = absPathFrom top (fromRawFilePath d)+			return $ l { worktree = Just (toRawFilePath p) } 	return $ r { location = l' }  {- 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.ByteString -> M.Map ConfigKey [ConfigValue] parse s-	-- --list output will have an = in the first line-	| all ('=' `elem`) (take 1 ls) = sep '=' ls+	| S.null s = M.empty+	-- --list output will have a '=' in the first line+	-- (The first line of --null --list output is the name of a key,+	-- which is assumed to never contain '='.)+	| S.elem eq firstline = sep eq $ S.split nl s 	-- --null --list output separates keys from values with newlines-	| otherwise = sep '\n' $ splitc '\0' s+	| otherwise = sep nl $ S.split 0 s   where-	ls = lines s-	sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .-		map (separate (== c))+	nl = fromIntegral (ord '\n')+	eq = fromIntegral (ord '=')+	firstline = S.takeWhile (/= nl) s -{- Checks if a string from git config is a true value. -}-isTrue :: String -> Maybe Bool-isTrue s+	sep c = M.fromListWith (++)+		. map (\(k,v) -> (ConfigKey k, [ConfigValue (S.drop 1 v)])) +		. map (S.break (== c))++{- Checks if a string from git config is a true/false value. -}+isTrueFalse :: String -> Maybe Bool+isTrueFalse = isTrueFalse' . ConfigValue . encodeBS'++isTrueFalse' :: ConfigValue -> Maybe Bool+isTrueFalse' (ConfigValue s) 	| s' == "true" = Just True 	| s' == "false" = Just False 	| otherwise = Nothing   where-	s' = map toLower s+	s' = S8.map toLower s  boolConfig :: Bool -> String boolConfig True = "true" boolConfig False = "false" +boolConfig' :: Bool -> S.ByteString+boolConfig' True = "true"+boolConfig' False = "false"+ isBare :: Repo -> Bool-isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r+isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r -coreBare :: String+coreBare :: ConfigKey coreBare = "core.bare"  {- Runs a command to get the configuration of a repo,  - and returns a repo populated with the configuration, as well as the raw  - output of the command. -}-fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String))+fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, S.ByteString)) fromPipe r cmd params = try $ 	withHandle StdoutHandle createProcessSuccess p $ \h -> do-		val <- hGetContentsStrict h+		val <- S.hGetContents h 		r' <- store val r 		return (r', val)   where@@ -171,7 +196,7 @@  {- Reads git config from a specified file and returns the repo populated  - with the configuration. -}-fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))+fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString)) fromFile r f = fromPipe r "git" 	[ Param "config" 	, Param "--file"@@ -181,13 +206,13 @@  {- Changes a git config setting in the specified config file.  - (Creates the file if it does not already exist.) -}-changeFile :: FilePath -> String -> String -> IO Bool-changeFile f k v = boolSystem "git"+changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool+changeFile f (ConfigKey k) v = boolSystem "git" 	[ Param "config" 	, Param "--file" 	, File f-	, Param k-	, Param v+	, Param (decodeBS' k)+	, Param (decodeBS' v) 	]  {- Unsets a git config setting, in both the git repo,@@ -196,10 +221,10 @@  - If unsetting the config fails, including in a read-only repo, or  - when the config is not set, returns Nothing.  -}-unset :: String -> Repo -> IO (Maybe Repo)-unset k r = ifM (Git.Command.runBool ps r)-	( return $ Just $ r { config = M.delete k (config r) }+unset :: ConfigKey -> Repo -> IO (Maybe Repo)+unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)+	( return $ Just $ r { config = M.delete ck (config r) } 	, return Nothing 	)   where-	ps = [Param "config", Param "--unset-all", Param k]+	ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]
Git/Construct.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2010-2012 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}@@ -58,11 +58,11 @@  - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir-	| absoluteGitPath dir = hunt+	| absoluteGitPath (encodeBS dir) = hunt 	| otherwise = 		error $ "internal error, " ++ dir ++ " is not absolute"   where-	ret = pure . newFrom . LocalUnknown+	ret = pure . newFrom . LocalUnknown . toRawFilePath 	canondir = dropTrailingPathSeparator dir 	{- When dir == "foo/.git", git looks for "foo/.git/.git", 	 - and failing that, uses "foo" as the repository. -}@@ -117,7 +117,7 @@ 				[ Url.scheme reference 				, "//" 				, auth-				, repoPath r+				, fromRawFilePath (repoPath r) 				] 			in r { location = Url $ fromJust $ parseURI absurl } @@ -127,9 +127,8 @@   where 	filterconfig f = filter f $ M.toList $ config repo 	filterkeys f = filterconfig (\(k,_) -> f k)-	remotepairs = filterkeys isremote-	isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k-	construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo+	remotepairs = filterkeys isRemoteKey+	construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)  {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo@@ -139,11 +138,8 @@  {- 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 = intercalate "." $ -		reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k+remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo+remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName  {- Constructs a new Repo for one of a Repo's remotes using a given  - location (ie, an url). -}@@ -158,7 +154,7 @@ fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do 	dir' <- expandTilde dir-	fromPath $ repoPath repo </> dir'+	fromPath $ fromRawFilePath (repoPath repo) </> dir'  {- Git remotes can have a directory that is specified relative  - to the user's home directory, or that contains tilde expansions.@@ -208,20 +204,29 @@   where 	check test cont = maybe cont (return . Just) =<< test 	checkdir c = ifM c-		( return $ Just $ LocalUnknown dir+		( return $ Just $ LocalUnknown $ toRawFilePath dir 		, return Nothing 		)-	isRepo = checkdir $ gitSignature $ ".git" </> "config"+	isRepo = checkdir $ +		gitSignature (".git" </> "config")+			<||>+		-- A git-worktree lacks .git/config, but has .git/commondir.+		-- (Normally the .git is a file, not a symlink, but it can+		-- be converted to a symlink and git will still work;+		-- this handles that case.)+		gitSignature (".git" </> "gitdir") 	isBareRepo = checkdir $ gitSignature "config" 		<&&> doesDirectoryExist (dir </> "objects") 	gitDirFile = do+		-- git-submodule, git-worktree, and --separate-git-dir+		-- make .git be a file pointing to the real git directory. 		c <- firstLine <$> 			catchDefaultIO "" (readFile $ dir </> ".git") 		return $ if gitdirprefix `isPrefixOf` c 			then Just $ Local -				{ gitdir = absPathFrom dir $+				{ gitdir = toRawFilePath $ absPathFrom dir $ 					drop (length gitdirprefix) c-				, worktree = Just dir+				, worktree = Just (toRawFilePath dir) 				} 			else Nothing 	  where@@ -233,7 +238,6 @@ 	{ location = l 	, config = M.empty 	, fullconfig = M.empty-	, remotes = [] 	, remoteName = Nothing 	, gitEnv = Nothing 	, gitEnvOverridesGitDir = False
Git/CurrentRepo.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2012 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.CurrentRepo where@@ -12,6 +12,7 @@ import Git.Construct import qualified Git.Config import Utility.Env+import Utility.Env.Set  {- Gets the current git repository.  -@@ -24,12 +25,20 @@  - directory if necessary to ensure it is within the repository's work  - tree. While not needed for git commands, this is useful for anything  - else that looks for files in the worktree.+ -+ - Also works around a git bug when running some hooks. It+ - runs the hooks in the top of the repository, but if GIT_WORK_TREE+ - was relative (but not "."), it then points to the wrong directory.+ - In this situation GIT_PREFIX contains the directory that + - GIT_WORK_TREE is relative to.  -} get :: IO Repo get = do-	gd <- pathenv "GIT_DIR"+	gd <- getpathenv "GIT_DIR" 	r <- configure gd =<< fromCwd-	wt <- maybe (worktree $ location r) Just <$> pathenv "GIT_WORK_TREE"+	prefix <- getpathenv "GIT_PREFIX"+	wt <- maybe (fromRawFilePath <$> worktree (location r)) Just+		<$> getpathenvprefix "GIT_WORK_TREE" prefix 	case wt of 		Nothing -> return r 		Just d -> do@@ -38,22 +47,39 @@ 				setCurrentDirectory d 			return $ addworktree wt r   where-	pathenv s = do+	getpathenv s = do 		v <- getEnv s 		case v of 			Just d -> do 				unsetEnv s-				Just <$> absPath d+				return (Just d) 			Nothing -> return Nothing+	+	getpathenvprefix s (Just prefix) | not (null prefix) =+		getpathenv s >>= \case+			Nothing -> return Nothing+			Just d+				| d == "." -> return (Just d)+				| otherwise -> Just <$> absPath (prefix </> d)+	getpathenvprefix s _ = getpathenv s  	configure Nothing (Just r) = Git.Config.read r 	configure (Just d) _ = do 		absd <- absPath d 		curr <- getCurrentDirectory-		Git.Config.read $ newFrom $-			Local { gitdir = absd, worktree = Just curr }+		r <- Git.Config.read $ newFrom $+			Local+				{ gitdir = toRawFilePath absd+				, worktree = Just (toRawFilePath curr)+				}+		return $ if Git.Config.isBare r+			then r { location = (location r) { worktree = Nothing } }+			else r+ 	configure Nothing Nothing = giveup "Not in a git repository." -	addworktree w r = changelocation r $-		Local { gitdir = gitdir (location r), worktree = w }+	addworktree w r = changelocation r $ Local+		{ gitdir = gitdir (location r)+		, worktree = fmap toRawFilePath w+		} 	changelocation r l = r { location = l }
Git/Destroyer.hs view
@@ -4,7 +4,7 @@  -  - Copyright 2013, 2014 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.Destroyer (@@ -83,7 +83,7 @@ applyDamage :: [Damage] -> Repo -> IO () applyDamage ds r = do 	contents <- sort . filter (not . skipped)-		<$> dirContentsRecursive (localGitDir r)+		<$> dirContentsRecursive (fromRawFilePath (localGitDir r)) 	forM_ ds $ \d -> do 		let withfile s a = do 			let f = selectFile contents s
Git/DiffTreeItem.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2012 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.DiffTreeItem (
Git/FilePath.hs view
@@ -5,12 +5,14 @@  - top of the repository even when run in a subdirectory. Adding some  - types helps keep that straight.  -- - Copyright 2012-2013 Joey Hess <id@joeyh.name>+ - Copyright 2012-2019 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}  module Git.FilePath ( 	TopFilePath,@@ -29,30 +31,39 @@ import Common import Git -import qualified System.FilePath.Posix+import qualified System.FilePath.ByteString as P+import qualified System.FilePath.Posix.ByteString+import GHC.Generics+import Control.DeepSeq+import qualified Data.ByteString as S -{- A FilePath, relative to the top of the git repository. -}-newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }-	deriving (Show, Eq, Ord)+{- A RawFilePath, relative to the top of the git repository. -}+newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }+	deriving (Show, Eq, Ord, Generic) +instance NFData TopFilePath+ {- A file in a branch or other treeish. -} data BranchFilePath = BranchFilePath Ref TopFilePath+	deriving (Show, Eq, Ord)  {- Git uses the branch:file form to refer to a BranchFilePath -}-descBranchFilePath :: BranchFilePath -> String-descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f+descBranchFilePath :: BranchFilePath -> S.ByteString+descBranchFilePath (BranchFilePath b f) =+	encodeBS' (fromRef b) <> ":" <> getTopFilePath f  {- Path to a TopFilePath, within the provided git repo. -}-fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath-fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p)+fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath+fromTopFilePath p repo = P.combine (repoPath repo) (getTopFilePath p)  {- The input FilePath can be absolute, or relative to the CWD. -}-toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath-toTopFilePath file repo = TopFilePath <$> relPathDirToFile (repoPath repo) file+toTopFilePath :: RawFilePath -> Git.Repo -> IO TopFilePath+toTopFilePath file repo = TopFilePath . toRawFilePath+	<$> relPathDirToFile (fromRawFilePath (repoPath repo)) (fromRawFilePath file) -{- The input FilePath must already be relative to the top of the git+{- The input RawFilePath must already be relative to the top of the git  - repository -}-asTopFilePath :: FilePath -> TopFilePath+asTopFilePath :: RawFilePath -> TopFilePath asTopFilePath file = TopFilePath file  {- Git may use a different representation of a path when storing@@ -62,25 +73,25 @@  - despite Windows using '\'.  -  -}-type InternalGitPath = String+type InternalGitPath = RawFilePath -toInternalGitPath :: FilePath -> InternalGitPath+toInternalGitPath :: RawFilePath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else-toInternalGitPath = replace "\\" "/"+toInternalGitPath = encodeBS . replace "\\" "/" . decodeBS #endif -fromInternalGitPath :: InternalGitPath -> FilePath+fromInternalGitPath :: InternalGitPath -> RawFilePath #ifndef mingw32_HOST_OS fromInternalGitPath = id #else-fromInternalGitPath = replace "/" "\\"+fromInternalGitPath = encodeBS . replace "/" "\\" . decodeBS #endif  {- isAbsolute on Windows does not think "/foo" or "\foo" is absolute,  - so try posix paths.  -}-absoluteGitPath :: FilePath -> Bool-absoluteGitPath p = isAbsolute p ||-	System.FilePath.Posix.isAbsolute (toInternalGitPath p)+absoluteGitPath :: RawFilePath -> Bool+absoluteGitPath p = P.isAbsolute p ||+	System.FilePath.Posix.ByteString.isAbsolute (toInternalGitPath p)
Git/Filename.hs view
@@ -3,7 +3,7 @@  -  - Copyright 2010, 2011 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.Filename where@@ -12,23 +12,44 @@ import Utility.Format (decode_c, encode_c)  import Data.Char+import Data.Word+import qualified Data.ByteString as S -decode :: String -> FilePath-decode [] = []-decode f@(c:s)-	-- encoded strings will be inside double quotes-	| c == '"' && end s == ['"'] = decode_c $ beginning s-	| otherwise = f+-- encoded filenames will be inside double quotes+decode :: S.ByteString -> RawFilePath+decode b = case S.uncons b of+	Nothing -> b+	Just (h, t)+		| h /= q -> b+		| otherwise -> case S.unsnoc t of+			Nothing -> b+			Just (i, l)+				| l /= q -> b+				| otherwise ->+					encodeBS $ decode_c $ decodeBS i+  where+  	q :: Word8+	q = fromIntegral (ord '"')  {- Should not need to use this, except for testing decode. -}-encode :: FilePath -> String-encode s = "\"" ++ encode_c s ++ "\""+encode :: RawFilePath -> S.ByteString+encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\"" -{- For quickcheck. - -- - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for- - why this only tests chars < 256 -}-prop_encode_decode_roundtrip :: String -> Bool-prop_encode_decode_roundtrip s = s' == decode (encode s')+prop_encode_decode_roundtrip :: FilePath -> Bool+prop_encode_decode_roundtrip s = s' ==+	fromRawFilePath (decode (encode (toRawFilePath s')))   where-	s' = filter (\c -> ord c < 256) s+	s' = nonul (nohigh s)+	-- Encoding and then decoding roundtrips only when+	-- the string does not contain high unicode, because eg, +	-- both "\12345" and "\227\128\185" are encoded to+	-- "\343\200\271".+	--+	-- This property papers over the problem, by only+	-- testing ascii+	nohigh = filter isAscii+	-- A String can contain a NUL, but toRawFilePath+	-- truncates on the NUL, which is generally fine+	-- because unix filenames cannot contain NUL.+	-- So the encoding only roundtrips when there is no nul.+	nonul = filter (/= '\NUL')
Git/Fsck.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE BangPatterns #-}@@ -22,10 +22,11 @@ import Git.Command import Git.Sha import Utility.Batch-import qualified Git.Version  import qualified Data.Set as S import Control.Concurrent.Async+import qualified Data.Semigroup as Sem+import Prelude  data FsckResults  	= FsckFoundMissing@@ -44,15 +45,21 @@  type Truncated = Bool +appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput+appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) =+	FsckOutput (S.union s1 s2) (t1 || t2)+appendFsckOutput (FsckOutput s t) _ = FsckOutput s t+appendFsckOutput _ (FsckOutput s t) = FsckOutput s t+appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput+appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning+appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning+appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning++instance Sem.Semigroup FsckOutput where+	(<>) = appendFsckOutput+ instance Monoid FsckOutput where 	mempty = NoFsckOutput-	mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2)-	mappend (FsckOutput s t) _ = FsckOutput s t-	mappend _ (FsckOutput s t) = FsckOutput s t-	mappend NoFsckOutput NoFsckOutput = NoFsckOutput-	mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning-	mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning-	mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning  {- Runs fsck to find some of the broken objects in the repository.  - May not find all broken objects, if fsck fails on bad data in some of@@ -65,9 +72,7 @@  -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do-	supportsNoDangling <- (>= Git.Version.normalize "1.7.10")-		<$> Git.Version.installed-	let (command, params) = ("git", fsckParams supportsNoDangling r)+	let (command, params) = ("git", fsckParams r) 	(command', params') <- if batchmode 		then toBatchCommand (command, params) 		else return (command, params)@@ -78,8 +83,8 @@ 			, std_err = CreatePipe 			} 	(o1, o2) <- concurrently-		(parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))-		(parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p))+		(parseFsckOutput maxobjs r (stdoutHandle p))+		(parseFsckOutput maxobjs r (stderrHandle p)) 	fsckok <- checkSuccessProcess pid 	case mappend o1 o2 of 		FsckOutput badobjs truncated@@ -112,15 +117,15 @@ findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput-parseFsckOutput maxobjs r supportsNoDangling h = do+parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput+parseFsckOutput maxobjs r h = do 	ls <- lines <$> hGetContents h 	if null ls 		then return NoFsckOutput 		else if all ("duplicateEntries" `isInfixOf`) ls 			then return AllDuplicateEntriesWarning 			else do-				let shas = findShas supportsNoDangling ls+				let shas = findShas ls 				let !truncated = length shas > maxobjs 				missingobjs <- findMissing (take maxobjs shas) r 				return $ FsckOutput missingobjs truncated@@ -133,18 +138,14 @@ 		, Param (fromRef s) 		] r -findShas :: Bool -> [String] -> [Sha]-findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted+findShas :: [String] -> [Sha]+findShas = catMaybes . map extractSha . concat . map words . filter wanted   where-	wanted l-		| supportsNoDangling = True-		| otherwise = not ("dangling " `isPrefixOf` l)+	wanted l = not ("dangling " `isPrefixOf` l) -fsckParams :: Bool -> Repo -> [CommandParam]-fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes-	[ Just "fsck"-	, if supportsNoDangling-		then Just "--no-dangling"-		else Nothing-	, Just "--no-reflogs"+fsckParams :: Repo -> [CommandParam]+fsckParams = gitCommandLine $ map Param+	[ "fsck"+	, "--no-dangling"+	, "--no-reflogs" 	]
+ Git/HashObject.hs view
@@ -0,0 +1,76 @@+{- git hash-object interface+ -+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Git.HashObject where++import Common+import Git+import Git.Sha+import Git.Command+import Git.Types+import qualified Utility.CoProcess as CoProcess+import Utility.Tmp++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder++type HashObjectHandle = CoProcess.CoProcessHandle++hashObjectStart :: Bool -> Repo -> IO HashObjectHandle+hashObjectStart writeobject = gitCoProcessStart True $ catMaybes+	[ Just (Param "hash-object")+	, if writeobject then Just (Param "-w") else Nothing+	, Just (Param "--stdin-paths")+	, Just (Param "--no-filters")+	]++hashObjectStop :: HashObjectHandle -> IO ()+hashObjectStop = CoProcess.stop++{- Injects a file into git, returning the Sha of the object. -}+hashFile :: HashObjectHandle -> FilePath -> IO Sha+hashFile h file = CoProcess.query h send receive+  where+	send to = hPutStrLn to =<< absPath file+	receive from = getSha "hash-object" $ hGetLine from++class HashableBlob t where+	hashableBlobToHandle :: Handle -> t -> IO ()++instance HashableBlob L.ByteString where+	hashableBlobToHandle = L.hPut++instance HashableBlob S.ByteString where+	hashableBlobToHandle = S.hPut++instance HashableBlob Builder where+	hashableBlobToHandle = hPutBuilder++{- Injects a blob into git. Unfortunately, the current git-hash-object+ - interface does not allow batch hashing without using temp files. -}+hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha+hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do+	hashableBlobToHandle tmph b+	hClose tmph+	hashFile h tmp++{- Injects some content into git, returning its Sha.+ - + - Avoids using a tmp file, but runs a new hash-object command each+ - time called. -}+hashObject :: ObjectType -> String -> Repo -> IO Sha+hashObject objtype content = hashObject' objtype (flip hPutStr content)++hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha+hashObject' objtype writer repo = getSha subcmd $+	pipeWriteRead (map Param params) (Just writer) repo+  where+	subcmd = "hash-object"+	params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"]
Git/Index.hs view
@@ -1,8 +1,8 @@ {- git index file stuff  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.Index where@@ -10,6 +10,7 @@ import Common import Git import Utility.Env+import Utility.Env.Set  indexEnv :: String indexEnv = "GIT_INDEX_FILE"@@ -46,25 +47,14 @@ 	reset (Just v) = setEnv indexEnv v True 	reset _ = unsetEnv var +{- The normal index file. Does not check GIT_INDEX_FILE. -} indexFile :: Repo -> FilePath-indexFile r = localGitDir r </> "index"+indexFile r = fromRawFilePath (localGitDir r) </> "index" -{- Git locks the index by creating this file. -}-indexFileLock :: Repo -> FilePath-indexFileLock r = indexFile r ++ ".lock"+{- The index file git will currently use, checking GIT_INDEX_FILE. -}+currentIndexFile :: Repo -> IO FilePath+currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv	 -{- When the pre-commit hook is run, and git commit has been run with- - a file or files specified to commit, rather than committing the staged- - index, git provides the pre-commit hook with a "false index file".- -- - Changes made to this index will influence the commit, but won't- - affect the real index file.- -- - This detects when we're in this situation, using a heuristic, which- - might be broken by changes to git. Any use of this should have a test- - case to make sure it works.- -}-haveFalseIndex :: IO Bool-haveFalseIndex = maybe (False) check <$> getEnv indexEnv-  where-	check f = "next-index" `isPrefixOf` takeFileName f+{- Git locks the index by creating this file. -}+indexFileLock :: FilePath -> FilePath+indexFileLock f = f ++ ".lock"
Git/LsFiles.hs view
@@ -1,13 +1,15 @@ {- git ls-files interface  -- - Copyright 2010,2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.LsFiles ( 	inRepo,+	inRepoOrBranch, 	notInRepo,+	notInRepoIncludingEmptyDirectories, 	allFiles, 	deleted, 	modified,@@ -32,69 +34,89 @@  import Numeric import System.Posix.Types+import qualified Data.ByteString.Lazy as L -{- Scans for files that are checked into git at the specified locations. -}-inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-inRepo l = pipeNullSplit $ -	Param "ls-files" :-	Param "--cached" :-	Param "-z" :-	Param "--" :-	map File l+{- Scans for files that are checked into git's index at the specified locations. -}+inRepo :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+inRepo = inRepo' []  +inRepo' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+inRepo' ps l repo = pipeNullSplit' params repo+  where+	params = +		Param "ls-files" :+		Param "--cached" :+		Param "-z" :+		ps +++		(Param "--" : map (File . fromRawFilePath) l)++{- Files that are checked into the index or have been committed to a+ - branch. -}+inRepoOrBranch :: Branch -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b]+ {- Scans for files at the specified locations that are not checked into git. -}-notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)-notInRepo include_ignored l repo = pipeNullSplit params repo+notInRepo :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+notInRepo = notInRepo' []++notInRepo' :: [CommandParam] -> Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+notInRepo' ps include_ignored l repo = pipeNullSplit' params repo   where 	params = concat 		[ [ Param "ls-files", Param "--others"]+		, ps 		, exclude 		, [ Param "-z", Param "--" ]-		, map File l+		, map (File . fromRawFilePath) l 		] 	exclude 		| include_ignored = [] 		| otherwise = [Param "--exclude-standard"] +{- Scans for files at the specified locations that are not checked into+ - git. Empty directories are included in the result. -}+notInRepoIncludingEmptyDirectories :: Bool -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+notInRepoIncludingEmptyDirectories = notInRepo' [Param "--directory"]+ {- Finds all files in the specified locations, whether checked into git or  - not. -}-allFiles :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-allFiles l = pipeNullSplit $+allFiles :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+allFiles l = pipeNullSplit' $ 	Param "ls-files" : 	Param "--cached" : 	Param "--others" : 	Param "-z" : 	Param "--" :-	map File l+	map (File . fromRawFilePath) l  {- Returns a list of files in the specified locations that have been  - deleted. -}-deleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-deleted l repo = pipeNullSplit params repo+deleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+deleted l repo = pipeNullSplit' params repo   where 	params = 		Param "ls-files" : 		Param "--deleted" : 		Param "-z" : 		Param "--" :-		map File l+		map (File . fromRawFilePath) l  {- Returns a list of files in the specified locations that have been  - modified. -}-modified :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-modified l repo = pipeNullSplit params repo+modified :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+modified l repo = pipeNullSplit' params repo   where 	params =  		Param "ls-files" : 		Param "--modified" : 		Param "-z" : 		Param "--" :-		map File l+		map (File . fromRawFilePath) l  {- Files that have been modified or are not checked into git (and are not  - ignored). -}-modifiedOthers :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-modifiedOthers l repo = pipeNullSplit params repo+modifiedOthers :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+modifiedOthers l repo = pipeNullSplit' params repo   where 	params =  		Param "ls-files" :@@ -103,69 +125,69 @@ 		Param "--exclude-standard" : 		Param "-z" : 		Param "--" :-		map File l+		map (File . fromRawFilePath) l  {- Returns a list of all files that are staged for commit. -}-staged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+staged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) staged = staged' []  {- Returns a list of the files, staged for commit, that are being added,  - moved, or changed (but not deleted), from the specified locations. -}-stagedNotDeleted :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+stagedNotDeleted :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) stagedNotDeleted = staged' [Param "--diff-filter=ACMRT"] -staged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)-staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix+staged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool)+staged' ps l repo = pipeNullSplit' (prefix ++ ps ++ suffix) repo   where 	prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"]-	suffix = Param "--" : map File l+	suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)+type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode)  {- Returns details about files that are staged in the index,  - as well as files not yet in git. Skips ignored files. -}-stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)+stagedOthersDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedOthersDetails = stagedDetails' [Param "--others", Param "--exclude-standard"]  {- Returns details about all files that are staged in the index. -}-stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)+stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails = stagedDetails' []  {- Gets details about staged files, including the Sha of their staged  - contents. -}-stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)+stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) stagedDetails' ps l repo = do 	(ls, cleanup) <- pipeNullSplit params repo 	return (map parse ls, cleanup)   where 	params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ -		Param "--" : map File l+		Param "--" : map (File . fromRawFilePath) l 	parse s-		| null file = (s, Nothing, Nothing)-		| otherwise = (file, extractSha $ take shaSize rest, readmode mode)+		| null file = (L.toStrict s, Nothing, Nothing)+		| otherwise = (toRawFilePath file, extractSha $ take shaSize rest, readmode mode) 	  where-		(metadata, file) = separate (== '\t') s+		(metadata, file) = separate (== '\t') (decodeBL' s) 		(mode, rest) = separate (== ' ') metadata 		readmode = fst <$$> headMaybe . readOct  {- Returns a list of the files in the specified locations that are staged  - for commit, and whose type has changed. -}-typeChangedStaged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+typeChangedStaged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChangedStaged = typeChanged' [Param "--cached"]  {- Returns a list of the files in the specified locations whose type has  - changed.  Files only staged for commit will not be included. -}-typeChanged :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)+typeChanged :: [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged = typeChanged' [] -typeChanged' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)+typeChanged' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) typeChanged' ps l repo = do 	(fs, cleanup) <- pipeNullSplit (prefix ++ ps ++ suffix) repo 	-- git diff returns filenames relative to the top of the git repo; 	-- convert to filenames relative to the cwd, like git ls-files.-	top <- absPath (repoPath repo)+	top <- absPath (fromRawFilePath (repoPath repo)) 	currdir <- getCurrentDirectory-	return (map (\f -> relPathDirToFileAbs currdir $ top </> f) fs, cleanup)+	return (map (\f -> toRawFilePath (relPathDirToFileAbs currdir $ top </> decodeBL' f)) fs, cleanup)   where 	prefix =  		[ Param "diff"@@ -173,7 +195,7 @@ 		, Param "--diff-filter=T" 		, Param "-z" 		]-	suffix = Param "--" : (if null l then [File "."] else map File l)+	suffix = Param "--" : (if null l then [File "."] else map (File . fromRawFilePath) l)  {- A item in conflict has two possible values.  - Either can be Nothing, when that side deleted the file. -}@@ -183,10 +205,10 @@ 	} deriving (Show)  data Unmerged = Unmerged-	{ unmergedFile :: FilePath-	, unmergedBlobType :: Conflicting BlobType+	{ unmergedFile :: RawFilePath+	, unmergedTreeItemType :: Conflicting TreeItemType 	, unmergedSha :: Conflicting Sha-	} deriving (Show)+	}  {- Returns a list of the files in the specified locations that have  - unresolved merge conflicts.@@ -198,38 +220,38 @@  -   3 = them  - If a line is omitted, that side removed the file.  -}-unmerged :: [FilePath] -> Repo -> IO ([Unmerged], IO Bool)+unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool) unmerged l repo = do 	(fs, cleanup) <- pipeNullSplit params repo-	return (reduceUnmerged [] $ catMaybes $ map parseUnmerged fs, cleanup)+	return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)   where 	params =  		Param "ls-files" : 		Param "--unmerged" : 		Param "-z" : 		Param "--" :-		map File l+		map (File . fromRawFilePath) l  data InternalUnmerged = InternalUnmerged 	{ isus :: Bool-	, ifile :: FilePath-	, iblobtype :: Maybe BlobType+	, ifile :: RawFilePath+	, itreeitemtype :: Maybe TreeItemType 	, isha :: Maybe Sha-	} deriving (Show)+	}  parseUnmerged :: String -> Maybe InternalUnmerged parseUnmerged s 	| null file = Nothing 	| otherwise = case words metadata of-		(rawblobtype:rawsha:rawstage:_) -> do+		(rawtreeitemtype:rawsha:rawstage:_) -> do 			stage <- readish rawstage :: Maybe Int 			if stage /= 2 && stage /= 3 				then Nothing 				else do-					blobtype <- readBlobType rawblobtype+					treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype) 					sha <- extractSha rawsha-					return $ InternalUnmerged (stage == 2) file-						(Just blobtype) (Just sha)+					return $ InternalUnmerged (stage == 2) (toRawFilePath file)+						(Just treeitemtype) (Just sha) 		_ -> Nothing   where 	(metadata, file) = separate (== '\t') s@@ -239,12 +261,12 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest   where 	(rest, sibi) = findsib i is-	(blobtypeA, blobtypeB, shaA, shaB)-		| isus i    = (iblobtype i, iblobtype sibi, isha i, isha sibi)-		| otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)+	(treeitemtypeA, treeitemtypeB, shaA, shaB)+		| isus i    = (itreeitemtype i, itreeitemtype sibi, isha i, isha sibi)+		| otherwise = (itreeitemtype sibi, itreeitemtype i, isha sibi, isha i) 	new = Unmerged 		{ unmergedFile = ifile i-		, unmergedBlobType = Conflicting blobtypeA blobtypeB+		, unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB 		, unmergedSha = Conflicting shaA shaB 		} 	findsib templatei [] = ([], removed templatei)@@ -253,6 +275,6 @@ 		| otherwise = (l:ls, removed templatei) 	removed templatei = templatei 		{ isus = not (isus templatei)-		, iblobtype = Nothing+		, itreeitemtype = Nothing 		, isha = Nothing 		}
Git/LsTree.hs view
@@ -1,19 +1,21 @@ {- git ls-tree interface  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE BangPatterns #-}  module Git.LsTree ( 	TreeItem(..),+	LsTreeMode(..), 	lsTree, 	lsTree', 	lsTreeParams, 	lsTreeFiles, 	parseLsTree,+	formatLsTree, ) where  import Common@@ -22,42 +24,52 @@ import Git.Sha import Git.FilePath import qualified Git.Filename+import Utility.Attoparsec  import Numeric-import Data.Char+import Data.Either import System.Posix.Types+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.Attoparsec.ByteString.Char8 as A8  data TreeItem = TreeItem 	{ mode :: FileMode-	, typeobj :: String+	, typeobj :: S.ByteString 	, sha :: Ref 	, file :: TopFilePath 	} deriving Show -{- Lists the complete contents of a tree, recursing into sub-trees,- - with lazy output. -}-lsTree :: Ref -> Repo -> IO ([TreeItem], IO Bool)+data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive++{- Lists the contents of a tree, with lazy output. -}+lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool) lsTree = lsTree' [] -lsTree' :: [CommandParam] -> Ref -> Repo -> IO ([TreeItem], IO Bool)-lsTree' ps t repo = do-	(l, cleanup) <- pipeNullSplit (lsTreeParams t ps) repo-	return (map parseLsTree l, cleanup)+lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)+lsTree' ps lsmode t repo = do+	(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo+	return (rights (map parseLsTree l), cleanup) -lsTreeParams :: Ref -> [CommandParam] -> [CommandParam]-lsTreeParams r ps =+lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]+lsTreeParams lsmode r ps = 	[ Param "ls-tree" 	, Param "--full-tree" 	, Param "-z"-	, Param "-r"-	] ++ ps +++	] ++ recursiveparams ++ ps ++ 	[ Param "--" 	, File $ fromRef r 	]+  where+	recursiveparams = case lsmode of+		LsTreeRecursive -> [ Param "-r" ]+		LsTreeNonRecursive -> []  {- Lists specified files in a tree. -} lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]-lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo+lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)+	<$> pipeNullSplitStrict ps repo   where 	ps = 		[ Param "ls-tree"@@ -67,21 +79,34 @@ 		, File $ fromRef t 		] ++ map File fs +parseLsTree :: L.ByteString -> Either String TreeItem+parseLsTree b = case A.parse parserLsTree b of+	A.Done _ r  -> Right r+	A.Fail _ _ err -> Left err+ {- Parses a line of ls-tree output, in format:  - mode SP type SP sha TAB file  -  - (The --long format is not currently supported.) -}-parseLsTree :: String -> TreeItem-parseLsTree l = TreeItem -	{ mode = smode-	, typeobj = t-	, sha = Ref s-	, file = sfile-	}-  where-	(m, past_m) = splitAt 7 l -- mode is 6 bytes-	(!t, past_t) = separate isSpace past_m-	(!s, past_s) = splitAt shaSize past_t-	!f = drop 1 past_s-	!smode = fst $ Prelude.head $ readOct m-	!sfile = asTopFilePath $ Git.Filename.decode f+parserLsTree :: A.Parser TreeItem+parserLsTree = TreeItem+	-- mode+	<$> octal+	<* A8.char ' '+	-- type+	<*> A.takeTill (== 32)+	<* A8.char ' '+	-- sha+	<*> (Ref . decodeBS' <$> A.take shaSize)+	<* A8.char '\t'+	-- file+	<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)++{- Inverse of parseLsTree -}+formatLsTree :: TreeItem -> String+formatLsTree ti = unwords+	[ showOct (mode ti) ""+	, decodeBS (typeobj ti)+	, fromRef (sha ti)+	, fromRawFilePath (getTopFilePath (file ti))+	]
Git/Objects.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.Objects where@@ -12,7 +12,7 @@ import Git.Sha  objectsDir :: Repo -> FilePath-objectsDir r = localGitDir r </> "objects"+objectsDir r = fromRawFilePath (localGitDir r) </> "objects"  packDir :: Repo -> FilePath packDir r = objectsDir r </> "pack"
Git/Ref.hs view
@@ -1,10 +1,12 @@ {- git ref stuff  -- - Copyright 2011-2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Git.Ref where  import Common@@ -13,13 +15,14 @@ import Git.Sha import Git.Types -import Data.Char (chr)+import Data.Char (chr, ord)+import qualified Data.ByteString as S  headRef :: Ref headRef = Ref "HEAD"  headFile :: Repo -> FilePath-headFile r = localGitDir r </> "HEAD"+headFile r = fromRawFilePath (localGitDir r) </> "HEAD"  setHeadRef :: Ref -> Repo -> IO () setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref)@@ -33,11 +36,18 @@  - Converts such a fully qualified ref into a base ref  - (eg: master or origin/master). -} base :: Ref -> Ref-base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef+base = removeBase "refs/heads/" . removeBase "refs/remotes/"++{- Removes a directory such as "refs/heads/master" from a+ - fully qualified ref. Any ref not starting with it is left as-is. -}+removeBase :: String -> Ref -> Ref+removeBase dir (Ref r)+	| prefix `isPrefixOf` r = Ref (drop (length prefix) r)+	| otherwise = Ref r   where-	remove prefix s-		| prefix `isPrefixOf` s = drop (length prefix) s-		| otherwise = s+	prefix = case end dir of+		['/'] -> dir+		_ -> dir ++ "/"  {- 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,@@ -45,14 +55,18 @@ underBase :: String -> Ref -> Ref underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r) +{- Convert a branch such as "master" into a fully qualified ref. -}+branchRef :: Branch -> Ref+branchRef = underBase "refs/heads"+ {- A Ref that can be used to refer to a file in the repository, as staged  - in the index.  -  - Prefixing the file with ./ makes this work even if in a subdirectory  - of a repo.  -}-fileRef :: FilePath -> Ref-fileRef f = Ref $ ":./" ++ f+fileRef :: RawFilePath -> Ref+fileRef f = Ref $ ":./" ++ fromRawFilePath f  {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref@@ -60,7 +74,7 @@  {- A Ref that can be used to refer to a file in the repository as it  - appears in a given Ref. -}-fileFromRef :: Ref -> FilePath -> Ref+fileFromRef :: Ref -> RawFilePath -> Ref fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)  {- Checks if a ref exists. -}@@ -71,24 +85,29 @@ {- The file used to record a ref. (Git also stores some refs in a  - packed-refs file.) -} file :: Ref -> Repo -> FilePath-file ref repo = localGitDir repo </> fromRef ref+file ref repo = fromRawFilePath (localGitDir repo) </> fromRef ref  {- Checks if HEAD exists. It generally will, except for in a repository  - that was just created. -} headExists :: Repo -> IO Bool headExists repo = do-	ls <- lines <$> pipeReadStrict [Param "show-ref", Param "--head"] repo-	return $ any (" HEAD" `isSuffixOf`) ls+	ls <- S.split nl <$> pipeReadStrict [Param "show-ref", Param "--head"] repo+	return $ any (" HEAD" `S.isSuffixOf`) ls+  where+	nl = fromIntegral (ord '\n')  {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) sha branch repo = process <$> showref repo   where-	showref = pipeReadStrict [Param "show-ref",-		Param "--hash", -- get the hash-		Param $ fromRef branch]-	process [] = Nothing-	process s = Just $ Ref $ firstLine s+	showref = pipeReadStrict+		[ Param "show-ref"+		, Param "--hash" -- get the hash+		, Param $ fromRef branch+		]+	process s+		| S.null s = Nothing+		| otherwise = Just $ Ref $ decodeBS' $ firstLine' s  headSha :: Repo -> IO (Maybe Sha) headSha = sha headRef@@ -101,25 +120,47 @@ matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo -{- List of (shas, branches) matching a given ref or refs. -}+{- List of (shas, branches) matching a given ref spec. -} matching' :: [String] -> Repo -> IO [(Sha, Branch)]-matching' ps repo = map gen . lines <$> +matching' ps repo = map gen . lines . decodeBS' <$>  	pipeReadStrict (Param "show-ref" : map Param ps) repo   where 	gen l = let (r, b) = separate (== ' ') l 		in (Ref r, Ref b) -{- List of (shas, branches) matching a given ref spec.+{- List of (shas, branches) matching a given ref.  - Duplicate shas are filtered out. -} matchingUniq :: [Ref] -> Repo -> IO [(Sha, Branch)] matchingUniq refs repo = nubBy uniqref <$> matching refs repo   where 	uniqref (a, _) (b, _) = a == b -{- Gets the sha of the tree a ref uses. -}+{- List of all refs. -}+list :: Repo -> IO [(Sha, Ref)]+list = matching' []++{- Deletes a ref. This can delete refs that are not branches, + - which git branch --delete refuses to delete. -}+delete :: Sha -> Ref -> Repo -> IO ()+delete oldvalue ref = run+	[ Param "update-ref"+	, Param "-d"+	, Param $ fromRef ref+	, Param $ fromRef oldvalue+	]++{- Gets the sha of the tree a ref uses. + -+ - The ref may be something like a branch name, and it could contain+ - ":subdir" if a subtree is wanted. -} tree :: Ref -> Repo -> IO (Maybe Sha)-tree ref = extractSha <$$> pipeReadStrict-	[ Param "rev-parse", Param (fromRef ref ++ ":") ]+tree (Ref ref) = extractSha . decodeBS <$$> pipeReadStrict+	[ Param "rev-parse", Param "--verify", Param "--quiet", Param ref' ]+  where+	ref' = if ":" `isInfixOf` ref+		then ref+		-- de-reference commit objects to the tree+		else ref ++ ":"  {- Checks if a String is a legal git ref name.  -
Git/RefLog.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.RefLog where@@ -21,7 +21,7 @@ getMulti bs = get' (map (Param . fromRef) bs)  get' :: [CommandParam] -> Repo -> IO [Sha]-get' ps = mapMaybe extractSha . lines <$$> pipeReadStrict ps'+get' ps = mapMaybe extractSha . lines . decodeBS <$$> pipeReadStrict ps'   where 	ps' = catMaybes 		[ Just $ Param "log"
Git/Remote.hs view
@@ -2,10 +2,11 @@  -  - Copyright 2012 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Git.Remote where @@ -15,11 +16,22 @@  import Data.Char import qualified Data.Map as M+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath #endif +{- Is a git config key one that specifies the location of a remote? -}+isRemoteKey :: ConfigKey -> Bool+isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k++{- Get a remote's name from the config key that specifies its location. -}+remoteKeyToRemoteName :: ConfigKey -> RemoteName+remoteKeyToRemoteName (ConfigKey k) = decodeBS' $+	S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k+ {- Construct a legal git remote name out of an arbitrary input string.  -  - There seems to be no formal definition of this in the git source,@@ -43,6 +55,7 @@ 	legal c = isAlphaNum c 	 data RemoteLocation = RemoteUrl String | RemotePath FilePath+	deriving (Eq)  remoteLocationIsUrl :: RemoteLocation -> Bool remoteLocationIsUrl (RemoteUrl _) = True@@ -67,16 +80,16 @@ 	-- insteadof config can rewrite remote location 	calcloc l 		| null insteadofs = l-		| otherwise = replacement ++ drop (length bestvalue) l+		| otherwise = replacement ++ drop (S.length bestvalue) l 	  where-		replacement = drop (length prefix) $-			take (length bestkey - length suffix) bestkey-		(bestkey, bestvalue) = maximumBy longestvalue insteadofs+		replacement = decodeBS' $ S.drop (S.length prefix) $+			S.take (S.length bestkey - S.length suffix) bestkey+		(ConfigKey bestkey, ConfigValue bestvalue) = maximumBy longestvalue insteadofs 		longestvalue (_, a) (_, b) = compare b a-		insteadofs = filterconfig $ \(k, v) -> -			prefix `isPrefixOf` k &&-			suffix `isSuffixOf` k &&-			v `isPrefixOf` l+		insteadofs = filterconfig $ \(ConfigKey k, ConfigValue v) -> +			prefix `S.isPrefixOf` k &&+			suffix `S.isSuffixOf` k &&+			v `S.isPrefixOf` encodeBS l 		filterconfig f = filter f $ 			concatMap splitconfigs $ M.toList $ fullconfig repo 		splitconfigs (k, vs) = map (\v -> (k, v)) vs@@ -104,5 +117,5 @@ 	-- git on Windows will write a path to .git/config with "drive:", 	-- which is not to be confused with a "host:" 	dosstyle = hasDrive-	dospath = fromInternalGitPath+	dospath = fromRawFilePath . fromInternalGitPath . toRawFilePath #endif
Git/Repair.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2013-2014 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.Repair (@@ -11,7 +11,6 @@ 	removeBadBranches, 	successfulRepair, 	cleanCorruptObjects,-	retrieveMissingObjects, 	resetLocalBranches, 	checkIndex, 	checkIndexFast,@@ -36,7 +35,7 @@ import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch-import Utility.Tmp+import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode import Utility.Tuple@@ -102,10 +101,11 @@ 		unlessM (boolSystem "git" [Param "init", File tmpdir]) $ 			error $ "failed to create temp repository in " ++ tmpdir 		tmpr <- Config.read =<< Construct.fromAbsPath tmpdir-		stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing+		rs <- Construct.fromRemotes r+		stillmissing <- pullremotes tmpr rs fetchrefstags missing 		if S.null (knownMissing stillmissing) 			then return stillmissing-			else pullremotes tmpr (remotes r) fetchallrefs stillmissing+			else pullremotes tmpr rs fetchallrefs stillmissing   where 	pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of 		Nothing -> return stillmissing@@ -227,7 +227,7 @@  - Relies on packed refs being exploded before it's called.  -} getAllRefs :: Repo -> IO [Ref]-getAllRefs r = getAllRefs' (localGitDir r </> "refs")+getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")  getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do@@ -245,13 +245,13 @@ 		nukeFile f   where 	makeref (sha, ref) = do-		let dest = localGitDir r </> fromRef ref+		let dest = fromRawFilePath (localGitDir r) </> fromRef ref 		createDirectoryIfMissing True (parentDir dest) 		unlessM (doesFileExist dest) $ 			writeFile dest (fromRef sha)  packedRefsFile :: Repo -> FilePath-packedRefsFile r = localGitDir r </> "packed-refs"+packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs"  parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of@@ -263,7 +263,7 @@ {- git-branch -d cannot be used to remove a branch that is directly  - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO ()-nukeBranchRef b r = nukeFile $ localGitDir r </> fromRef b+nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) </> fromRef b  {- Finds the most recent commit to a branch that does not need any  - of the missing objects. If the input branch is good as-is, returns it.@@ -284,7 +284,7 @@ 				, Param "--format=%H" 				, Param (fromRef branch) 				] r-			let branchshas = catMaybes $ map extractSha ls+			let branchshas = catMaybes $ map (extractSha . decodeBL) ls 			reflogshas <- RefLog.get branch r 			-- XXX Could try a bit harder here, and look 			-- for uncorrupted old commits in branches in the@@ -313,7 +313,7 @@ 			, Param "--format=%H %T" 			, Param (fromRef commit) 			] r-		let committrees = map parse ls+		let committrees = map (parse . decodeBL) ls 		if any isNothing committrees || null committrees 			then do 				void cleanup@@ -341,8 +341,8 @@ verifyTree missing treesha r 	| S.member treesha missing = return False 	| otherwise = do-		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams treesha []) r-		let objshas = map (LsTree.sha . LsTree.parseLsTree) ls+		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r+		let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls 		if any (`S.member` missing) objshas 			then do 				void cleanup@@ -370,7 +370,7 @@ 	length indexcontents `seq` cleanup  missingIndex :: Repo -> IO Bool-missingIndex r = not <$> doesFileExist (localGitDir r </> "index")+missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "index")  {- Finds missing and ok files staged in the index. -} partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)@@ -394,12 +394,12 @@ 			UpdateIndex.streamUpdateIndex r 				=<< (catMaybes <$> mapM reinject good) 		void cleanup-		return $ map fst3 bad+		return $ map (fromRawFilePath . fst3) bad   where-	reinject (file, Just sha, Just mode) = case toBlobType mode of+	reinject (file, Just sha, Just mode) = case toTreeItemType mode of 		Nothing -> return Nothing-		Just blobtype -> Just <$>-			UpdateIndex.stageFile sha blobtype file r+		Just treeitemtype -> Just <$>+			UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r 	reinject _ = return Nothing  newtype GoodCommits = GoodCommits (S.Set Sha)@@ -446,7 +446,7 @@ 		let f = indexFile g 		void $ tryIO $ allowWrite f   where-	headfile = localGitDir g </> "HEAD"+	headfile = fromRawFilePath (localGitDir g) </> "HEAD" 	validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)  {- Put it all together. -}
Git/Sha.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2011 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.Sha where
Git/Types.hs view
@@ -1,16 +1,23 @@ {- git data types  -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2019 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Git.Types where  import Network.URI+import Data.String+import Data.Default import qualified Data.Map as M+import qualified Data.ByteString as S import System.Posix.Types import Utility.SafeCommand+import Utility.FileSystemEncoding  {- Support repositories on local disk, and repositories accessed via an URL.  -@@ -23,19 +30,19 @@  - else known about it.  -} data RepoLocation-	= Local { gitdir :: FilePath, worktree :: Maybe FilePath }-	| LocalUnknown FilePath+	= Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath }+	| LocalUnknown RawFilePath 	| Url URI 	| Unknown 	deriving (Show, Eq, Ord)  data Repo = Repo 	{ location :: RepoLocation-	, config :: M.Map String String+	, config :: M.Map ConfigKey ConfigValue 	-- 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+	, fullconfig :: M.Map ConfigKey [ConfigValue]+	-- remoteName holds the name used for this repo in some other+	-- repo's list of remotes, when this repo is such a remote 	, remoteName :: Maybe RemoteName 	-- alternate environment to use when running git commands 	, gitEnv :: Maybe [(String, String)]@@ -44,6 +51,33 @@ 	, gitGlobalOpts :: [CommandParam] 	} deriving (Show, Eq, Ord) +newtype ConfigKey = ConfigKey S.ByteString+	deriving (Ord, Eq)++newtype ConfigValue = ConfigValue S.ByteString+	deriving (Ord, Eq, Semigroup, Monoid)++instance Default ConfigValue where+	def = ConfigValue mempty++fromConfigKey :: ConfigKey -> String+fromConfigKey (ConfigKey s) = decodeBS' s++instance Show ConfigKey where+	show = fromConfigKey++fromConfigValue :: ConfigValue -> String+fromConfigValue (ConfigValue s) = decodeBS' s++instance Show ConfigValue where+	show = fromConfigValue++instance IsString ConfigKey where+	fromString = ConfigKey . encodeBS'++instance IsString ConfigValue where+	fromString = ConfigValue . encodeBS'+ type RemoteName = String  {- A git ref. Can be a sha1, or a branch or tag name. -}@@ -64,45 +98,48 @@  {- Types of objects that can be stored in git. -} data ObjectType = BlobObject | CommitObject | TreeObject-	deriving (Eq) -instance Show ObjectType where-	show BlobObject = "blob"-	show CommitObject = "commit"-	show TreeObject = "tree"--readObjectType :: String -> Maybe ObjectType+readObjectType :: S.ByteString -> Maybe ObjectType readObjectType "blob" = Just BlobObject readObjectType "commit" = Just CommitObject readObjectType "tree" = Just TreeObject readObjectType _ = Nothing -{- Types of blobs. -}-data BlobType = FileBlob | ExecutableBlob | SymlinkBlob-	deriving (Eq)+fmtObjectType :: ObjectType -> S.ByteString+fmtObjectType BlobObject = "blob"+fmtObjectType CommitObject = "commit"+fmtObjectType TreeObject = "tree" -{- Git uses magic numbers to denote the type of a blob. -}-instance Show BlobType where-	show FileBlob = "100644"-	show ExecutableBlob = "100755"-	show SymlinkBlob = "120000"+{- Types of items in a tree. -}+data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule+	deriving (Eq, Show) -readBlobType :: String -> Maybe BlobType-readBlobType "100644" = Just FileBlob-readBlobType "100755" = Just ExecutableBlob-readBlobType "120000" = Just SymlinkBlob-readBlobType _ = Nothing+{- Git uses magic numbers to denote the type of a tree item. -}+readTreeItemType :: S.ByteString -> Maybe TreeItemType+readTreeItemType "100644" = Just TreeFile+readTreeItemType "100755" = Just TreeExecutable+readTreeItemType "120000" = Just TreeSymlink+readTreeItemType "160000" = Just TreeSubmodule+readTreeItemType _ = Nothing -toBlobType :: FileMode -> Maybe BlobType-toBlobType 0o100644 = Just FileBlob-toBlobType 0o100755 = Just ExecutableBlob-toBlobType 0o120000 = Just SymlinkBlob-toBlobType _ = Nothing+fmtTreeItemType :: TreeItemType -> S.ByteString+fmtTreeItemType TreeFile = "100644"+fmtTreeItemType TreeExecutable = "100755"+fmtTreeItemType TreeSymlink = "120000"+fmtTreeItemType TreeSubmodule = "160000" -fromBlobType :: BlobType -> FileMode-fromBlobType FileBlob = 0o100644-fromBlobType ExecutableBlob = 0o100755-fromBlobType SymlinkBlob = 0o120000+toTreeItemType :: FileMode -> Maybe TreeItemType+toTreeItemType 0o100644 = Just TreeFile+toTreeItemType 0o100755 = Just TreeExecutable+toTreeItemType 0o120000 = Just TreeSymlink+toTreeItemType 0o160000 = Just TreeSubmodule+toTreeItemType _ = Nothing++fromTreeItemType :: TreeItemType -> FileMode+fromTreeItemType TreeFile = 0o100644+fromTreeItemType TreeExecutable = 0o100755+fromTreeItemType TreeSymlink = 0o120000+fromTreeItemType TreeSubmodule = 0o160000  data Commit = Commit 	{ commitTree :: Sha
Git/UpdateIndex.hs view
@@ -1,11 +1,11 @@ {- git-update-index library  -- - Copyright 2011-2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-}  module Git.UpdateIndex ( 	Streamer,@@ -21,6 +21,7 @@ 	unstageFile, 	stageSymlink, 	stageDiffTreeItem,+	refreshIndex, ) where  import Common@@ -31,12 +32,14 @@ import Git.Sha import qualified Git.DiffTreeItem as Diff +import qualified Data.ByteString.Lazy as L+ {- Streamers are passed a callback and should feed it lines in the form  - read by update-index, and generated by ls-tree. -}-type Streamer = (String -> IO ()) -> IO ()+type Streamer = (L.ByteString -> IO ()) -> IO ()  {- A streamer with a precalculated value. -}-pureStreamer :: String -> Streamer+pureStreamer :: L.ByteString -> Streamer pureStreamer !s = \streamer -> streamer s  {- Streams content into update-index from a list of Streamers. -}@@ -48,8 +51,8 @@  streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do-	hPutStr h s-	hPutStr h "\0"+	L.hPutStr h s+	L.hPutStr h "\0"  startUpdateIndex :: Repo -> IO UpdateIndexHandle startUpdateIndex repo = do@@ -83,38 +86,66 @@  {- Generates a line suitable to be fed into update-index, to add  - a given file with a given sha. -}-updateIndexLine :: Sha -> BlobType -> TopFilePath -> String-updateIndexLine sha filetype file =-	show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file+updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString+updateIndexLine sha treeitemtype file = L.fromStrict $+	fmtTreeItemType treeitemtype+	<> " blob "+	<> encodeBS (fromRef sha)+	<> "\t"+	<> indexPath file -stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer-stageFile sha filetype file repo = do-	p <- toTopFilePath file repo-	return $ pureStreamer $ updateIndexLine sha filetype p+stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer+stageFile sha treeitemtype file repo = do+	p <- toTopFilePath (toRawFilePath file) repo+	return $ pureStreamer $ updateIndexLine sha treeitemtype p  {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer unstageFile file repo = do-	p <- toTopFilePath file repo+	p <- toTopFilePath (toRawFilePath file) repo 	return $ unstageFile' p  unstageFile' :: TopFilePath -> Streamer-unstageFile' p = pureStreamer $ "0 " ++ fromRef nullSha ++ "\t" ++ indexPath p+unstageFile' p = pureStreamer $ L.fromStrict $+	"0 "+	<> encodeBS' (fromRef nullSha)+	<> "\t"+	<> indexPath p  {- A streamer that adds a symlink to the index. -} stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer stageSymlink file sha repo = do 	!line <- updateIndexLine 		<$> pure sha-		<*> pure SymlinkBlob-		<*> toTopFilePath file repo+		<*> pure TreeSymlink+		<*> toTopFilePath (toRawFilePath file) repo 	return $ pureStreamer line  {- A streamer that applies a DiffTreeItem to the index. -} stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer-stageDiffTreeItem d = case toBlobType (Diff.dstmode d) of+stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of 	Nothing -> unstageFile' (Diff.file d) 	Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)  indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath++{- Refreshes the index, by checking file stat information.  -}+refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool+refreshIndex repo feeder = do+	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)+		{ std_in = CreatePipe }+	feeder $ \f -> do+		hPutStr h f+		hPutStr h "\0"+	hFlush h+	hClose h+	checkSuccessProcess p+  where+	params = +		[ Param "update-index"+		, Param "-q"+		, Param "--refresh"+		, Param "-z"+		, Param "--stdin"+		]
Git/Url.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2010, 2011 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  module Git.Url (@@ -11,9 +11,10 @@ 	port, 	hostuser, 	authority,+	path, ) where -import Network.URI hiding (scheme, authority)+import Network.URI hiding (scheme, authority, path)  import Common import Git.Types@@ -65,6 +66,11 @@ authpart :: (URIAuth -> a) -> Repo -> Maybe a authpart a Repo { location = Url u } = a <$> uriAuthority u authpart _ repo = notUrl repo++{- Path part of an URL repo. -}+path :: Repo -> FilePath+path Repo { location = Url u } = uriPath u+path repo = notUrl repo  notUrl :: Repo -> a notUrl repo = error $
Git/Version.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2011, 2013 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# OPTIONS_GHC -fno-warn-tabs #-}
Utility/Applicative.hs view
@@ -5,7 +5,11 @@  - License: BSD-2-clause  -} -module Utility.Applicative where+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Applicative (+	(<$$>),+) where  {- Like <$> , but supports one level of currying.  -
+ Utility/Attoparsec.hs view
@@ -0,0 +1,21 @@+{- attoparsec utility functions+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2007-2015 Bryan O'Sullivan+ -+ - License: BSD-3-clause+ -}++module Utility.Attoparsec where++import qualified Data.Attoparsec.ByteString as A+import qualified Data.ByteString as B++-- | Parse and decode an unsigned octal number.+--+-- This parser does not accept a leading @\"0o\"@ string.+octal :: Integral a => A.Parser a+octal = B.foldl' step 0 `fmap` A.takeWhile1 isOctDigit+  where+	isOctDigit w = w >= 48 && w <= 55+	step a w = a * 8 + fromIntegral (w - 48)
Utility/Batch.hs view
@@ -7,11 +7,18 @@  {-# LANGUAGE CPP #-} -module Utility.Batch where+module Utility.Batch (+	batch,+	BatchCommandMaker,+	getBatchCommandMaker,+	toBatchCommand,+	batchCommand,+	batchCommandEnv,+) where  import Common -#if defined(linux_HOST_OS) || defined(__ANDROID__)+#if defined(linux_HOST_OS) import Control.Concurrent.Async import System.Posix.Process #endif@@ -29,7 +36,7 @@  - systems, the action is simply ran.  -} batch :: IO a -> IO a-#if defined(linux_HOST_OS) || defined(__ANDROID__)+#if defined(linux_HOST_OS) batch a = wait =<< batchthread   where 	batchthread = asyncBound $ do@@ -51,11 +58,7 @@ #ifndef mingw32_HOST_OS 	nicers <- filterM (inPath . fst) 		[ ("nice", [])-#ifndef __ANDROID__-		-- Android's ionice does not allow specifying a command,-		-- so don't use it. 		, ("ionice", ["-c3"])-#endif 		, ("nocache", []) 		] 	return $ \(command, params) ->
Utility/Data.hs view
@@ -7,7 +7,10 @@  {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Data where+module Utility.Data (+	firstJust,+	eitherToMaybe,+) where  {- First item in the list that is not Nothing. -} firstJust :: Eq a => [Maybe a] -> Maybe a
Utility/Directory.hs view
@@ -16,22 +16,18 @@ import System.IO.Error import Control.Monad import System.FilePath+import System.PosixCompat.Files import Control.Applicative-import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe import Prelude -#ifdef mingw32_HOST_OS-import qualified System.Win32 as Win32-#else-import qualified System.Posix as Posix+#ifndef mingw32_HOST_OS import Utility.SafeCommand import Control.Monad.IfElse #endif  import Utility.SystemDirectory-import Utility.PosixFiles import Utility.Tmp import Utility.Exception import Utility.Monad@@ -158,90 +154,3 @@ #else 	go = removeFile file #endif--#ifndef mingw32_HOST_OS-data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream-#else-data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())-#endif--type IsOpen = MVar () -- full when the handle is open--openDirectory :: FilePath -> IO DirectoryHandle-openDirectory path = do-#ifndef mingw32_HOST_OS-	dirp <- Posix.openDirStream path-	isopen <- newMVar ()-	return (DirectoryHandle isopen dirp)-#else-	(h, fdat) <- Win32.findFirstFile (path </> "*")-	-- Indicate that the fdat contains a filename that readDirectory-	-- has not yet returned, by making the MVar be full.-	-- (There's always at least a "." entry.)-	alreadyhave <- newMVar ()-	isopen <- newMVar ()-	return (DirectoryHandle isopen h fdat alreadyhave)-#endif--closeDirectory :: DirectoryHandle -> IO ()-#ifndef mingw32_HOST_OS-closeDirectory (DirectoryHandle isopen dirp) =-	whenOpen isopen $-		Posix.closeDirStream dirp-#else-closeDirectory (DirectoryHandle isopen h _ alreadyhave) =-	whenOpen isopen $ do-		_ <- tryTakeMVar alreadyhave-		Win32.findClose h-#endif-  where-	whenOpen :: IsOpen -> IO () -> IO ()-	whenOpen mv f = do-		v <- tryTakeMVar mv-		when (isJust v) f--{- |Reads the next entry from the handle. Once the end of the directory-is reached, returns Nothing and automatically closes the handle.--}-readDirectory :: DirectoryHandle -> IO (Maybe FilePath)-#ifndef mingw32_HOST_OS-readDirectory hdl@(DirectoryHandle _ dirp) = do-	e <- Posix.readDirStream dirp-	if null e-		then do-			closeDirectory hdl-			return Nothing-		else return (Just e)-#else-readDirectory hdl@(DirectoryHandle _ h fdat mv) = do-	-- If the MVar is full, then the filename in fdat has-	-- not yet been returned. Otherwise, need to find the next-	-- file.-	r <- tryTakeMVar mv-	case r of-		Just () -> getfn-		Nothing -> do-			more <- Win32.findNextFile h fdat-			if more-				then getfn-				else do-					closeDirectory hdl-					return Nothing-  where-	getfn = do-		filename <- Win32.getFindDataFileName fdat-		return (Just filename)-#endif---- True only when directory exists and contains nothing.--- Throws exception if directory does not exist.-isDirectoryEmpty :: FilePath -> IO Bool-isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check-  where-	check h = do-		v <- readDirectory h-		case v of-			Nothing -> return True-			Just f-				| not (dirCruft f) -> return False-				| otherwise -> check h
Utility/DottedVersion.hs view
@@ -7,7 +7,11 @@  {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.DottedVersion where+module Utility.DottedVersion (+	DottedVersion,+	fromDottedVersion,+	normalize,+) where  import Common @@ -18,7 +22,10 @@ 	compare (DottedVersion _ x) (DottedVersion _ y) = compare x y  instance Show DottedVersion where-	show (DottedVersion s _) = s+	show = fromDottedVersion++fromDottedVersion :: DottedVersion -> String+fromDottedVersion (DottedVersion s _) = s  {- To compare dotted versions like 1.7.7 and 1.8, they are normalized to  - a somewhat arbitrary integer representation. -}
Utility/Env.hs view
@@ -8,7 +8,14 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Env where+module Utility.Env (+	getEnv,+	getEnvDefault,+	getEnvironment,+	addEntry,+	addEntries,+	delEntry,+) where  #ifdef mingw32_HOST_OS import Utility.Exception@@ -16,7 +23,6 @@ import Data.Maybe import Prelude import qualified System.Environment as E-import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif@@ -40,29 +46,6 @@ getEnvironment = PE.getEnvironment #else getEnvironment = E.getEnvironment-#endif--{- Sets an environment variable. To overwrite an existing variable,- - overwrite must be True.- -- - On Windows, setting a variable to "" unsets it. -}-setEnv :: String -> String -> Bool -> IO ()-#ifndef mingw32_HOST_OS-setEnv var val overwrite = PE.setEnv var val overwrite-#else-setEnv var val True = System.SetEnv.setEnv var val-setEnv var val False = do-	r <- getEnv var-	case r of-		Nothing -> setEnv var val True-		Just _ -> return ()-#endif--unsetEnv :: String -> IO ()-#ifndef mingw32_HOST_OS-unsetEnv = PE.unsetEnv-#else-unsetEnv = System.SetEnv.unsetEnv #endif  {- Adds the environment variable to the input environment. If already
+ Utility/Env/Basic.hs view
@@ -0,0 +1,25 @@+{- portable environment variables, without any dependencies+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Env.Basic (+	getEnv,+	getEnvDefault,+) where++import Utility.Exception+import Control.Applicative+import Data.Maybe+import Prelude+import qualified System.Environment as E++getEnv :: String -> IO (Maybe String)+getEnv = catchMaybeIO . E.getEnv++getEnvDefault :: String -> String -> IO String+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
+ Utility/Env/Set.hs view
@@ -0,0 +1,43 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.Env.Set (+	setEnv,+	unsetEnv,+) where++#ifdef mingw32_HOST_OS+import qualified System.SetEnv+import Utility.Env+#else+import qualified System.Posix.Env as PE+#endif++{- Sets an environment variable. To overwrite an existing variable,+ - overwrite must be True.+ -+ - On Windows, setting a variable to "" unsets it. -}+setEnv :: String -> String -> Bool -> IO ()+#ifndef mingw32_HOST_OS+setEnv var val overwrite = PE.setEnv var val overwrite+#else+setEnv var val True = System.SetEnv.setEnv var val+setEnv var val False = do+	r <- getEnv var+	case r of+		Nothing -> setEnv var val True+		Just _ -> return ()+#endif++unsetEnv :: String -> IO ()+#ifndef mingw32_HOST_OS+unsetEnv = PE.unsetEnv+#else+unsetEnv = System.SetEnv.unsetEnv+#endif
Utility/Exception.hs view
@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Exception (@@ -29,11 +29,7 @@ import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) import Control.Exception (SomeAsyncException)-#endif-#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType)@@ -46,15 +42,7 @@  - where there's a problem that the user is excpected to see in some  - circumstances. -} giveup :: [Char] -> a-#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,9,0) giveup = errorWithoutStackTrace-#else-giveup = error-#endif-#else-giveup = error-#endif  {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool@@ -95,11 +83,7 @@ catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` 	[ M.Handler (\ (e :: AsyncException) -> throwM e)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) 	, M.Handler (\ (e :: SomeAsyncException) -> throwM e)-#endif-#endif 	, M.Handler (\ (e :: SomeException) -> onerr e) 	]
Utility/FileMode.hs view
@@ -15,9 +15,9 @@ import System.IO import Control.Monad import System.PosixCompat.Types-import Utility.PosixFiles+import System.PosixCompat.Files #ifndef mingw32_HOST_OS-import System.Posix.Files+import System.Posix.Files (symbolicLinkMode) import Control.Monad.IO.Class (liftIO) #endif import Control.Monad.IO.Class (MonadIO)@@ -69,6 +69,7 @@ otherGroupModes =  	[ groupReadMode, otherReadMode 	, groupWriteMode, otherWriteMode+	, groupExecuteMode, otherExecuteMode 	]  {- Removes the write bits from a file. -}
Utility/FileSize.hs view
@@ -4,8 +4,13 @@  -}  {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.FileSize where+module Utility.FileSize (+	FileSize,+	getFileSize,+	getFileSize',+) where  import System.PosixCompat.Files #ifdef mingw32_HOST_OS@@ -28,7 +33,10 @@ getFileSize f = bracket (openFile f ReadMode) hClose hFileSize #endif -{- Gets the size of the file, when its FileStatus is already known. -}+{- Gets the size of the file, when its FileStatus is already known.+ -+ - On windows, uses getFileSize. Otherwise, the FileStatus contains the+ - size, so this does not do any work. -} getFileSize' :: FilePath -> FileStatus -> IO FileSize #ifndef mingw32_HOST_OS getFileSize' _ s = return $ fromIntegral $ fileSize s
Utility/FileSystemEncoding.hs view
@@ -12,12 +12,17 @@ 	useFileSystemEncoding, 	fileEncoding, 	withFilePath,+	RawFilePath,+	fromRawFilePath,+	toRawFilePath,+	decodeBL,+	encodeBL, 	decodeBS, 	encodeBS,-	decodeW8,-	encodeW8,-	encodeW8NUL,-	decodeW8NUL,+	decodeBL',+	encodeBL',+	decodeBS',+	encodeBS', 	truncateFilePath, 	s2w8, 	w82s,@@ -32,8 +37,10 @@ import System.IO.Unsafe import Data.Word import Data.List+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS+import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 #endif @@ -103,31 +110,91 @@ 		`catchNonAsync` (\_ -> return fp)  {- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}-decodeBS :: L.ByteString -> FilePath+decodeBL :: L.ByteString -> FilePath #ifndef mingw32_HOST_OS-decodeBS = encodeW8NUL . L.unpack+decodeBL = encodeW8NUL . L.unpack #else {- On Windows, we assume that the ByteString is utf-8, since Windows  - only uses unicode for filenames. -}-decodeBS = L8.toString+decodeBL = L8.toString #endif  {- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}-encodeBS :: FilePath -> L.ByteString+encodeBL :: FilePath -> L.ByteString #ifndef mingw32_HOST_OS-encodeBS = L.pack . decodeW8NUL+encodeBL = L.pack . decodeW8NUL #else-encodeBS = L8.fromString+encodeBL = L8.fromString #endif +decodeBS :: S.ByteString -> FilePath+#ifndef mingw32_HOST_OS+decodeBS = encodeW8NUL . S.unpack+#else+decodeBS = S8.toString+#endif++encodeBS :: FilePath -> S.ByteString+#ifndef mingw32_HOST_OS+encodeBS = S.pack . decodeW8NUL+#else+encodeBS = S8.fromString+#endif++{- Faster version that assumes the string does not contain NUL;+ - if it does it will be truncated before the NUL. -}+decodeBS' :: S.ByteString -> FilePath+#ifndef mingw32_HOST_OS+decodeBS' = encodeW8 . S.unpack+#else+decodeBS' = S8.toString+#endif++encodeBS' :: FilePath -> S.ByteString+#ifndef mingw32_HOST_OS+encodeBS' = S.pack . decodeW8+#else+encodeBS' = S8.fromString+#endif++decodeBL' :: L.ByteString -> FilePath+#ifndef mingw32_HOST_OS+decodeBL' = encodeW8 . L.unpack+#else+decodeBL' = L8.toString+#endif++encodeBL' :: FilePath -> L.ByteString+#ifndef mingw32_HOST_OS+encodeBL' = L.pack . decodeW8+#else+encodeBL' = L8.fromString+#endif++{- Recent versions of the unix package have this alias; defined here+ - for backwards compatibility. -}+type RawFilePath = S.ByteString++{- Note that the RawFilePath is assumed to never contain NUL,+ - since filename's don't. This should only be used with actual+ - RawFilePaths not arbitrary ByteString that may contain NUL. -}+fromRawFilePath :: RawFilePath -> FilePath+fromRawFilePath = decodeBS'++{- Note that the FilePath is assumed to never contain NUL,+ - since filename's don't. This should only be used with actual FilePaths+ - not arbitrary String that may contain NUL. -}+toRawFilePath :: FilePath -> RawFilePath+toRawFilePath = encodeBS'+ {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.  -- - w82c produces a String, which may contain Chars that are invalid+ - w82s produces a String, which may contain Chars that are invalid  - unicode. From there, this is really a simple matter of applying the  - file system encoding, only complicated by GHC's interface to doing so.  -  - Note that the encoding stops at any NUL in the input. FilePaths- - do not normally contain embedded NUL, but Haskell Strings may.+ - cannot contain embedded NUL, but Haskell Strings may.  -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath@@ -135,8 +202,6 @@ 	enc <- Encoding.getFileSystemEncoding 	GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc -{- Useful when you want the actual number of bytes that will be used to- - represent the FilePath on disk. -} decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath
Utility/Format.hs view
@@ -15,7 +15,7 @@ ) where  import Text.Printf (printf)-import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord)+import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord, isAscii) import Data.Maybe (fromMaybe) import Data.Word (Word8) import Data.List (isPrefixOf)@@ -176,12 +176,12 @@ {- For quickcheck.   -  - Encoding and then decoding roundtrips only when- - the string does not contain high unicode, because eg, - - both "\12345" and "\227\128\185" are encoded to "\343\200\271".+ - the string is ascii because eg, both "\12345" and+ - "\227\128\185" are encoded to "\343\200\271".  -- - This property papers over the problem, by only testing chars < 256.+ - This property papers over the problem, by only testing ascii.  -} prop_encode_c_decode_c_roundtrip :: String -> Bool prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s')   where-	s' = filter (\c -> ord c < 256) s+	s' = filter isAscii s
Utility/HumanNumber.hs view
@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -module Utility.HumanNumber where+module Utility.HumanNumber (showImprecise) where  {- Displays a fractional value as a string with a limited number  - of decimal digits. -}
Utility/HumanTime.hs view
@@ -60,15 +60,17 @@ fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } 	| d == 0 = "0s"-	| otherwise = concatMap showunit $ go [] units d+	| otherwise = concatMap showunit $ take 2 $ go [] units d   where-	showunit (u, n)-		| n > 0 = show n ++ [u]-		| otherwise = ""+	showunit (u, n) = show n ++ [u] 	go c [] _ = reverse c 	go c ((u, n):us) v = 		let (q,r) = v `quotRem` n-		in go ((u, q):c) us r+		in if q > 0+			then go ((u, q):c) us r+			else if null c+				then go c us r+				else reverse c  units :: [(Char, Integer)] units =
Utility/Metered.hs view
@@ -1,16 +1,48 @@ {- Metered IO and actions  -- - Copyright 2012-2016 Joey Hess <id@joeyh.name>+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE TypeSynonymInstances, BangPatterns #-} -module Utility.Metered where+module Utility.Metered (+	MeterUpdate,+	nullMeterUpdate,+	combineMeterUpdate,+	BytesProcessed(..),+	toBytesProcessed,+	fromBytesProcessed,+	addBytesProcessed,+	zeroBytesProcessed,+	withMeteredFile,+	meteredWrite,+	meteredWrite',+	meteredWriteFile,+	offsetMeterUpdate,+	hGetContentsMetered,+	hGetMetered,+	defaultChunkSize,+	watchFileSize,+	OutputHandler(..),+	ProgressParser,+	commandMeter,+	commandMeter',+	demeterCommand,+	demeterCommandEnv,+	avoidProgress,+	rateLimitMeterUpdate,+	Meter,+	mkMeter,+	setMeterTotalSize,+	updateMeter,+	displayMeterHandle,+	clearMeterHandle,+	bandwidthMeter,+) where  import Common-import Utility.FileSystemEncoding import Utility.Percentage import Utility.DataUnits import Utility.HumanTime@@ -81,11 +113,6 @@ withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> 	hGetContentsMetered h meterupdate >>= a -{- Sends the content of a file to a Handle, updating the meter as it's- - written. -}-streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO ()-streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h- {- Writes a ByteString to a Handle, updating a meter as it's written. -} meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () meteredWrite meterupdate h = void . meteredWrite' meterupdate h@@ -211,7 +238,14 @@  - to update a meter.  -} commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool-commandMeter progressparser oh meterupdate cmd params = +commandMeter progressparser oh meterupdate cmd params = do+	ret <- commandMeter' progressparser oh meterupdate cmd params+	return $ case ret of+		Just ExitSuccess -> True+		_ -> False++commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode)+commandMeter' progressparser oh meterupdate cmd params =  	outputFilter cmd params Nothing 		(feedprogress zeroBytesProcessed []) 		handlestderr@@ -224,7 +258,7 @@ 				unless (quietMode oh) $ do 					S.hPut stdout b 					hFlush stdout-				let s = encodeW8 (S.unpack b)+				let s = decodeBS b 				let (mbytes, buf') = progressparser (buf++s) 				case mbytes of 					Nothing -> feedprogress prev buf' h@@ -246,9 +280,13 @@ demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing  demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool-demeterCommandEnv oh cmd params environ = outputFilter cmd params environ-	(\outh -> avoidProgress True outh stdouthandler)-	(\errh -> avoidProgress True errh $ stderrHandler oh)+demeterCommandEnv oh cmd params environ = do+	ret <- outputFilter cmd params environ+		(\outh -> avoidProgress True outh stdouthandler)+		(\errh -> avoidProgress True errh $ stderrHandler oh)+	return $ case ret of+		Just ExitSuccess -> True+		_ -> False   where 	stdouthandler l =  		unless (quietMode oh) $@@ -271,16 +309,15 @@ 	-> Maybe [(String, String)] 	-> (Handle -> IO ()) 	-> (Handle -> IO ())-	-> IO Bool-outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do+	-> IO (Maybe ExitCode)+outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do 	(_, Just outh, Just errh, pid) <- createProcess p 		{ std_out = CreatePipe 		, std_err = CreatePipe 		} 	void $ async $ tryIO (outfilter outh) >> hClose outh 	void $ async $ tryIO (errfilter errh) >> hClose errh-	ret <- checkSuccessProcess pid-	return ret+	waitForProcess pid   where 	p = (proc cmd (toCommand params)) 		{ env = environ }@@ -288,14 +325,14 @@ -- | Limit a meter to only update once per unit of time. -- -- It's nice to display the final update to 100%, even if it comes soon--- after a previous update. To make that happen, a total size has to be--- provided.-rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate-rateLimitMeterUpdate delta totalsize meterupdate = do+-- after a previous update. To make that happen, the Meter has to know+-- its total size.+rateLimitMeterUpdate :: NominalDiffTime -> Meter -> MeterUpdate -> IO MeterUpdate+rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do 	lastupdate <- newMVar (toEnum 0 :: POSIXTime) 	return $ mu lastupdate   where-	mu lastupdate n@(BytesProcessed i) = case totalsize of+	mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case 		Just t | i >= t -> meterupdate n 		_ -> do 			now <- getPOSIXTime@@ -306,35 +343,38 @@ 					meterupdate n 				else putMVar lastupdate prev -data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter+data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter  type MeterState = (BytesProcessed, POSIXTime) -type DisplayMeter = MVar String -> String -> IO ()+type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO ()  type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String  -- | Make a meter. Pass the total size, if it's known.-mkMeter :: Maybe Integer -> RenderMeter -> DisplayMeter -> IO Meter-mkMeter totalsize rendermeter displaymeter = Meter-	<$> pure totalsize+mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter+mkMeter totalsize displaymeter = Meter+	<$> newMVar totalsize 	<*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) 	<*> newMVar ""-	<*> pure rendermeter 	<*> pure displaymeter +setMeterTotalSize :: Meter -> Integer -> IO ()+setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just+ -- | Updates the meter, displaying it if necessary.-updateMeter :: Meter -> BytesProcessed -> IO ()-updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do+updateMeter :: Meter -> MeterUpdate+updateMeter (Meter totalsizev sv bv displaymeter) new = do 	now <- getPOSIXTime 	(old, before) <- swapMVar sv (new, now)-	when (old /= new) $-		displaymeter bv $ -			rendermeter totalsize (old, before) (new, now)+	when (old /= new) $ do+		totalsize <- readMVar totalsizev+		displaymeter bv totalsize (old, before) (new, now)  -- | Display meter to a Handle.-displayMeterHandle :: Handle -> DisplayMeter-displayMeterHandle h v s = do+displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter+displayMeterHandle h rendermeter v msize old new = do+	let s = rendermeter msize old new 	olds <- swapMVar v s 	-- Avoid writing when the rendered meter has not changed. 	when (olds /= s) $ do@@ -344,29 +384,32 @@  -- | Clear meter displayed by displayMeterHandle. clearMeterHandle :: Meter -> Handle -> IO ()-clearMeterHandle (Meter _ _ v _ _) h = do+clearMeterHandle (Meter _ _ v _) h = do 	olds <- readMVar v 	hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r" 	hFlush h  -- | Display meter in the form:---   10%         300 KiB/s 16m40s+--   10%  1.3MiB  300 KiB/s 16m40s -- or when total size is not known:---   1.3 MiB     300 KiB/s+--   1.3 MiB      300 KiB/s bandwidthMeter :: RenderMeter bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = 	unwords $ catMaybes-		[ Just percentoramount-		-- Pad enough for max width: "xxxx.xx KiB  xxxx KiB/s"-		, Just $ replicate (23 - length percentoramount - length rate) ' '+		[ Just percentamount+		-- Pad enough for max width: "100%  xxxx.xx KiB  xxxx KiB/s"+		, Just $ replicate (29 - length percentamount - length rate) ' ' 		, Just rate 		, estimatedcompletion 		]   where-	percentoramount = case mtotalsize of-		Just totalsize -> showPercentage 0 $-			percentage totalsize (min new totalsize)-		Nothing -> roughSize' memoryUnits True 2 new+	amount = roughSize' memoryUnits True 2 new+	percentamount = case mtotalsize of+		Just totalsize ->+			let p = showPercentage 0 $+				percentage totalsize (min new totalsize)+			in p ++ replicate (6 - length p) ' ' ++ amount+		Nothing -> amount 	rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s" 	bytespersecond 		| duration == 0 = fromIntegral transferred@@ -377,5 +420,5 @@ 		Just totalsize 			| bytespersecond > 0 ->  				Just $ fromDuration $ Duration $-					totalsize `div` bytespersecond+					(totalsize - new) `div` bytespersecond 		_ -> Nothing
Utility/Misc.hs view
@@ -5,22 +5,31 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Misc where+module Utility.Misc (+	hGetContentsStrict,+	readFileStrict,+	separate,+	firstLine,+	firstLine',+	segment,+	segmentDelim,+	massReplace,+	hGetSomeString,+	exitBool, +	prop_segment_regressionTest,+) where+ import System.IO import Control.Monad import Foreign import Data.Char import Data.List import System.Exit-#ifndef mingw32_HOST_OS-import System.Posix.Process (getAnyProcessStatus)-import Utility.Exception-#endif import Control.Applicative+import qualified Data.ByteString as S import Prelude  {- A version of hgetContents that is not lazy. Ensures file is @@ -49,6 +58,11 @@ firstLine :: String -> String firstLine = takeWhile (/= '\n') +firstLine' :: S.ByteString -> S.ByteString+firstLine' = S.takeWhile (/= nl)+  where+	nl = fromIntegral (ord '\n')+ {- Splits a list into segments that are delimited by items matching  - a predicate. (The delimiters are not included in the segments.)  - Segments may be empty. -}@@ -111,22 +125,6 @@   where 	peekbytes :: Int -> Ptr Word8 -> IO [Word8] 	peekbytes len buf = mapM (peekElemOff buf) [0..pred len]--{- Reaps any zombie git processes. - -- - Warning: Not thread safe. Anything that was expecting to wait- - on a process and get back an exit status is going to be confused- - if this reap gets there first. -}-reapZombies :: IO ()-#ifndef mingw32_HOST_OS-reapZombies =-	-- throws an exception when there are no child processes-	catchDefaultIO Nothing (getAnyProcessStatus False True)-		>>= maybe (return ()) (const reapZombies)--#else-reapZombies = return ()-#endif  exitBool :: Bool -> IO a exitBool False = exitFailure
Utility/Monad.hs view
@@ -7,7 +7,19 @@  {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Monad where+module Utility.Monad (+	firstM,+	getM,+	anyM,+	allM,+	untilTrue,+	ifM,+	(<||>),+	(<&&>),+	observe,+	after,+	noop,+) where  import Data.Maybe import Control.Monad
Utility/PartialPrelude.hs view
@@ -7,7 +7,18 @@  {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.PartialPrelude where+module Utility.PartialPrelude (+	Utility.PartialPrelude.read,+	Utility.PartialPrelude.head,+	Utility.PartialPrelude.tail,+	Utility.PartialPrelude.init,+	Utility.PartialPrelude.last,+	Utility.PartialPrelude.readish,+	Utility.PartialPrelude.headMaybe,+	Utility.PartialPrelude.lastMaybe,+	Utility.PartialPrelude.beginning,+	Utility.PartialPrelude.end,+) where  import qualified Data.Maybe @@ -38,11 +49,9 @@  {- 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.+ - Unlike Text.Read.readMaybe, this ignores some trailing text+ - after the part that can be read. However, if the trailing text looks+ - like another readable value, it fails.  -} readish :: Read a => String -> Maybe a readish s = case reads s of
Utility/Path.hs view
@@ -5,11 +5,33 @@  - License: BSD-2-clause  -} -{-# LANGUAGE PackageImports, CPP #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Path where+module Utility.Path (+	simplifyPath,+	absPathFrom,+	parentDir,+	upFrom,+	dirContains,+	absPath,+	relPathCwdToFile,+	relPathDirToFile,+	relPathDirToFileAbs,+	segmentPaths,+	runSegmentPaths,+	relHome,+	inPath,+	searchPath,+	dotfile,+	sanitizeFilePath,+	splitShortExtensions, +	prop_upFrom_basics,+	prop_relPathDirToFile_basics,+	prop_relPathDirToFile_regressionTest,+) where+ import System.FilePath import Data.List import Data.Maybe@@ -17,17 +39,11 @@ import Control.Applicative import Prelude -#ifdef mingw32_HOST_OS-import qualified System.FilePath.Posix as Posix-#else-import System.Posix.Files-import Utility.Exception-#endif- import Utility.Monad import Utility.UserInfo import Utility.Directory import Utility.Split+import Utility.FileSystemEncoding  {- Simplifies a path, removing any "." component, collapsing "dir/..",   - and removing the trailing path separator.@@ -97,7 +113,10 @@  - are all equivilant.  -} dirContains :: FilePath -> FilePath -> Bool-dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'+dirContains a b = a == b+	|| a' == b'+	|| (addTrailingPathSeparator a') `isPrefixOf` b'+	|| a' == "." && normalise ("." </> b') == b'   where 	a' = norm a 	b' = norm b@@ -136,17 +155,22 @@  -} relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to-	| takeDrive from /= takeDrive to = to+#ifdef mingw32_HOST_OS+	| normdrive from /= normdrive to = to+#endif 	| otherwise = joinPath $ dotdots ++ uncommon   where 	pfrom = sp from 	pto = sp to-	sp = map dropTrailingPathSeparator . splitPath+	sp = map dropTrailingPathSeparator . splitPath . dropDrive 	common = map fst $ takeWhile same $ zip pfrom pto 	same (c,d) = c == d 	uncommon = drop numcommon pto 	dotdots = replicate (length pfrom - numcommon) ".." 	numcommon = length common+#ifdef mingw32_HOST_OS+	normdrive = map toLower . takeWhile (/= ':') . takeDrive+#endif  prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to@@ -180,20 +204,21 @@  - we stop preserving ordering at that point. Presumably a user passing  - that many paths in doesn't care too much about order of the later ones.  -}-segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]+segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation segmentPaths (l:ls) new = found : segmentPaths ls rest   where 	(found, rest) = if length ls < 100-		then partition (l `dirContains`) new-		else break (\p -> not (l `dirContains` p)) new+		then partition inl new+		else break (not . inl) new+	inl f = fromRawFilePath l `dirContains` fromRawFilePath f  {- This assumes that it's cheaper to call segmentPaths on the result,  - than it would be to run the action separately with each path. In  - the case of git file list commands, that assumption tends to hold.  -}-runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]+runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]] runSegmentPaths a paths = segmentPaths paths <$> a paths  {- Converts paths in the home directory to use ~/ -}@@ -241,50 +266,6 @@ 	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)   where 	f = takeFileName file--{- Converts a DOS style path to a msys2 style path. Only on Windows.- - Any trailing '\' is preserved as a trailing '/' - - - - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i- -- - The virtual filesystem contains:- -  /c, /d, ...	mount points for Windows drives- -}-toMSYS2Path :: FilePath -> FilePath-#ifndef mingw32_HOST_OS-toMSYS2Path = id-#else-toMSYS2Path p-	| null drive = recombine parts-	| otherwise = recombine $ "/" : driveletter drive : parts-  where-	(drive, p') = splitDrive p-	parts = splitDirectories p'-	driveletter = map toLower . takeWhile (/= ':')-	recombine = fixtrailing . Posix.joinPath-	fixtrailing s-		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s-		| otherwise = s-#endif--{- Maximum size to use for a file in a specified directory.- -- - Many systems have a 255 byte limit to the name of a file, - - so that's taken as the max if the system has a larger limit, or has no- - limit.- -}-fileNameLengthLimit :: FilePath -> IO Int-#ifdef mingw32_HOST_OS-fileNameLengthLimit _ = return 255-#else-fileNameLengthLimit dir = do-	-- getPathVar can fail due to statfs(2) overflow-	l <- catchDefaultIO 0 $-		fromIntegral <$> getPathVar dir FileNameLimit-	if l <= 0-		then return 255-		else return $ minimum [l, 255]-#endif  {- Given a string that we'd like to use as the basis for FilePath, but that  - was provided by a third party and is not to be trusted, returns the closest
− Utility/PosixFiles.hs 
@@ -1,42 +0,0 @@-{- POSIX files (and compatablity wrappers).- -- - This is like System.PosixCompat.Files, but with a few fixes.- -- - Copyright 2014 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-tabs #-}--module Utility.PosixFiles (-	module X,-	rename-) where--import System.PosixCompat.Files as X hiding (rename)--#ifndef mingw32_HOST_OS-import System.Posix.Files (rename)-#else-import qualified System.Win32.File as Win32-import qualified System.Win32.HardLink as Win32-#endif--{- System.PosixCompat.Files.rename on Windows calls renameFile,- - so cannot rename directories. - -- - Instead, use Win32 moveFile, which can. It needs to be told to overwrite- - any existing file. -}-#ifdef mingw32_HOST_OS-rename :: FilePath -> FilePath -> IO ()-rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING-#endif--{- System.PosixCompat.Files.createLink throws an error, but windows- - does support hard links. -}-#ifdef mingw32_HOST_OS-createLink :: FilePath -> FilePath -> IO ()-createLink = Win32.createHardLink-#endif
Utility/Process.hs view
@@ -24,11 +24,10 @@ 	createProcessSuccess, 	createProcessChecked, 	createBackgroundProcess,-	processTranscript,-	processTranscript', 	withHandle, 	withIOHandles, 	withOEHandles,+	withNullHandle, 	withQuietOutput, 	feedWithQuietOutput, 	createProcess,@@ -54,13 +53,6 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad-#ifndef mingw32_HOST_OS-import qualified System.Posix.IO-#else-import Control.Applicative-#endif-import Data.Maybe-import Prelude  type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -170,68 +162,6 @@ createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p --- | Runs a process, optionally feeding it some input, and--- returns a transcript combining its stdout and stderr, and--- whether it succeeded or failed.-processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)-processTranscript cmd opts = processTranscript' (proc cmd opts)--processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)-processTranscript' cp input = do-#ifndef mingw32_HOST_OS-{- This implementation interleves stdout and stderr in exactly the order- - the process writes them. -}-	(readf, writef) <- System.Posix.IO.createPipe-	readh <- System.Posix.IO.fdToHandle readf-	writeh <- System.Posix.IO.fdToHandle writef-	p@(_, _, _, pid) <- createProcess $ cp-		{ std_in = if isJust input then CreatePipe else Inherit-		, std_out = UseHandle writeh-		, std_err = UseHandle writeh-		}-	hClose writeh--	get <- mkreader readh-	writeinput input p-	transcript <- get--	ok <- checkSuccessProcess pid-	return (transcript, ok)-#else-{- This implementation for Windows puts stderr after stdout. -}-	p@(_, _, _, pid) <- createProcess $ cp-		{ std_in = if isJust input then CreatePipe else Inherit-		, std_out = CreatePipe-		, std_err = CreatePipe-		}--	getout <- mkreader (stdoutHandle p)-	geterr <- mkreader (stderrHandle p)-	writeinput input p-	transcript <- (++) <$> getout <*> geterr--	ok <- checkSuccessProcess pid-	return (transcript, ok)-#endif-  where-	mkreader h = do-		s <- hGetContents h-		v <- newEmptyMVar-		void $ forkIO $ do-			void $ E.evaluate (length s)-			putMVar v ()-		return $ do-			takeMVar v-			return s--	writeinput (Just s) p = do-		let inh = stdinHandle p-		unless (null s) $ do-			hPutStr inh s-			hFlush inh-		hClose inh-	writeinput Nothing _ = return ()- -- | Runs a CreateProcessRunner, on a CreateProcess structure, that -- is adjusted to pipe only from/to a single StdHandle, and passes -- the resulting Handle to an action.@@ -248,13 +178,10 @@ 		, std_out = Inherit 		, std_err = Inherit 		}-	(select, p')-		| h == StdinHandle  =-			(stdinHandle, base { std_in = CreatePipe })-		| h == StdoutHandle =-			(stdoutHandle, base { std_out = CreatePipe })-		| h == StderrHandle =-			(stderrHandle, base { std_err = CreatePipe })+	(select, p') = case h of+		StdinHandle -> (stdinHandle, base { std_in = CreatePipe })+		StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })+		StderrHandle -> (stderrHandle, base { std_err = CreatePipe })  -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles@@ -284,13 +211,16 @@ 		, std_err = CreatePipe 		} +withNullHandle :: (Handle -> IO a) -> IO a+withNullHandle = withFile devNull WriteMode+ -- | Forces the CreateProcessRunner to run quietly; -- both stdout and stderr are discarded. withQuietOutput 	:: CreateProcessRunner 	-> CreateProcess 	-> IO ()-withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do+withQuietOutput creator p = withNullHandle $ \nullh -> do 	let p' = p 		{ std_out = UseHandle nullh 		, std_err = UseHandle nullh@@ -316,7 +246,8 @@ #ifndef mingw32_HOST_OS devNull = "/dev/null" #else-devNull = "NUL"+-- Use device namespace to prevent GHC from rewriting path+devNull = "\\\\.\\NUL" #endif  -- | Extract a desired handle from createProcess's tuple.
Utility/QuickCheck.hs view
@@ -6,7 +6,7 @@  -}  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE TypeSynonymInstances, CPP #-}+{-# LANGUAGE TypeSynonymInstances #-}  module Utility.QuickCheck 	( module X@@ -15,29 +15,24 @@  import Test.QuickCheck as X import Data.Time.Clock.POSIX+import Data.Ratio import System.Posix.Types-#if ! MIN_VERSION_QuickCheck(2,8,2)-import qualified Data.Map as M-import qualified Data.Set as S-#endif-import Control.Applicative+import Data.List.NonEmpty (NonEmpty(..)) import Prelude -#if ! MIN_VERSION_QuickCheck(2,8,2)-instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where-	arbitrary = M.fromList <$> arbitrary--instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where-	arbitrary = S.fromList <$> arbitrary-#endif--{- Times before the epoch are excluded. -}+{- Times before the epoch are excluded. Half with decimal and half without. -} instance Arbitrary POSIXTime where-	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral+	arbitrary = do+		n <- nonNegative arbitrarySizedBoundedIntegral :: Gen Int+		d <- nonNegative arbitrarySizedIntegral+		withd <- arbitrary+		return $ if withd+			then fromIntegral n + fromRational (1 % max d 1)+			else fromIntegral n  {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where-	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)+	arbitrary = positive arbitrarySizedBoundedIntegral  {- Inodes are never negative. -} instance Arbitrary FileID where@@ -46,6 +41,9 @@ {- File sizes are never negative. -} instance Arbitrary FileOffset where 	arbitrary = nonNegative arbitrarySizedIntegral++instance Arbitrary l => Arbitrary (NonEmpty l) where+	arbitrary = (:|) <$> arbitrary <*> arbitrary  nonNegative :: (Num a, Ord a) => Gen a -> Gen a nonNegative g = g `suchThat` (>= 0)
Utility/Rsync.hs view
@@ -7,12 +7,26 @@  {-# LANGUAGE CPP #-} -module Utility.Rsync where+module Utility.Rsync (+	rsyncShell,+	rsyncServerSend,+	rsyncServerReceive,+	rsyncUseDestinationPermissions,+	rsync,+	rsyncUrlIsShell,+	rsyncUrlIsPath,+	rsyncProgress,+	filterRsyncSafeOptions,+) where  import Common import Utility.Metered import Utility.Tuple +#ifdef mingw32_HOST_OS+import qualified System.FilePath.Posix as Posix+#endif+ import Data.Char import System.Console.GetOpt @@ -99,7 +113,16 @@  - The params must enable rsync's --progress mode for this to work.  -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool-rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup+rsyncProgress oh meter ps =+	commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case+		Just ExitSuccess -> return True+		Just (ExitFailure exitcode) -> do+			when (exitcode /= 1) $+				hPutStrLn stderr $ "rsync exited " ++ show exitcode+			return False+		Nothing -> do+			hPutStrLn stderr $ "unable to run rsync"+			return False  {- Strategy: Look for chunks prefixed with \r (rsync writes a \r before  - the first progress output, and each thereafter). The first number@@ -139,3 +162,27 @@ 	[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]   where 	reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""++{- Converts a DOS style path to a msys2 style path. Only on Windows.+ - Any trailing '\' is preserved as a trailing '/' + - + - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i+ -+ - The virtual filesystem contains:+ -  /c, /d, ...	mount points for Windows drives+ -}+#ifdef mingw32_HOST_OS+toMSYS2Path :: FilePath -> FilePath+toMSYS2Path p+	| null drive = recombine parts+	| otherwise = recombine $ "/" : driveletter drive : parts+  where+	(drive, p') = splitDrive p+	parts = splitDirectories p'+	driveletter = map toLower . takeWhile (/= ':')+	recombine = fixtrailing . Posix.joinPath+	fixtrailing s+		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s+		| otherwise = s+#endif+
Utility/SafeCommand.hs view
@@ -7,7 +7,23 @@  {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.SafeCommand where+module Utility.SafeCommand (+	CommandParam(..),+	toCommand,+	boolSystem,+	boolSystem',+	boolSystemEnv,+	safeSystem,+	safeSystem',+	safeSystemEnv,+	shellWrap,+	shellEscape,+	shellUnEscape,+	segmentXargsOrdered,+	segmentXargsUnordered,+	prop_isomorphic_shellEscape,+	prop_isomorphic_shellEscape_multiword,+) where  import System.Exit import Utility.Process@@ -27,19 +43,21 @@ -- | Used to pass a list of CommandParams to a function that runs -- a command and expects Strings. -} toCommand :: [CommandParam] -> [String]-toCommand = map unwrap+toCommand = map toCommand'++toCommand' :: CommandParam -> String+toCommand' (Param s) = s+-- Files that start with a non-alphanumeric that is not a path+-- separator are modified to avoid the command interpreting them as+-- options or other special constructs.+toCommand' (File s@(h:_))+	| isAlphaNum h || h `elem` pathseps = s+	| otherwise = "./" ++ s   where-	unwrap (Param s) = s-	-- Files that start with a non-alphanumeric that is not a path-	-- separator are modified to avoid the command interpreting them as-	-- options or other special constructs.-	unwrap (File s@(h:_))-		| isAlphaNum h || h `elem` pathseps = s-		| otherwise = "./" ++ s-	unwrap (File s) = s 	-- '/' is explicitly included because it's an alternative 	-- path separator on Windows. 	pathseps = pathSeparator:"./"+toCommand' (File s) = s  -- | Run a system command, and returns True or False if it succeeded or failed. --
Utility/Split.hs view
@@ -7,7 +7,12 @@  {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Split where+module Utility.Split (+	split,+	splitc,+	replace,+	dropFromEnd,+) where  import Data.List (intercalate) import Data.List.Split (splitOn)@@ -28,3 +33,7 @@ -- | same as Data.List.Utils.replace replace :: Eq a => [a] -> [a] -> [a] -> [a]  replace old new = intercalate new . split old++-- | Only traverses the list once while dropping the last n items.+dropFromEnd :: Int -> [a] -> [a]+dropFromEnd n l = zipWith const l (drop n l)
Utility/ThreadScheduler.hs view
@@ -8,7 +8,14 @@  {-# LANGUAGE CPP #-} -module Utility.ThreadScheduler where+module Utility.ThreadScheduler (+	Seconds(..),+	Microseconds,+	runEvery,+	threadDelaySeconds,+	waitForTermination,+	oneSecond,+) where  import Control.Monad import Control.Concurrent@@ -18,10 +25,8 @@ #endif #ifndef mingw32_HOST_OS import System.Posix.Signals-#ifndef __ANDROID__ import System.Posix.Terminal #endif-#endif  newtype Seconds = Seconds { fromSeconds :: Int } 	deriving (Eq, Ord, Show)@@ -63,10 +68,8 @@ 	let check sig = void $ 		installHandler sig (CatchOnce $ putMVar lock ()) Nothing 	check softwareTermination-#ifndef __ANDROID__ 	whenM (queryTerminal stdInput) $ 		check keyboardSignal-#endif 	takeMVar lock #endif
Utility/Tmp.hs view
@@ -1,4 +1,4 @@-{- Temporary files and directories.+{- Temporary files.  -  - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -@@ -8,31 +8,33 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.Tmp where+module Utility.Tmp (+	Template,+	viaTmp,+	withTmpFile,+	withTmpFileIn,+	relatedTemplate,+) where  import System.IO-import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class-#ifndef mingw32_HOST_OS-import System.Posix.Temp (mkdtemp)-#endif+import System.PosixCompat.Files  import Utility.Exception import Utility.FileSystemEncoding-import Utility.PosixFiles  type Template = String  {- Runs an action like writeFile, writing to a temp file first and  - then moving it into place. The temp file is stored in the same  - directory as the final file to avoid cross-device renames. -}-viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () viaTmp a file content = bracketIO setup cleanup use   where 	(dir, base) = splitFileName file-	template = base ++ ".tmp"+	template = relatedTemplate (base ++ ".tmp") 	setup = do 		createDirectoryIfMissing True dir 		openTempFile dir template@@ -61,51 +63,6 @@ 		hClose h 		catchBoolIO (removeFile name >> return True) 	use (name, h) = a name h--{- Runs an action with a tmp directory located within the system's tmp- - directory (or within "." if there is none), then removes the tmp- - directory and all its contents. -}-withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a-withTmpDir template a = do-	topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory-#ifndef mingw32_HOST_OS-	-- Use mkdtemp to create a temp directory securely in /tmp.-	bracket-		(liftIO $ mkdtemp $ topleveltmpdir </> template)-		removeTmpDir-		a-#else-	withTmpDirIn topleveltmpdir template a-#endif--{- Runs an action with a tmp directory located within a specified directory,- - then removes the tmp directory and all its contents. -}-withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a-withTmpDirIn tmpdir template = bracketIO create removeTmpDir-  where-	create = do-		createDirectoryIfMissing True tmpdir-		makenewdir (tmpdir </> template) (0 :: Int)-	makenewdir t n = do-		let dir = t ++ "." ++ show n-		catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do-			createDirectory dir-			return dir--{- Deletes the entire contents of the the temporary directory, if it- - exists. -}-removeTmpDir :: MonadIO m => FilePath -> m ()-removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do-#if mingw32_HOST_OS-	-- Windows will often refuse to delete a file-	-- after a process has just written to it and exited.-	-- Because it's crap, presumably. So, ignore failure-	-- to delete the temp directory.-	_ <- tryIO $ removeDirectoryRecursive tmpdir-	return ()-#else-	removeDirectoryRecursive tmpdir-#endif  {- It's not safe to use a FilePath of an existing file as the template  - for openTempFile, because if the FilePath is really long, the tmpfile
+ Utility/Tmp/Dir.hs view
@@ -0,0 +1,70 @@+{- Temporary directories+ -+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Tmp.Dir (+	withTmpDir,+	withTmpDirIn,+) where++import Control.Monad.IfElse+import System.FilePath+import System.Directory+import Control.Monad.IO.Class+#ifndef mingw32_HOST_OS+import System.Posix.Temp (mkdtemp)+#endif++import Utility.Exception+import Utility.Tmp (Template)++{- Runs an action with a tmp directory located within the system's tmp+ - directory (or within "." if there is none), then removes the tmp+ - directory and all its contents. -}+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a+withTmpDir template a = do+	topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory+#ifndef mingw32_HOST_OS+	-- Use mkdtemp to create a temp directory securely in /tmp.+	bracket+		(liftIO $ mkdtemp $ topleveltmpdir </> template)+		removeTmpDir+		a+#else+	withTmpDirIn topleveltmpdir template a+#endif++{- Runs an action with a tmp directory located within a specified directory,+ - then removes the tmp directory and all its contents. -}+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a+withTmpDirIn tmpdir template = bracketIO create removeTmpDir+  where+	create = do+		createDirectoryIfMissing True tmpdir+		makenewdir (tmpdir </> template) (0 :: Int)+	makenewdir t n = do+		let dir = t ++ "." ++ show n+		catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do+			createDirectory dir+			return dir++{- Deletes the entire contents of the the temporary directory, if it+ - exists. -}+removeTmpDir :: MonadIO m => FilePath -> m ()+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do+#if mingw32_HOST_OS+	-- Windows will often refuse to delete a file+	-- after a process has just written to it and exited.+	-- Because it's crap, presumably. So, ignore failure+	-- to delete the temp directory.+	_ <- tryIO $ removeDirectoryRecursive tmpdir+	return ()+#else+	removeDirectoryRecursive tmpdir+#endif
Utility/Tuple.hs view
@@ -5,7 +5,11 @@  - License: BSD-2-clause  -} -module Utility.Tuple where+module Utility.Tuple (+	fst3,+	snd3,+	thd3,+) where  fst3 :: (a,b,c) -> a fst3 (a,_,_) = a
Utility/UserInfo.hs view
@@ -14,12 +14,14 @@ 	myUserGecos, ) where -import Utility.Env-import Utility.Data+import Utility.Env.Basic import Utility.Exception+#ifndef mingw32_HOST_OS+import Utility.Data+import Control.Applicative+#endif  import System.PosixCompat-import Control.Applicative import Prelude  {- Current user's home directory.@@ -45,8 +47,8 @@ #endif  myUserGecos :: IO (Maybe String)--- userGecos crashes on Android and is not available on Windows.-#if defined(__ANDROID__) || defined(mingw32_HOST_OS)+-- userGecos is not available on Windows.+#if defined(mingw32_HOST_OS) myUserGecos = return Nothing #else myUserGecos = eitherToMaybe <$> myVal [] userGecos@@ -55,9 +57,13 @@ myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars   where+	go [] = either (const $ envnotset) (Right . extract) <$> get+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #ifndef mingw32_HOST_OS-	go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)+	-- This may throw an exception if the system doesn't have a+	-- passwd file etc; don't let it crash.+	get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else-	go [] = return $ Left ("environment not set: " ++ show envvars)+	get = return envnotset #endif-	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v+	envnotset = Left ("environment not set: " ++ show envvars)
git-repair.cabal view
@@ -1,12 +1,12 @@ Name: git-repair-Version: 1.20170626+Version: 1.20200102 Cabal-Version: >= 1.8-License: GPL+License: AGPL-3 Maintainer: Joey Hess <joey@kitenet.net> Author: Joey Hess Stability: Stable Copyright: 2013 Joey Hess-License-File: GPL+License-File: COPYRIGHT Build-Type: Custom Homepage: http://git-repair.branchable.com/ Category: Utility@@ -25,13 +25,10 @@   TODO   git-repair.1 -Flag network-uri-  Description: Get Network.URI from the network-uri package-  Default: True- custom-setup-  Setup-Depends: base (>= 4.5), hslogger, split, unix-compat, process,-    unix, filepath, exceptions, bytestring, directory, IfElse, data-default,+  Setup-Depends: base (>= 4.11.1.0 && < 5.0), +    hslogger, split, unix-compat, process, unix, filepath,+    exceptions, bytestring, directory, IfElse, data-default,     mtl, Cabal  source-repository head@@ -41,23 +38,22 @@ Executable git-repair   Main-Is: git-repair.hs   GHC-Options: -threaded -Wall -fno-warn-tabs+  Extensions: LambdaCase   Build-Depends: split, hslogger, directory, filepath, containers, mtl,-   unix-compat, bytestring, exceptions (>= 0.6), transformers,-   base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck,-   utf8-string, async, optparse-applicative (>= 0.10.0),-   data-default--  if flag(network-uri)-    Build-Depends: network-uri (>= 2.6), network (>= 2.6)-  else-    Build-Depends: network (< 2.6), network (>= 2.0)+   unix-compat (>= 0.5), bytestring, exceptions (>= 0.6), transformers,+   base (>= 4.11.1.0 && < 5.0), IfElse, text, process, time, QuickCheck,+   utf8-string, async, optparse-applicative (>= 0.14.1),+   data-default, deepseq, attoparsec,+   network-uri (>= 2.6), network (>= 2.6),+   filepath-bytestring (>= 1.4.2.1.0)    if (os(windows))     Build-Depends: setenv   else-    Build-Depends: unix+    Build-Depends: unix (>= 2.7.2)    Other-Modules:+    BuildInfo     Build.Configure     Build.TestConfig     Build.Version@@ -75,6 +71,7 @@     Git.FilePath     Git.Filename     Git.Fsck+    Git.HashObject     Git.Index     Git.LsFiles     Git.LsTree@@ -88,6 +85,7 @@     Git.UpdateIndex     Git.Url     Git.Version+    Utility.Attoparsec     Utility.Applicative     Utility.Batch     Utility.CoProcess@@ -96,6 +94,8 @@     Utility.Directory     Utility.DottedVersion     Utility.Env+    Utility.Env.Basic+    Utility.Env.Set     Utility.Exception     Utility.FileMode     Utility.FileSize@@ -109,7 +109,6 @@     Utility.PartialPrelude     Utility.Path     Utility.Percentage-    Utility.PosixFiles     Utility.Process     Utility.Process.Shim     Utility.QuickCheck@@ -119,5 +118,6 @@     Utility.SystemDirectory     Utility.ThreadScheduler     Utility.Tmp+    Utility.Tmp.Dir     Utility.Tuple     Utility.UserInfo
git-repair.hs view
@@ -2,7 +2,7 @@  -  - Copyright 2013 Joey Hess <joey@kitenet.net>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  import Options.Applicative@@ -14,8 +14,7 @@ import qualified Git.Construct import qualified Git.Destroyer import qualified Git.Fsck-import Utility.Tmp-import Utility.FileSystemEncoding+import Utility.Tmp.Dir  data Settings = Settings 	{ forced :: Bool