diff --git a/Build/collect-ghc-options.sh b/Build/collect-ghc-options.sh new file mode 100644 --- /dev/null +++ b/Build/collect-ghc-options.sh @@ -0,0 +1,12 @@ +#!/bin/sh +# Generate --ghc-options to pass LDFLAGS, CFLAGS, and CPPFLAGS through ghc +# and on to ld, cc, and cpp. +for w in $LDFLAGS; do + printf -- "-optl%s\n" "$w" +done +for w in $CFLAGS; do + printf -- "-optc%s\n" "$w" +done +for w in $CPPFLAGS; do + printf -- "-optc-Wp,%s\n" "$w" +done diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,18 @@ +github-backup (1.20160522) unstable; urgency=medium + + * Work around git weirdness in handling of relative path to GIT_INDEX_FILE + when in a subdirectory of the repository. + * Various updates to internal git and utility libraries shared + with git-annex. + * debian: Add lintian overrides for rpath. + * debian: Bump standards-version. + * Makefile: Pass LDFLAGS, CFLAGS, and CPPFLAGS through ghc and on to + ld, cc, and cpp. This lets the Debian package build with various + hardening options. Although their benefit to a largely haskell program + is unknown. + + -- Joey Hess Sun, 22 May 2016 15:24:04 -0400 + github-backup (1.20160511) unstable; urgency=medium * Fix build with directory-1.2.6.2. diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -26,8 +26,10 @@ repoDescribe, repoLocation, repoPath, + repoWorkTree, localGitDir, attributes, + attributesLocal, hookPath, assertLocal, adjustPath, @@ -72,6 +74,10 @@ repoPath Repo { location = LocalUnknown dir } = dir repoPath Repo { location = Unknown } = error "unknown repoPath" +repoWorkTree :: Repo -> Maybe FilePath +repoWorkTree Repo { location = Local { worktree = Just d } } = Just d +repoWorkTree _ = Nothing + {- Path to a local repository's .git directory. -} localGitDir :: Repo -> FilePath localGitDir Repo { location = Local { gitdir = d } } = d @@ -125,8 +131,11 @@ {- Path to a repository's gitattributes file. -} attributes :: Repo -> FilePath attributes repo - | repoIsLocalBare repo = repoPath repo ++ "/info/.gitattributes" - | otherwise = repoPath repo ++ "/.gitattributes" + | repoIsLocalBare repo = attributesLocal repo + | otherwise = repoPath repo ".gitattributes" + +attributesLocal :: Repo -> FilePath +attributesLocal repo = localGitDir repo "info" "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -23,7 +23,7 @@ - branch is not created yet. So, this also looks at show-ref HEAD - to double-check. -} -current :: Repo -> IO (Maybe Git.Ref) +current :: Repo -> IO (Maybe Branch) current r = do v <- currentUnsafe r case v of @@ -35,7 +35,7 @@ ) {- The current branch, which may not really exist yet. -} -currentUnsafe :: Repo -> IO (Maybe Git.Ref) +currentUnsafe :: Repo -> IO (Maybe Branch) currentUnsafe r = parse . firstLine <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where @@ -48,15 +48,25 @@ changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null <$> diffs + | otherwise = not . null + <$> changed' origbranch newbranch [Param "-n1"] repo where - diffs = pipeReadStrict + +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo + where + ps = [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) - , Param "-n1" , Param "--pretty=%H" - ] repo + ] ++ extraps +{- Lists commits that are in the second branch and not in the first branch. -} +changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] +changedCommits origbranch newbranch extraps repo = + catMaybes . map extractSha . lines + <$> changed' origbranch newbranch extraps repo + {- Check if it's possible to fast-forward from the old - ref to the new ref. - @@ -90,7 +100,7 @@ where no_ff = return False do_ff to = do - update branch to repo + update' branch to repo return True findbest c [] = return $ Just c findbest c (r:rs) @@ -121,10 +131,6 @@ 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 @@ -144,36 +150,51 @@ 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 + sha <- commitTree commitmode message parentrefs tree 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 +commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha +commitTree commitmode message parentrefs tree repo = + getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) + sendmsg repo + where + ps = applyCommitMode commitmode $ + map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs + sendmsg = Just $ flip hPutStr message + {- 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 +{- Updates a branch (or other ref) to a new Sha or branch Ref. -} +update :: String -> Branch -> Ref -> Repo -> IO () +update message branch r = run [ Param "update-ref" + , Param "-m" + , Param message , Param $ fromRef branch - , Param $ fromRef sha + , Param $ fromRef r + ] + +update' :: Branch -> Ref -> Repo -> IO () +update' branch r = run + [ Param "update-ref" + , Param $ fromRef branch + , Param $ fromRef r ] {- Checks out a branch, creating it if necessary. -} diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011, 2013 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,6 +13,7 @@ catFile, catFileDetails, catTree, + catCommit, catObject, catObjectDetails, ) where @@ -20,6 +21,10 @@ import System.IO import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.Map as M +import Data.String +import Data.Char import Data.Tuple.Utils import Numeric import System.Posix.Types @@ -104,10 +109,51 @@ (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 + +catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit) +catCommit h commitref = go <$> catObjectDetails h commitref + where + go (Just (b, _, CommitObject)) = parseCommit b + go _ = Nothing + +parseCommit :: L.ByteString -> Maybe Commit +parseCommit b = Commit + <$> (extractSha . L8.unpack =<< field "tree") + <*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent")) + <*> (parsemetadata <$> field "author") + <*> (parsemetadata <$> field "committer") + <*> Just (L8.unpack $ L.intercalate (L.singleton nl) message) + where + field n = headMaybe =<< fields n + fields n = M.lookup (fromString n) fieldmap + fieldmap = M.fromListWith (++) ((map breakfield) header) + breakfield l = + let (k, sp_v) = L.break (== sp) l + in (k, [L.drop 1 sp_v]) + (header, message) = separate L.null ls + ls = L.split nl b + + -- author and committer lines have the form: "name date" + -- The email is always present, even if empty "<>" + parsemetadata l = CommitMetaData + { commitName = whenset $ L.init name_sp + , commitEmail = whenset email + , commitDate = whenset $ L.drop 2 gt_sp_date + } + where + (name_sp, rest) = L.break (== lt) l + (email, gt_sp_date) = L.break (== gt) (L.drop 1 rest) + whenset v + | L.null v = Nothing + | otherwise = Just (L8.unpack v) + + nl = fromIntegral (ord '\n') + sp = fromIntegral (ord ' ') + lt = fromIntegral (ord '<') + gt = fromIntegral (ord '>') diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -17,9 +17,11 @@ {- 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 + setdir ++ settree ++ gitGlobalOpts r ++ params where - setdir = Param $ "--git-dir=" ++ gitdir l + setdir + | gitEnvOverridesGitDir r = [] + | otherwise = [Param $ "--git-dir=" ++ gitdir l] settree = case worktree l of Nothing -> [] Just t -> [Param $ "--work-tree=" ++ t] diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -236,6 +236,7 @@ , remotes = [] , remoteName = Nothing , gitEnv = Nothing + , gitEnvOverridesGitDir = False , gitGlobalOpts = [] } diff --git a/Git/FilePath.hs b/Git/FilePath.hs --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -14,8 +14,8 @@ module Git.FilePath ( TopFilePath, - fromTopFilePath, getTopFilePath, + fromTopFilePath, toTopFilePath, asTopFilePath, InternalGitPath, @@ -31,11 +31,11 @@ {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } - deriving (Show) + deriving (Show, Eq, Ord) -{- Returns an absolute FilePath. -} +{- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath -fromTopFilePath p repo = absPathFrom (repoPath repo) (getTopFilePath p) +fromTopFilePath p repo = combine (repoPath repo) (getTopFilePath p) {- The input FilePath can be absolute, or relative to the CWD. -} toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath diff --git a/Git/Index.hs b/Git/Index.hs new file mode 100644 --- /dev/null +++ b/Git/Index.hs @@ -0,0 +1,70 @@ +{- git index file stuff + - + - Copyright 2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Index where + +import Common +import Git +import Utility.Env + +indexEnv :: String +indexEnv = "GIT_INDEX_FILE" + +{- Gets value to set GIT_INDEX_FILE to. Input should be absolute path, + - or relative to the CWD. + - + - When relative, GIT_INDEX_FILE is interpreted by git as being + - relative to the top of the work tree of the git repository, + - not to the CWD. Worse, other environment variables (GIT_WORK_TREE) + - or git options (--work-tree) or configuration (core.worktree) + - can change what the relative path is interpreted relative to. + - + - So, an absolute path is the only safe option for this to return. + -} +indexEnvVal :: FilePath -> IO String +indexEnvVal = absPath + +{- Forces git to use the specified index file. + - + - Returns an action that will reset back to the default + - index file. + - + - Warning: Not thread safe. + -} +override :: FilePath -> Repo -> IO (IO ()) +override index _r = do + res <- getEnv var + val <- indexEnvVal index + setEnv var val True + return $ reset res + where + var = "GIT_INDEX_FILE" + reset (Just v) = setEnv indexEnv v True + reset _ = unsetEnv var + +indexFile :: Repo -> FilePath +indexFile r = localGitDir r "index" + +{- Git locks the index by creating this file. -} +indexFileLock :: Repo -> FilePath +indexFileLock r = indexFile r ++ ".lock" + +{- When the pre-commit hook is run, and git commit has been run with + - a file or files specified to commit, rather than committing the staged + - index, git provides the pre-commit hook with a "false index file". + - + - Changes made to this index will influence the commit, but won't + - affect the real index file. + - + - This detects when we're in this situation, using a heuristic, which + - might be broken by changes to git. Any use of this should have a test + - case to make sure it works. + -} +haveFalseIndex :: IO Bool +haveFalseIndex = maybe (False) check <$> getEnv indexEnv + where + check f = "next-index" `isPrefixOf` takeFileName f diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -137,7 +137,7 @@ {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool -full (Queue cur lim _) = cur > lim +full (Queue cur lim _) = cur >= lim {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -18,6 +18,12 @@ headRef :: Ref headRef = Ref "HEAD" +headFile :: Repo -> FilePath +headFile r = localGitDir r "HEAD" + +setHeadRef :: Ref -> Repo -> IO () +setHeadRef ref r = writeFile (headFile r) ("ref: " ++ fromRef ref) + {- Converts a fully qualified git ref into a user-visible string. -} describe :: Ref -> String describe = fromRef . base @@ -31,11 +37,14 @@ | prefix `isPrefixOf` s = drop (length prefix) s | otherwise = s +{- Gets the basename of any qualified ref. -} +basename :: Ref -> Ref +basename = Ref . reverse . takeWhile (/= '/') . reverse . fromRef + {- 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) +under dir r = Ref $ dir ++ "/" ++ fromRef (basename 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, diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -11,7 +11,6 @@ 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. - @@ -40,6 +39,7 @@ , remoteName :: Maybe RemoteName -- alternate environment to use when running git commands , gitEnv :: Maybe [(String, String)] + , gitEnvOverridesGitDir :: Bool -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam] } deriving (Show, Eq, Ord) @@ -98,3 +98,24 @@ toBlobType 0o100755 = Just ExecutableBlob toBlobType 0o120000 = Just SymlinkBlob toBlobType _ = Nothing + +fromBlobType :: BlobType -> FileMode +fromBlobType FileBlob = 0o100644 +fromBlobType ExecutableBlob = 0o100755 +fromBlobType SymlinkBlob = 0o120000 + +data Commit = Commit + { commitTree :: Sha + , commitParent :: [Sha] + , commitAuthorMetaData :: CommitMetaData + , commitCommitterMetaData :: CommitMetaData + , commitMessage :: String + } + deriving (Show) + +data CommitMetaData = CommitMetaData + { commitName :: Maybe String + , commitEmail :: Maybe String + , commitDate :: Maybe String -- In raw git form, "epoch -tzoffset" + } + deriving (Show) diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -9,7 +9,7 @@ Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi - $(CABAL) configure + $(CABAL) configure --ghc-options="$(shell Build/collect-ghc-options.sh)" install: build install -d $(DESTDIR)$(PREFIX)/bin diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -21,7 +21,8 @@ tryNonAsync, tryWhenExists, catchIOErrorType, - IOErrorType(..) + IOErrorType(..), + catchPermissionDenied, ) where import Control.Monad.Catch as X hiding (Handler) @@ -97,3 +98,6 @@ onlymatching e | ioeGetErrorType e == errtype = onmatchingerr e | otherwise = throwM e + +catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a +catchPermissionDenied = catchIOErrorType PermissionDenied diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -18,9 +18,10 @@ import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files +import Control.Monad.IO.Class (liftIO) #endif +import Control.Monad.IO.Class (MonadIO) import Foreign (complement) -import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Catch import Utility.Exception diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -19,6 +19,7 @@ encodeW8NUL, decodeW8NUL, truncateFilePath, + setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -164,3 +165,10 @@ else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif + +{- This avoids ghc's output layer crashing on invalid encoded characters in + - filenames when printing them out. -} +setConsoleEncoding :: IO () +setConsoleEncoding = do + fileEncoding stdout + fileEncoding stderr diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -12,7 +12,6 @@ import Data.String.Utils import System.FilePath -import System.Directory import Data.List import Data.Maybe import Data.Char @@ -29,6 +28,7 @@ import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo +import Utility.Directory {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -60,7 +60,7 @@ {- Makes a path absolute. - - The first parameter is a base directory (ie, the cwd) to use if the path - - is not already absolute. + - is not already absolute, and should itsef be absolute. - - Does not attempt to deal with edge cases or ensure security with - untrusted inputs. @@ -252,15 +252,21 @@ 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 +{- 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 -toCygPath = id +toMSYS2Path = id #else -toCygPath p +toMSYS2Path p | null drive = recombine parts - | otherwise = recombine $ "/cygdrive" : driveletter drive : parts + | otherwise = recombine $ "/" : driveletter drive : parts where (drive, p') = splitDrive p parts = splitDirectories p' diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs --- a/Utility/PosixFiles.hs +++ b/Utility/PosixFiles.hs @@ -1,6 +1,6 @@ {- POSIX files (and compatablity wrappers). - - - This is like System.PosixCompat.Files, except with a fixed rename. + - This is like System.PosixCompat.Files, but with a few fixes. - - Copyright 2014 Joey Hess - @@ -21,6 +21,7 @@ import System.Posix.Files (rename) #else import qualified System.Win32.File as Win32 +import qualified System.Win32.HardLink as Win32 #endif {- System.PosixCompat.Files.rename on Windows calls renameFile, @@ -31,4 +32,11 @@ #ifdef mingw32_HOST_OS rename :: FilePath -> FilePath -> IO () rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING +#endif + +{- System.PosixCompat.Files.createLink throws an error, but windows + - does support hard links. -} +#ifdef mingw32_HOST_OS +createLink :: FilePath -> FilePath -> IO () +createLink = Win32.createHardLink #endif diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -18,6 +18,7 @@ readProcessEnv, writeReadProcessEnv, forceSuccessProcess, + forceSuccessProcess', checkSuccessProcess, ignoreFailureProcess, createProcessSuccess, @@ -129,11 +130,12 @@ -- | 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 +forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p + +forceSuccessProcess' :: CreateProcess -> ExitCode -> IO () +forceSuccessProcess' _ ExitSuccess = return () +forceSuccessProcess' p (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 diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -11,9 +11,9 @@ module Utility.Tmp where import System.IO -import System.Directory import Control.Monad.IfElse import System.FilePath +import System.Directory import Control.Monad.IO.Class #ifndef mingw32_HOST_OS import System.Posix.Temp (mkdtemp) diff --git a/Utility/URI.hs b/Utility/URI.hs deleted file mode 100644 --- a/Utility/URI.hs +++ /dev/null @@ -1,18 +0,0 @@ -{- 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 diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -17,9 +17,7 @@ import Utility.Env import System.PosixCompat -#ifndef mingw32_HOST_OS import Control.Applicative -#endif import Prelude {- Current user's home directory. @@ -58,6 +56,6 @@ #ifndef mingw32_HOST_OS go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) #else - go [] = error $ "environment not set: " ++ show envvars + go [] = extract <$> error ("environment not set: " ++ show envvars) #endif go (v:vs) = maybe (go vs) return =<< getEnv v diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,18 @@ +github-backup (1.20160522) unstable; urgency=medium + + * Work around git weirdness in handling of relative path to GIT_INDEX_FILE + when in a subdirectory of the repository. + * Various updates to internal git and utility libraries shared + with git-annex. + * debian: Add lintian overrides for rpath. + * debian: Bump standards-version. + * Makefile: Pass LDFLAGS, CFLAGS, and CPPFLAGS through ghc and on to + ld, cc, and cpp. This lets the Debian package build with various + hardening options. Although their benefit to a largely haskell program + is unknown. + + -- Joey Hess Sun, 22 May 2016 15:24:04 -0400 + github-backup (1.20160511) unstable; urgency=medium * Fix build with directory-1.2.6.2. diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -17,7 +17,7 @@ libghc-vector-dev, libghc-utf8-string-dev, Maintainer: James McCoy -Standards-Version: 3.9.5 +Standards-Version: 3.9.8 Vcs-Git: git://github.com/joeyh/github-backup.git Homepage: http://github.com/joeyh/github-backup diff --git a/debian/github-backup.lintian-overrides b/debian/github-backup.lintian-overrides new file mode 100644 --- /dev/null +++ b/debian/github-backup.lintian-overrides @@ -0,0 +1,1 @@ +binary-or-shlib-defines-rpath 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.20160511 +Version: 1.20160522 Cabal-Version: >= 1.8 Maintainer: Joey Hess Author: Joey Hess @@ -59,6 +59,9 @@ Build-Depends: network-uri (>= 2.6), network (>= 2.6) else Build-Depends: network (< 2.6), network (>= 2.0) + +custom-setup + Setup-Depends: base (>= 4.5), hslogger, MissingH source-repository head type: git diff --git a/github-backup.hs b/github-backup.hs --- a/github-backup.hs +++ b/github-backup.hs @@ -50,6 +50,7 @@ import Git.HashObject import Git.FilePath import Git.CatFile +import Git.Index import Utility.Env repoUrl :: GithubUserRepo -> String @@ -348,9 +349,9 @@ withIndex :: Backup a -> Backup a withIndex a = do r <- getState gitRepo - let f = Git.localGitDir r "github-backup.index" + f <- liftIO $ indexEnvVal $ Git.localGitDir r "github-backup.index" e <- liftIO getEnvironment - let r' = r { Git.Types.gitEnv = Just $ ("GIT_INDEX_FILE", f):e } + let r' = r { Git.Types.gitEnv = Just $ (indexEnv, f):e } changeState $ \s -> s { gitRepo = r' } v <- a changeState $ \s -> s { gitRepo = (gitRepo s) { Git.Types.gitEnv = Git.Types.gitEnv r } }