diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +github-backup (1.20161110) unstable; urgency=medium + + * Fix build with recent versions of the directory package. + Thanks, James McCoy. + * Various updates to internal git and utility libraries shared + with git-annex. + + -- Joey Hess Thu, 10 Nov 2016 11:55:44 -0400 + github-backup (1.20160922) unstable; urgency=medium * Increase base bounds to 4.8 to get mapM_ etc that works on Vector. diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -12,7 +12,6 @@ import Data.String.Utils as X hiding (join) import System.FilePath as X -import System.Directory as X import System.IO as X hiding (FilePath) import System.PosixCompat.Files as X #ifndef mingw32_HOST_OS @@ -20,6 +19,7 @@ #endif import System.Exit as X +import Utility.SystemDirectory as X import Utility.Misc as X import Utility.Exception as X import Utility.SafeCommand as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -16,6 +16,7 @@ catCommit, catObject, catObjectDetails, + catObjectMetaData, ) where import System.IO @@ -37,21 +38,28 @@ import Git.FilePath import qualified Utility.CoProcess as CoProcess -data CatFileHandle = CatFileHandle CoProcess.CoProcessHandle Repo +data CatFileHandle = CatFileHandle + { catFileProcess :: CoProcess.CoProcessHandle + , checkFileProcess :: CoProcess.CoProcessHandle + } catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle -catFileStart' restartable repo = do - coprocess <- CoProcess.rawMode =<< gitCoProcessStart restartable +catFileStart' restartable repo = CatFileHandle + <$> startp "--batch" + <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + where + startp p = gitCoProcessStart restartable [ Param "cat-file" - , Param "--batch" + , Param p ] repo - return $ CatFileHandle coprocess repo catFileStop :: CatFileHandle -> IO () -catFileStop (CatFileHandle p _) = CoProcess.stop p +catFileStop h = do + CoProcess.stop (catFileProcess h) + CoProcess.stop (checkFileProcess h) {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString @@ -68,31 +76,51 @@ catObject h object = maybe L.empty fst3 <$> catObjectDetails h object catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catObjectDetails (CatFileHandle hdl _) object = CoProcess.query hdl send receive +catObjectDetails h object = query (catFileProcess h) object $ \from -> do + header <- hGetLine from + case parseResp object header of + Just (ParsedResp sha size objtype) -> do + content <- S.hGet from (fromIntegral size) + eatchar '\n' from + return $ Just (L.fromChunks [content], sha, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where - query = fromRef object - send to = hPutStrLn to query - receive from = do - header <- hGetLine from - case words header of - [sha, objtype, size] - | length sha == shaSize -> - case (readObjectType objtype, reads size) of - (Just t, [(bytes, "")]) -> readcontent t bytes from sha - _ -> dne - | otherwise -> dne - _ - | header == fromRef object ++ " missing" -> dne - | otherwise -> error $ "unknown response from git cat-file " ++ show (header, query) - readcontent objtype bytes from sha = do - content <- S.hGet from bytes - eatchar '\n' from - return $ Just (L.fromChunks [content], Ref sha, objtype) - dne = return Nothing eatchar expected from = do c <- hGetChar from when (c /= expected) $ error $ "missing " ++ (show expected) ++ " from git cat-file" + +{- Gets the size and type of an object, without reading its content. -} +catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType)) +catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do + resp <- hGetLine from + case parseResp object resp of + Just (ParsedResp _ size objtype) -> + return $ Just (size, objtype) + Just DNE -> return Nothing + Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object) + +data ParsedResp = ParsedResp Sha Integer ObjectType | DNE + +query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a +query hdl object receive = CoProcess.query hdl send receive + where + send to = hPutStrLn to (fromRef object) + +parseResp :: Ref -> String -> Maybe ParsedResp +parseResp object l + | " missing" `isSuffixOf` l -- less expensive than full check + && l == fromRef object ++ " missing" = Just DNE + | otherwise = case words l of + [sha, objtype, size] + | length sha == shaSize -> + case (readObjectType objtype, reads size) of + (Just t, [(bytes, "")]) -> + Just $ ParsedResp (Ref sha) bytes t + _ -> Nothing + | otherwise -> Nothing + _ -> Nothing {- Gets a list of files and directories in a tree. (Not recursive.) -} catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)] diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -20,7 +20,7 @@ type HashObjectHandle = CoProcess.CoProcessHandle hashObjectStart :: Repo -> IO HashObjectHandle -hashObjectStart = CoProcess.rawMode <=< gitCoProcessStart True +hashObjectStart = gitCoProcessStart True [ Param "hash-object" , Param "-w" , Param "--stdin-paths" diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -28,23 +28,16 @@ describe :: Ref -> String describe = fromRef . base -{- Often git refs are fully qualified (eg: refs/heads/master). - - Converts such a fully qualified ref into a base ref (eg: master). -} +{- Often git refs are fully qualified + - (eg refs/heads/master or refs/remotes/origin/master). + - Converts such a fully qualified ref into a base ref + - (eg: master or origin/master). -} base :: Ref -> Ref base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef where remove prefix s | 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 ++ "/" ++ 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/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -24,11 +24,6 @@ find -name \*.o -exec rm {} \; find -name \*.hi -exec rm {} \; -# Upload to hackage. -hackage: clean - @cabal sdist - @cabal upload dist/*.tar.gz - # hothasktags chokes on some template haskell etc, so ignore errors tags: find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -13,7 +13,6 @@ start, stop, query, - rawMode ) where import Common @@ -44,7 +43,15 @@ start' :: CoProcessSpec -> IO CoProcessState start' s = do (pid, from, to) <- startInteractiveProcess (coProcessCmd s) (coProcessParams s) (coProcessEnv s) + rawMode from + rawMode to return $ CoProcessState pid to from s + where + rawMode h = do + fileEncoding h +#ifdef mingw32_HOST_OS + hSetNewlineMode h noNewlineTranslation +#endif stop :: CoProcessHandle -> IO () stop ch = do @@ -79,16 +86,3 @@ { coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 } putMVar ch s' query ch send receive - -rawMode :: CoProcessHandle -> IO CoProcessHandle -rawMode ch = do - s <- readMVar ch - raw $ coProcessFrom s - raw $ coProcessTo s - return ch - where - raw h = do - fileEncoding h -#ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation -#endif 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.20160922 +Version: 1.20161110 Cabal-Version: >= 1.8 Maintainer: Joey Hess Author: Joey Hess