github-backup 1.20160922 → 1.20161110

raw patch · 8 files changed

+78/−59 lines, 8 files

Files

• CHANGELOG +9/−0
• Common.hs +1/−1
• Git/CatFile.hs +54/−26
• Git/HashObject.hs +1/−1
• Git/Ref.hs +4/−11
• Makefile +0/−5
• Utility/CoProcess.hs +8/−14
• github-backup.cabal +1/−1

@@ -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 <id@joeyh.name>  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.

@@ -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

@@ -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)]

@@ -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"

@@ -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,

@@ -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

@@ -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

@@ -1,5 +1,5 @@ Name: github-backup-Version: 1.20160922+Version: 1.20161110 Cabal-Version: >= 1.8 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess