pax_global_header 0000666 0000000 0000000 00000000064 12561161061 0014511 g ustar 00root root 0000000 0000000 52 comment=1f9d8f1cae868492f52f2c704ea15ddda2977d4e
github-backup-1.20150807/ 0000775 0000000 0000000 00000000000 12561161061 0014645 5 ustar 00root root 0000000 0000000 github-backup-1.20150807/.gitattributes 0000664 0000000 0000000 00000000054 12561161061 0017537 0 ustar 00root root 0000000 0000000 debian/changelog merge=dpkg-mergechangelogs
github-backup-1.20150807/Build/ 0000775 0000000 0000000 00000000000 12561161061 0015704 5 ustar 00root root 0000000 0000000 github-backup-1.20150807/Build/Configure.hs 0000664 0000000 0000000 00000001316 12561161061 0020162 0 ustar 00root root 0000000 0000000 {- Checks system configuration and generates SysConfig.hs. -}
module Build.Configure where
import System.Environment
import Control.Applicative
import Control.Monad.IfElse
import Build.TestConfig
import Build.Version
import Git.Version
tests :: [TestCase]
tests =
[ TestCase "version" (Config "version" . StringConfig <$> getVersion)
, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
, TestCase "git version" getGitVersion
]
getGitVersion :: Test
getGitVersion = Config "gitversion" . StringConfig . show
<$> Git.Version.installed
run :: [TestCase] -> IO ()
run ts = do
args <- getArgs
config <- runTests ts
writeSysConfig config
whenM (isReleaseBuild) $
cabalSetup "github-backup.cabal"
github-backup-1.20150807/Build/TestConfig.hs 0000664 0000000 0000000 00000010243 12561161061 0020305 0 ustar 00root root 0000000 0000000 {- Tests the system and generates Build.SysConfig.hs. -}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.TestConfig where
import Utility.Path
import Utility.Monad
import Utility.SafeCommand
import System.IO
import System.FilePath
import System.Directory
type ConfigKey = String
data ConfigValue =
BoolConfig Bool |
StringConfig String |
MaybeStringConfig (Maybe String) |
MaybeBoolConfig (Maybe Bool)
data Config = Config ConfigKey ConfigValue
type Test = IO Config
type TestName = String
data TestCase = TestCase TestName Test
instance Show ConfigValue where
show (BoolConfig b) = show b
show (StringConfig s) = show s
show (MaybeStringConfig s) = show s
show (MaybeBoolConfig s) = show s
instance Show Config where
show (Config key value) = unlines
[ key ++ " :: " ++ valuetype value
, key ++ " = " ++ show value
]
where
valuetype (BoolConfig _) = "Bool"
valuetype (StringConfig _) = "String"
valuetype (MaybeStringConfig _) = "Maybe String"
valuetype (MaybeBoolConfig _) = "Maybe Bool"
writeSysConfig :: [Config] -> IO ()
writeSysConfig config = writeFile "Build/SysConfig.hs" body
where
body = unlines $ header ++ map show config ++ footer
header = [
"{- Automatically generated. -}"
, "module Build.SysConfig where"
, ""
]
footer = []
runTests :: [TestCase] -> IO [Config]
runTests [] = return []
runTests (TestCase tname t : ts) = do
testStart tname
c <- t
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
testCmd k cmdline = do
ok <- boolSystem "sh" [ Param "-c", Param $ quiet cmdline ]
return $ Config k (BoolConfig ok)
{- Ensures that one of a set of commands is available by running each in
- turn. The Config is set to the first one found. -}
selectCmd :: ConfigKey -> [(String, String)] -> Test
selectCmd k = searchCmd
(return . Config k . StringConfig)
(\cmds -> do
testEnd $ Config k $ BoolConfig False
error $ "* need one of these commands, but none are available: " ++ show cmds
)
maybeSelectCmd :: ConfigKey -> [(String, String)] -> Test
maybeSelectCmd k = searchCmd
(return . Config k . MaybeStringConfig . Just)
(\_ -> return $ Config k $ MaybeStringConfig Nothing)
searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test
searchCmd success failure cmdsparams = search cmdsparams
where
search [] = failure $ fst $ unzip cmdsparams
search ((c, params):cs) = do
ok <- boolSystem "sh" [ Param "-c", Param $ quiet $ c ++ " " ++ params ]
if ok
then success c
else search cs
{- Finds a command, either in PATH or perhaps in a sbin directory not in
- PATH. If it's in PATH the config is set to just the command name,
- but if it's found outside PATH, the config is set to the full path to
- the command. -}
findCmdPath :: ConfigKey -> String -> Test
findCmdPath k command = do
ifM (inPath command)
( return $ Config k $ MaybeStringConfig $ Just command
, do
r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"]
return $ Config k $ MaybeStringConfig r
)
where
find d =
let f = d command
in ifM (doesFileExist f) ( return (Just f), return Nothing )
quiet :: String -> String
quiet s = s ++ " >/dev/null 2>&1"
testStart :: TestName -> IO ()
testStart s = do
putStr $ " checking " ++ s ++ "..."
hFlush stdout
testEnd :: Config -> IO ()
testEnd (Config _ (BoolConfig True)) = status "yes"
testEnd (Config _ (BoolConfig False)) = status "no"
testEnd (Config _ (StringConfig s)) = status s
testEnd (Config _ (MaybeStringConfig (Just s))) = status s
testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"
testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"
testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"
testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"
status :: String -> IO ()
status s = putStrLn $ ' ':s
github-backup-1.20150807/Build/Version.hs 0000664 0000000 0000000 00000004071 12561161061 0017667 0 ustar 00root root 0000000 0000000 {- Package version determination, for configure script. -}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.Version where
import Data.Maybe
import Control.Applicative
import Data.List
import System.Environment
import System.Directory
import Data.Char
import System.Process
import Utility.Monad
import Utility.Exception
type Version = String
{- Set when making an official release. (Distribution vendors should set
- this too.) -}
isReleaseBuild :: IO Bool
isReleaseBuild = (== Just "1") <$> catchMaybeIO (getEnv "RELEASE_BUILD")
{- Version is usually based on the major version from the changelog,
- plus the date of the last commit, plus the git rev of that commit.
- This works for autobuilds, ad-hoc builds, etc.
-
- If git or a git repo is not available, or something goes wrong,
- or this is a release build, just use the version from the changelog. -}
getVersion :: IO Version
getVersion = do
changelogversion <- getChangelogVersion
ifM (isReleaseBuild)
( return changelogversion
, catchDefaultIO changelogversion $ do
let major = takeWhile (/= '.') changelogversion
autoversion <- takeWhile (\c -> isAlphaNum c || c == '-') <$> readProcess "sh"
[ "-c"
, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"
] ""
if null autoversion
then return changelogversion
else return $ concat [ major, ".", autoversion ]
)
getChangelogVersion :: IO Version
getChangelogVersion = do
changelog <- readFile "debian/changelog"
let verline = takeWhile (/= '\n') changelog
return $ middle (words verline !! 1)
where
middle = drop 1 . init
{- Set up cabal file with version. -}
cabalSetup :: FilePath -> IO ()
cabalSetup cabalfile = do
version <- takeWhile (\c -> isDigit c || c == '.')
<$> getChangelogVersion
cabal <- readFile cabalfile
writeFile tmpcabalfile $ unlines $
map (setfield "Version" version) $
lines cabal
renameFile tmpcabalfile cabalfile
where
tmpcabalfile = cabalfile++".tmp"
setfield field value s
| fullfield `isPrefixOf` s = fullfield ++ value
| otherwise = s
where
fullfield = field ++ ": "
github-backup-1.20150807/Build/make-sdist.sh 0000775 0000000 0000000 00000001252 12561161061 0020304 0 ustar 00root root 0000000 0000000 #!/bin/sh
#
# Workaround for `cabal sdist` requiring all included files to be listed
# in .cabal.
# Create target directory
sdist_dir=github-backup-$(grep '^Version:' github-backup.cabal | sed -re 's/Version: *//')
mkdir --parents dist/$sdist_dir
find . \( -name .git -or -name dist -or -name cabal-dev \) -prune \
-or -not -name \\*.orig -not -type d -print \
| perl -ne "print unless length >= 100 - length q{$sdist_dir}" \
| xargs cp --parents --target-directory dist/$sdist_dir
cd dist
tar --format=ustar -caf $sdist_dir.tar.gz $sdist_dir
# Check that tarball can be unpacked by cabal.
# It's picky about tar longlinks etc.
rm -rf $sdist_dir
cabal unpack $sdist_dir.tar.gz
github-backup-1.20150807/CHANGELOG 0000777 0000000 0000000 00000000000 12561161061 0021146 2debian/changelog ustar 00root root 0000000 0000000 github-backup-1.20150807/COPYRIGHT 0000777 0000000 0000000 00000000000 12561161061 0021310 2debian/copyright ustar 00root root 0000000 0000000 github-backup-1.20150807/Common.hs 0000664 0000000 0000000 00000001610 12561161061 0016427 0 ustar 00root root 0000000 0000000 {-# LANGUAGE PackageImports, CPP #-}
module Common (module X) where
import Control.Monad as X
import Control.Monad.IfElse as X
import Control.Applicative as X
import "mtl" Control.Monad.State.Strict as X (liftIO)
import Data.Maybe as X
import Data.List as X hiding (head, tail, init, last)
import Data.String.Utils as X hiding (join)
import System.FilePath as X
import System.Directory as X
import System.IO as X hiding (FilePath)
import System.PosixCompat.Files as X
#ifndef mingw32_HOST_OS
import System.Posix.IO as X hiding (createPipe)
#endif
import System.Exit as X
import Utility.Misc as X
import Utility.Exception as X
import Utility.SafeCommand as X
import Utility.Process as X
import Utility.Path as X
import Utility.Directory as X
import Utility.Monad as X
import Utility.Data as X
import Utility.Applicative as X
import Utility.FileSystemEncoding as X
import Utility.PartialPrelude as X
github-backup-1.20150807/GPL 0000664 0000000 0000000 00000104513 12561161061 0015216 0 ustar 00root root 0000000 0000000 GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
Copyright (C)
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
.
The GNU General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
.
github-backup-1.20150807/Git.hs 0000664 0000000 0000000 00000011257 12561161061 0015732 0 ustar 00root root 0000000 0000000 {- git repository handling
-
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- Copyright 2010-2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Git (
Repo(..),
Ref(..),
fromRef,
Branch,
Sha,
Tag,
repoIsUrl,
repoIsSsh,
repoIsHttp,
repoIsLocal,
repoIsLocalBare,
repoIsLocalUnknown,
repoDescribe,
repoLocation,
repoPath,
localGitDir,
attributes,
hookPath,
assertLocal,
adjustPath,
relPath,
) where
import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
import Common
import Git.Types
#ifndef mingw32_HOST_OS
import Utility.FileMode
#endif
{- User-visible description of a git repo. -}
repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = Local { worktree = Just dir } } = dir
repoDescribe Repo { location = Local { gitdir = dir } } = dir
repoDescribe Repo { location = LocalUnknown dir } = dir
repoDescribe Repo { location = Unknown } = "UNKNOWN"
{- Location of the repo, either as a path or url. -}
repoLocation :: Repo -> String
repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = Local { worktree = Just dir } } = dir
repoLocation Repo { location = Local { gitdir = dir } } = dir
repoLocation Repo { location = LocalUnknown dir } = 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 { 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"
{- Path to a local repository's .git directory. -}
localGitDir :: Repo -> FilePath
localGitDir Repo { location = Local { gitdir = d } } = d
localGitDir _ = error "unknown localGitDir"
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True
repoIsUrl _ = False
repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url }
| scheme == "ssh:" = True
-- git treats these the same as ssh
| scheme == "git+ssh:" = True
| scheme == "ssh+git:" = True
| otherwise = False
where
scheme = uriScheme url
repoIsSsh _ = False
repoIsHttp :: Repo -> Bool
repoIsHttp Repo { location = Url url }
| uriScheme url == "http:" = True
| uriScheme url == "https:" = True
| otherwise = False
repoIsHttp _ = False
repoIsLocal :: Repo -> Bool
repoIsLocal Repo { location = Local { } } = True
repoIsLocal _ = False
repoIsLocalBare :: Repo -> Bool
repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True
repoIsLocalBare _ = False
repoIsLocalUnknown :: Repo -> Bool
repoIsLocalUnknown Repo { location = LocalUnknown { } } = True
repoIsLocalUnknown _ = False
assertLocal :: Repo -> a -> a
assertLocal repo action
| repoIsUrl repo = error $ unwords
[ "acting on non-local git repo"
, repoDescribe repo
, "not supported"
]
| otherwise = action
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> FilePath
attributes repo
| repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes"
| otherwise = repoPath repo ++ "/.gitattributes"
{- 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
ifM (catchBoolIO $ isexecutable hook)
( return $ Just hook , return Nothing )
where
#if mingw32_HOST_OS
isexecutable f = doesFileExist f
#else
isexecutable f = isExecutable . fileMode <$> getFileStatus f
#endif
{- Makes the path to a local Repo be relative to the cwd. -}
relPath :: Repo -> IO Repo
relPath = adjustPath torel
where
torel p = do
p' <- relPathCwdToFile p
if null p'
then return "."
else return 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
return $ r
{ location = l
{ gitdir = d'
, worktree = w'
}
}
adjustPath f r@(Repo { location = LocalUnknown d }) = do
d' <- f d
return $ r { location = LocalUnknown d' }
adjustPath _ r = pure r
github-backup-1.20150807/Git/ 0000775 0000000 0000000 00000000000 12561161061 0015370 5 ustar 00root root 0000000 0000000 github-backup-1.20150807/Git/Branch.hs 0000664 0000000 0000000 00000013514 12561161061 0017125 0 ustar 00root root 0000000 0000000 {- git branch stuff
-
- Copyright 2011 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Git.Branch where
import Common
import Git
import Git.Sha
import Git.Command
import qualified Git.Ref
import qualified Git.BuildVersion
{- 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
- to double-check.
-}
current :: Repo -> IO (Maybe Git.Ref)
current r = do
v <- currentUnsafe r
case v of
Nothing -> return Nothing
Just branch ->
ifM (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 Git.Ref)
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
{- Checks if the second branch has any commits not present on the first
- branch. -}
changed :: Branch -> Branch -> Repo -> IO Bool
changed origbranch newbranch repo
| origbranch == newbranch = return False
| otherwise = not . null <$> diffs
where
diffs = pipeReadStrict
[ Param "log"
, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
, Param "-n1"
, Param "--pretty=%H"
] repo
{- Check if it's possible to fast-forward from the old
- ref to the new ref.
-
- 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 <$>
pipeReadStrict
[ Param "log"
, Param $ fromRef old ++ ".." ++ fromRef new
, Param "-n1"
, Param "--pretty=%H"
, Param "--ancestry-path"
] repo
{- Given a set of refs that are all known to have commits not
- on the branch, tries to update the branch by a fast-forward.
-
- In order for that to be possible, one of the refs must contain
- every commit present in all the other refs.
-}
fastForward :: Branch -> [Ref] -> Repo -> IO Bool
fastForward _ [] _ = return True
fastForward branch (first:rest) repo =
-- First, check that the branch does not contain any
-- new commits that are not in the first ref. If it does,
-- cannot fast-forward.
ifM (changed first branch repo)
( no_ff
, maybe no_ff do_ff =<< findbest first rest
)
where
no_ff = return False
do_ff to = do
update branch to repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
| c == r = findbest c rs
| otherwise = do
better <- changed c r repo
worse <- changed r c repo
case (better, worse) of
(True, True) -> return Nothing -- divergent fail
(True, False) -> findbest r rs -- better
(False, True) -> findbest c rs -- worse
(False, False) -> findbest c rs -- same
{- The user may have set commit.gpgsign, indending all their manual
- commits to be signed. But signing automatic/background commits could
- easily lead to unwanted gpg prompts or failures.
-}
data CommitMode = ManualCommit | AutomaticCommit
deriving (Eq)
applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]
applyCommitMode commitmode ps
| commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =
Param "--no-gpg-sign" : ps
| otherwise = ps
{- Commit via the usual git command. -}
commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
commitCommand = commitCommand' runBool
{- Commit will fail when the tree is clean. This suppresses that error. -}
commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO ()
commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps
commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
commitCommand' runner commitmode ps = runner $
Param "commit" : applyCommitMode commitmode ps
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha.
-
- Without allowempy set, avoids making a commit if there is exactly
- one parent, and it has the same tree that would be committed.
-
- Unlike git-commit, does not run any hooks, or examine the work tree
- in any way.
-}
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
ifM (cancommit tree)
( do
sha <- getSha "commit-tree" $
pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo
update branch sha repo
return $ Just sha
, return Nothing
)
where
ps = applyCommitMode commitmode $
map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
cancommit tree
| allowempty = return True
| otherwise = case parentrefs of
[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
_ -> return True
sendmsg = Just $ flip hPutStr message
commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
commitAlways commitmode message branch parentrefs repo = fromJust
<$> commit commitmode True message branch parentrefs repo
{- A leading + makes git-push force pushing a branch. -}
forcePush :: String -> String
forcePush b = "+" ++ b
{- Updates a branch (or other ref) to a new Sha. -}
update :: Branch -> Sha -> Repo -> IO ()
update branch sha = run
[ Param "update-ref"
, Param $ fromRef branch
, Param $ fromRef sha
]
{- Checks out a branch, creating it if necessary. -}
checkout :: Branch -> Repo -> IO ()
checkout branch = run
[ Param "checkout"
, Param "-q"
, Param "-B"
, Param $ fromRef $ Git.Ref.base branch
]
{- Removes a branch. -}
delete :: Branch -> Repo -> IO ()
delete branch = run
[ Param "branch"
, Param "-q"
, Param "-D"
, Param $ fromRef $ Git.Ref.base branch
]
github-backup-1.20150807/Git/BuildVersion.hs 0000664 0000000 0000000 00000001113 12561161061 0020325 0 ustar 00root root 0000000 0000000 {- git build version
-
- Copyright 2011 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.BuildVersion where
import Git.Version
import qualified Build.SysConfig
{- 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
older :: String -> Bool
older n = buildVersion < normalize n
github-backup-1.20150807/Git/CatFile.hs 0000664 0000000 0000000 00000006507 12561161061 0017243 0 ustar 00root root 0000000 0000000 {- git cat-file interface
-
- Copyright 2011, 2013 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.CatFile (
CatFileHandle,
catFileStart,
catFileStart',
catFileStop,
catFile,
catFileDetails,
catTree,
catObject,
catObjectDetails,
) where
import System.IO
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Tuple.Utils
import Numeric
import System.Posix.Types
import Common
import Git
import Git.Sha
import Git.Command
import Git.Types
import Git.FilePath
import qualified Utility.CoProcess as CoProcess
data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo
catFileStart :: Repo -> IO CatFileHandle
catFileStart = catFileStart' True
catFileStart' :: Bool -> Repo -> IO CatFileHandle
catFileStart' restartable repo = do
coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable
[ Param "cat-file"
, Param "--batch"
] repo
return $ CatFileHandle coprocess repo
catFileStop :: CatFileHandle -> IO ()
catFileStop (CatFileHandle p _) = CoProcess.stop p
{- Reads a file from a specified branch. -}
catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
catFile h branch file = catObject h $ Ref $
fromRef branch ++ ":" ++ toInternalGitPath file
catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
catFileDetails h branch file = catObjectDetails h $ Ref $
fromRef branch ++ ":" ++ toInternalGitPath file
{- Uses a running git cat-file read the content of an object.
- Objects that do not exist will have "" returned. -}
catObject :: CatFileHandle -> Ref -> IO L.ByteString
catObject h object = maybe L.empty fst3 <$> catObjectDetails h object
catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive
where
query = fromRef object
send to = hPutStrLn to query
receive from = do
header <- hGetLine from
case words header of
[sha, objtype, size]
| length sha == shaSize ->
case (readObjectType objtype, reads size) of
(Just t, [(bytes, "")]) -> readcontent t bytes from sha
_ -> dne
| otherwise -> dne
_
| header == fromRef object ++ " missing" -> dne
| otherwise -> error $ "unknown response from git cat-file " ++ show (header, query)
readcontent objtype bytes from sha = do
content <- S.hGet from bytes
eatchar '\n' from
return $ Just (L.fromChunks [content], Ref sha, objtype)
dne = return Nothing
eatchar expected from = do
c <- hGetChar from
when (c /= expected) $
error $ "missing " ++ (show expected) ++ " from git cat-file"
{- 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
where
go (Just (b, _, TreeObject)) = parsetree [] b
go _ = []
parsetree c b = case L.break (== 0) b of
(modefile, rest)
| L.null modefile -> c
| otherwise -> parsetree
(parsemodefile modefile:c)
(dropsha rest)
-- these 20 bytes after the NUL hold the file's sha
-- TODO: convert from raw form to regular sha
dropsha = L.drop 21
parsemodefile b =
let (modestr, file) = separate (== ' ') (decodeBS b)
in (file, readmode modestr)
readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
github-backup-1.20150807/Git/Command.hs 0000664 0000000 0000000 00000010621 12561161061 0017302 0 ustar 00root root 0000000 0000000 {- running git commands
-
- Copyright 2010-2013 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Git.Command where
import Common
import Git
import Git.Types
import qualified Utility.CoProcess as CoProcess
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
gitCommandLine params r@(Repo { location = l@(Local { } ) }) =
setdir : settree ++ gitGlobalOpts r ++ params
where
setdir = Param $ "--git-dir=" ++ gitdir l
settree = case worktree l of
Nothing -> []
Just t -> [Param $ "--work-tree=" ++ t]
gitCommandLine _ repo = assertLocal repo $ error "internal"
{- Runs git in the specified repo. -}
runBool :: [CommandParam] -> Repo -> IO Bool
runBool params repo = assertLocal repo $
boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)
{- Runs git in the specified repo, throwing an error if it fails. -}
run :: [CommandParam] -> Repo -> IO ()
run params repo = assertLocal repo $
unlessM (runBool params repo) $
error $ "git " ++ show params ++ " failed"
{- Runs git and forces it to be quiet, throwing an error if it fails. -}
runQuiet :: [CommandParam] -> Repo -> IO ()
runQuiet params repo = withQuietOutput createProcessSuccess $
(proc "git" $ toCommand $ gitCommandLine (params) repo)
{ env = gitEnv repo }
{- 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
- return True if it succeeded. Failure to wait will result in zombies.
-}
pipeReadLazy :: [CommandParam] -> Repo -> IO (String, IO Bool)
pipeReadLazy params repo = assertLocal repo $ do
(_, Just h, _, pid) <- createProcess p { std_out = CreatePipe }
fileEncoding h
c <- hGetContents h
return (c, checkSuccessProcess pid)
where
p = gitCreateProcess params repo
{- Runs a git command, and returns its output, strictly.
-
- Nonzero exit status is ignored.
-}
pipeReadStrict :: [CommandParam] -> Repo -> IO String
pipeReadStrict params repo = assertLocal repo $
withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do
fileEncoding h
output <- hGetContentsStrict h
hClose h
return output
where
p = gitCreateProcess params repo
{- Runs a git command, feeding it an input, and returning its output,
- which is expected to be fairly small, since it's all read into memory
- strictly. -}
pipeWriteRead :: [CommandParam] -> Maybe (Handle -> IO ()) -> Repo -> IO String
pipeWriteRead params writer repo = assertLocal repo $
writeReadProcessEnv "git" (toCommand $ gitCommandLine params repo)
(gitEnv repo) writer (Just adjusthandle)
where
adjusthandle h = do
fileEncoding h
hSetNewlineMode h noNewlineTranslation
{- 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
{- 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 params repo = do
(s, cleanup) <- pipeReadLazy params repo
return (filter (not . null) $ split sep s, cleanup)
where
sep = "\0"
pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String]
pipeNullSplitStrict params repo = do
s <- pipeReadStrict params repo
return $ filter (not . null) $ split sep s
where
sep = "\0"
pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String]
pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo
{- Doesn't run the cleanup action. A zombie results. -}
leaveZombie :: (a, IO Bool) -> a
leaveZombie = fst
{- Runs a git command as a coprocess. -}
gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle
gitCoProcessStart restartable params repo = CoProcess.start numrestarts "git"
(toCommand $ gitCommandLine params repo)
(gitEnv repo)
where
{- If a long-running git command like cat-file --batch
- crashes, it will likely start up again ok. If it keeps crashing
- 10 times, something is badly wrong. -}
numrestarts = if restartable then 10 else 0
gitCreateProcess :: [CommandParam] -> Repo -> CreateProcess
gitCreateProcess params repo =
(proc "git" $ toCommand $ gitCommandLine params repo)
{ env = gitEnv repo }
github-backup-1.20150807/Git/Config.hs 0000664 0000000 0000000 00000014300 12561161061 0017127 0 ustar 00root root 0000000 0000000 {- git repository configuration handling
-
- Copyright 2010-2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.Config where
import qualified Data.Map as M
import Data.Char
import Common
import Git
import Git.Types
import qualified Git.Construct
import qualified Git.Command
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 list with each line of a multiline config setting. -}
getList :: String -> Repo -> [String]
getList key repo = M.findWithDefault [] key (fullconfig repo)
{- Returns a single git config setting, if set. -}
getMaybe :: String -> Repo -> Maybe String
getMaybe key repo = M.lookup key (config repo)
{- Runs git config and populates a repo with its config.
- Avoids re-reading config when run repeatedly. -}
read :: Repo -> IO Repo
read repo@(Repo { config = c })
| c == M.empty = read' repo
| otherwise = return repo
{- Reads config even if it was read before. -}
reRead :: Repo -> IO Repo
reRead r = read' $ r
{ config = M.empty
, fullconfig = M.empty
}
{- Cannot use pipeRead because it relies on the config having been already
- read. Instead, chdir to the repo and run git config.
-}
read' :: Repo -> IO Repo
read' repo = go repo
where
go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal"
git_config d = withHandle StdoutHandle createProcessSuccess p $
hRead repo
where
params = ["config", "--null", "--list"]
p = (proc "git" params)
{ cwd = Just d
, env = gitEnv repo
}
{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
global = do
home <- myHomeDir
ifM (doesFileExist $ home ".gitconfig")
( do
repo <- withHandle StdoutHandle createProcessSuccess p $
hRead (Git.Construct.fromUnknown)
return $ Just repo
, return Nothing
)
where
params = ["config", "--null", "--list", "--global"]
p = (proc "git" params)
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo
hRead repo h = do
-- We use the FileSystemEncoding when reading from git-config,
-- because it can contain arbitrary filepaths (and other strings)
-- in any encoding.
fileEncoding h
val <- hGetContentsStrict h
store val repo
{- Stores a git config into a Repo, returning the new version of the Repo.
- The git config may be multiple lines, or a single line.
- Config settings can be updated incrementally.
-}
store :: String -> Repo -> IO Repo
store s repo = do
let c = parse s
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 }
{- Updates the location of a repo, based on its configuration.
-
- Git.Construct makes LocalUknown repos, of which only a directory is
- known. Once the config is read, this can be fixed up to a Local repo,
- based on the core.bare and core.worktree settings.
-}
updateLocation :: Repo -> IO Repo
updateLocation r@(Repo { location = LocalUnknown d })
| isBare r = ifM (doesDirectoryExist dotgit)
( updateLocation' r $ Local dotgit Nothing
, updateLocation' r $ Local d Nothing
)
| otherwise = updateLocation' r $ Local dotgit (Just d)
where
dotgit = (d ".git")
updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
updateLocation r = return r
updateLocation' :: Repo -> RepoLocation -> IO Repo
updateLocation' r l = do
l' <- case getMaybe "core.worktree" r of
Nothing -> return l
Just d -> do
{- core.worktree is relative to the gitdir -}
top <- absPath $ gitdir l
return $ l { worktree = Just $ absPathFrom top d }
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
-- --list output will have an = in the first line
| all ('=' `elem`) (take 1 ls) = sep '=' ls
-- --null --list output separates keys from values with newlines
| otherwise = sep '\n' $ split "\0" s
where
ls = lines s
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
map (separate (== c))
{- Checks if a string from git config is a true value. -}
isTrue :: String -> Maybe Bool
isTrue s
| s' == "true" = Just True
| s' == "false" = Just False
| otherwise = Nothing
where
s' = map toLower s
boolConfig :: Bool -> String
boolConfig True = "true"
boolConfig False = "false"
isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r
coreBare :: String
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 r cmd params = try $
withHandle StdoutHandle createProcessSuccess p $ \h -> do
fileEncoding h
val <- hGetContentsStrict h
r' <- store val r
return (r', val)
where
p = proc cmd $ toCommand params
{- Reads git config from a specified file and returns the repo populated
- with the configuration. -}
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String))
fromFile r f = fromPipe r "git"
[ Param "config"
, Param "--file"
, File f
, Param "--list"
]
{- 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"
[ Param "config"
, Param "--file"
, File f
, Param k
, Param v
]
{- Unsets a git config setting, in both the git repo,
- and the cached config in the Repo.
-
- 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) }
, return Nothing
)
where
ps = [Param "config", Param "--unset-all", Param k]
github-backup-1.20150807/Git/Construct.hs 0000664 0000000 0000000 00000014700 12561161061 0017712 0 ustar 00root root 0000000 0000000 {- Construction of Git Repo objects
-
- Copyright 2010-2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Git.Construct (
fromCwd,
fromAbsPath,
fromPath,
fromUrl,
fromUnknown,
localToUrl,
remoteNamed,
remoteNamedFromKey,
fromRemotes,
fromRemoteLocation,
repoAbsPath,
checkForRepo,
newFrom,
) where
#ifndef mingw32_HOST_OS
import System.Posix.User
#endif
import qualified Data.Map as M hiding (map, split)
import Network.URI
import Common
import Git.Types
import Git
import Git.Remote
import Git.FilePath
import qualified Git.Url as Url
import Utility.UserInfo
{- Finds the git repository used for the cwd, which may be in a parent
- directory. -}
fromCwd :: IO (Maybe Repo)
fromCwd = getCurrentDirectory >>= seekUp
where
seekUp dir = do
r <- checkForRepo dir
case r of
Nothing -> case upFrom dir of
Nothing -> return Nothing
Just d -> seekUp d
Just loc -> pure $ Just $ newFrom loc
{- Local Repo constructor, accepts a relative or absolute path. -}
fromPath :: FilePath -> IO Repo
fromPath dir = fromAbsPath =<< absPath dir
{- Local Repo constructor, requires an absolute path to the repo be
- specified. -}
fromAbsPath :: FilePath -> IO Repo
fromAbsPath dir
| absoluteGitPath dir = ifM (doesDirectoryExist dir') ( ret dir' , hunt )
| otherwise =
error $ "internal error, " ++ dir ++ " is not absolute"
where
ret = pure . newFrom . LocalUnknown
{- Git always looks for "dir.git" in preference to
- to "dir", even if dir ends in a "/". -}
canondir = dropTrailingPathSeparator dir
dir' = canondir ++ ".git"
{- When dir == "foo/.git", git looks for "foo/.git/.git",
- and failing that, uses "foo" as the repository. -}
hunt
| (pathSeparator:".git") `isSuffixOf` canondir =
ifM (doesDirectoryExist $ dir ".git")
( ret dir
, ret $ takeDirectory canondir
)
| otherwise = ret dir
{- Remote Repo constructor. Throws exception on invalid url.
-
- Git is somewhat forgiving about urls to repositories, allowing
- eg spaces that are not normally allowed unescaped in urls.
-}
fromUrl :: String -> IO Repo
fromUrl url
| not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
| otherwise = fromUrlStrict url
fromUrlStrict :: String -> IO Repo
fromUrlStrict url
| startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u
| otherwise = pure $ newFrom $ Url u
where
u = fromMaybe bad $ parseURI url
bad = error $ "bad url " ++ url
{- Creates a repo that has an unknown location. -}
fromUnknown :: Repo
fromUnknown = newFrom Unknown
{- Converts a local Repo into a remote repo, using the reference repo
- which is assumed to be on the same host. -}
localToUrl :: Repo -> Repo -> Repo
localToUrl reference r
| not $ repoIsUrl reference = error "internal error; reference repo not url"
| repoIsUrl r = r
| otherwise = case Url.authority reference of
Nothing -> r
Just auth ->
let absurl = concat
[ Url.scheme reference
, "//"
, auth
, repoPath r
]
in r { location = Url $ fromJust $ parseURI absurl }
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
fromRemotes :: Repo -> IO [Repo]
fromRemotes repo = mapM construct remotepairs
where
filterconfig f = filter f $ M.toList $ config repo
filterkeys f = filterconfig (\(k,_) -> f k)
remotepairs = filterkeys isremote
isremote k = startswith "remote." k && endswith ".url" k
construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo
{- Sets the name of a remote when constructing the Repo to represent it. -}
remoteNamed :: String -> IO Repo -> IO Repo
remoteNamed n constructor = do
r <- constructor
return $ r { remoteName = Just n }
{- Sets the name of a remote based on the git config key, such as
- "remote.foo.url". -}
remoteNamedFromKey :: String -> IO Repo -> IO Repo
remoteNamedFromKey k = remoteNamed basename
where
basename = intercalate "." $
reverse $ drop 1 $ reverse $ drop 1 $ split "." k
{- Constructs a new Repo for one of a Repo's remotes using a given
- location (ie, an url). -}
fromRemoteLocation :: String -> Repo -> IO Repo
fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
where
gen (RemotePath p) = fromRemotePath p repo
gen (RemoteUrl u) = fromUrl u
{- Constructs a Repo from the path specified in the git remotes of
- another Repo. -}
fromRemotePath :: FilePath -> Repo -> IO Repo
fromRemotePath dir repo = do
dir' <- expandTilde dir
fromPath $ repoPath repo dir'
{- Git remotes can have a directory that is specified relative
- to the user's home directory, or that contains tilde expansions.
- This converts such a directory to an absolute path.
- Note that it has to run on the system where the remote is.
-}
repoAbsPath :: FilePath -> IO FilePath
repoAbsPath d = do
d' <- expandTilde d
h <- myHomeDir
return $ h d'
expandTilde :: FilePath -> IO FilePath
#ifdef mingw32_HOST_OS
expandTilde = return
#else
expandTilde = expandt True
where
expandt _ [] = return ""
expandt _ ('/':cs) = do
v <- expandt True cs
return ('/':v)
expandt True ('~':'/':cs) = do
h <- myHomeDir
return $ h cs
expandt True ('~':cs) = do
let (name, rest) = findname "" cs
u <- getUserEntryForName name
return $ homeDirectory u rest
expandt _ (c:cs) = do
v <- expandt False cs
return (c:v)
findname n [] = (n, "")
findname n (c:cs)
| c == '/' = (n, cs)
| otherwise = findname (n++[c]) cs
#endif
{- Checks if a git repository exists in a directory. Does not find
- git repositories in parent directories. -}
checkForRepo :: FilePath -> IO (Maybe RepoLocation)
checkForRepo dir =
check isRepo $
check gitDirFile $
check isBareRepo $
return Nothing
where
check test cont = maybe cont (return . Just) =<< test
checkdir c = ifM c
( return $ Just $ LocalUnknown dir
, return Nothing
)
isRepo = checkdir $ gitSignature $ ".git" "config"
isBareRepo = checkdir $ gitSignature "config"
<&&> doesDirectoryExist (dir "objects")
gitDirFile = do
c <- firstLine <$>
catchDefaultIO "" (readFile $ dir ".git")
return $ if gitdirprefix `isPrefixOf` c
then Just $ Local
{ gitdir = absPathFrom dir $
drop (length gitdirprefix) c
, worktree = Just dir
}
else Nothing
where
gitdirprefix = "gitdir: "
gitSignature file = doesFileExist $ dir file
newFrom :: RepoLocation -> Repo
newFrom l = Repo
{ location = l
, config = M.empty
, fullconfig = M.empty
, remotes = []
, remoteName = Nothing
, gitEnv = Nothing
, gitGlobalOpts = []
}
github-backup-1.20150807/Git/DiffTreeItem.hs 0000664 0000000 0000000 00000000740 12561161061 0020234 0 ustar 00root root 0000000 0000000 {- git diff-tree item
-
- Copyright 2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.DiffTreeItem (
DiffTreeItem(..),
) where
import System.Posix.Types
import Git.FilePath
import Git.Types
data DiffTreeItem = DiffTreeItem
{ srcmode :: FileMode
, dstmode :: FileMode
, srcsha :: Sha -- nullSha if file was added
, dstsha :: Sha -- nullSha if file was deleted
, status :: String
, file :: TopFilePath
} deriving Show
github-backup-1.20150807/Git/FilePath.hs 0000664 0000000 0000000 00000004050 12561161061 0017417 0 ustar 00root root 0000000 0000000 {- git FilePath library
-
- Different git commands use different types of FilePaths to refer to
- files in the repository. Some commands use paths relative to the
- top of the repository even when run in a subdirectory. Adding some
- types helps keep that straight.
-
- Copyright 2012-2013 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Git.FilePath (
TopFilePath,
fromTopFilePath,
getTopFilePath,
toTopFilePath,
asTopFilePath,
InternalGitPath,
toInternalGitPath,
fromInternalGitPath,
absoluteGitPath
) where
import Common
import Git
import qualified System.FilePath.Posix
{- A FilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
deriving (Show)
{- Returns an absolute FilePath. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
fromTopFilePath p repo = absPathFrom (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
{- The input FilePath must already be relative to the top of the git
- repository -}
asTopFilePath :: FilePath -> TopFilePath
asTopFilePath file = TopFilePath file
{- Git may use a different representation of a path when storing
- it internally.
-
- On Windows, git uses '/' to separate paths stored in the repository,
- despite Windows using '\'.
-
-}
type InternalGitPath = String
toInternalGitPath :: FilePath -> InternalGitPath
#ifndef mingw32_HOST_OS
toInternalGitPath = id
#else
toInternalGitPath = replace "\\" "/"
#endif
fromInternalGitPath :: InternalGitPath -> FilePath
#ifndef mingw32_HOST_OS
fromInternalGitPath = id
#else
fromInternalGitPath = replace "/" "\\"
#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)
github-backup-1.20150807/Git/HashObject.hs 0000664 0000000 0000000 00000003313 12561161061 0017736 0 ustar 00root root 0000000 0000000 {- git hash-object interface
-
- Copyright 2011-2014 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
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
type HashObjectHandle = CoProcess.CoProcessHandle
hashObjectStart :: Repo -> IO HashObjectHandle
hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart True
[ Param "hash-object"
, Param "-w"
, Param "--stdin-paths"
, 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
{- Injects a blob into git. Unfortunately, the current git-hash-object
- interface does not allow batch hashing without using temp files. -}
hashBlob :: HashObjectHandle -> String -> IO Sha
hashBlob h s = withTmpFile "hash" $ \tmp tmph -> do
hPutStr tmph s
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", show objtype, "-w", "--stdin", "--no-filters"]
github-backup-1.20150807/Git/Queue.hs 0000664 0000000 0000000 00000012164 12561161061 0017014 0 ustar 00root root 0000000 0000000 {- git repository command queue
-
- Copyright 2010,2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP, BangPatterns #-}
module Git.Queue (
Queue,
new,
addCommand,
addUpdateIndex,
size,
full,
flush,
) where
import Utility.SafeCommand
import Common
import Git
import Git.Command
import qualified Git.UpdateIndex
import qualified Data.Map as M
{- Queable actions that can be performed in a git repository.
-}
data Action
{- Updating the index file, using a list of streamers that can
- be added to as the queue grows. -}
= UpdateIndexAction
{ getStreamers :: [Git.UpdateIndex.Streamer] -- in reverse order
}
{- A git command to run, on a list of files that can be added to
- as the queue grows. -}
| CommandAction
{ getSubcommand :: String
, getParams :: [CommandParam]
, getFiles :: [CommandParam]
}
{- A key that can uniquely represent an action in a Map. -}
data ActionKey = UpdateIndexActionKey | CommandActionKey String
deriving (Eq, Ord)
actionKey :: Action -> ActionKey
actionKey (UpdateIndexAction _) = UpdateIndexActionKey
actionKey CommandAction { getSubcommand = s } = CommandActionKey s
{- A queue of actions to perform (in any order) on a git repository,
- with lists of files to perform them on. This allows coalescing
- similar git commands. -}
data Queue = Queue
{ size :: Int
, _limit :: Int
, items :: M.Map ActionKey Action
}
{- A recommended maximum size for the queue, after which it should be
- run.
-
- 10240 is semi-arbitrary. If we assume git filenames are between 10 and
- 255 characters long, then the queue will build up between 100kb and
- 2550kb long commands. The max command line length on linux is somewhere
- above 20k, so this is a fairly good balance -- the queue will buffer
- only a few megabytes of stuff and a minimal number of commands will be
- run by xargs. -}
defaultLimit :: Int
defaultLimit = 10240
{- Constructor for empty queue. -}
new :: Maybe Int -> Queue
new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
{- Adds an git command to the queue.
-
- Git commands with the same subcommand but different parameters are
- assumed to be equivilant enough to perform in any order with the same
- result.
-}
addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
addCommand subcommand params files q repo =
updateQueue action different (length files) q repo
where
key = actionKey action
action = CommandAction
{ getSubcommand = subcommand
, getParams = params
, getFiles = allfiles
}
allfiles = map File files ++ maybe [] getFiles (M.lookup key $ items q)
different (CommandAction { getSubcommand = s }) = s /= subcommand
different _ = True
{- Adds an update-index streamer to the queue. -}
addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue
addUpdateIndex streamer q repo =
updateQueue action different 1 q repo
where
key = actionKey action
-- the list is built in reverse order
action = UpdateIndexAction $ streamer : streamers
streamers = maybe [] getStreamers $ M.lookup key $ items q
different (UpdateIndexAction _) = False
different _ = True
{- Updates or adds an action in the queue. If the queue already contains a
- different action, it will be flushed; this is to ensure that conflicting
- actions, like add and rm, are run in the right order.-}
updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue
updateQueue !action different sizeincrease q repo
| null (filter different (M.elems (items q))) = return $ go q
| otherwise = go <$> flush q repo
where
go q' = newq
where
!newq = q'
{ size = newsize
, items = newitems
}
!newsize = size q' + sizeincrease
!newitems = M.insertWith' const (actionKey action) action (items q')
{- Is a queue large enough that it should be flushed? -}
full :: Queue -> Bool
full (Queue cur lim _) = cur > lim
{- Runs a queue on a git repository. -}
flush :: Queue -> Repo -> IO Queue
flush (Queue _ lim m) repo = do
forM_ (M.elems m) $ runAction repo
return $ Queue 0 lim M.empty
{- Runs an Action on a list of files in a git repository.
-
- Complicated by commandline length limits.
-
- Intentionally runs the command even if the list of files is empty;
- this allows queueing commands that do not need a list of files. -}
runAction :: Repo -> Action -> IO ()
runAction repo (UpdateIndexAction streamers) =
-- list is stored in reverse order
Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
runAction repo action@(CommandAction {}) = do
#ifndef mingw32_HOST_OS
let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo }
withHandle StdinHandle createProcessSuccess p $ \h -> do
fileEncoding h
hPutStr h $ intercalate "\0" $ toCommand $ getFiles action
hClose h
#else
-- Using xargs on Windows is problimatic, so just run the command
-- once per file (not as efficient.)
if null (getFiles action)
then void $ boolSystemEnv "git" gitparams (gitEnv repo)
else forM_ (getFiles action) $ \f ->
void $ boolSystemEnv "git" (gitparams ++ [f]) (gitEnv repo)
#endif
where
gitparams = gitCommandLine
(Param (getSubcommand action):getParams action) repo
github-backup-1.20150807/Git/Ref.hs 0000664 0000000 0000000 00000010677 12561161061 0016453 0 ustar 00root root 0000000 0000000 {- git ref stuff
-
- Copyright 2011-2013 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.Ref where
import Common
import Git
import Git.Command
import Git.Sha
import Git.Types
import Data.Char (chr)
headRef :: Ref
headRef = Ref "HEAD"
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
describe = fromRef . base
{- Often git refs are fully qualified (eg: refs/heads/master).
- Converts such a fully qualified ref into a base ref (eg: master). -}
base :: Ref -> Ref
base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
where
remove prefix s
| prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s
{- Given a directory and any ref, takes the basename of the ref and puts
- it under the directory. -}
under :: String -> Ref -> Ref
under dir r = Ref $ dir ++ "/" ++
(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)
{- Given a directory such as "refs/remotes/origin", and a ref such as
- refs/heads/master, yields a version of that ref under the directory,
- such as refs/remotes/origin/master. -}
underBase :: String -> Ref -> Ref
underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)
{- 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
{- Converts a Ref to refer to the content of the Ref on a given date. -}
dateRef :: Ref -> RefDate -> Ref
dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d
{- 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 r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
{- Checks if a ref exists. -}
exists :: Ref -> Repo -> IO Bool
exists ref = runBool
[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]
{- 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
{- 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
{- 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
headSha :: Repo -> IO (Maybe Sha)
headSha = sha headRef
{- List of (shas, branches) matching a given ref or refs. -}
matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
matching refs repo = matching' (map fromRef refs) repo
{- Includes HEAD in the output, if asked for it. -}
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. -}
matching' :: [String] -> Repo -> IO [(Sha, Branch)]
matching' ps repo = map gen . lines <$>
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.
- 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. -}
tree :: Ref -> Repo -> IO (Maybe Sha)
tree ref = extractSha <$$> pipeReadStrict
[ Param "rev-parse", Param (fromRef ref ++ ":") ]
{- Checks if a String is a legal git ref name.
-
- The rules for this are complex; see git-check-ref-format(1) -}
legal :: Bool -> String -> Bool
legal allowonelevel s = all (== False) illegal
where
illegal =
[ any ("." `isPrefixOf`) pathbits
, any (".lock" `isSuffixOf`) pathbits
, not allowonelevel && length pathbits < 2
, contains ".."
, any (\c -> contains [c]) illegalchars
, begins "/"
, ends "/"
, contains "//"
, ends "."
, contains "@{"
, null s
]
contains v = v `isInfixOf` s
ends v = v `isSuffixOf` s
begins v = v `isPrefixOf` s
pathbits = split "/" s
illegalchars = " ~^:?*[\\" ++ controlchars
controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)]
github-backup-1.20150807/Git/Remote.hs 0000664 0000000 0000000 00000006311 12561161061 0017160 0 ustar 00root root 0000000 0000000 {- git remote stuff
-
- Copyright 2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Git.Remote where
import Common
import Git
import Git.Types
import Data.Char
import qualified Data.Map as M
import Network.URI
#ifdef mingw32_HOST_OS
import Git.FilePath
#endif
{- 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,
- just some ad-hoc checks, and some other things that fail with certian
- types of names (like ones starting with '-').
-}
makeLegalName :: String -> RemoteName
makeLegalName s = case filter legal $ replace "/" "_" s of
-- it can't be empty
[] -> "unnamed"
-- it can't start with / or - or .
'.':s' -> makeLegalName s'
'/':s' -> makeLegalName s'
'-':s' -> makeLegalName s'
s' -> s'
where
{- Only alphanumerics, and a few common bits of punctuation common
- in hostnames. -}
legal '_' = True
legal '.' = True
legal c = isAlphaNum c
data RemoteLocation = RemoteUrl String | RemotePath FilePath
remoteLocationIsUrl :: RemoteLocation -> Bool
remoteLocationIsUrl (RemoteUrl _) = True
remoteLocationIsUrl _ = False
remoteLocationIsSshUrl :: RemoteLocation -> Bool
remoteLocationIsSshUrl (RemoteUrl u) = "ssh://" `isPrefixOf` u
remoteLocationIsSshUrl _ = False
{- Determines if a given remote location is an url, or a local
- path. Takes the repository's insteadOf configuration into account. -}
parseRemoteLocation :: String -> Repo -> RemoteLocation
parseRemoteLocation s repo = ret $ calcloc s
where
ret v
#ifdef mingw32_HOST_OS
| dosstyle v = RemotePath (dospath v)
#endif
| scpstyle v = RemoteUrl (scptourl v)
| urlstyle v = RemoteUrl v
| otherwise = RemotePath v
-- insteadof config can rewrite remote location
calcloc l
| null insteadofs = l
| otherwise = replacement ++ drop (length bestvalue) l
where
replacement = drop (length prefix) $
take (length bestkey - length suffix) bestkey
(bestkey, bestvalue) = maximumBy longestvalue insteadofs
longestvalue (_, a) (_, b) = compare b a
insteadofs = filterconfig $ \(k, v) ->
startswith prefix k &&
endswith suffix k &&
startswith v l
filterconfig f = filter f $
concatMap splitconfigs $ M.toList $ fullconfig repo
splitconfigs (k, vs) = map (\v -> (k, v)) vs
(prefix, suffix) = ("url." , ".insteadof")
urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
-- git remotes can be written scp style -- [user@]host:dir
-- but foo::bar is a git-remote-helper location instead
scpstyle v = ":" `isInfixOf` v
&& not ("//" `isInfixOf` v)
&& not ("::" `isInfixOf` v)
scptourl v = "ssh://" ++ host ++ slash dir
where
(host, dir)
-- handle ipv6 address inside []
| "[" `isPrefixOf` v = case break (== ']') v of
(h, ']':':':d) -> (h ++ "]", d)
(h, ']':d) -> (h ++ "]", d)
(h, d) -> (h, d)
| otherwise = separate (== ':') v
slash d | d == "" = "/~/" ++ d
| "/" `isPrefixOf` d = d
| "~" `isPrefixOf` d = '/':d
| otherwise = "/~/" ++ d
#ifdef mingw32_HOST_OS
-- 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
#endif
github-backup-1.20150807/Git/Sha.hs 0000664 0000000 0000000 00000002053 12561161061 0016437 0 ustar 00root root 0000000 0000000 {- git SHA stuff
-
- Copyright 2011 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.Sha where
import Common
import Git.Types
{- Runs an action that causes a git subcommand to emit a Sha, and strips
- any trailing newline, returning the sha. -}
getSha :: String -> IO String -> IO Sha
getSha subcommand a = maybe bad return =<< extractSha <$> a
where
bad = error $ "failed to read sha from git " ++ subcommand
{- Extracts the Sha from a string. There can be a trailing newline after
- it, but nothing else. -}
extractSha :: String -> Maybe Sha
extractSha s
| len == shaSize = val s
| len == shaSize + 1 && length s' == shaSize = val s'
| otherwise = Nothing
where
len = length s
s' = firstLine s
val v
| all (`elem` "1234567890ABCDEFabcdef") v = Just $ Ref v
| otherwise = Nothing
{- Size of a git sha. -}
shaSize :: Int
shaSize = 40
nullSha :: Ref
nullSha = Ref $ replicate shaSize '0'
{- Git's magic empty tree. -}
emptyTree :: Ref
emptyTree = Ref "4b825dc642cb6eb9a060e54bf8d69288fbee4904"
github-backup-1.20150807/Git/Types.hs 0000664 0000000 0000000 00000005330 12561161061 0017031 0 ustar 00root root 0000000 0000000 {- git data types
-
- Copyright 2010-2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.Types where
import Network.URI
import qualified Data.Map as M
import System.Posix.Types
import Utility.SafeCommand
import Utility.URI ()
{- Support repositories on local disk, and repositories accessed via an URL.
-
- Repos on local disk have a git directory, and unless bare, a worktree.
-
- A local repo may not have had its config read yet, in which case all
- that's known about it is its path.
-
- Finally, an Unknown repository may be known to exist, but nothing
- else known about it.
-}
data RepoLocation
= Local { gitdir :: FilePath, worktree :: Maybe FilePath }
| LocalUnknown FilePath
| Url URI
| Unknown
deriving (Show, Eq, Ord)
data Repo = Repo
{ location :: RepoLocation
, config :: M.Map String String
-- a given git config key can actually have multiple values
, fullconfig :: M.Map String [String]
, remotes :: [Repo]
-- remoteName holds the name used for this repo in remotes
, remoteName :: Maybe RemoteName
-- alternate environment to use when running git commands
, gitEnv :: Maybe [(String, String)]
-- global options to pass to git when running git commands
, gitGlobalOpts :: [CommandParam]
} deriving (Show, Eq, Ord)
type RemoteName = String
{- A git ref. Can be a sha1, or a branch or tag name. -}
newtype Ref = Ref String
deriving (Eq, Ord, Read, Show)
fromRef :: Ref -> String
fromRef (Ref s) = s
{- Aliases for Ref. -}
type Branch = Ref
type Sha = Ref
type Tag = Ref
{- A date in the format described in gitrevisions. Includes the
- braces, eg, "{yesterday}" -}
newtype RefDate = RefDate String
{- 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 "blob" = Just BlobObject
readObjectType "commit" = Just CommitObject
readObjectType "tree" = Just TreeObject
readObjectType _ = Nothing
{- Types of blobs. -}
data BlobType = FileBlob | ExecutableBlob | SymlinkBlob
deriving (Eq)
{- Git uses magic numbers to denote the type of a blob. -}
instance Show BlobType where
show FileBlob = "100644"
show ExecutableBlob = "100755"
show SymlinkBlob = "120000"
readBlobType :: String -> Maybe BlobType
readBlobType "100644" = Just FileBlob
readBlobType "100755" = Just ExecutableBlob
readBlobType "120000" = Just SymlinkBlob
readBlobType _ = Nothing
toBlobType :: FileMode -> Maybe BlobType
toBlobType 0o100644 = Just FileBlob
toBlobType 0o100755 = Just ExecutableBlob
toBlobType 0o120000 = Just SymlinkBlob
toBlobType _ = Nothing
github-backup-1.20150807/Git/UpdateIndex.hs 0000664 0000000 0000000 00000007114 12561161061 0020141 0 ustar 00root root 0000000 0000000 {- git-update-index library
-
- Copyright 2011-2013 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns, CPP #-}
module Git.UpdateIndex (
Streamer,
pureStreamer,
streamUpdateIndex,
streamUpdateIndex',
startUpdateIndex,
stopUpdateIndex,
lsTree,
lsSubTree,
updateIndexLine,
stageFile,
unstageFile,
stageSymlink,
stageDiffTreeItem,
) where
import Common
import Git
import Git.Types
import Git.Command
import Git.FilePath
import Git.Sha
import qualified Git.DiffTreeItem as Diff
{- 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 ()
{- A streamer with a precalculated value. -}
pureStreamer :: String -> Streamer
pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $
(\h -> forM_ as $ streamUpdateIndex' h)
data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
hPutStr h s
hPutStr h "\0"
startUpdateIndex :: Repo -> IO UpdateIndexHandle
startUpdateIndex repo = do
(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
{ std_in = CreatePipe }
fileEncoding h
return $ UpdateIndexHandle p h
where
params = map Param ["update-index", "-z", "--index-info"]
stopUpdateIndex :: UpdateIndexHandle -> IO Bool
stopUpdateIndex (UpdateIndexHandle p h) = do
hClose h
checkSuccessProcess p
{- A streamer that adds the current tree for a ref. Useful for eg, copying
- and modifying branches. -}
lsTree :: Ref -> Repo -> Streamer
lsTree (Ref x) repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do
(s, cleanup) <- pipeNullSplit params repo
mapM_ streamer s
void $ cleanup
where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p]
{- 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
stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer
stageFile sha filetype file repo = do
p <- toTopFilePath file repo
return $ pureStreamer $ updateIndexLine sha filetype p
{- A streamer that removes a file from the index. -}
unstageFile :: FilePath -> Repo -> IO Streamer
unstageFile file repo = do
p <- toTopFilePath file repo
return $ unstageFile' p
unstageFile' :: TopFilePath -> Streamer
unstageFile' p = pureStreamer $ "0 " ++ 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
return $ pureStreamer line
{- A streamer that applies a DiffTreeItem to the index. -}
stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer
stageDiffTreeItem d = case toBlobType (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
github-backup-1.20150807/Git/Url.hs 0000664 0000000 0000000 00000003305 12561161061 0016467 0 ustar 00root root 0000000 0000000 {- git repository urls
-
- Copyright 2010, 2011 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.Url (
scheme,
host,
port,
hostuser,
authority,
) where
import Network.URI hiding (scheme, authority)
import Common
import Git.Types
import Git
{- Scheme of an URL repo. -}
scheme :: Repo -> String
scheme Repo { location = Url u } = uriScheme u
scheme repo = notUrl repo
{- Work around a bug in the real uriRegName
- -}
uriRegName' :: URIAuth -> String
uriRegName' a = fixup $ uriRegName a
where
fixup x@('[':rest)
| rest !! len == ']' = take len rest
| otherwise = x
where
len = length rest - 1
fixup x = x
{- Hostname of an URL repo. -}
host :: Repo -> Maybe String
host = authpart uriRegName'
{- Port of an URL repo, if it has a nonstandard one. -}
port :: Repo -> Maybe Integer
port r =
case authpart uriPort r of
Nothing -> Nothing
Just ":" -> Nothing
Just (':':p) -> readish p
Just _ -> Nothing
{- Hostname of an URL repo, including any username (ie, "user@host") -}
hostuser :: Repo -> Maybe String
hostuser r = (++)
<$> authpart uriUserInfo r
<*> authpart uriRegName' r
{- The full authority portion an URL repo. (ie, "user@host:port") -}
authority :: Repo -> Maybe String
authority = authpart assemble
where
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
{- Applies a function to extract part of the uriAuthority of an URL repo. -}
authpart :: (URIAuth -> a) -> Repo -> Maybe a
authpart a Repo { location = Url u } = a <$> uriAuthority u
authpart _ repo = notUrl repo
notUrl :: Repo -> a
notUrl repo = error $
"acting on local git repo " ++ repoDescribe repo ++ " not supported"
github-backup-1.20150807/Git/Version.hs 0000664 0000000 0000000 00000001105 12561161061 0017346 0 ustar 00root root 0000000 0000000 {- git versions
-
- Copyright 2011, 2013 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Git.Version (
installed,
older,
normalize,
GitVersion,
) where
import Common
import Utility.DottedVersion
type GitVersion = DottedVersion
installed :: IO GitVersion
installed = normalize . extract <$> readProcess "git" ["--version"]
where
extract s = case lines s of
[] -> ""
(l:_) -> unwords $ drop 2 $ words l
older :: String -> IO Bool
older n = do
v <- installed
return $ v < normalize n
github-backup-1.20150807/Github/ 0000775 0000000 0000000 00000000000 12561161061 0016067 5 ustar 00root root 0000000 0000000 github-backup-1.20150807/Github/Data/ 0000775 0000000 0000000 00000000000 12561161061 0016740 5 ustar 00root root 0000000 0000000 github-backup-1.20150807/Github/Data/Readable.hs 0000664 0000000 0000000 00000000627 12561161061 0021000 0 ustar 00root root 0000000 0000000 {-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module re-exports the @Github.Data.Definitions@ module, adding
-- instances of @Read@ to it.
module Github.Data.Readable (module Github.Data.Definitions) where
import Github.Data.Definitions
deriving instance Read GithubDate
deriving instance Read GithubOwner
deriving instance Read Repo
deriving instance Read RepoRef
github-backup-1.20150807/Github/EnumRepos.hs 0000664 0000000 0000000 00000003361 12561161061 0020343 0 ustar 00root root 0000000 0000000 module Github.EnumRepos where
import qualified Github.Repos as Github
import Data.List
import Data.List.Utils
import Data.Maybe
import Utility.PartialPrelude
import qualified Git
import qualified Git.Types
-- A github user and repo.
data GithubUserRepo = GithubUserRepo String String
deriving (Eq, Show, Read, Ord)
class ToGithubUserRepo a where
toGithubUserRepo :: a -> GithubUserRepo
instance ToGithubUserRepo Github.Repo where
toGithubUserRepo r = GithubUserRepo
(Github.githubOwnerLogin $ Github.repoOwner r)
(Github.repoName r)
instance ToGithubUserRepo Github.RepoRef where
toGithubUserRepo (Github.RepoRef owner name) =
GithubUserRepo (Github.githubOwnerLogin owner) name
gitHubRepos :: Git.Repo -> [Git.Repo]
gitHubRepos = fst . unzip . gitHubPairs
gitHubRemotes :: Git.Repo -> [GithubUserRepo]
gitHubRemotes = snd . unzip . gitHubPairs
gitHubPairs :: Git.Repo -> [(Git.Repo, GithubUserRepo)]
gitHubPairs = filter (not . wiki ) . mapMaybe check . Git.Types.remotes
where
check r@Git.Repo { Git.Types.location = Git.Types.Url u } =
headMaybe $ mapMaybe (checkurl r $ show u) gitHubUrlPrefixes
check _ = Nothing
checkurl r u prefix
| prefix `isPrefixOf` u && length bits == 2 =
Just (r,
GithubUserRepo (bits !! 0)
(dropdotgit $ bits !! 1))
| otherwise = Nothing
where
rest = drop (length prefix) u
bits = filter (not . null) $ split "/" rest
dropdotgit s
| ".git" `isSuffixOf` s = take (length s - length ".git") s
| otherwise = s
wiki (_, GithubUserRepo _ u) = ".wiki" `isSuffixOf` u
{- All known prefixes for urls to github repos. -}
gitHubUrlPrefixes :: [String]
gitHubUrlPrefixes =
[ "git@github.com:"
, "git://github.com/"
, "https://github.com/"
, "http://github.com/"
, "ssh://git@github.com/~/"
]
github-backup-1.20150807/Github/GetAuth.hs 0000664 0000000 0000000 00000001043 12561161061 0017762 0 ustar 00root root 0000000 0000000 {-# LANGUAGE CPP #-}
module Github.GetAuth where
import Utility.Env
#if MIN_VERSION_github(0,9,0)
import qualified Github.Auth as Github
#else
import qualified Github.Issues as Github
#endif
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
getAuth :: IO (Maybe Github.GithubAuth)
getAuth = do
user <- getEnv "GITHUB_USER"
password <- getEnv "GITHUB_PASSWORD"
return $ case (user, password) of
(Just u, Just p) -> Just $
Github.GithubBasicAuth (tobs u) (tobs p)
_ -> Nothing
where
tobs = encodeUtf8 . T.pack
github-backup-1.20150807/Makefile 0000664 0000000 0000000 00000002413 12561161061 0016305 0 ustar 00root root 0000000 0000000 PREFIX=/usr
CABAL?=cabal # set to "./Setup" if you lack a cabal program
build: Build/SysConfig.hs
$(CABAL) build
ln -sf dist/build/github-backup/github-backup github-backup
ln -sf dist/build/gitriddance/gitriddance gitriddance
@$(MAKE) tags >/dev/null 2>&1 &
Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs
if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi
$(CABAL) configure
install: build
install -d $(DESTDIR)$(PREFIX)/bin
install github-backup gitriddance $(DESTDIR)$(PREFIX)/bin
install -d $(DESTDIR)$(PREFIX)/share/man/man1
install -m 0644 github-backup.1 gitriddance.1 $(DESTDIR)$(PREFIX)/share/man/man1
install -d $(DESTDIR)$(PREFIX)/share/bash-completion/completions
./github-backup --bash-completion-script github-backup > $(DESTDIR)$(PREFIX)/share/bash-completion/completions/github-backup
clean:
rm -rf github-backup gitriddance dist configure Build/SysConfig.hs Setup tags
find -name \*.o -exec rm {} \;
find -name \*.hi -exec rm {} \;
# Upload to hackage.
hackage: clean
./Build/make-sdist.sh
@cabal upload dist/*.tar.gz
# hothasktags chokes on some template haskell etc, so ignore errors
tags:
find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null
github-backup-1.20150807/README.md 0000664 0000000 0000000 00000006777 12561161061 0016145 0 ustar 00root root 0000000 0000000 github-backup is a simple tool you run in a git repository you cloned from
GitHub. It backs up everything GitHub publishes about the repository,
including branches, tags, other forks, issues, comments, wikis, milestones,
pull requests, watchers, and stars.
## Installation
cabal install github-backup --bindir=$HOME/bin
(Cabal is bundled with the [Haskell Platform](http://www.haskell.org/platform/).)
## Use
Run `github-backup` with no parameters, inside a git repository cloned
from GitHub to back up that repository.
Or, if you have a GitHub account, run `github-backup username`
to clone and back up your account's repositories, as well
as the repositories you're watching and have starred.
## Why backup GitHub repositories
There are a couple of reasons to want to back this stuff up:
* In case something happens to GitHub. More generally because
keeping your data in the cloud *and* relying on the cloud to
back it up is foolish.
* In case someone takes down a repository that you were interested in.
If you run github-backup with your username, it will back up all
the repositories you have watched and starred.
* So you can keep working on your repository while on a plane, or
on a remote beach or mountaintop. Just like Linus intended.
## What to expect
Each time you run github-backup, it will find any new forks on GitHub. It
will add remotes to your repository for the forks, using names like
`github_torvalds_subsurface`. It will fetch from every fork.
It downloads metadata from each fork. This is stored
into a branch named "github". Each fork gets a directory in there,
like `torvalds_subsurface`. Inside the directory there will be some
files, like `torvalds_subsurface/watchers`. There may be further
directories, like for comments: `torvalds_subsurface/comments/1`.
You can follow the commits to the github branch to see what information
changed on GitHub over time.
The format of the files in the github branch is currently Haskell
serialized data types. This is plain text, and readable, if you squint.
## Limitations
github-backup is repository-focused. It does not try to back up other
information from GitHub. In particular, social network stuff, like
users who are following you, is not backed up.
github-backup does not log into GitHub, so it cannot backup private
repositories.
Notes added to commits and lines of code don't get backed up yet.
There is only recently API support for this.
The labels that can be added to issues and milestones are not backed up.
Neither are the hooks. They could be, but don't seem important
enough for the extra work involved. Yell if you need them.
github-backup re-downloads all issues, comments, and so on
each time it's run. This may be slow if your repo has a lot of them,
or even if it just has a lot of forks.
Bear in mind that this uses the GitHub API; don't run it every 5 minutes.
GitHub [rate limits](http://developer.github.com/v3/#rate-limiting) the
API to some small number of requests per hour when used without
authentication. To avoid this limit, you can set `GITHUB_USER` and
`GITHUB_PASSWORD` in the environment and it will log in when making
(most) API requests.
Anyway, github-backup *does* do an incremental backup, picking up where it
left off, so will complete the backup eventually even if it's rate limited.
## Author
github-backup was written by Joey Hess
It is made possible thanks to:
* Mike Burns's [haskell github library](http://hackage.haskell.org/package/github)
* GitHub, for providing an API exposing this data.
github-backup-1.20150807/Setup.hs 0000664 0000000 0000000 00000000423 12561161061 0016300 0 ustar 00root root 0000000 0000000 {- cabal setup file -}
import Distribution.Simple
import Distribution.Simple.Setup
import qualified Build.Configure as Configure
main = defaultMainWithHooks simpleUserHooks
{ preConf = configure
}
configure _ _ = do
Configure.run Configure.tests
return (Nothing, [])
github-backup-1.20150807/Utility/ 0000775 0000000 0000000 00000000000 12561161061 0016310 5 ustar 00root root 0000000 0000000 github-backup-1.20150807/Utility/Applicative.hs 0000664 0000000 0000000 00000000526 12561161061 0021110 0 ustar 00root root 0000000 0000000 {- applicative stuff
-
- Copyright 2012 Joey Hess
-
- License: BSD-2-clause
-}
module Utility.Applicative where
{- Like <$> , but supports one level of currying.
-
- foo v = bar <$> action v == foo = bar <$$> action
-}
(<$$>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b
f <$$> v = fmap f . v
infixr 4 <$$>
github-backup-1.20150807/Utility/CoProcess.hs 0000664 0000000 0000000 00000004754 12561161061 0020556 0 ustar 00root root 0000000 0000000 {- Interface for running a shell command as a coprocess,
- sending it queries and getting back results.
-
- Copyright 2012-2013 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
module Utility.CoProcess (
CoProcessHandle,
start,
stop,
query,
rawMode
) where
import Common
import Control.Concurrent.MVar
type CoProcessHandle = MVar CoProcessState
data CoProcessState = CoProcessState
{ coProcessPid :: ProcessHandle
, coProcessTo :: Handle
, coProcessFrom :: Handle
, coProcessSpec :: CoProcessSpec
}
data CoProcessSpec = CoProcessSpec
{ coProcessNumRestarts :: Int
, coProcessCmd :: FilePath
, coProcessParams :: [String]
, coProcessEnv :: Maybe [(String, String)]
}
start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
start numrestarts cmd params environ = do
s <- start' $ CoProcessSpec numrestarts cmd params environ
newMVar s
start' :: CoProcessSpec -> IO CoProcessState
start' s = do
(pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s)
return $ CoProcessState pid to from s
stop :: CoProcessHandle -> IO ()
stop ch = do
s <- readMVar ch
hClose $ coProcessTo s
hClose $ coProcessFrom s
let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)
forceSuccessProcess p (coProcessPid s)
{- To handle a restartable process, any IO exception thrown by the send and
- receive actions are assumed to mean communication with the process
- failed, and the failed action is re-run with a new process. -}
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
query ch send receive = do
s <- readMVar ch
restartable s (send $ coProcessTo s) $ const $
restartable s (hFlush $ coProcessTo s) $ const $
restartable s (receive $ coProcessFrom s)
return
where
restartable s a cont
| coProcessNumRestarts (coProcessSpec s) > 0 =
maybe restart cont =<< catchMaybeIO a
| otherwise = cont =<< a
restart = do
s <- takeMVar ch
void $ catchMaybeIO $ do
hClose $ coProcessTo s
hClose $ coProcessFrom s
void $ waitForProcess $ coProcessPid s
s' <- start' $ (coProcessSpec s)
{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }
putMVar ch s'
query ch send receive
rawMode :: CoProcessHandle -> IO CoProcessHandle
rawMode ch = do
s <- readMVar ch
raw $ coProcessFrom s
raw $ coProcessTo s
return ch
where
raw h = do
fileEncoding h
#ifdef mingw32_HOST_OS
hSetNewlineMode h noNewlineTranslation
#endif
github-backup-1.20150807/Utility/Data.hs 0000664 0000000 0000000 00000000660 12561161061 0017517 0 ustar 00root root 0000000 0000000 {- utilities for simple data types
-
- Copyright 2013 Joey Hess
-
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Data where
{- First item in the list that is not Nothing. -}
firstJust :: Eq a => [Maybe a] -> Maybe a
firstJust ms = case dropWhile (== Nothing) ms of
[] -> Nothing
(md:_) -> md
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (const Nothing) Just
github-backup-1.20150807/Utility/Directory.hs 0000664 0000000 0000000 00000015413 12561161061 0020614 0 ustar 00root root 0000000 0000000 {- directory traversal and manipulation
-
- Copyright 2011-2014 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory where
import System.IO.Error
import System.Directory
import Control.Monad
import System.FilePath
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
import Utility.SafeCommand
import Control.Monad.IfElse
#endif
import Utility.PosixFiles
import Utility.Tmp
import Utility.Exception
import Utility.Monad
import Utility.Applicative
dirCruft :: FilePath -> Bool
dirCruft "." = True
dirCruft ".." = True
dirCruft _ = False
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: FilePath -> IO [FilePath]
dirContents d = map (d ) . filter (not . dirCruft) <$> getDirectoryContents d
{- Gets files in a directory, and then its subdirectories, recursively,
- and lazily.
-
- Does not follow symlinks to other subdirectories.
-
- When the directory does not exist, no exception is thrown,
- instead, [] is returned. -}
dirContentsRecursive :: FilePath -> IO [FilePath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -}
dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
where
go [] = return []
go (dir:dirs)
| skipdir (takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs)
return (files ++ files')
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
ms <- catchMaybeIO $ getSymbolicLinkStatus entry
case ms of
(Just s)
| isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks ->
ifM (doesDirectoryExist entry)
( recurse
, skip
)
_ -> skip
{- Gets the directory tree from a point, recursively and lazily,
- with leaf directories **first**, skipping any whose basenames
- match the skipdir. Does not follow symlinks. -}
dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
where
go c [] = return c
go c (dir:dirs)
| skipdir (takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
subdirs <- go c
=<< filterM (isDirectory <$$> getSymbolicLinkStatus)
=<< catchDefaultIO [] (dirContents dir)
go (subdirs++[dir]) dirs
{- Moves one filename to another.
- First tries a rename, but falls back to moving across devices if needed. -}
moveFile :: FilePath -> FilePath -> IO ()
moveFile src dest = tryIO (rename src dest) >>= onrename
where
onrename (Right _) = noop
onrename (Left e)
| isPermissionError e = rethrow
| isDoesNotExistError e = rethrow
| otherwise = viaTmp mv dest ""
where
rethrow = throwM e
mv tmp _ = do
-- copyFile is likely not as optimised as
-- the mv command, so we'll use the command.
--
-- But, while Windows has a "mv", it does not seem very
-- reliable, so use copyFile there.
#ifndef mingw32_HOST_OS
-- If dest is a directory, mv would move the file
-- into it, which is not desired.
whenM (isdir dest) rethrow
ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
let e' = e
#else
r <- tryIO $ copyFile src tmp
let (ok, e') = case r of
Left err -> (False, err)
Right _ -> (True, e)
#endif
unless ok $ do
-- delete any partial
_ <- tryIO $ removeFile tmp
throwM e'
isdir f = do
r <- tryIO $ getFileStatus f
case r of
(Left _) -> return False
(Right s) -> return $ isDirectory s
{- Removes a file, which may or may not exist, and does not have to
- be a regular file.
-
- Note that an exception is thrown if the file exists but
- cannot be removed. -}
nukeFile :: FilePath -> IO ()
nukeFile file = void $ tryWhenExists go
where
#ifndef mingw32_HOST_OS
go = removeLink file
#else
go = removeFile file
#endif
#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
github-backup-1.20150807/Utility/DottedVersion.hs 0000664 0000000 0000000 00000002020 12561161061 0021427 0 ustar 00root root 0000000 0000000 {- dotted versions, such as 1.0.1
-
- Copyright 2011-2014 Joey Hess
-
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.DottedVersion where
import Common
data DottedVersion = DottedVersion String Integer
deriving (Eq)
instance Ord DottedVersion where
compare (DottedVersion _ x) (DottedVersion _ y) = compare x y
instance Show DottedVersion where
show (DottedVersion s _) = s
{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
- a somewhat arbitrary integer representation. -}
normalize :: String -> DottedVersion
normalize v = DottedVersion v $
sum $ mult 1 $ reverse $ extend precision $ take precision $
map readi $ split "." v
where
extend n l = l ++ replicate (n - length l) 0
mult _ [] = []
mult n (x:xs) = (n*x) : mult (n*10^width) xs
readi :: String -> Integer
readi s = case reads s of
((x,_):_) -> x
_ -> 0
precision = 10 -- number of segments of the version to compare
width = length "yyyymmddhhmmss" -- maximum width of a segment
github-backup-1.20150807/Utility/Env.hs 0000664 0000000 0000000 00000004002 12561161061 0017370 0 ustar 00root root 0000000 0000000 {- portable environment variables
-
- Copyright 2013 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Env where
#ifdef mingw32_HOST_OS
import Utility.Exception
import Control.Applicative
import Data.Maybe
import Prelude
import qualified System.Environment as E
import qualified System.SetEnv
#else
import qualified System.Posix.Env as PE
#endif
getEnv :: String -> IO (Maybe String)
#ifndef mingw32_HOST_OS
getEnv = PE.getEnv
#else
getEnv = catchMaybeIO . E.getEnv
#endif
getEnvDefault :: String -> String -> IO String
#ifndef mingw32_HOST_OS
getEnvDefault = PE.getEnvDefault
#else
getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
#endif
getEnvironment :: IO [(String, String)]
#ifndef mingw32_HOST_OS
getEnvironment = PE.getEnvironment
#else
getEnvironment = E.getEnvironment
#endif
{- 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
- present in the list, removes the old value.
-
- This does not really belong here, but Data.AssocList is for some reason
- buried inside hxt.
-}
addEntry :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
addEntry k v l = ( (k,v) : ) $! delEntry k l
addEntries :: Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]
addEntries = foldr (.) id . map (uncurry addEntry) . reverse
delEntry :: Eq k => k -> [(k, v)] -> [(k, v)]
delEntry _ [] = []
delEntry k (x@(k1,_) : rest)
| k == k1 = rest
| otherwise = ( x : ) $! delEntry k rest
github-backup-1.20150807/Utility/Exception.hs 0000664 0000000 0000000 00000005637 12561161061 0020615 0 ustar 00root root 0000000 0000000 {- Simple IO exception handling (and some more)
-
- Copyright 2011-2015 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
module X,
catchBoolIO,
catchMaybeIO,
catchDefaultIO,
catchMsgIO,
catchIO,
tryIO,
bracketIO,
catchNonAsync,
tryNonAsync,
tryWhenExists,
catchHardwareFault,
) where
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
import GHC.IO.Exception (IOErrorType(..))
import Utility.Data
{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
catchBoolIO = catchDefaultIO False
{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
catchMaybeIO a = do
catchDefaultIO Nothing $ do
v <- a
return (Just v)
{- Catches IO errors and returns a default value. -}
catchDefaultIO :: MonadCatch m => a -> m a -> m a
catchDefaultIO def a = catchIO a (const $ return def)
{- Catches IO errors and returns the error message. -}
catchMsgIO :: MonadCatch m => m a -> m (Either String a)
catchMsgIO a = do
v <- tryIO a
return $ either (Left . show) Right v
{- catch specialized for IO errors only -}
catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchIO = M.catch
{- try specialized for IO errors only -}
tryIO :: MonadCatch m => m a -> m (Either IOException a)
tryIO = M.try
{- bracket with setup and cleanup actions lifted to IO.
-
- Note that unlike catchIO and tryIO, this catches all exceptions. -}
bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a
bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
{- Catches all exceptions except for async exceptions.
- This is often better to use than catching them all, so that
- ThreadKilled and UserInterrupt get through.
-}
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
, M.Handler (\ (e :: SomeException) -> onerr e)
]
tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)
tryNonAsync a = go `catchNonAsync` (return . Left)
where
go = do
v <- a
return (Right v)
{- Catches only DoesNotExist exceptions, and lets all others through. -}
tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists a = do
v <- tryJust (guard . isDoesNotExistError) a
return (eitherToMaybe v)
{- Catches only exceptions caused by hardware faults.
- Ie, disk IO error. -}
catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchHardwareFault a onhardwareerr = catchIO a onlyhw
where
onlyhw e
| ioeGetErrorType e == HardwareFault = onhardwareerr e
| otherwise = throwM e
github-backup-1.20150807/Utility/FileMode.hs 0000664 0000000 0000000 00000007743 12561161061 0020343 0 ustar 00root root 0000000 0000000 {- File mode utilities.
-
- Copyright 2010-2012 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
module Utility.FileMode where
import System.IO
import Control.Monad
import System.PosixCompat.Types
import Utility.PosixFiles
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
import Foreign (complement)
import Utility.Exception
{- Applies a conversion function to a file's mode. -}
modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO ()
modifyFileMode f convert = do
s <- getFileStatus f
let old = fileMode s
let new = convert old
when (new /= old) $
setFileMode f new
{- Adds the specified FileModes to the input mode, leaving the rest
- unchanged. -}
addModes :: [FileMode] -> FileMode -> FileMode
addModes ms m = combineModes (m:ms)
{- Removes the specified FileModes from the input mode. -}
removeModes :: [FileMode] -> FileMode -> FileMode
removeModes ms m = m `intersectFileModes` complement (combineModes ms)
writeModes :: [FileMode]
writeModes = [ownerWriteMode, groupWriteMode, otherWriteMode]
readModes :: [FileMode]
readModes = [ownerReadMode, groupReadMode, otherReadMode]
executeModes :: [FileMode]
executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
otherGroupModes :: [FileMode]
otherGroupModes =
[ groupReadMode, otherReadMode
, groupWriteMode, otherWriteMode
]
{- Removes the write bits from a file. -}
preventWrite :: FilePath -> IO ()
preventWrite f = modifyFileMode f $ removeModes writeModes
{- Turns a file's owner write bit back on. -}
allowWrite :: FilePath -> IO ()
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
{- Turns a file's owner read bit back on. -}
allowRead :: FilePath -> IO ()
allowRead f = modifyFileMode f $ addModes [ownerReadMode]
{- Allows owner and group to read and write to a file. -}
groupSharedModes :: [FileMode]
groupSharedModes =
[ ownerWriteMode, groupWriteMode
, ownerReadMode, groupReadMode
]
groupWriteRead :: FilePath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
checkMode :: FileMode -> FileMode -> Bool
checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
{- Checks if a file mode indicates it's a symlink. -}
isSymLink :: FileMode -> Bool
#ifdef mingw32_HOST_OS
isSymLink _ = False
#else
isSymLink = checkMode symbolicLinkMode
#endif
{- Checks if a file has any executable bits set. -}
isExecutable :: FileMode -> Bool
isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0
{- Runs an action without that pesky umask influencing it, unless the
- passed FileMode is the standard one. -}
noUmask :: FileMode -> IO a -> IO a
#ifndef mingw32_HOST_OS
noUmask mode a
| mode == stdFileMode = a
| otherwise = withUmask nullFileMode a
#else
noUmask _ a = a
#endif
withUmask :: FileMode -> IO a -> IO a
#ifndef mingw32_HOST_OS
withUmask umask a = bracket setup cleanup go
where
setup = setFileCreationMask umask
cleanup = setFileCreationMask
go _ = a
#else
withUmask _ a = a
#endif
combineModes :: [FileMode] -> FileMode
combineModes [] = 0
combineModes [m] = m
combineModes (m:ms) = foldl unionFileModes m ms
isSticky :: FileMode -> Bool
#ifdef mingw32_HOST_OS
isSticky _ = False
#else
isSticky = checkMode stickyMode
stickyMode :: FileMode
stickyMode = 512
setSticky :: FilePath -> IO ()
setSticky f = modifyFileMode f $ addModes [stickyMode]
#endif
{- Writes a file, ensuring that its modes do not allow it to be read
- or written by anyone other than the current user,
- before any content is written.
-
- When possible, this is done using the umask.
-
- On a filesystem that does not support file permissions, this is the same
- as writeFile.
-}
writeFileProtected :: FilePath -> String -> IO ()
writeFileProtected file content = writeFileProtected' file
(\h -> hPutStr h content)
writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO ()
writeFileProtected' file writer = withUmask 0o0077 $
withFile file WriteMode $ \h -> do
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
writer h
github-backup-1.20150807/Utility/FileSystemEncoding.hs 0000664 0000000 0000000 00000011317 12561161061 0022402 0 ustar 00root root 0000000 0000000 {- GHC File system encoding handling.
-
- Copyright 2012-2014 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.FileSystemEncoding (
fileEncoding,
withFilePath,
md5FilePath,
decodeBS,
decodeW8,
encodeW8,
encodeW8NUL,
decodeW8NUL,
truncateFilePath,
) where
import qualified GHC.Foreign as GHC
import qualified GHC.IO.Encoding as Encoding
import Foreign.C
import System.IO
import System.IO.Unsafe
import qualified Data.Hash.MD5 as MD5
import Data.Word
import Data.Bits.Utils
import Data.List.Utils
import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.Lazy.UTF8 as L8
#endif
{- Sets a Handle to use the filesystem encoding. This causes data
- written or read from it to be encoded/decoded the same
- as ghc 7.4 does to filenames etc. This special encoding
- allows "arbitrary undecodable bytes to be round-tripped through it".
-}
fileEncoding :: Handle -> IO ()
#ifndef mingw32_HOST_OS
fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding
#else
{- The file system encoding does not work well on Windows,
- and Windows only has utf FilePaths anyway. -}
fileEncoding h = hSetEncoding h Encoding.utf8
#endif
{- Marshal a Haskell FilePath into a NUL terminated C string using temporary
- storage. The FilePath is encoded using the filesystem encoding,
- reversing the decoding that should have been done when the FilePath
- was obtained. -}
withFilePath :: FilePath -> (CString -> IO a) -> IO a
withFilePath fp f = Encoding.getFileSystemEncoding
>>= \enc -> GHC.withCString enc fp f
{- Encodes a FilePath into a String, applying the filesystem encoding.
-
- There are very few things it makes sense to do with such an encoded
- string. It's not a legal filename; it should not be displayed.
- So this function is not exported, but instead used by the few functions
- that can usefully consume it.
-
- This use of unsafePerformIO is belived to be safe; GHC's interface
- only allows doing this conversion with CStrings, and the CString buffer
- is allocated, used, and deallocated within the call, with no side
- effects.
-}
{-# NOINLINE _encodeFilePath #-}
_encodeFilePath :: FilePath -> String
_encodeFilePath fp = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
GHC.withCString enc fp $ GHC.peekCString Encoding.char8
{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -}
md5FilePath :: FilePath -> MD5.Str
md5FilePath = MD5.Str . _encodeFilePath
{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
decodeBS :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
decodeBS = encodeW8 . L.unpack
#else
{- On Windows, we assume that the ByteString is utf-8, since Windows
- only uses unicode for filenames. -}
decodeBS = L8.toString
#endif
{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
-
- w82c produces a String, which may contain Chars that are invalid
- unicode. From there, this is really a simple matter of applying the
- file system encoding, only complicated by GHC's interface to doing so.
-
- Note that the encoding stops at any NUL in the input. FilePaths
- do not normally contain embedded NUL, but Haskell Strings may.
-}
{-# NOINLINE encodeW8 #-}
encodeW8 :: [Word8] -> FilePath
encodeW8 w8 = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
{- Useful when you want the actual number of bytes that will be used to
- represent the FilePath on disk. -}
decodeW8 :: FilePath -> [Word8]
decodeW8 = s2w8 . _encodeFilePath
{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -}
encodeW8NUL :: [Word8] -> FilePath
encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul)
where
nul = ['\NUL']
decodeW8NUL :: FilePath -> [Word8]
decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul
where
nul = ['\NUL']
{- Truncates a FilePath to the given number of bytes (or less),
- as represented on disk.
-
- Avoids returning an invalid part of a unicode byte sequence, at the
- cost of efficiency when running on a large FilePath.
-}
truncateFilePath :: Int -> FilePath -> FilePath
#ifndef mingw32_HOST_OS
truncateFilePath n = go . reverse
where
go f =
let bytes = decodeW8 f
in if length bytes <= n
then reverse f
else go (drop 1 f)
#else
{- On Windows, count the number of bytes used by each utf8 character. -}
truncateFilePath n = reverse . go [] n . L8.fromString
where
go coll cnt bs
| cnt <= 0 = coll
| otherwise = case L8.decode bs of
Just (c, x) | c /= L8.replacement_char ->
let x' = fromIntegral x
in if cnt - x' < 0
then coll
else go (c:coll) (cnt - x') (L8.drop 1 bs)
_ -> coll
#endif
github-backup-1.20150807/Utility/Misc.hs 0000664 0000000 0000000 00000010705 12561161061 0017542 0 ustar 00root root 0000000 0000000 {- misc utility functions
-
- Copyright 2010-2011 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Misc where
import Utility.FileSystemEncoding
import Utility.Monad
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 Prelude
{- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -}
hGetContentsStrict :: Handle -> IO String
hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
{- A version of readFile that is not lazy. -}
readFileStrict :: FilePath -> IO String
readFileStrict = readFile >=> \s -> length s `seq` return s
{- Reads a file strictly, and using the FileSystemEncoding, so it will
- never crash on a badly encoded file. -}
readFileStrictAnyEncoding :: FilePath -> IO String
readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
fileEncoding h
hClose h `after` hGetContentsStrict h
{- Writes a file, using the FileSystemEncoding so it will never crash
- on a badly encoded content string. -}
writeFileAnyEncoding :: FilePath -> String -> IO ()
writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
fileEncoding h
hPutStr h content
{- Like break, but the item matching the condition is not included
- in the second result list.
-
- separate (== ':') "foo:bar" = ("foo", "bar")
- separate (== ':') "foobar" = ("foobar", "")
-}
separate :: (a -> Bool) -> [a] -> ([a], [a])
separate c l = unbreak $ break c l
where
unbreak r@(a, b)
| null b = r
| otherwise = (a, tail b)
{- Breaks out the first line. -}
firstLine :: String -> String
firstLine = takeWhile (/= '\n')
{- Splits a list into segments that are delimited by items matching
- a predicate. (The delimiters are not included in the segments.)
- Segments may be empty. -}
segment :: (a -> Bool) -> [a] -> [[a]]
segment p l = map reverse $ go [] [] l
where
go c r [] = reverse $ c:r
go c r (i:is)
| p i = go [] (c:r) is
| otherwise = go (i:c) r is
prop_segment_regressionTest :: Bool
prop_segment_regressionTest = all id
-- Even an empty list is a segment.
[ segment (== "--") [] == [[]]
-- There are two segements in this list, even though the first is empty.
, segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]]
]
{- Includes the delimiters as segments of their own. -}
segmentDelim :: (a -> Bool) -> [a] -> [[a]]
segmentDelim p l = map reverse $ go [] [] l
where
go c r [] = reverse $ c:r
go c r (i:is)
| p i = go [] ([i]:c:r) is
| otherwise = go (i:c) r is
{- Replaces multiple values in a string.
-
- Takes care to skip over just-replaced values, so that they are not
- mangled. For example, massReplace [("foo", "new foo")] does not
- replace the "new foo" with "new new foo".
-}
massReplace :: [(String, String)] -> String -> String
massReplace vs = go [] vs
where
go acc _ [] = concat $ reverse acc
go acc [] (c:cs) = go ([c]:acc) vs cs
go acc ((val, replacement):rest) s
| val `isPrefixOf` s =
go (replacement:acc) vs (drop (length val) s)
| otherwise = go acc rest s
{- Wrapper around hGetBufSome that returns a String.
-
- The null string is returned on eof, otherwise returns whatever
- data is currently available to read from the handle, or waits for
- data to be written to it if none is currently available.
-
- Note on encodings: The normal encoding of the Handle is ignored;
- each byte is converted to a Char. Not unicode clean!
-}
hGetSomeString :: Handle -> Int -> IO String
hGetSomeString h sz = do
fp <- mallocForeignPtrBytes sz
len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz
map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len)
where
peekbytes :: Int -> Ptr Word8 -> IO [Word8]
peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
{- Reaps any zombie git processes.
-
- Warning: Not thread safe. Anything that was expecting to wait
- on a process and get back an exit status is going to be confused
- if this reap gets there first. -}
reapZombies :: IO ()
#ifndef mingw32_HOST_OS
reapZombies = do
-- throws an exception when there are no child processes
catchDefaultIO Nothing (getAnyProcessStatus False True)
>>= maybe (return ()) (const reapZombies)
#else
reapZombies = return ()
#endif
exitBool :: Bool -> IO a
exitBool False = exitFailure
exitBool True = exitSuccess
github-backup-1.20150807/Utility/Monad.hs 0000664 0000000 0000000 00000003647 12561161061 0017714 0 ustar 00root root 0000000 0000000 {- monadic stuff
-
- Copyright 2010-2012 Joey Hess
-
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Monad where
import Data.Maybe
import Control.Monad
{- Return the first value from a list, if any, satisfying the given
- predicate -}
firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
firstM _ [] = return Nothing
firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)
{- Runs the action on values from the list until it succeeds, returning
- its result. -}
getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
getM _ [] = return Nothing
getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x
{- Returns true if any value in the list satisfies the predicate,
- stopping once one is found. -}
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM p = liftM isJust . firstM p
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM _ [] = return True
allM p (x:xs) = p x <&&> allM p xs
{- Runs an action on values from a list until it succeeds. -}
untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool
untilTrue = flip anyM
{- if with a monadic conditional. -}
ifM :: Monad m => m Bool -> (m a, m a) -> m a
ifM cond (thenclause, elseclause) = do
c <- cond
if c then thenclause else elseclause
{- short-circuiting monadic || -}
(<||>) :: Monad m => m Bool -> m Bool -> m Bool
ma <||> mb = ifM ma ( return True , mb )
{- short-circuiting monadic && -}
(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
ma <&&> mb = ifM ma ( mb , return False )
{- Same fixity as && and || -}
infixr 3 <&&>
infixr 2 <||>
{- Runs an action, passing its value to an observer before returning it. -}
observe :: Monad m => (a -> m b) -> m a -> m a
observe observer a = do
r <- a
_ <- observer r
return r
{- b `after` a runs first a, then b, and returns the value of a -}
after :: Monad m => m b -> m a -> m a
after = observe . const
{- do nothing -}
noop :: Monad m => m ()
noop = return ()
github-backup-1.20150807/Utility/PartialPrelude.hs 0000664 0000000 0000000 00000003253 12561161061 0021564 0 ustar 00root root 0000000 0000000 {- Parts of the Prelude are partial functions, which are a common source of
- bugs.
-
- This exports functions that conflict with the prelude, which avoids
- them being accidentially used.
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.PartialPrelude where
import qualified Data.Maybe
{- read should be avoided, as it throws an error
- Instead, use: readish -}
read :: Read a => String -> a
read = Prelude.read
{- head is a partial function; head [] is an error
- Instead, use: take 1 or headMaybe -}
head :: [a] -> a
head = Prelude.head
{- tail is also partial
- Instead, use: drop 1 -}
tail :: [a] -> [a]
tail = Prelude.tail
{- init too
- Instead, use: beginning -}
init :: [a] -> [a]
init = Prelude.init
{- last too
- Instead, use: end or lastMaybe -}
last :: [a] -> a
last = Prelude.last
{- Attempts to read a value from a String.
-
- Ignores leading/trailing whitespace, and throws away any trailing
- text after the part that can be read.
-
- readMaybe is available in Text.Read in new versions of GHC,
- but that one requires the entire string to be consumed.
-}
readish :: Read a => String -> Maybe a
readish s = case reads s of
((x,_):_) -> Just x
_ -> Nothing
{- Like head but Nothing on empty list. -}
headMaybe :: [a] -> Maybe a
headMaybe = Data.Maybe.listToMaybe
{- Like last but Nothing on empty list. -}
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
lastMaybe v = Just $ Prelude.last v
{- All but the last element of a list.
- (Like init, but no error on an empty list.) -}
beginning :: [a] -> [a]
beginning [] = []
beginning l = Prelude.init l
{- Like last, but no error on an empty list. -}
end :: [a] -> [a]
end [] = []
end l = [Prelude.last l]
github-backup-1.20150807/Utility/Path.hs 0000664 0000000 0000000 00000024373 12561161061 0017551 0 ustar 00root root 0000000 0000000 {- path manipulation
-
- Copyright 2010-2014 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE PackageImports, CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Path where
import Data.String.Utils
import System.FilePath
import System.Directory
import Data.List
import Data.Maybe
import Data.Char
import Control.Applicative
import Prelude
#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix
#else
import System.Posix.Files
import Utility.Exception
#endif
import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
-
- On Windows, preserves whichever style of path separator might be used in
- the input FilePaths. This is done because some programs in Windows
- demand a particular path separator -- and which one actually varies!
-
- This does not guarantee that two paths that refer to the same location,
- and are both relative to the same location (or both absolute) will
- yeild the same result. Run both through normalise from System.FilePath
- to ensure that.
-}
simplifyPath :: FilePath -> FilePath
simplifyPath path = dropTrailingPathSeparator $
joinDrive drive $ joinPath $ norm [] $ splitPath path'
where
(drive, path') = splitDrive path
norm c [] = reverse c
norm c (p:ps)
| p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." =
norm (drop 1 c) ps
| p' == "." = norm c ps
| otherwise = norm (p:c) ps
where
p' = dropTrailingPathSeparator p
{- Makes a path absolute.
-
- The first parameter is a base directory (ie, the cwd) to use if the path
- is not already absolute.
-
- Does not attempt to deal with edge cases or ensure security with
- untrusted inputs.
-}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path)
{- On Windows, this converts the paths to unix-style, in order to run
- MissingH's absNormPath on them. -}
absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
#ifndef mingw32_HOST_OS
absNormPathUnix dir path = MissingH.absNormPath dir path
#else
absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
where
fromdos = replace "\\" "/"
todos = replace "/" "\\"
#endif
{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
parentDir :: FilePath -> FilePath
parentDir = takeDirectory . dropTrailingPathSeparator
{- Just the parent directory of a path, or Nothing if the path has no
- parent (ie for "/" or ".") -}
upFrom :: FilePath -> Maybe FilePath
upFrom dir
| length dirs < 2 = Nothing
| otherwise = Just $ joinDrive drive (join s $ init dirs)
where
-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
(drive, path) = splitDrive dir
dirs = filter (not . null) $ split s path
s = [pathSeparator]
prop_upFrom_basics :: FilePath -> Bool
prop_upFrom_basics dir
| null dir = True
| dir == "/" = p == Nothing
| otherwise = p /= Just dir
where
p = upFrom dir
{- Checks if the first FilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- are all equivilant.
-}
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
where
a' = norm a
b' = norm b
norm = normalise . simplifyPath
{- Converts a filename into an absolute path.
-
- Unlike Directory.canonicalizePath, this does not require the path
- already exists. -}
absPath :: FilePath -> IO FilePath
absPath file = do
cwd <- getCurrentDirectory
return $ absPathFrom cwd file
{- Constructs a relative path from the CWD to a file.
-
- For example, assuming CWD is /tmp/foo/bar:
- relPathCwdToFile "/tmp/foo" == ".."
- relPathCwdToFile "/tmp/foo/bar" == ""
-}
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = do
c <- getCurrentDirectory
relPathDirToFile c f
{- Constructs a relative path from a directory to a file. -}
relPathDirToFile :: FilePath -> FilePath -> IO FilePath
relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
{- This requires the first path to be absolute, and the
- second path cannot contain ../ or ./
-
- On Windows, if the paths are on different drives,
- a relative path is not possible and the path is simply
- returned as-is.
-}
relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
relPathDirToFileAbs from to
| takeDrive from /= takeDrive to = to
| otherwise = join s $ dotdots ++ uncommon
where
s = [pathSeparator]
pfrom = split s from
pto = split s to
common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
| null from || null to = True
| from == to = null r
| otherwise = not (null r)
where
r = relPathDirToFileAbs from to
prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
where
{- Two paths have the same directory component at the same
- location, but it's not really the same directory.
- Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference =
relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
{- Given an original list of paths, and an expanded list derived from it,
- which may be arbitrarily reordered, generates a list of lists, where
- each sublist corresponds to one of the original paths.
-
- When the original path is a directory, any items in the expanded list
- that are contained in that directory will appear in its segment.
-
- The order of the original list of paths is attempted to be preserved in
- the order of the returned segments. However, doing so has a O^NM
- growth factor. So, if the original list has more than 100 paths on it,
- 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 [] 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
{- This assumes that it's cheaper to call segmentPaths on the result,
- than it would be to run the action separately with each path. In
- the case of git file list commands, that assumption tends to hold.
-}
runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths
{- Converts paths in the home directory to use ~/ -}
relHome :: FilePath -> IO String
relHome path = do
home <- myHomeDir
return $ if dirContains home path
then "~/" ++ relPathDirToFileAbs home path
else path
{- Checks if a command is available in PATH.
-
- The command may be fully-qualified, in which case, this succeeds as
- long as it exists. -}
inPath :: String -> IO Bool
inPath command = isJust <$> searchPath command
{- Finds a command in PATH and returns the full path to it.
-
- The command may be fully qualified already, in which case it will
- be returned if it exists.
-}
searchPath :: String -> IO (Maybe FilePath)
searchPath command
| isAbsolute command = check command
| otherwise = getSearchPath >>= getM indir
where
indir d = check $ d command
check f = firstM doesFileExist
#ifdef mingw32_HOST_OS
[f, f ++ ".exe"]
#else
[f]
#endif
{- Checks if a filename is a unix dotfile. All files inside dotdirs
- count as dotfiles. -}
dotfile :: FilePath -> Bool
dotfile file
| f == "." = False
| f == ".." = False
| f == "" = False
| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
where
f = takeFileName file
{- Converts a DOS style path to a Cygwin style path. Only on Windows.
- Any trailing '\' is preserved as a trailing '/' -}
toCygPath :: FilePath -> FilePath
#ifndef mingw32_HOST_OS
toCygPath = id
#else
toCygPath p
| null drive = recombine parts
| otherwise = recombine $ "/cygdrive" : driveletter drive : parts
where
(drive, p') = splitDrive p
parts = splitDirectories p'
driveletter = map toLower . takeWhile (/= ':')
recombine = fixtrailing . Posix.joinPath
fixtrailing s
| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
| otherwise = s
#endif
{- Maximum size to use for a file in a specified directory.
-
- Many systems have a 255 byte limit to the name of a file,
- so that's taken as the max if the system has a larger limit, or has no
- limit.
-}
fileNameLengthLimit :: FilePath -> IO Int
#ifdef mingw32_HOST_OS
fileNameLengthLimit _ = return 255
#else
fileNameLengthLimit dir = do
-- 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]
where
#endif
{- Given a string that we'd like to use as the basis for FilePath, but that
- was provided by a third party and is not to be trusted, returns the closest
- sane FilePath.
-
- All spaces and punctuation and other wacky stuff are replaced
- with '_', except for '.'
- "../" will thus turn into ".._", which is safe.
-}
sanitizeFilePath :: String -> FilePath
sanitizeFilePath = map sanitize
where
sanitize c
| c == '.' = c
| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
| otherwise = c
{- Similar to splitExtensions, but knows that some things in FilePaths
- after a dot are too long to be extensions. -}
splitShortExtensions :: FilePath -> (FilePath, [String])
splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
splitShortExtensions' maxextension = go []
where
go c f
| len > 0 && len <= maxextension && not (null base) =
go (ext:c) base
| otherwise = (f, c)
where
(base, ext) = splitExtension f
len = length ext
github-backup-1.20150807/Utility/PosixFiles.hs 0000664 0000000 0000000 00000001475 12561161061 0020740 0 ustar 00root root 0000000 0000000 {- POSIX files (and compatablity wrappers).
-
- This is like System.PosixCompat.Files, except with a fixed rename.
-
- Copyright 2014 Joey Hess
-
- 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
#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
github-backup-1.20150807/Utility/Process.hs 0000664 0000000 0000000 00000026072 12561161061 0020271 0 ustar 00root root 0000000 0000000 {- System.Process enhancements, including additional ways of running
- processes, and logging.
-
- Copyright 2012-2015 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP, Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Process (
module X,
CreateProcess(..),
StdHandle(..),
readProcess,
readProcess',
readProcessEnv,
writeReadProcessEnv,
forceSuccessProcess,
checkSuccessProcess,
ignoreFailureProcess,
createProcessSuccess,
createProcessChecked,
createBackgroundProcess,
processTranscript,
processTranscript',
withHandle,
withIOHandles,
withOEHandles,
withQuietOutput,
feedWithQuietOutput,
createProcess,
startInteractiveProcess,
stdinHandle,
stdoutHandle,
stderrHandle,
ioHandles,
processHandle,
devNull,
) where
import qualified System.Process
import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
import System.Process hiding (createProcess, readProcess)
import System.Exit
import System.IO
import System.Log.Logger
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
#ifndef mingw32_HOST_OS
import qualified System.Posix.IO
#else
import Control.Applicative
#endif
import Data.Maybe
import Prelude
import Utility.Misc
import Utility.Exception
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
data StdHandle = StdinHandle | StdoutHandle | StderrHandle
deriving (Eq)
-- | Normally, when reading from a process, it does not need to be fed any
-- standard input.
readProcess :: FilePath -> [String] -> IO String
readProcess cmd args = readProcessEnv cmd args Nothing
readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String
readProcessEnv cmd args environ = readProcess' p
where
p = (proc cmd args)
{ std_out = CreatePipe
, env = environ
}
readProcess' :: CreateProcess -> IO String
readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
output <- hGetContentsStrict h
hClose h
return output
-- | Runs an action to write to a process on its stdin,
-- returns its output, and also allows specifying the environment.
writeReadProcessEnv
:: FilePath
-> [String]
-> Maybe [(String, String)]
-> (Maybe (Handle -> IO ()))
-> (Maybe (Handle -> IO ()))
-> IO String
writeReadProcessEnv cmd args environ writestdin adjusthandle = do
(Just inh, Just outh, _, pid) <- createProcess p
maybe (return ()) (\a -> a inh) adjusthandle
maybe (return ()) (\a -> a outh) adjusthandle
-- fork off a thread to start consuming the output
output <- hGetContents outh
outMVar <- newEmptyMVar
_ <- forkIO $ E.evaluate (length output) >> putMVar outMVar ()
-- now write and flush any input
maybe (return ()) (\a -> a inh >> hFlush inh) writestdin
hClose inh -- done with stdin
-- wait on the output
takeMVar outMVar
hClose outh
-- wait on the process
forceSuccessProcess p pid
return output
where
p = (proc cmd args)
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
, env = environ
}
-- | Waits for a ProcessHandle, and throws an IOError if the process
-- did not exit successfully.
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
forceSuccessProcess p pid = do
code <- waitForProcess pid
case code of
ExitSuccess -> return ()
ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
-- | Waits for a ProcessHandle and returns True if it exited successfully.
-- Note that using this with createProcessChecked will throw away
-- the Bool, and is only useful to ignore the exit code of a process,
-- while still waiting for it. -}
checkSuccessProcess :: ProcessHandle -> IO Bool
checkSuccessProcess pid = do
code <- waitForProcess pid
return $ code == ExitSuccess
ignoreFailureProcess :: ProcessHandle -> IO Bool
ignoreFailureProcess pid = do
void $ waitForProcess pid
return True
-- | Runs createProcess, then an action on its handles, and then
-- forceSuccessProcess.
createProcessSuccess :: CreateProcessRunner
createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
-- | Runs createProcess, then an action on its handles, and then
-- a checker action on its exit code, which must wait for the process.
createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
createProcessChecked checker p a = do
t@(_, _, _, pid) <- createProcess p
r <- tryNonAsync $ a t
_ <- checker pid
either E.throw return r
-- | Leaves the process running, suitable for lazy streaming.
-- Note: Zombies will result, and must be waited on.
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p
-- | Runs a process, optionally feeding it some input, and
-- returns a transcript combining its stdout and stderr, and
-- whether it succeeded or failed.
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
processTranscript cmd opts input = processTranscript' cmd opts Nothing input
processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
processTranscript' cmd opts environ 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 $
(proc cmd opts)
{ std_in = if isJust input then CreatePipe else Inherit
, std_out = UseHandle writeh
, std_err = UseHandle writeh
, env = environ
}
hClose writeh
get <- mkreader readh
writeinput input p
transcript <- get
ok <- checkSuccessProcess pid
return (transcript, ok)
#else
{- This implementation for Windows puts stderr after stdout. -}
p@(_, _, _, pid) <- createProcess $
(proc cmd opts)
{ std_in = if isJust input then CreatePipe else Inherit
, std_out = CreatePipe
, std_err = CreatePipe
, env = environ
}
getout <- mkreader (stdoutHandle p)
geterr <- mkreader (stderrHandle p)
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.
withHandle
:: StdHandle
-> CreateProcessRunner
-> CreateProcess
-> (Handle -> IO a)
-> IO a
withHandle h creator p a = creator p' $ a . select
where
base = p
{ std_in = Inherit
, std_out = Inherit
, std_err = Inherit
}
(select, p')
| h == StdinHandle =
(stdinHandle, base { std_in = CreatePipe })
| h == StdoutHandle =
(stdoutHandle, base { std_out = CreatePipe })
| h == StderrHandle =
(stderrHandle, base { std_err = CreatePipe })
-- | Like withHandle, but passes (stdin, stdout) handles to the action.
withIOHandles
:: CreateProcessRunner
-> CreateProcess
-> ((Handle, Handle) -> IO a)
-> IO a
withIOHandles creator p a = creator p' $ a . ioHandles
where
p' = p
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
}
-- | Like withHandle, but passes (stdout, stderr) handles to the action.
withOEHandles
:: CreateProcessRunner
-> CreateProcess
-> ((Handle, Handle) -> IO a)
-> IO a
withOEHandles creator p a = creator p' $ a . oeHandles
where
p' = p
{ std_in = Inherit
, std_out = CreatePipe
, std_err = CreatePipe
}
-- | Forces the CreateProcessRunner to run quietly;
-- both stdout and stderr are discarded.
withQuietOutput
:: CreateProcessRunner
-> CreateProcess
-> IO ()
withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
let p' = p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
}
creator p' $ const $ return ()
-- | Stdout and stderr are discarded, while the process is fed stdin
-- from the handle.
feedWithQuietOutput
:: CreateProcessRunner
-> CreateProcess
-> (Handle -> IO a)
-> IO a
feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do
let p' = p
{ std_in = CreatePipe
, std_out = UseHandle nullh
, std_err = UseHandle nullh
}
creator p' $ a . stdinHandle
devNull :: FilePath
#ifndef mingw32_HOST_OS
devNull = "/dev/null"
#else
devNull = "NUL"
#endif
-- | Extract a desired handle from createProcess's tuple.
-- These partial functions are safe as long as createProcess is run
-- with appropriate parameters to set up the desired handle.
-- Get it wrong and the runtime crash will always happen, so should be
-- easily noticed.
type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
stdinHandle :: HandleExtractor
stdinHandle (Just h, _, _, _) = h
stdinHandle _ = error "expected stdinHandle"
stdoutHandle :: HandleExtractor
stdoutHandle (_, Just h, _, _) = h
stdoutHandle _ = error "expected stdoutHandle"
stderrHandle :: HandleExtractor
stderrHandle (_, _, Just h, _) = h
stderrHandle _ = error "expected stderrHandle"
ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
ioHandles (Just hin, Just hout, _, _) = (hin, hout)
ioHandles _ = error "expected ioHandles"
oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
oeHandles (_, Just hout, Just herr, _) = (hout, herr)
oeHandles _ = error "expected oeHandles"
processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid
-- | Debugging trace for a CreateProcess.
debugProcess :: CreateProcess -> IO ()
debugProcess p = do
debugM "Utility.Process" $ unwords
[ action ++ ":"
, showCmd p
]
where
action
| piped (std_in p) && piped (std_out p) = "chat"
| piped (std_in p) = "feed"
| piped (std_out p) = "read"
| otherwise = "call"
piped Inherit = False
piped _ = True
-- | Shows the command that a CreateProcess will run.
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
where
go (ShellCommand s) = s
go (RawCommand c ps) = c ++ " " ++ show ps
-- | Starts an interactive process. Unlike runInteractiveProcess in
-- System.Process, stderr is inherited.
startInteractiveProcess
:: FilePath
-> [String]
-> Maybe [(String, String)]
-> IO (ProcessHandle, Handle, Handle)
startInteractiveProcess cmd args environ = do
let p = (proc cmd args)
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
, env = environ
}
(Just from, Just to, _, pid) <- createProcess p
return (pid, to, from)
-- | Wrapper around 'System.Process.createProcess' from System.Process,
-- that does debug logging.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
debugProcess p
System.Process.createProcess p
github-backup-1.20150807/Utility/SafeCommand.hs 0000664 0000000 0000000 00000010736 12561161061 0021030 0 ustar 00root root 0000000 0000000 {- safely running shell commands
-
- Copyright 2010-2015 Joey Hess
-
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.SafeCommand where
import System.Exit
import Utility.Process
import Data.String.Utils
import System.FilePath
import Data.Char
import Control.Applicative
import Prelude
-- | Parameters that can be passed to a shell command.
data CommandParam
= Param String -- ^ A parameter
| File FilePath -- ^ The name of a file
deriving (Eq, Show, Ord)
-- | Used to pass a list of CommandParams to a function that runs
-- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
toCommand = map unwrap
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:"./"
-- | Run a system command, and returns True or False if it succeeded or failed.
--
-- This and other command running functions in this module log the commands
-- run at debug level, using System.Log.Logger.
boolSystem :: FilePath -> [CommandParam] -> IO Bool
boolSystem command params = boolSystem' command params id
boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool
boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess
where
dispatch ExitSuccess = True
dispatch _ = False
boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv command params environ = boolSystem' command params $
\p -> p { env = environ }
-- | Runs a system command, returning the exit status.
safeSystem :: FilePath -> [CommandParam] -> IO ExitCode
safeSystem command params = safeSystem' command params id
safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode
safeSystem' command params mkprocess = do
(_, _, _, pid) <- createProcess p
waitForProcess pid
where
p = mkprocess $ proc command (toCommand params)
safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode
safeSystemEnv command params environ = safeSystem' command params $
\p -> p { env = environ }
-- | Wraps a shell command line inside sh -c, allowing it to be run in a
-- login shell that may not support POSIX shell, eg csh.
shellWrap :: String -> String
shellWrap cmdline = "sh -c " ++ shellEscape cmdline
-- | Escapes a filename or other parameter to be safely able to be exposed to
-- the shell.
--
-- This method works for POSIX shells, as well as other shells like csh.
shellEscape :: String -> String
shellEscape f = "'" ++ escaped ++ "'"
where
-- replace ' with '"'"'
escaped = join "'\"'\"'" $ split "'" f
-- | Unescapes a set of shellEscaped words or filenames.
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word : shellUnEscape rest
where
(word, rest) = findword "" s
findword w [] = (w, "")
findword w (c:cs)
| c == ' ' = (w, cs)
| c == '\'' = inquote c w cs
| c == '"' = inquote c w cs
| otherwise = findword (w++[c]) cs
inquote _ w [] = (w, "")
inquote q w (c:cs)
| c == q = findword w cs
| otherwise = inquote q (w++[c]) cs
-- | For quickcheck.
prop_idempotent_shellEscape :: String -> Bool
prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s
prop_idempotent_shellEscape_multiword :: [String] -> Bool
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
-- | Segments a list of filenames into groups that are all below the maximum
-- command-line length limit.
segmentXargsOrdered :: [FilePath] -> [[FilePath]]
segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered
-- | Not preserving order is a little faster, and streams better when
-- there are a great many filenames.
segmentXargsUnordered :: [FilePath] -> [[FilePath]]
segmentXargsUnordered l = go l [] 0 []
where
go [] c _ r = (c:r)
go (f:fs) c accumlen r
| newlen > maxlen && len < maxlen = go (f:fs) [] 0 (c:r)
| otherwise = go fs (f:c) newlen r
where
len = length f
newlen = accumlen + len
{- 10k of filenames per command, well under 100k limit
- of Linux (and OSX has a similar limit);
- allows room for other parameters etc. Also allows for
- eg, multibyte characters. -}
maxlen = 10240
github-backup-1.20150807/Utility/State.hs 0000664 0000000 0000000 00000001272 12561161061 0017726 0 ustar 00root root 0000000 0000000 {- state monad support
-
- Copyright 2012 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE PackageImports #-}
module Utility.State where
import "mtl" Control.Monad.State.Strict
{- Modifies Control.Monad.State's state, forcing a strict update.
- This avoids building thunks in the state and leaking.
- Why it's not the default, I don't know.
-
- Example: changeState $ \s -> s { foo = bar }
-}
changeState :: MonadState s m => (s -> s) -> m ()
changeState f = do
x <- get
put $! f x
{- Gets a value from the internal state, selected by the passed value
- constructor. -}
getState :: MonadState s m => (s -> a) -> m a
getState = gets
github-backup-1.20150807/Utility/Tmp.hs 0000664 0000000 0000000 00000007225 12561161061 0017412 0 ustar 00root root 0000000 0000000 {- Temporary files and directories.
-
- Copyright 2010-2013 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp where
import System.IO
import System.Directory
import Control.Monad.IfElse
import System.FilePath
import Control.Monad.IO.Class
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 a file content = bracketIO setup cleanup use
where
(dir, base) = splitFileName file
template = base ++ ".tmp"
setup = do
createDirectoryIfMissing True dir
openTempFile dir template
cleanup (tmpfile, h) = do
_ <- tryIO $ hClose h
tryIO $ removeFile tmpfile
use (tmpfile, h) = do
liftIO $ hClose h
a tmpfile content
liftIO $ rename tmpfile file
{- Runs an action with a tmp file located in the system's tmp directory
- (or in "." if there is none) then removes the file. -}
withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a
withTmpFile template a = do
tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
withTmpFileIn tmpdir template a
{- Runs an action with a tmp file located in the specified directory,
- then removes the file. -}
withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a
withTmpFileIn tmpdir template a = bracket create remove use
where
create = liftIO $ openTempFile tmpdir template
remove (name, h) = liftIO $ do
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
tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
withTmpDirIn tmpdir template a
{- Runs an action with a tmp directory located within a specified directory,
- then removes the tmp directory and all its contents. -}
withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
withTmpDirIn tmpdir template = bracketIO create remove
where
remove d = whenM (doesDirectoryExist d) $ do
#if mingw32_HOST_OS
-- Windows will often refuse to delete a file
-- after a process has just written to it and exited.
-- Because it's crap, presumably. So, ignore failure
-- to delete the temp directory.
_ <- tryIO $ removeDirectoryRecursive d
return ()
#else
removeDirectoryRecursive d
#endif
create = do
createDirectoryIfMissing True tmpdir
makenewdir (tmpdir template) (0 :: Int)
makenewdir t n = do
let dir = t ++ "." ++ show n
either (const $ makenewdir t $ n + 1) (const $ return dir)
=<< tryIO (createDirectory dir)
{- It's not safe to use a FilePath of an existing file as the template
- for openTempFile, because if the FilePath is really long, the tmpfile
- will be longer, and may exceed the maximum filename length.
-
- This generates a template that is never too long.
- (Well, it allocates 20 characters for use in making a unique temp file,
- anyway, which is enough for the current implementation and any
- likely implementation.)
-}
relatedTemplate :: FilePath -> FilePath
relatedTemplate f
| len > 20 = truncateFilePath (len - 20) f
| otherwise = f
where
len = length f
github-backup-1.20150807/Utility/URI.hs 0000664 0000000 0000000 00000000474 12561161061 0017310 0 ustar 00root root 0000000 0000000 {- Network.URI
-
- Copyright 2014 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
module Utility.URI where
-- Old versions of network lacked an Ord for URI
#if ! MIN_VERSION_network(2,4,0)
import Network.URI
instance Ord URI where
a `compare` b = show a `compare` show b
#endif
github-backup-1.20150807/Utility/UserInfo.hs 0000664 0000000 0000000 00000002522 12561161061 0020377 0 ustar 00root root 0000000 0000000 {- user info
-
- Copyright 2012 Joey Hess
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.UserInfo (
myHomeDir,
myUserName,
myUserGecos,
) where
import Utility.Env
import System.PosixCompat
#ifndef mingw32_HOST_OS
import Control.Applicative
#endif
import Prelude
{- Current user's home directory.
-
- getpwent will fail on LDAP or NIS, so use HOME if set. -}
myHomeDir :: IO FilePath
myHomeDir = myVal env homeDirectory
where
#ifndef mingw32_HOST_OS
env = ["HOME"]
#else
env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin
#endif
{- Current user's user name. -}
myUserName :: IO String
myUserName = myVal env userName
where
#ifndef mingw32_HOST_OS
env = ["USER", "LOGNAME"]
#else
env = ["USERNAME", "USER", "LOGNAME"]
#endif
myUserGecos :: IO (Maybe String)
-- userGecos crashes on Android and is not available on Windows.
#if defined(__ANDROID__) || defined(mingw32_HOST_OS)
myUserGecos = return Nothing
#else
myUserGecos = Just <$> myVal [] userGecos
#endif
myVal :: [String] -> (UserEntry -> String) -> IO String
myVal envvars extract = go envvars
where
#ifndef mingw32_HOST_OS
go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)
#else
go [] = error $ "environment not set: " ++ show envvars
#endif
go (v:vs) = maybe (go vs) return =<< getEnv v
github-backup-1.20150807/configure.hs 0000664 0000000 0000000 00000000120 12561161061 0017153 0 ustar 00root root 0000000 0000000 {- configure program -}
import Build.Configure
main :: IO ()
main = run tests
github-backup-1.20150807/debian/ 0000775 0000000 0000000 00000000000 12561161061 0016067 5 ustar 00root root 0000000 0000000 github-backup-1.20150807/debian/changelog 0000664 0000000 0000000 00000016473 12561161061 0017754 0 ustar 00root root 0000000 0000000 github-backup (1.20150807) unstable; urgency=medium
* Added bash completion.
* Add --no-forks flag that turns off backing up forks.
Thanks, Phil Ruffwind.
* Avoid nonzero exit due to temporary failures that can be retried next
time github-backup runs, so that it can be used in a cron job with eg,
chronic.
-- Joey Hess Fri, 07 Aug 2015 12:50:02 -0400
github-backup (1.20150618) unstable; urgency=medium
* Fix broken configure script.
-- Joey Hess Thu, 18 Jun 2015 16:56:41 -0400
github-backup (1.20150617) unstable; urgency=medium
* Add missing build deps for windows to cabal file.
Thanks, Jeff Segal.
* Various updates to internal git and utility libraries shared
with git-annex.
-- Joey Hess Wed, 17 Jun 2015 14:44:14 -0400
github-backup (1.20150106) unstable; urgency=medium
* Fix build with process 1.2.1.0.
* Various updates to internal git and utility libraries shared
with git-annex.
-- Joey Hess Tue, 06 Jan 2015 19:08:08 -0400
github-backup (1.20141222) unstable; urgency=medium
* Added gitriddance(1), a utility to close all issues and pull requests,
for repos that don't want to be bothered with GitHub's proprietary
issue tracker.
* gitriddance depends on github 0.13.1, which has bug fixes
for posting comments.
* Various updates to internal git and utility libraries shared
with git-annex.
-- Joey Hess Mon, 22 Dec 2014 15:30:08 -0400
github-backup (1.20141204.1) unstable; urgency=medium
* Set myself as maintainer.
-- James McCoy Fri, 19 Jun 2015 21:32:18 -0400
github-backup (1.20141204) unstable; urgency=high
* Fix broken argument parser for the username|organization parameter.
Closes: #772043
-- Joey Hess Thu, 04 Dec 2014 12:29:06 -0400
github-backup (1.20141110) unstable; urgency=medium
* Orphaned the Debian package.
(I continue to maintain github-backup upstream.)
-- Joey Hess Mon, 10 Nov 2014 12:19:59 -0400
github-backup (1.20141031) unstable; urgency=medium
* Adjust cabal file for network-uri split.
* Avoid using optparse-applicate's argument combinator, so it will build
with 0.11 and older too.
* Various updates to internal git and utility libraries shared with
git-annex.
-- Joey Hess Fri, 31 Oct 2014 11:17:49 -0400
github-backup (1.20140831) unstable; urgency=medium
* Fix build with github 0.10.
-- Joey Hess Sun, 31 Aug 2014 15:31:26 -0700
github-backup (1.20140807) unstable; urgency=medium
* Fix build with github 0.9.
* Fix creation of github branch.
-- Joey Hess Thu, 07 Aug 2014 22:17:22 -0400
github-backup (1.20140721) unstable; urgency=medium
* Fix typo in fix for url parsing. Closes: #755261
-- Joey Hess Mon, 21 Jul 2014 13:10:49 -0400
github-backup (1.20140720) unstable; urgency=medium
* Deal with trailing slashes on github repo urls. Closes: #755261
* Fix bug introduced by change to embedded git libraries
in last release. Closes: #755262
-- Joey Hess Sun, 20 Jul 2014 17:20:26 -0400
github-backup (1.20140707) unstable; urgency=medium
* Add --exclude to skip backing up a specific repository
when backing up a user or organization's repositories.
Closes: #754072
* Converted to using optparse-applicative.
* Multiple usernames can now be specified to back up at once.
-- Joey Hess Mon, 07 Jul 2014 23:01:03 -0400
github-backup (1.20140704) unstable; urgency=medium
* Avoid making signed commits when committing to the github-backup branch
and the user has commit.gpgsign=true.
Closes: #753720
* Various updates to internal git and utility libraries shared with git-annex.
-- Joey Hess Fri, 04 Jul 2014 12:01:11 -0400
github-backup (1.20131203) unstable; urgency=low
* Now also backs up the repos a user has starred, when run with a user's
name.
* Now finds and backs up the parent repository that a repository got forked
from.
* Uses authentication for all API calls.
* Fairer ordering of requests when backing up many repositories at once.
* Avoid making requests for data that has already been backed up until
after new data has been backed up. Handles API rate limiting much better.
Closes: #723859
-- Joey Hess Tue, 03 Dec 2013 12:45:18 -0400
github-backup (1.20131101) unstable; urgency=low
* Now also backs up the repos a user is watching, when run with a user's
name. Useful if you want to back up repositories that you have not forked;
just watch them and run github-backup.
* Can now log in to github, to avoid increasingly small API rate limits.
Set GITHUB_USER and GITHUB_PASSWORD environment to enable.
Note that a few api calls don't use authentication; see
https://github.com/fpco/github/issues/40
* Build-Depend on git. Closes: #728481
* Don't include tmp directory in files stored in the github branch.
-- Joey Hess Fri, 01 Nov 2013 18:00:16 -0400
github-backup (1.20131006) unstable; urgency=low
* Ported to Windows.
* Improve error message when it fails to query github for repositories
belonging to a user. Closes: #705084
* Various updates to internal git and utility libraries shared with git-annex.
* Makefile now uses cabal to build.
-- Joey Hess Sun, 06 Oct 2013 18:04:56 -0400
github-backup (1.20130622) unstable; urgency=low
* Add missing unix-compat build dependency. Closes: #713279
-- Joey Hess Sat, 22 Jun 2013 13:08:57 -0400
github-backup (1.20130618) unstable; urgency=low
* Much better creation and committing to the github branch.
-- Joey Hess Mon, 17 Jun 2013 17:40:02 -0400
github-backup (1.20130617) unstable; urgency=low
* Build-Depend on libghc-extensible-exceptions-dev. Closes: #712549
* Various updates to internal git and utility libraries shared with
git-annex, including some Windows portability.
* Fixed to never touch the git work tree or index file, instead using
its own to commit to the github branch.
-- Joey Hess Mon, 17 Jun 2013 12:28:30 -0400
github-backup (1.20130614) unstable; urgency=low
* Pass --ignore-removal to git-add, in preparation for a future change
to its default behavior. Requires git 1.8.3. Closes: #711287
-- Joey Hess Fri, 14 Jun 2013 15:50:49 -0400
github-backup (1.20130414) experimental; urgency=low
* Updated to use haskell-github 0.6.0, which supports pagination of queries
Thanks to John Wiegley for making those changes.
* Also backup closed issues. Thanks, John Wiegley.
* cabal file no longer tries to list every source file, as that was
error-prone, and I left some out.
-- Joey Hess Fri, 12 Apr 2013 18:33:11 -0400
github-backup (1.20120627) unstable; urgency=low
* Rebuilt with new haskell-github, that works with the new version
of http-conduit in Debian. Closes: #678787
* Various updates to internal git and utility libraries shared with git-annex.
-- Joey Hess Wed, 27 Jun 2012 22:21:01 -0400
github-backup (1.20120314) unstable; urgency=low
* First release.
-- Joey Hess Tue, 13 Mar 2012 20:22:43 -0400
github-backup-1.20150807/debian/compat 0000664 0000000 0000000 00000000002 12561161061 0017265 0 ustar 00root root 0000000 0000000 9
github-backup-1.20150807/debian/control 0000664 0000000 0000000 00000001722 12561161061 0017474 0 ustar 00root root 0000000 0000000 Source: github-backup
Section: utils
Priority: optional
Build-Depends:
debhelper (>= 9),
ghc,
git,
libghc-github-dev (>= 0.13.1),
libghc-missingh-dev,
libghc-hslogger-dev,
libghc-pretty-show-dev,
libghc-ifelse-dev,
libghc-exceptions-dev,
libghc-transformers-dev,
libghc-unix-compat-dev,
libghc-optparse-applicative-dev
Maintainer: James McCoy
Standards-Version: 3.9.5
Vcs-Git: git://github.com/joeyh/github-backup.git
Homepage: http://github.com/joeyh/github-backup
Package: github-backup
Architecture: any
Section: utils
Depends: ${misc:Depends}, ${shlibs:Depends}, git
Description: backs up data from GitHub
github-backup is a simple tool you run in a git repository you cloned from
GitHub. It backs up everything GitHub publishes about the repository,
including other forks, issues, comments, wikis, milestones, pull requests,
and watchers.
.
Also includes gitriddance, which can be used to close all open issues and
pull requests.
github-backup-1.20150807/debian/copyright 0000664 0000000 0000000 00000003224 12561161061 0020023 0 ustar 00root root 0000000 0000000 Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
Source: native package
Files: *
Copyright: © 2010-2014 Joey Hess
License: GPL-3+
The full text of version 3 of the GPL is distributed as doc/GPL in
this package's source, or in /usr/share/common-licenses/GPL-3 on
Debian systems.
Files: Utility/*
Copyright: 2012-2014 Joey Hess
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.
github-backup-1.20150807/debian/manpages 0000664 0000000 0000000 00000000020 12561161061 0017575 0 ustar 00root root 0000000 0000000 github-backup.1
github-backup-1.20150807/debian/rules 0000775 0000000 0000000 00000000273 12561161061 0017151 0 ustar 00root root 0000000 0000000 #!/usr/bin/make -f
# Avoid using cabal, as it writes to $HOME
export CABAL=./Setup
# Do use the changelog's version number, rather than making one up.
export RELEASE_BUILD=1
%:
dh $@
github-backup-1.20150807/github-backup.1 0000664 0000000 0000000 00000002436 12561161061 0017461 0 ustar 00root root 0000000 0000000 .\" -*- nroff -*-
.TH github-backup 1 "Commands"
.SH NAME
github-backup \- backs up data from GitHub
.SH SYNOPSIS
.B github-backup [\fIusername\fP|\fIorganization\fP ...] [options]
.SH DESCRIPTION
.I github-backup
is a simple tool you run in a git repository you cloned from
GitHub. It backs up everything GitHub publishes about the repository,
including other branches, tags, forks, issues, comments, wikis,
milestones, pull requests, and watchers.
.PP
Alternately, if you pass it the username of a GitHub user, it will check
out, and back up, all that user's repositories, as well as all the
repositories that user is watching. (Also works to pass
the name of an organization using GitHub.)
.PP
By default it runs without logging in to GitHub. To log in, set
GITHUB_USER and GITHUB_PASSWORD environment variables. However note that
this only works around API rate limiting; it does not allow private
repositories to be downloaded.
.SH OPTIONS
.PP
.IP --exclude=username/repository
When backing up a user or an organization, this can be used to exclude
bacup of a particular repository belonging to the user or organization.
This option can be specified any number of time to exclude more than one
repository.
.PP
.IP --no-forks
Avoid backing up a repository's forks.
.SH AUTHOR
Joey Hess
github-backup-1.20150807/github-backup.cabal 0000664 0000000 0000000 00000003727 12561161061 0020367 0 ustar 00root root 0000000 0000000 Name: github-backup
Version: 1.20150807
Cabal-Version: >= 1.8
Maintainer: Joey Hess
Author: Joey Hess
Stability: Stable
Copyright: 2012 Joey Hess
License: GPL-3
License-File: COPYRIGHT
Build-Type: Custom
Extra-Source-Files: CHANGELOG
Homepage: https://github.com/joeyh/github-backup
Category: Utility
Synopsis: backs up everything github knows about a repository, to the repository
Description:
github-backup is a simple tool you run in a git repository you cloned from
Github. It backs up everything Github knows about the repository, including
other forks, issues, comments, milestones, pull requests, and watchers.
Also includes gitriddance, which can be used to close all open issues and
pull requests.
Flag network-uri
Description: Get Network.URI from the network-uri package
Default: True
Executable github-backup
Main-Is: github-backup.hs
GHC-Options: -Wall -fno-warn-tabs
Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl,
network, exceptions, transformers, unix-compat, bytestring,
IfElse, pretty-show, text, process, optparse-applicative,
github >= 0.7.2,
base >= 4.5, base < 5
if (! os(windows))
Build-Depends: unix
else
Build-Depends: Win32, setenv, utf8-string
if flag(network-uri)
Build-Depends: network-uri (>= 2.6), network (>= 2.6)
else
Build-Depends: network (< 2.6), network (>= 2.0)
Executable gitriddance
Main-Is: gitriddance.hs
GHC-Options: -Wall
Build-Depends: github >= 0.13.1, base >= 4.5, base < 5, text, filepath,
MissingH, exceptions, transformers, bytestring, hslogger, process,
containers, unix-compat, IfElse, directory, mtl
if (! os(windows))
Build-Depends: unix
else
Build-Depends: Win32, setenv, utf8-string
if flag(network-uri)
Build-Depends: network-uri (>= 2.6), network (>= 2.6)
else
Build-Depends: network (< 2.6), network (>= 2.0)
source-repository head
type: git
location: git://github.com/joeyh/github-backup.git
github-backup-1.20150807/github-backup.hs 0000664 0000000 0000000 00000046445 12561161061 0017743 0 ustar 00root root 0000000 0000000 {- github-backup
-
- Copyright 2012-2013 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PackageImports #-}
module Main where
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Either
import Data.Monoid
import Options.Applicative
import Text.Show.Pretty
import "mtl" Control.Monad.State.Strict
import qualified Github.Repos as Github
#if MIN_VERSION_github(0,9,0)
import qualified Github.Auth as Github
#endif
import qualified Github.Repos.Forks as Github
import qualified Github.PullRequests as Github
import qualified Github.Repos.Watching as Github
import qualified Github.Repos.Starring as Github
import qualified Github.Data.Definitions as Github ()
import qualified Github.Issues as Github
import qualified Github.Issues.Comments
import qualified Github.Issues.Milestones
import Common
import Utility.State
import qualified Git
import qualified Git.Construct
import qualified Git.Config
import qualified Git.Types
import qualified Git.Command
import qualified Git.Ref
import qualified Git.Branch
import qualified Git.UpdateIndex
import Github.GetAuth
import Github.EnumRepos
import Git.HashObject
import Git.FilePath
import Git.CatFile
import Utility.Env
repoUrl :: GithubUserRepo -> String
repoUrl (GithubUserRepo user remote) =
"git://github.com/" ++ user ++ "/" ++ remote ++ ".git"
repoWikiUrl :: GithubUserRepo -> String
repoWikiUrl (GithubUserRepo user remote) =
"git://github.com/" ++ user ++ "/" ++ remote ++ ".wiki.git"
-- A name for a github api call.
type ApiName = String
-- A request to make of github. It may have an extra parameter.
data Request = RequestSimple ApiName GithubUserRepo
| RequestNum ApiName GithubUserRepo Int
deriving (Eq, Show, Read, Ord)
requestRepo :: Request -> GithubUserRepo
requestRepo (RequestSimple _ repo) = repo
requestRepo (RequestNum _ repo _) = repo
requestName :: Request -> String
requestName (RequestSimple name _) = name
requestName (RequestNum name _ _) = name
data BackupState = BackupState
{ failedRequests :: S.Set Request
, retriedRequests :: S.Set Request
, retriedFailed :: S.Set Request
, gitRepo :: Git.Repo
, gitHubAuth :: Maybe Github.GithubAuth
, deferredBackups :: [Backup ()]
, catFileHandle :: Maybe CatFileHandle
, noForks :: Bool
}
{- Our monad. -}
newtype Backup a = Backup { runBackup :: StateT BackupState IO a }
deriving (
Monad,
MonadState BackupState,
MonadIO,
Functor,
Applicative
)
inRepo :: (Git.Repo -> IO a) -> Backup a
inRepo a = liftIO . a =<< getState gitRepo
failedRequest :: Request -> Github.Error -> Backup ()
failedRequest req e = unless ignorable $ do
set <- getState failedRequests
changeState $ \s -> s { failedRequests = S.insert req set }
where
-- "410 Gone" is used for repos that have issues etc disabled.
ignorable = "410 Gone" `isInfixOf` show e
runRequest :: Request -> Backup ()
runRequest req = do
-- avoid re-running requests that were already retried
retried <- getState retriedRequests
unless (S.member req retried) $
(lookupApi req) req
type Storer = Request -> Backup ()
data ApiListItem = ApiListItem ApiName Storer Bool
apiList :: [ApiListItem]
apiList =
[ ApiListItem "watchers" watchersStore True
, ApiListItem "stargazers" stargazersStore True
, ApiListItem "pullrequests" pullrequestsStore True
, ApiListItem "pullrequest" pullrequestStore False
, ApiListItem "milestones" milestonesStore True
, ApiListItem "issues" issuesStore True
, ApiListItem "issuecomments" issuecommentsStore False
-- Recursive things last.
, ApiListItem "userrepo" userrepoStore True
, ApiListItem "forks" forksStore True
]
{- Map of Github api calls we can make to store their data. -}
api :: M.Map ApiName Storer
api = M.fromList $ map (\(ApiListItem n s _) -> (n, s)) apiList
{- List of toplevel api calls that are followed to get data. -}
toplevelApi :: [ApiName]
toplevelApi = map (\(ApiListItem n _ _) -> n) $
filter (\(ApiListItem _ _ toplevel) -> toplevel) apiList
lookupApi :: Request -> Storer
lookupApi req = fromMaybe bad $ M.lookup name api
where
name = requestName req
bad = error $ "internal error: bad api call: " ++ name
watchersStore :: Storer
watchersStore = simpleHelper "watchers" Github.watchersFor' $
storeSorted "watchers"
stargazersStore :: Storer
stargazersStore = simpleHelper "stargazers" Github.stargazersFor $
storeSorted "stargazers"
pullrequestsStore :: Storer
pullrequestsStore = simpleHelper "pullrequest" Github.pullRequestsFor' $
forValues $ \req r -> do
let repo = requestRepo req
let n = Github.pullRequestNumber r
runRequest $ RequestNum "pullrequest" repo n
pullrequestStore :: Storer
pullrequestStore = numHelper "pullrequest" Github.pullRequest' $ \n ->
store ("pullrequest" show n)
milestonesStore :: Storer
milestonesStore = simpleHelper "milestone" Github.Issues.Milestones.milestones' $
forValues $ \req m -> do
let n = Github.milestoneNumber m
store ("milestone" show n) req m
issuesStore :: Storer
issuesStore = withHelper "issue" (\a u r y ->
Github.issuesForRepo' a u r (y <> [Github.Open])
>>= either (return . Left)
(\xs -> Github.issuesForRepo' a u r
(y <> [Github.OnlyClosed])
>>= either (return . Left)
(\ys -> return (Right (xs <> ys)))))
[Github.PerPage 100] go
where
go = forValues $ \req i -> do
let repo = requestRepo req
let n = Github.issueNumber i
store ("issue" show n) req i
runRequest (RequestNum "issuecomments" repo n)
issuecommentsStore :: Storer
issuecommentsStore = numHelper "issuecomments" Github.Issues.Comments.comments' $ \n ->
forValues $ \req c -> do
let i = Github.issueCommentId c
store ("issue" show n ++ "_comment" show i) req c
userrepoStore :: Storer
userrepoStore = simpleHelper "repo" Github.userRepo' $ \req r -> do
store "repo" req r
when (Github.repoHasWiki r == Just True) $
updateWiki $ toGithubUserRepo r
maybe noop addFork $ Github.repoParent r
maybe noop addFork $ Github.repoSource r
forksStore :: Storer
forksStore = simpleHelper "forks" Github.forksFor' $ \req fs -> do
storeSorted "forks" req fs
mapM_ addFork fs
forValues :: (Request -> v -> Backup ()) -> Request -> [v] -> Backup ()
forValues a req vs = forM_ vs (a req)
type ApiCall v = Maybe Github.GithubAuth -> String -> String -> IO (Either Github.Error v)
type ApiWith v b = Maybe Github.GithubAuth -> String -> String -> b -> IO (Either Github.Error v)
type ApiNum v = ApiWith v Int
type Handler v = Request -> v -> Backup ()
type Helper = Request -> Backup ()
simpleHelper :: FilePath -> ApiCall v -> Handler v -> Helper
simpleHelper dest call handler req@(RequestSimple _ (GithubUserRepo user repo)) =
deferOn dest req $ do
auth <- getState gitHubAuth
either (failedRequest req) (handler req) =<< liftIO (call auth user repo)
simpleHelper _ _ _ r = badRequest r
withHelper :: FilePath -> ApiWith v b -> b -> Handler v -> Helper
withHelper dest call b handler req@(RequestSimple _ (GithubUserRepo user repo)) =
deferOn dest req $ do
auth <- getState gitHubAuth
either (failedRequest req) (handler req) =<< liftIO (call auth user repo b)
withHelper _ _ _ _ r = badRequest r
numHelper :: FilePath -> ApiNum v -> (Int -> Handler v) -> Helper
numHelper dest call handler req@(RequestNum _ (GithubUserRepo user repo) num) =
deferOn dest req $ do
auth <- getState gitHubAuth
either (failedRequest req) (handler num req) =<< liftIO (call auth user repo num)
numHelper _ _ _ r = badRequest r
badRequest :: Request -> a
badRequest r = error $ "internal error: bad request type " ++ show r
{- When the specified file or directory already exists in git, the action
- is deferred until later. -}
deferOn :: FilePath -> Request -> Backup () -> Backup ()
deferOn f req a = ifM (ingit $ storeLocation f req)
( changeState $ \s -> s { deferredBackups = a : deferredBackups s }
, a
)
where
ingit f' = do
h <- getCatFileHandle
liftIO $ isJust <$> catObjectDetails h
(Git.Types.Ref $ Git.Types.fromRef branchname ++ ":" ++ f')
getCatFileHandle :: Backup CatFileHandle
getCatFileHandle = go =<< getState catFileHandle
where
go (Just h) = return h
go Nothing = do
h <- withIndex $ inRepo catFileStart
changeState $ \s -> s { catFileHandle = Just h }
return h
store :: Show a => FilePath -> Request -> a -> Backup ()
store filebase req val = do
file <- ()
<$> workDir
<*> pure (storeLocation filebase req)
liftIO $ do
createDirectoryIfMissing True (takeDirectory file)
writeFile file (ppShow val)
storeLocation :: FilePath -> Request -> FilePath
storeLocation filebase = location . requestRepo
where
location (GithubUserRepo user repo) =
user ++ "_" ++ repo filebase
workDir :: Backup FilePath
workDir = ()
<$> (Git.repoPath <$> getState gitRepo)
<*> pure "github-backup.tmp"
storeSorted :: Ord a => Show a => FilePath -> Request -> [a] -> Backup ()
storeSorted file req val = store file req (sort val)
{- Commits all files in the workDir into the github branch, and deletes the
- workDir.
-
- The commit is made to the github branch without ever checking it out,
- or otherwise disturbing the work tree.
-}
commitWorkDir :: Backup ()
commitWorkDir = do
dir <- workDir
whenM (liftIO $ doesDirectoryExist dir) $ do
branchref <- getBranch
withIndex $ do
r <- getState gitRepo
liftIO $ do
-- Reset index to current content of github
-- branch. Does not touch work tree.
Git.Command.run
[Param "reset", Param "-q", Param $ Git.Types.fromRef branchref, File "." ] r
-- Stage workDir files into the index.
h <- hashObjectStart r
Git.UpdateIndex.streamUpdateIndex r
[genstream dir h]
hashObjectStop h
-- Commit
void $ Git.Branch.commit Git.Branch.AutomaticCommit False "github-backup" fullname [branchref] r
removeDirectoryRecursive dir
where
genstream dir h streamer = do
fs <- filter (not . dirCruft) <$> dirContentsRecursive dir
forM_ fs $ \f -> do
sha <- hashFile h f
path <- asTopFilePath <$> relPathDirToFile dir f
streamer $ Git.UpdateIndex.updateIndexLine
sha Git.Types.FileBlob path
{- Returns the ref of the github branch, creating it first if necessary. -}
getBranch :: Backup Git.Ref
getBranch = maybe (hasOrigin >>= create) return =<< branchsha
where
create True = do
inRepo $ Git.Command.run
[Param "branch", Param $ Git.Types.fromRef branchname, Param $ Git.Types.fromRef originname]
fromMaybe (error $ "failed to create " ++ Git.Types.fromRef branchname)
<$> branchsha
create False = withIndex $
inRepo $ Git.Branch.commitAlways Git.Branch.AutomaticCommit "branch created" fullname []
branchsha = inRepo $ Git.Ref.sha fullname
{- Runs an action with a different index file, used for the github branch. -}
withIndex :: Backup a -> Backup a
withIndex a = do
r <- getState gitRepo
let f = Git.localGitDir r "github-backup.index"
e <- liftIO getEnvironment
let r' = r { Git.Types.gitEnv = Just $ ("GIT_INDEX_FILE", f):e }
changeState $ \s -> s { gitRepo = r' }
v <- a
changeState $ \s -> s { gitRepo = (gitRepo s) { Git.Types.gitEnv = Git.Types.gitEnv r } }
return v
branchname :: Git.Ref
branchname = Git.Ref "github"
fullname :: Git.Ref
fullname = Git.Ref $ "refs/heads/" ++ Git.Types.fromRef branchname
originname :: Git.Ref
originname = Git.Ref $ "refs/remotes/origin/" ++ Git.Types.fromRef branchname
hasOrigin :: Backup Bool
hasOrigin = inRepo $ Git.Ref.exists originname
updateWiki :: GithubUserRepo -> Backup ()
updateWiki fork =
ifM (any (\r -> Git.remoteName r == Just remote) <$> remotes)
( void fetchwiki
, void $
-- github often does not really have a wiki,
-- don't bloat config if there is none
unlessM (addRemote remote $ repoWikiUrl fork) $
removeRemote remote
)
where
fetchwiki = inRepo $ Git.Command.runBool [Param "fetch", Param remote]
remotes = Git.remotes <$> getState gitRepo
remote = remoteFor fork
remoteFor (GithubUserRepo user repo) =
"github_" ++ user ++ "_" ++ repo ++ ".wiki"
addFork :: ToGithubUserRepo a => a -> Backup ()
addFork forksource = unlessM (elem fork . gitHubRemotes <$> getState gitRepo) $ do
liftIO $ putStrLn $ "New fork: " ++ repoUrl fork
void $ addRemote (remoteFor fork) (repoUrl fork)
gitRepo' <- inRepo $ Git.Config.reRead
changeState $ \s -> s { gitRepo = gitRepo' }
gatherMetaData fork
where
fork = toGithubUserRepo forksource
remoteFor (GithubUserRepo user repo) = "github_" ++ user ++ "_" ++ repo
{- Adds a remote, also fetching from it. -}
addRemote :: String -> String -> Backup Bool
addRemote remotename remoteurl =
inRepo $ Git.Command.runBool
[ Param "remote"
, Param "add"
, Param "-f"
, Param remotename
, Param remoteurl
]
removeRemote :: String -> Backup ()
removeRemote remotename = void $ inRepo $ Git.Command.runBool
[ Param "remote"
, Param "rm"
, Param remotename
]
{- Fetches from the github remote. Done by github-backup, just because
- it would be weird for a backup to not fetch all available data.
- Even though its real focus is on metadata not stored in git. -}
fetchRepo :: Git.Repo -> Backup Bool
fetchRepo repo = inRepo $ Git.Command.runBool
[Param "fetch", Param $ fromJust $ Git.Types.remoteName repo]
gatherMetaData :: GithubUserRepo -> Backup ()
gatherMetaData repo = do
noforks <- getState noForks
liftIO $ putStrLn $ "Gathering metadata for " ++ repoUrl repo ++ " ..."
mapM_ call (filter (forksfilter noforks) toplevelApi)
where
call name = runRequest $ RequestSimple name repo
forksfilter noforks name = not (noforks && name == "forks")
storeRetry :: [Request] -> Git.Repo -> IO ()
storeRetry [] r = void $ do
try $ removeFile (retryFile r) :: IO (Either SomeException ())
storeRetry retryrequests r = writeFile (retryFile r) (show retryrequests)
loadRetry :: Git.Repo -> IO [Request]
loadRetry r = maybe [] (fromMaybe [] . readish)
<$> catchMaybeIO (readFileStrict (retryFile r))
retryFile :: Git.Repo -> FilePath
retryFile r = Git.localGitDir r "github-backup.todo"
retry :: Backup ()
retry = do
todo <- inRepo loadRetry
unless (null todo) $ do
liftIO $ putStrLn $
"Retrying " ++ show (length todo) ++
" requests that failed last time..."
mapM_ runRequest todo
changeState $ \s -> s
{ retriedFailed = failedRequests s
, failedRequests = S.empty
, retriedRequests = S.fromList todo
}
summarizeRequests :: [Request] -> [String]
summarizeRequests = go M.empty
where
go m [] = map format $ sort $ map swap $ M.toList m
go m (r:rs) = go (M.insertWith (+) (requestName r) (1 :: Integer) m) rs
format (num, name) = show num ++ "\t" ++ name
swap (a, b) = (b, a)
{- Save all backup data. Files that were written to the workDir are committed.
- Requests that failed are saved for next time. Requests that were retried
- this time and failed are ordered last, to ensure that we don't get stuck
- retrying the same requests and not making progress when run again.
-
- Returns any requests that failed.
-}
save :: Backup [Request]
save = do
commitWorkDir
failed <- getState failedRequests
retriedfailed <- getState retriedFailed
let toretry = S.toList failed ++ S.toList retriedfailed
inRepo $ storeRetry toretry
endState
return toretry
showFailures :: [Request] -> IO ()
showFailures [] = noop
showFailures l = hPutStrLn stderr $ unlines $
["Backup may be incomplete; " ++
show (length l) ++ " requests failed:"
] ++ map (" " ++) (summarizeRequests l) ++
[ "Run again later."
]
newState :: Bool -> Git.Repo -> IO BackupState
newState noforks r = BackupState
<$> pure S.empty
<*> pure S.empty
<*> pure S.empty
<*> pure r
<*> getAuth
<*> pure []
<*> pure Nothing
<*> pure noforks
endState :: Backup ()
endState = liftIO . maybe noop catFileStop =<< getState catFileHandle
genBackupState :: Bool -> Git.Repo -> IO BackupState
genBackupState noforks repo = newState noforks =<< Git.Config.read repo
backupRepo :: Bool -> (Maybe Git.Repo) -> IO ()
backupRepo _ Nothing = error "not in a git repository, and nothing specified to back up"
backupRepo noforks (Just repo) =
genBackupState noforks repo >>= evalStateT (runBackup go) >>= showFailures
where
go = do
retry
mainBackup
runDeferred
save
mainBackup :: Backup ()
mainBackup = do
remotes <- gitHubPairs <$> getState gitRepo
when (null remotes) $
error "no github remotes found"
forM_ remotes $ \(r, remote) -> do
void $ fetchRepo r
gatherMetaData remote
runDeferred :: Backup ()
runDeferred = go =<< getState deferredBackups
where
go [] = noop
go l = do
changeState $ \s -> s { deferredBackups = [] }
void $ sequence l
-- Running the deferred actions could cause
-- more actions to be deferred; run them too.
runDeferred
backupOwner :: Bool -> [GithubUserRepo] -> Owner -> IO ()
backupOwner noforks exclude (Owner name) = do
auth <- getAuth
l <- sequence
[ Github.userRepos' auth name Github.All
, Github.reposWatchedBy' auth name
, Github.reposStarredBy auth name
, Github.organizationRepos' auth name
]
let nameurls = nub $ mapMaybe makenameurl $ concat $ rights l
when (null nameurls) $
if (null $ rights l)
then error $ unlines $ "Failed to query github for repos:" : map show (lefts l)
else error $ "No GitHub repositories found for " ++ name
-- Clone any missing repos, and get a BackupState for each repo
-- that is to be backed up.
states <- catMaybes <$> forM nameurls prepare
-- First pass only retries things that failed before, so the
-- retried actions will run in each repo before too much API is
-- used up.
states' <- forM states (execStateT . runBackup $ retry)
states'' <- forM states' (execStateT . runBackup $ mainBackup)
forM states'' (evalStateT . runBackup $ runDeferred >> save)
>>= showFailures . concat
where
excludeurls = map repoUrl exclude
makenameurl repo =
#if MIN_VERSION_github(0,10,0)
case Github.repoGitUrl repo of
Just url -> Just (Github.repoName repo, url)
Nothing -> Nothing
#else
Just (Github.repoName repo, Github.repoGitUrl repo)
#endif
prepare (dir, url)
| url `elem` excludeurls = return Nothing
| otherwise = do
unlessM (doesDirectoryExist dir) $ do
putStrLn $ "New repository: " ++ dir
ok <- boolSystem "git"
[ Param "clone"
, Param url
, Param dir
]
unless ok $ error "clone failed"
Just <$> (genBackupState noforks =<< Git.Construct.fromPath dir)
data Options = Options
{ includeOwner :: [Owner]
, excludeRepo :: [GithubUserRepo]
, noForksOpt :: Bool
}
deriving (Show)
data Owner = Owner String
deriving (Show)
options :: Parser Options
options = Options <$> many owneropt <*> many excludeopt <*> noforksopt
where
owneropt = Owner <$> (argument str)
( metavar "USERNAME|ORGANIZATION"
<> help "Back up repositories owned by this entity."
)
excludeopt = parseUserRepo <$> (strOption
( long "exclude"
<> metavar "USERNAME/REPOSITORY"
<> help "Skip backing up a repository."
))
noforksopt = switch
( long "no-forks"
<> help "Do not backup forks."
)
parseUserRepo :: String -> GithubUserRepo
parseUserRepo s =
let (user, repo) = separate (== '/') s
in GithubUserRepo user repo
main :: IO ()
main = execParser opts >>= go
where
opts = info (helper <*> options)
( fullDesc
<> progDesc desc
<> header "github-backup - backs up data from GitHub"
)
desc = unlines
[ "Backs up all forks, issues, etc of a GitHub repository."
, "Run without any parameters inside a clone of a repository to back it up."
, "Or, specify whose repositories to back up."
]
go (Options owner exclude noforks)
| null owner = backupRepo noforks =<< Git.Construct.fromCwd
| otherwise = mapM_ (backupOwner noforks exclude) owner
github-backup-1.20150807/gitriddance.1 0000664 0000000 0000000 00000002071 12561161061 0017204 0 ustar 00root root 0000000 0000000 .\" -*- nroff -*-
.TH gitriddance 1 "Commands"
.SH NAME
gitriddance \- closes all open issues and pull requests
.SH SYNOPSIS
.B gitriddance [comment]
.SH DESCRIPTION
.I gitriddance
closes all open issues and pull requests on GitHub. This is useful for
projects that have their own issue trackers, patch submission systems etc,
rather than relying on GitHub's, which many of us find to be clumsy,
slow, proprietary, and encouraging of drive-by pull requests of poor quality.
.PP
It should be run in a git repository that was cloned from GitHub. It
looks at the origin remote to find the repository on GitHub. All open
issues and pull requests will have a comment posted to them, and be closed.
.PP
The text of the comment is either passed as a command-line parameter,
or can be configured by setting core.gitriddance. For example:
.IP
git config core.gitriddance "Please submit patches to http://ikiwiki.info/todo/"
.PP
In order for gitriddance to log into GitHub, you need to set
the GITHUB_USER and GITHUB_PASSWORD environment variables.
.SH AUTHOR
Joey Hess
github-backup-1.20150807/gitriddance.hs 0000664 0000000 0000000 00000004336 12561161061 0017464 0 ustar 00root root 0000000 0000000 {- gitriddance - close all open issues and pull requests
-
- Copyright 2014 Joey Hess
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Main where
import qualified Github.Repos as Github
#if MIN_VERSION_github(0,9,0)
import qualified Github.Auth as Github
#endif
import qualified Github.Issues as Github
import qualified Github.Issues.Comments as Github
import System.Environment
import Common
import qualified Git
import qualified Git.Construct
import qualified Git.Config
import Github.GetAuth
import Github.EnumRepos
main :: IO ()
main = do
auth <- fromMaybe (error "Must set GITHUB_USER and GITHUB_PASSWORD")
<$> getAuth
r <- maybe (error "not in a git repository") Git.Config.read
=<< Git.Construct.fromCwd
msg <- maybe (getMsg r) id <$> (headMaybe <$> getArgs)
case gitHubRemotes (onlyOriginRemote r) of
[] -> error "origin does not seem to be a github repository"
[origin] -> closeall auth origin msg
_ -> error "somehow found multiple origin repos; this should be impossible!"
getMsg :: Git.Repo -> String
getMsg r = fromMaybe (error "core.gitriddance needs to be set to a message to use when closing issues/pull requests (or pass the message on the command line)")
(Git.Config.getMaybe "core.gitriddance" r)
{- Limit to only having the origin remote; we don't want to affect any
- other remotes that might be on github. -}
onlyOriginRemote :: Git.Repo -> Git.Repo
onlyOriginRemote r = r { Git.remotes = filter isorigin (Git.remotes r) }
where
isorigin rmt = Git.remoteName rmt == Just "origin"
closeall :: Github.GithubAuth -> GithubUserRepo -> String -> IO ()
closeall auth (GithubUserRepo user repo) msg =
either (oops "getting issue list") (mapM_ close)
=<< Github.issuesForRepo' (Just auth) user repo [Github.Open]
where
oops action err = error $ "failed " ++ action ++ ": " ++ show err
close issue = do
let i = Github.issueNumber issue
putStrLn $ "closing issue: " ++ Github.issueTitle issue
either (oops "posting comment") (const $ return ())
=<< Github.createComment auth user repo i msg
either (oops "closing issue/pull") (const $ return ())
=<< Github.editIssue auth user repo i
(Github.editOfIssue { Github.editIssueState = Just "closed" } )