packages feed

github-backup 1.20171126 → 1.20191219

raw patch · 31 files changed

+247/−443 lines, 31 filesdep ~githubdep ~network

Dependency ranges changed: github, network

Files

Build/Configure.hs view
@@ -1,11 +1,12 @@-{- Checks system configuration and generates SysConfig.hs. -}+{- Checks system configuration and generates SysConfig. -}  {-# OPTIONS_GHC -fno-warn-tabs #-}  module Build.Configure where -import Control.Applicative import Control.Monad.IfElse+import Control.Applicative+import Prelude  import Build.TestConfig import Build.Version@@ -14,7 +15,7 @@ tests :: [TestCase] tests = 	[ TestCase "version" (Config "version" . StringConfig <$> getVersion)-	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"+	, TestCase "git" $ testCmd "git" "git --version >/dev/null" 	, TestCase "git version" getGitVersion 	]
Build/TestConfig.hs view
@@ -1,4 +1,4 @@-{- Tests the system and generates Build.SysConfig.hs. -}+{- Tests the system and generates SysConfig. -}  {-# OPTIONS_GHC -fno-warn-tabs #-} @@ -7,10 +7,10 @@ import Utility.Path import Utility.Monad import Utility.SafeCommand+import Utility.Directory  import System.IO import System.FilePath-import System.Directory  type ConfigKey = String data ConfigValue =@@ -42,12 +42,11 @@ 		valuetype (MaybeBoolConfig _) = "Maybe Bool"  writeSysConfig :: [Config] -> IO ()-writeSysConfig config = writeFile "Build/SysConfig.hs" body+writeSysConfig config = writeFile "Build/SysConfig" body   where 	body = unlines $ header ++ map show config ++ footer 	header = [ 		  "{- Automatically generated. -}"-		, "module Build.SysConfig where" 		, "" 		] 	footer = []@@ -60,18 +59,6 @@ 	testEnd c 	rest <- runTests ts 	return $ c:rest--{- Tests that a command is available, aborting if not. -}-requireCmd :: ConfigKey -> String -> Test-requireCmd k cmdline = do-	ret <- testCmd k cmdline-	handle ret-  where-	handle r@(Config _ (BoolConfig True)) = return r-	handle r = do-		testEnd r-		error $ "** the " ++ c ++ " command is required"-	c = head $ words cmdline  {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test
Build/Version.hs view
@@ -4,16 +4,16 @@  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 Control.Applicative+import Prelude  import Utility.Monad import Utility.Exception+import Utility.Directory  type Version = String
+ BuildInfo.hs view
@@ -0,0 +1,12 @@+{- build info+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module BuildInfo where++#include "Build/SysConfig"
CHANGELOG view
@@ -1,3 +1,14 @@+github-backup (1.20191219) unstable; urgency=medium++  * Updated to use github-0.23 (0.24 needs larger changes)+  * Various updates to internal git and utility libraries shared+    with git-annex.+  * Remove support for building with old versions of network-uri and network+    before the split in 2.6.+  * stack.yaml: Updated to lts-13.29.++ -- Joey Hess <id@joeyh.name>  Thu, 19 Dec 2019 18:43:05 -0400+ github-backup (1.20171126) unstable; urgency=medium    * Updated to use github-0.18
@@ -2,14 +2,14 @@ Source: native package  Files: *-Copyright: © 2010-2014 Joey Hess <id@joeyh.name>+Copyright: © 2010-2018 Joey Hess <id@joeyh.name> 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 <id@joeyh.name>+Copyright: 2012-2018 Joey Hess <id@joeyh.name> License: BSD-2-clause  License: BSD-2-clause
Git/BuildVersion.hs view
@@ -8,14 +8,14 @@ module Git.BuildVersion where  import Git.Version-import qualified Build.SysConfig+import qualified BuildInfo  {- Using the version it was configured for avoids running git to check its  - version, at the cost that upgrading git won't be noticed.  - This is only acceptable because it's rare that git's version influences  - code's behavior. -} buildVersion :: GitVersion-buildVersion = normalize Build.SysConfig.gitversion+buildVersion = normalize BuildInfo.gitversion  older :: String -> Bool older n = buildVersion < normalize n
Git/Config.hs view
@@ -13,8 +13,8 @@ import Common import Git import Git.Types-import qualified Git.Construct import qualified Git.Command+import qualified Git.Construct import Utility.UserInfo  {- Returns a single git config setting, or a default value if not set. -}@@ -89,12 +89,10 @@ store :: String -> Repo -> IO Repo store s repo = do 	let c = parse s-	repo' <- updateLocation $ repo+	updateLocation $ repo 		{ config = (M.map Prelude.head c) `M.union` config repo 		, fullconfig = M.unionWith (++) c (fullconfig repo) 		}-	rs <- Git.Construct.fromRemotes repo'-	return $ repo' { remotes = rs }  {- Updates the location of a repo, based on its configuration.  -
Git/Construct.hs view
@@ -127,8 +127,7 @@   where 	filterconfig f = filter f $ M.toList $ config repo 	filterkeys f = filterconfig (\(k,_) -> f k)-	remotepairs = filterkeys isremote-	isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k+	remotepairs = filterkeys isRemoteKey 	construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo  {- Sets the name of a remote when constructing the Repo to represent it. -}@@ -140,10 +139,7 @@ {- Sets the name of a remote based on the git config key, such as  - "remote.foo.url". -} remoteNamedFromKey :: String -> IO Repo -> IO Repo-remoteNamedFromKey k = remoteNamed basename-  where-	basename = intercalate "." $ -		reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k+remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName  {- Constructs a new Repo for one of a Repo's remotes using a given  - location (ie, an url). -}@@ -233,7 +229,6 @@ 	{ location = l 	, config = M.empty 	, fullconfig = M.empty-	, remotes = [] 	, remoteName = Nothing 	, gitEnv = Nothing 	, gitEnvOverridesGitDir = False
Git/Index.hs view
@@ -10,6 +10,7 @@ import Common import Git import Utility.Env+import Utility.Env.Set  indexEnv :: String indexEnv = "GIT_INDEX_FILE"
Git/Queue.hs view
@@ -24,7 +24,7 @@ import Git.Command import qualified Git.UpdateIndex -import qualified Data.Map as M+import qualified Data.Map.Strict as M  {- Queable actions that can be performed in a git repository. -} data Action@@ -117,7 +117,7 @@ 			, items = newitems 			} 		!newsize = size q' + sizeincrease-		!newitems = M.insertWith' combineNewOld (actionKey action) action (items q')+		!newitems = M.insertWith combineNewOld (actionKey action) action (items q')  combineNewOld :: Action -> Action -> Action combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) =
Git/Remote.hs view
@@ -20,6 +20,15 @@ import Git.FilePath #endif +{- Is a git config key one that specifies the location of a remote? -}+isRemoteKey :: String -> Bool+isRemoteKey k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k++{- Get a remote's name from the config key that specifies its location. -}+remoteKeyToRemoteName :: String -> RemoteName+remoteKeyToRemoteName k = intercalate "." $+	reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k+ {- Construct a legal git remote name out of an arbitrary input string.  -  - There seems to be no formal definition of this in the git source,
Git/Types.hs view
@@ -1,6 +1,6 @@ {- git data types  -- - Copyright 2010-2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -34,8 +34,8 @@ 	, 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 holds the name used for this repo in some other+	-- repo's list of remotes, when this repo is such a remote 	, remoteName :: Maybe RemoteName 	-- alternate environment to use when running git commands 	, gitEnv :: Maybe [(String, String)]@@ -77,32 +77,36 @@ readObjectType "tree" = Just TreeObject readObjectType _ = Nothing -{- Types of blobs. -}-data BlobType = FileBlob | ExecutableBlob | SymlinkBlob+{- Types of items in a tree. -}+data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule 	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"+{- Git uses magic numbers to denote the type of a tree item. -}+readTreeItemType :: String -> Maybe TreeItemType+readTreeItemType "100644" = Just TreeFile+readTreeItemType "100755" = Just TreeExecutable+readTreeItemType "120000" = Just TreeSymlink+readTreeItemType "160000" = Just TreeSubmodule+readTreeItemType _ = Nothing -readBlobType :: String -> Maybe BlobType-readBlobType "100644" = Just FileBlob-readBlobType "100755" = Just ExecutableBlob-readBlobType "120000" = Just SymlinkBlob-readBlobType _ = Nothing+fmtTreeItemType :: TreeItemType -> String+fmtTreeItemType TreeFile = "100644"+fmtTreeItemType TreeExecutable = "100755"+fmtTreeItemType TreeSymlink = "120000"+fmtTreeItemType TreeSubmodule = "160000" -toBlobType :: FileMode -> Maybe BlobType-toBlobType 0o100644 = Just FileBlob-toBlobType 0o100755 = Just ExecutableBlob-toBlobType 0o120000 = Just SymlinkBlob-toBlobType _ = Nothing+toTreeItemType :: FileMode -> Maybe TreeItemType+toTreeItemType 0o100644 = Just TreeFile+toTreeItemType 0o100755 = Just TreeExecutable+toTreeItemType 0o120000 = Just TreeSymlink+toTreeItemType 0o160000 = Just TreeSubmodule+toTreeItemType _ = Nothing -fromBlobType :: BlobType -> FileMode-fromBlobType FileBlob = 0o100644-fromBlobType ExecutableBlob = 0o100755-fromBlobType SymlinkBlob = 0o120000+fromTreeItemType :: TreeItemType -> FileMode+fromTreeItemType TreeFile = 0o100644+fromTreeItemType TreeExecutable = 0o100755+fromTreeItemType TreeSymlink = 0o120000+fromTreeItemType TreeSubmodule = 0o160000  data Commit = Commit 	{ commitTree :: Sha
Git/UpdateIndex.hs view
@@ -83,14 +83,19 @@  {- Generates a line suitable to be fed into update-index, to add  - a given file with a given sha. -}-updateIndexLine :: Sha -> BlobType -> TopFilePath -> String-updateIndexLine sha filetype file =-	show filetype ++ " blob " ++ fromRef sha ++ "\t" ++ indexPath file+updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> String+updateIndexLine sha treeitemtype file = concat+	[ fmtTreeItemType treeitemtype+	, " blob "+	, fromRef sha+	, "\t"+	, indexPath file+	] -stageFile :: Sha -> BlobType -> FilePath -> Repo -> IO Streamer-stageFile sha filetype file repo = do+stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer+stageFile sha treeitemtype file repo = do 	p <- toTopFilePath file repo-	return $ pureStreamer $ updateIndexLine sha filetype p+	return $ pureStreamer $ updateIndexLine sha treeitemtype p  {- A streamer that removes a file from the index. -} unstageFile :: FilePath -> Repo -> IO Streamer@@ -106,13 +111,13 @@ stageSymlink file sha repo = do 	!line <- updateIndexLine 		<$> pure sha-		<*> pure SymlinkBlob+		<*> pure TreeSymlink 		<*> 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+stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of 	Nothing -> unstageFile' (Diff.file d) 	Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d)
Github/EnumRepos.hs view
@@ -28,14 +28,14 @@ 		(T.unpack $ Github.untagName $ Github.simpleOwnerLogin owner) 		(T.unpack $ Github.untagName name) -gitHubRepos :: Git.Repo -> [Git.Repo]+gitHubRepos :: [Git.Repo] -> [Git.Repo] gitHubRepos = fst . unzip . gitHubPairs -gitHubRemotes :: Git.Repo -> [GithubUserRepo]+gitHubRemotes :: [Git.Repo] -> [GithubUserRepo] gitHubRemotes = snd . unzip . gitHubPairs -gitHubPairs :: Git.Repo -> [(Git.Repo, GithubUserRepo)]-gitHubPairs = filter (not . wiki ) . mapMaybe check . Git.Types.remotes+gitHubPairs :: [Git.Repo] -> [(Git.Repo, GithubUserRepo)]+gitHubPairs = filter (not . wiki ) . mapMaybe check   where 	check r@Git.Repo { Git.Types.location = Git.Types.Url u } = 		headMaybe $ mapMaybe (checkurl r $ show u) gitHubUrlPrefixes
README.md view
@@ -5,7 +5,12 @@  ## Installation -First install Haskell's [stack](http://haskellstack.org/) tool.+Several distributions include packages of github-backup, for example+on Debian and Debian derived distributions it can easily be installed+with `sudo apt-get install github-backup`.++To build it from source, first install Haskell's+[stack](http://haskellstack.org/) tool. For example, on a Debian system:  	sudo apt-get install haskell-stack@@ -33,9 +38,9 @@  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 something happens to GitHub. (Some may argue that this has+  already happened.) 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
Utility/Directory.hs view
@@ -18,15 +18,11 @@ import System.FilePath import System.PosixCompat.Files import Control.Applicative-import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe import Prelude -#ifdef mingw32_HOST_OS-import qualified System.Win32 as Win32-#else-import qualified System.Posix as Posix+#ifndef mingw32_HOST_OS import Utility.SafeCommand import Control.Monad.IfElse #endif@@ -158,90 +154,3 @@ #else 	go = removeFile file #endif--#ifndef mingw32_HOST_OS-data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream-#else-data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())-#endif--type IsOpen = MVar () -- full when the handle is open--openDirectory :: FilePath -> IO DirectoryHandle-openDirectory path = do-#ifndef mingw32_HOST_OS-	dirp <- Posix.openDirStream path-	isopen <- newMVar ()-	return (DirectoryHandle isopen dirp)-#else-	(h, fdat) <- Win32.findFirstFile (path </> "*")-	-- Indicate that the fdat contains a filename that readDirectory-	-- has not yet returned, by making the MVar be full.-	-- (There's always at least a "." entry.)-	alreadyhave <- newMVar ()-	isopen <- newMVar ()-	return (DirectoryHandle isopen h fdat alreadyhave)-#endif--closeDirectory :: DirectoryHandle -> IO ()-#ifndef mingw32_HOST_OS-closeDirectory (DirectoryHandle isopen dirp) =-	whenOpen isopen $-		Posix.closeDirStream dirp-#else-closeDirectory (DirectoryHandle isopen h _ alreadyhave) =-	whenOpen isopen $ do-		_ <- tryTakeMVar alreadyhave-		Win32.findClose h-#endif-  where-	whenOpen :: IsOpen -> IO () -> IO ()-	whenOpen mv f = do-		v <- tryTakeMVar mv-		when (isJust v) f--{- |Reads the next entry from the handle. Once the end of the directory-is reached, returns Nothing and automatically closes the handle.--}-readDirectory :: DirectoryHandle -> IO (Maybe FilePath)-#ifndef mingw32_HOST_OS-readDirectory hdl@(DirectoryHandle _ dirp) = do-	e <- Posix.readDirStream dirp-	if null e-		then do-			closeDirectory hdl-			return Nothing-		else return (Just e)-#else-readDirectory hdl@(DirectoryHandle _ h fdat mv) = do-	-- If the MVar is full, then the filename in fdat has-	-- not yet been returned. Otherwise, need to find the next-	-- file.-	r <- tryTakeMVar mv-	case r of-		Just () -> getfn-		Nothing -> do-			more <- Win32.findNextFile h fdat-			if more-				then getfn-				else do-					closeDirectory hdl-					return Nothing-  where-	getfn = do-		filename <- Win32.getFindDataFileName fdat-		return (Just filename)-#endif---- True only when directory exists and contains nothing.--- Throws exception if directory does not exist.-isDirectoryEmpty :: FilePath -> IO Bool-isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check-  where-	check h = do-		v <- readDirectory h-		case v of-			Nothing -> return True-			Just f-				| not (dirCruft f) -> return False-				| otherwise -> check h
Utility/Env.hs view
@@ -16,7 +16,6 @@ import Data.Maybe import Prelude import qualified System.Environment as E-import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif@@ -40,29 +39,6 @@ getEnvironment = PE.getEnvironment #else getEnvironment = E.getEnvironment-#endif--{- Sets an environment variable. To overwrite an existing variable,- - overwrite must be True.- -- - On Windows, setting a variable to "" unsets it. -}-setEnv :: String -> String -> Bool -> IO ()-#ifndef mingw32_HOST_OS-setEnv var val overwrite = PE.setEnv var val overwrite-#else-setEnv var val True = System.SetEnv.setEnv var val-setEnv var val False = do-	r <- getEnv var-	case r of-		Nothing -> setEnv var val True-		Just _ -> return ()-#endif--unsetEnv :: String -> IO ()-#ifndef mingw32_HOST_OS-unsetEnv = PE.unsetEnv-#else-unsetEnv = System.SetEnv.unsetEnv #endif  {- Adds the environment variable to the input environment. If already
+ Utility/Env/Basic.hs view
@@ -0,0 +1,22 @@+{- portable environment variables, without any dependencies+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Env.Basic where++import Utility.Exception+import Control.Applicative+import Data.Maybe+import Prelude+import qualified System.Environment as E++getEnv :: String -> IO (Maybe String)+getEnv = catchMaybeIO . E.getEnv++getEnvDefault :: String -> String -> IO String+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
+ Utility/Env/Set.hs view
@@ -0,0 +1,41 @@+{- portable environment variables+ -+ - Copyright 2013 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.Env.Set where++#ifdef mingw32_HOST_OS+import qualified System.Environment as E+import qualified System.SetEnv+import Utility.Env+#else+import qualified System.Posix.Env as PE+#endif++{- Sets an environment variable. To overwrite an existing variable,+ - overwrite must be True.+ -+ - On Windows, setting a variable to "" unsets it. -}+setEnv :: String -> String -> Bool -> IO ()+#ifndef mingw32_HOST_OS+setEnv var val overwrite = PE.setEnv var val overwrite+#else+setEnv var val True = System.SetEnv.setEnv var val+setEnv var val False = do+	r <- getEnv var+	case r of+		Nothing -> setEnv var val True+		Just _ -> return ()+#endif++unsetEnv :: String -> IO ()+#ifndef mingw32_HOST_OS+unsetEnv = PE.unsetEnv+#else+unsetEnv = System.SetEnv.unsetEnv+#endif
Utility/FileMode.hs view
@@ -17,7 +17,7 @@ import System.PosixCompat.Types import System.PosixCompat.Files #ifndef mingw32_HOST_OS-import System.Posix.Files+import System.Posix.Files (symbolicLinkMode) import Control.Monad.IO.Class (liftIO) #endif import Control.Monad.IO.Class (MonadIO)
Utility/FileSystemEncoding.hs view
@@ -12,6 +12,9 @@ 	useFileSystemEncoding, 	fileEncoding, 	withFilePath,+	RawFilePath,+	fromRawFilePath,+	toRawFilePath, 	decodeBS, 	encodeBS, 	decodeW8,@@ -32,6 +35,7 @@ import System.IO.Unsafe import Data.Word import Data.List+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8@@ -119,6 +123,22 @@ #else encodeBS = L8.fromString #endif++{- Recent versions of the unix package have this alias; defined here+ - for backwards compatibility. -}+type RawFilePath = S.ByteString++{- Note that the RawFilePath is assumed to never contain NUL,+ - since filename's don't. This should only be used with actual+ - RawFilePaths not arbitrary ByteString that may contain NUL. -}+fromRawFilePath :: RawFilePath -> FilePath+fromRawFilePath = encodeW8 . S.unpack++{- Note that the FilePath is assumed to never contain NUL,+ - since filename's don't. This should only be used with actual FilePaths+ - not arbitrary String that may contain NUL. -}+toRawFilePath :: FilePath -> RawFilePath+toRawFilePath = S.pack . decodeW8  {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.  -
Utility/Misc.hs view
@@ -5,7 +5,6 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Misc where@@ -16,10 +15,6 @@ 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 @@ -111,22 +106,6 @@   where 	peekbytes :: Int -> Ptr Word8 -> IO [Word8] 	peekbytes len buf = mapM (peekElemOff buf) [0..pred len]--{- Reaps any zombie processes that may be hanging around.- -- - Warning: Not thread safe. Anything that was expecting to wait- - on a process and get back an exit status is going to be confused- - if this reap gets there first. -}-reapZombies :: IO ()-#ifndef mingw32_HOST_OS-reapZombies =-	-- throws an exception when there are no child processes-	catchDefaultIO Nothing (getAnyProcessStatus False True)-		>>= maybe (return ()) (const reapZombies)--#else-reapZombies = return ()-#endif  exitBool :: Bool -> IO a exitBool False = exitFailure
Utility/Path.hs view
@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -{-# LANGUAGE PackageImports, CPP #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Path where@@ -17,13 +17,6 @@ import Control.Applicative import Prelude -#ifdef mingw32_HOST_OS-import qualified System.FilePath.Posix as Posix-#else-import System.Posix.Files-import Utility.Exception-#endif- import Utility.Monad import Utility.UserInfo import Utility.Directory@@ -246,50 +239,6 @@ 	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)   where 	f = takeFileName file--{- Converts a DOS style path to a msys2 style path. Only on Windows.- - Any trailing '\' is preserved as a trailing '/' - - - - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i- -- - The virtual filesystem contains:- -  /c, /d, ...	mount points for Windows drives- -}-toMSYS2Path :: FilePath -> FilePath-#ifndef mingw32_HOST_OS-toMSYS2Path = id-#else-toMSYS2Path p-	| null drive = recombine parts-	| otherwise = recombine $ "/" : driveletter drive : parts-  where-	(drive, p') = splitDrive p-	parts = splitDirectories p'-	driveletter = map toLower . takeWhile (/= ':')-	recombine = fixtrailing . Posix.joinPath-	fixtrailing s-		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s-		| otherwise = s-#endif--{- Maximum size to use for a file in a specified directory.- -- - Many systems have a 255 byte limit to the name of a file, - - so that's taken as the max if the system has a larger limit, or has no- - limit.- -}-fileNameLengthLimit :: FilePath -> IO Int-#ifdef mingw32_HOST_OS-fileNameLengthLimit _ = return 255-#else-fileNameLengthLimit dir = do-	-- getPathVar can fail due to statfs(2) overflow-	l <- catchDefaultIO 0 $-		fromIntegral <$> getPathVar dir FileNameLimit-	if l <= 0-		then return 255-		else return $ minimum [l, 255]-#endif  {- Given a string that we'd like to use as the basis for FilePath, but that  - was provided by a third party and is not to be trusted, returns the closest
Utility/Process.hs view
@@ -24,11 +24,10 @@ 	createProcessSuccess, 	createProcessChecked, 	createBackgroundProcess,-	processTranscript,-	processTranscript', 	withHandle, 	withIOHandles, 	withOEHandles,+	withNullHandle, 	withQuietOutput, 	feedWithQuietOutput, 	createProcess,@@ -54,13 +53,6 @@ import Control.Concurrent import qualified Control.Exception as E import Control.Monad-#ifndef mingw32_HOST_OS-import qualified System.Posix.IO-#else-import Control.Applicative-#endif-import Data.Maybe-import Prelude  type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -170,68 +162,6 @@ createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p --- | Runs a process, optionally feeding it some input, and--- returns a transcript combining its stdout and stderr, and--- whether it succeeded or failed.-processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)-processTranscript cmd opts = processTranscript' (proc cmd opts)--processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)-processTranscript' cp input = do-#ifndef mingw32_HOST_OS-{- This implementation interleves stdout and stderr in exactly the order- - the process writes them. -}-	(readf, writef) <- System.Posix.IO.createPipe-	readh <- System.Posix.IO.fdToHandle readf-	writeh <- System.Posix.IO.fdToHandle writef-	p@(_, _, _, pid) <- createProcess $ cp-		{ std_in = if isJust input then CreatePipe else Inherit-		, std_out = UseHandle writeh-		, std_err = UseHandle writeh-		}-	hClose writeh--	get <- mkreader readh-	writeinput input p-	transcript <- get--	ok <- checkSuccessProcess pid-	return (transcript, ok)-#else-{- This implementation for Windows puts stderr after stdout. -}-	p@(_, _, _, pid) <- createProcess $ cp-		{ std_in = if isJust input then CreatePipe else Inherit-		, std_out = CreatePipe-		, std_err = CreatePipe-		}--	getout <- mkreader (stdoutHandle p)-	geterr <- mkreader (stderrHandle p)-	writeinput input p-	transcript <- (++) <$> getout <*> geterr--	ok <- checkSuccessProcess pid-	return (transcript, ok)-#endif-  where-	mkreader h = do-		s <- hGetContents h-		v <- newEmptyMVar-		void $ forkIO $ do-			void $ E.evaluate (length s)-			putMVar v ()-		return $ do-			takeMVar v-			return s--	writeinput (Just s) p = do-		let inh = stdinHandle p-		unless (null s) $ do-			hPutStr inh s-			hFlush inh-		hClose inh-	writeinput Nothing _ = return ()- -- | Runs a CreateProcessRunner, on a CreateProcess structure, that -- is adjusted to pipe only from/to a single StdHandle, and passes -- the resulting Handle to an action.@@ -248,13 +178,10 @@ 		, std_out = Inherit 		, std_err = Inherit 		}-	(select, p')-		| h == StdinHandle  =-			(stdinHandle, base { std_in = CreatePipe })-		| h == StdoutHandle =-			(stdoutHandle, base { std_out = CreatePipe })-		| h == StderrHandle =-			(stderrHandle, base { std_err = CreatePipe })+	(select, p') = case h of+		StdinHandle -> (stdinHandle, base { std_in = CreatePipe })+		StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })+		StderrHandle -> (stderrHandle, base { std_err = CreatePipe })  -- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles@@ -284,13 +211,16 @@ 		, std_err = CreatePipe 		} +withNullHandle :: (Handle -> IO a) -> IO a+withNullHandle = withFile devNull WriteMode+ -- | Forces the CreateProcessRunner to run quietly; -- both stdout and stderr are discarded. withQuietOutput 	:: CreateProcessRunner 	-> CreateProcess 	-> IO ()-withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do+withQuietOutput creator p = withNullHandle $ \nullh -> do 	let p' = p 		{ std_out = UseHandle nullh 		, std_err = UseHandle nullh@@ -316,7 +246,8 @@ #ifndef mingw32_HOST_OS devNull = "/dev/null" #else-devNull = "NUL"+-- Use device namespace to prevent GHC from rewriting path+devNull = "\\\\.\\NUL" #endif  -- | Extract a desired handle from createProcess's tuple.
Utility/Tmp.hs view
@@ -1,4 +1,4 @@-{- Temporary files and directories.+{- Temporary files.  -  - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -@@ -11,14 +11,10 @@ module Utility.Tmp where  import System.IO-import Control.Monad.IfElse import System.FilePath import System.Directory import Control.Monad.IO.Class import System.PosixCompat.Files-#ifndef mingw32_HOST_OS-import System.Posix.Temp (mkdtemp)-#endif  import Utility.Exception import Utility.FileSystemEncoding@@ -61,51 +57,6 @@ 		hClose h 		catchBoolIO (removeFile name >> return True) 	use (name, h) = a name h--{- Runs an action with a tmp directory located within the system's tmp- - directory (or within "." if there is none), then removes the tmp- - directory and all its contents. -}-withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a-withTmpDir template a = do-	topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory-#ifndef mingw32_HOST_OS-	-- Use mkdtemp to create a temp directory securely in /tmp.-	bracket-		(liftIO $ mkdtemp $ topleveltmpdir </> template)-		removeTmpDir-		a-#else-	withTmpDirIn topleveltmpdir template a-#endif--{- Runs an action with a tmp directory located within a specified directory,- - then removes the tmp directory and all its contents. -}-withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a-withTmpDirIn tmpdir template = bracketIO create removeTmpDir-  where-	create = do-		createDirectoryIfMissing True tmpdir-		makenewdir (tmpdir </> template) (0 :: Int)-	makenewdir t n = do-		let dir = t ++ "." ++ show n-		catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do-			createDirectory dir-			return dir--{- Deletes the entire contents of the the temporary directory, if it- - exists. -}-removeTmpDir :: MonadIO m => FilePath -> m ()-removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do-#if mingw32_HOST_OS-	-- Windows will often refuse to delete a file-	-- after a process has just written to it and exited.-	-- Because it's crap, presumably. So, ignore failure-	-- to delete the temp directory.-	_ <- tryIO $ removeDirectoryRecursive tmpdir-	return ()-#else-	removeDirectoryRecursive tmpdir-#endif  {- It's not safe to use a FilePath of an existing file as the template  - for openTempFile, because if the FilePath is really long, the tmpfile
Utility/UserInfo.hs view
@@ -14,7 +14,7 @@ 	myUserGecos, ) where -import Utility.Env+import Utility.Env.Basic import Utility.Exception #ifndef mingw32_HOST_OS import Utility.Data@@ -57,10 +57,13 @@ myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars   where+	go [] = either (const $ envnotset) (Right . extract) <$> get+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #ifndef mingw32_HOST_OS-	go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)+	-- This may throw an exception if the system doesn't have a+	-- passwd file etc; don't let it crash.+	get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else-	go [] = return $ either Left (Right . extract) $-		Left ("environment not set: " ++ show envvars)+	get = return envnotset #endif-	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v+	envnotset = Left ("environment not set: " ++ show envvars)
github-backup.cabal view
@@ -1,5 +1,5 @@ Name: github-backup-Version: 1.20171126+Version: 1.20191219 Cabal-Version: >= 1.8 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess@@ -30,31 +30,24 @@   configure.hs   Build/collect-ghc-options.sh -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 -threaded   Build-Depends:     base (>= 4.8 && < 5),-    github (>= 0.18 && < 0.19),+    github (>= 0.23 && < 0.24),     text, filepath, exceptions, transformers, bytestring, vector,     hslogger, split, process, containers, unix-compat, IfElse,-    directory, mtl, utf8-string, optparse-applicative, pretty-show+    directory, mtl, utf8-string, optparse-applicative, pretty-show,+    network-uri (>= 2.6), network (>= 2.6)      if (! os(windows))     Build-Depends: unix   else     Build-Depends: Win32, setenv   -  if flag(network-uri)-    Build-Depends: network-uri (>= 2.6), network (>= 2.6)-  else-    Build-Depends: network (< 2.6), network (>= 2.0)-     Other-Modules:+    BuildInfo     Build.Version     Build.TestConfig     Build.Configure@@ -95,6 +88,8 @@     Utility.UserInfo     Utility.Misc     Utility.Env+    Utility.Env.Basic+    Utility.Env.Set     Utility.PosixFiles     Utility.Data     Utility.PartialPrelude@@ -109,20 +104,16 @@   GHC-Options: -Wall -fno-warn-tabs   Build-Depends:      base (>= 4.8 && < 5),-    github (>= 0.18 && < 0.19),+    github (>= 0.23 && < 0.24),     text, filepath, exceptions, transformers, bytestring, vector,     hslogger, split, process, containers, unix-compat, IfElse,-    directory, mtl, utf8-string+    directory, mtl, utf8-string,+    network-uri (>= 2.6), network (>= 2.6)      if (! os(windows))     Build-Depends: unix   else     Build-Depends: Win32, setenv-  -  if flag(network-uri)-    Build-Depends: network-uri (>= 2.6), network (>= 2.6)-  else-    Build-Depends: network (< 2.6), network (>= 2.0)    Other-Modules:     Common@@ -141,6 +132,8 @@     Utility.Data     Utility.Directory     Utility.Env+    Utility.Env.Basic+    Utility.Env.Set     Utility.Exception     Utility.FileMode     Utility.FileSystemEncoding
github-backup.hs view
@@ -14,14 +14,12 @@ import qualified Data.Set as S import qualified Data.Text as T import Data.Either-import Data.Monoid import Data.String import GHC.Exts (toList) import Data.Vector (Vector) import Options.Applicative import Text.Show.Pretty import "mtl" Control.Monad.State.Strict-import qualified GitHub.Data.Id as Github import qualified GitHub.Data.Name as Github import qualified GitHub.Auth as Github import qualified GitHub.Data.Repos as Github@@ -83,6 +81,7 @@ 	, retriedRequests :: S.Set Request 	, retriedFailed :: S.Set Request 	, gitRepo :: Git.Repo+	, gitRepoRemotes :: [Git.Repo] 	, gitHubAuth :: Maybe Github.Auth 	, deferredBackups :: [Backup ()] 	, catFileHandle :: Maybe CatFileHandle@@ -160,7 +159,7 @@ pullrequestsStore = simpleHelper "pullrequest" Github.pullRequestsFor' $ 	forValues $ \req r -> do 		let repo = requestRepo req-		let n = Github.simplePullRequestNumber r+		let n = Github.unIssueNumber $ Github.simplePullRequestNumber r 		runRequest $ RequestNum "pullrequest" repo n  pullrequestStore :: Storer@@ -170,7 +169,7 @@ 	call auth user repo n = Github.pullRequest' auth 		(fromString user) 		(fromString repo)-		(Github.mkId (Github.Id 0) n)+		(Github.IssueNumber n)  milestonesStore :: Storer milestonesStore = simpleHelper "milestone" GitHub.Endpoints.Issues.Milestones.milestones' $@@ -185,7 +184,7 @@   where 	go = forValues $ \req i -> do 		let repo = requestRepo req-		let n = Github.issueNumber i+		let n = Github.unIssueNumber $ Github.issueNumber i 		store ("issue" </> show n) req i 		runRequest (RequestNum "issuecomments" repo n) @@ -198,7 +197,7 @@ 	call auth user repo n = GitHub.Endpoints.Issues.Comments.comments' auth 		(fromString user) 		(fromString repo)-		(Github.mkId (Github.Id 0) n)+		(Github.IssueNumber n)  userrepoStore :: Storer userrepoStore = simpleHelper "repo" Github.repository' $ \req r -> do@@ -326,7 +325,7 @@ 			sha <- hashFile h f 			path <- asTopFilePath <$> relPathDirToFile dir f 			streamer $ Git.UpdateIndex.updateIndexLine-				sha Git.Types.FileBlob path+				sha Git.Types.TreeFile path  {- Returns the ref of the github branch, creating it first if necessary. -} getBranch :: Backup Git.Ref@@ -367,7 +366,7 @@  updateWiki :: GithubUserRepo -> Backup () updateWiki fork =-	ifM (any (\r -> Git.remoteName r == Just remote) <$> remotes)+	ifM (any (\r -> Git.remoteName r == Just remote) <$> getState gitRepoRemotes) 		( void fetchwiki 		, void $ 			-- github often does not really have a wiki,@@ -377,13 +376,12 @@ 		)   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+addFork forksource = unlessM (elem fork . gitHubRemotes <$> getState gitRepoRemotes) $ do 	liftIO $ putStrLn $ "New fork: " ++ repoUrl fork 	void $ addRemote (remoteFor fork) (repoUrl fork) 	gitRepo' <- inRepo $ Git.Config.reRead@@ -494,6 +492,7 @@ 	<*> pure S.empty 	<*> pure S.empty 	<*> pure r+	<*> Git.Construct.fromRemotes r 	<*> getAuth 	<*> pure [] 	<*> pure Nothing@@ -518,7 +517,7 @@  mainBackup :: Backup () mainBackup = do-	remotes <- gitHubPairs <$> getState gitRepo+	remotes <- gitHubPairs <$> getState gitRepoRemotes 	when (null remotes) $ 		error "no github remotes found" 	forM_ remotes $ \(r, remote) -> do
gitriddance.hs view
@@ -28,8 +28,9 @@ 		<$> getAuth 	r <- maybe (error "not in a git repository") Git.Config.read 		=<< Git.Construct.fromCwd+	rs <- Git.Construct.fromRemotes r 	msg <- maybe (getMsg r) id <$> (headMaybe <$> getArgs)-	case gitHubRemotes (onlyOriginRemote r) of+	case map snd $ filter (isOriginRemote . fst) $ gitHubPairs rs 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!"@@ -38,12 +39,10 @@ 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+{- Identify 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"+isOriginRemote :: Git.Repo -> Bool+isOriginRemote rmt = Git.remoteName rmt == Just "origin"  closeall :: Github.Auth -> GithubUserRepo -> String -> IO () closeall auth (GithubUserRepo user repo) msg =@@ -55,7 +54,7 @@ 		let i = Github.issueNumber issue 		putStrLn $ "closing issue: " ++ T.unpack (Github.issueTitle issue) 		either (oops "posting comment") (const $ return ())-			=<< Github.createComment auth (fromString user) (fromString repo) (Github.mkId (Github.Id 0) i) (T.pack msg)+			=<< Github.createComment auth (fromString user) (fromString repo) i (T.pack msg) 		either (oops "closing issue/pull") (const $ return ())-			=<< Github.editIssue auth (fromString user) (fromString repo) (Github.mkId (Github.Id 0) i)+			=<< Github.editIssue auth (fromString user) (fromString repo) (Github.mkId (Github.Id 0) (Github.unIssueNumber i)) 				(Github.editOfIssue { Github.editIssueState = Just Github.StateClosed } )
stack.yaml view
@@ -1,7 +1,11 @@ packages: - '.' extra-deps: + - github-0.23  - IfElse-0.85+ - binary-instances-1+ - binary-orphans-1.0.1+ - time-compat-1.9.2.2 explicit-setup-deps:   github-backup: true-resolver: nightly-2017-11-25+resolver: lts-13.29