diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -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 ] diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -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 diff --git a/Build/Version.hs b/Build/Version.hs --- a/Build/Version.hs +++ b/Build/Version.hs @@ -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 diff --git a/BuildInfo.hs b/BuildInfo.hs new file mode 100644 --- /dev/null +++ b/BuildInfo.hs @@ -0,0 +1,12 @@ +{- build info + - + - Copyright 2017 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module BuildInfo where + +#include "Build/SysConfig" diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 Thu, 19 Dec 2019 18:43:05 -0400 + github-backup (1.20171126) unstable; urgency=medium * Updated to use github-0.18 diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -2,14 +2,14 @@ Source: native package Files: * -Copyright: © 2010-2014 Joey Hess +Copyright: © 2010-2018 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 +Copyright: 2012-2018 Joey Hess License: BSD-2-clause License: BSD-2-clause diff --git a/Git/BuildVersion.hs b/Git/BuildVersion.hs --- a/Git/BuildVersion.hs +++ b/Git/BuildVersion.hs @@ -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 diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -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. - diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -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 diff --git a/Git/Index.hs b/Git/Index.hs --- a/Git/Index.hs +++ b/Git/Index.hs @@ -10,6 +10,7 @@ import Common import Git import Utility.Env +import Utility.Env.Set indexEnv :: String indexEnv = "GIT_INDEX_FILE" diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -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) = diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -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, diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -1,6 +1,6 @@ {- git data types - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2018 Joey Hess - - 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 diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -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) diff --git a/Github/EnumRepos.hs b/Github/EnumRepos.hs --- a/Github/EnumRepos.hs +++ b/Github/EnumRepos.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -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 diff --git a/Utility/Env.hs b/Utility/Env.hs --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -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 diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs new file mode 100644 --- /dev/null +++ b/Utility/Env/Basic.hs @@ -0,0 +1,22 @@ +{- portable environment variables, without any dependencies + - + - Copyright 2013 Joey Hess + - + - 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 diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs new file mode 100644 --- /dev/null +++ b/Utility/Env/Set.hs @@ -0,0 +1,41 @@ +{- portable environment variables + - + - Copyright 2013 Joey Hess + - + - 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 diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -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) diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -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. - diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -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 diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -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 diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -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. diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,4 +1,4 @@ -{- Temporary files and directories. +{- Temporary files. - - Copyright 2010-2013 Joey Hess - @@ -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 diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -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) diff --git a/github-backup.cabal b/github-backup.cabal --- a/github-backup.cabal +++ b/github-backup.cabal @@ -1,5 +1,5 @@ Name: github-backup -Version: 1.20171126 +Version: 1.20191219 Cabal-Version: >= 1.8 Maintainer: Joey Hess 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 diff --git a/github-backup.hs b/github-backup.hs --- a/github-backup.hs +++ b/github-backup.hs @@ -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 diff --git a/gitriddance.hs b/gitriddance.hs --- a/gitriddance.hs +++ b/gitriddance.hs @@ -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 } ) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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