finished hlinting
This commit is contained in:
		
					parent
					
						
							
								57adb0347b
							
						
					
				
			
			
				commit
				
					
						eeae910242
					
				
			
		
					 23 changed files with 144 additions and 159 deletions
				
			
		| 
						 | 
				
			
			@ -30,7 +30,7 @@ module Backend (
 | 
			
		|||
) where
 | 
			
		||||
 | 
			
		||||
import Control.Monad.State
 | 
			
		||||
import IO (try)
 | 
			
		||||
import System.IO.Error (try)
 | 
			
		||||
import System.FilePath
 | 
			
		||||
import System.Posix.Files
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -34,7 +34,7 @@ backend = Backend {
 | 
			
		|||
	storeFileKey = dummyStore,
 | 
			
		||||
	retrieveKeyFile = copyKeyFile,
 | 
			
		||||
	removeKey = checkRemoveKey,
 | 
			
		||||
	hasKey = checkKeyFile,
 | 
			
		||||
	hasKey = inAnnex,
 | 
			
		||||
	fsckKey = mustProvide
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -42,19 +42,15 @@ mustProvide :: a
 | 
			
		|||
mustProvide = error "must provide this field"
 | 
			
		||||
 | 
			
		||||
{- Storing a key is a no-op. -}
 | 
			
		||||
dummyStore :: FilePath -> Key -> Annex (Bool)
 | 
			
		||||
dummyStore :: FilePath -> Key -> Annex Bool
 | 
			
		||||
dummyStore _ _ = return True
 | 
			
		||||
 | 
			
		||||
{- Just check if the .git/annex/ file for the key exists. -}
 | 
			
		||||
checkKeyFile :: Key -> Annex Bool
 | 
			
		||||
checkKeyFile k = inAnnex k
 | 
			
		||||
 | 
			
		||||
{- Try to find a copy of the file in one of the remotes,
 | 
			
		||||
 - and copy it over to this one. -}
 | 
			
		||||
copyKeyFile :: Key -> FilePath -> Annex (Bool)
 | 
			
		||||
copyKeyFile :: Key -> FilePath -> Annex Bool
 | 
			
		||||
copyKeyFile key file = do
 | 
			
		||||
	remotes <- Remotes.keyPossibilities key
 | 
			
		||||
	if (null remotes)
 | 
			
		||||
	if null remotes
 | 
			
		||||
		then do
 | 
			
		||||
			showNote "not available"
 | 
			
		||||
			showLocations key
 | 
			
		||||
| 
						 | 
				
			
			@ -68,52 +64,48 @@ copyKeyFile key file = do
 | 
			
		|||
			return False
 | 
			
		||||
		trycopy full (r:rs) = do
 | 
			
		||||
			probablythere <- probablyPresent r
 | 
			
		||||
			if (probablythere)
 | 
			
		||||
			if probablythere
 | 
			
		||||
				then do
 | 
			
		||||
					showNote $ "copying from " ++ (Git.repoDescribe r) ++ "..."
 | 
			
		||||
					showNote $ "copying from " ++ Git.repoDescribe r ++ "..."
 | 
			
		||||
					copied <- Remotes.copyFromRemote r key file
 | 
			
		||||
					if (copied)
 | 
			
		||||
					if copied
 | 
			
		||||
						then return True
 | 
			
		||||
						else trycopy full rs
 | 
			
		||||
				else trycopy full rs
 | 
			
		||||
		probablyPresent r = do
 | 
			
		||||
			-- This check is to avoid an ugly message if a
 | 
			
		||||
			-- remote is a drive that is not mounted.
 | 
			
		||||
			-- Avoid checking inAnnex for ssh remotes because
 | 
			
		||||
			-- that is unnecessarily slow, and the locationlog
 | 
			
		||||
			-- should be trusted. (If the ssh remote is down
 | 
			
		||||
			-- or really lacks the file, it's ok to show
 | 
			
		||||
			-- an ugly message before going on to the next
 | 
			
		||||
			-- remote.)
 | 
			
		||||
			if (not $ Git.repoIsUrl r)
 | 
			
		||||
		-- This check is to avoid an ugly message if a remote is a
 | 
			
		||||
		-- drive that is not mounted. Avoid checking inAnnex for ssh
 | 
			
		||||
		-- remotes because that is unnecessarily slow, and the
 | 
			
		||||
		-- locationlog should be trusted. (If the ssh remote is down
 | 
			
		||||
		-- or really lacks the file, it's ok to show an ugly message
 | 
			
		||||
		-- before going on to the next remote.)
 | 
			
		||||
		probablyPresent r =
 | 
			
		||||
			if not $ Git.repoIsUrl r
 | 
			
		||||
				then liftIO $ doesFileExist $ annexLocation r key
 | 
			
		||||
				else return True
 | 
			
		||||
 | 
			
		||||
{- Checks remotes to verify that enough copies of a key exist to allow
 | 
			
		||||
 - for a key to be safely removed (with no data loss), and fails with an
 | 
			
		||||
 - error if not. -}
 | 
			
		||||
checkRemoveKey :: Key -> Annex (Bool)
 | 
			
		||||
checkRemoveKey :: Key -> Annex Bool
 | 
			
		||||
checkRemoveKey key = do
 | 
			
		||||
	force <- Annex.flagIsSet "force"
 | 
			
		||||
	if (force)
 | 
			
		||||
	if force
 | 
			
		||||
		then return True
 | 
			
		||||
		else do
 | 
			
		||||
			remotes <- Remotes.keyPossibilities key
 | 
			
		||||
			numcopies <- getNumCopies
 | 
			
		||||
			if (numcopies > length remotes)
 | 
			
		||||
			if numcopies > length remotes
 | 
			
		||||
				then notEnoughCopies numcopies (length remotes) []
 | 
			
		||||
				else findcopies numcopies 0 remotes []
 | 
			
		||||
	where
 | 
			
		||||
		findcopies need have [] bad = 
 | 
			
		||||
			if (have >= need)
 | 
			
		||||
				then return True
 | 
			
		||||
				else notEnoughCopies need have bad
 | 
			
		||||
		findcopies need have (r:rs) bad = do
 | 
			
		||||
			if (have >= need)
 | 
			
		||||
				then return True
 | 
			
		||||
				else do
 | 
			
		||||
		findcopies need have [] bad
 | 
			
		||||
			| have >= need = return True
 | 
			
		||||
			| otherwise = notEnoughCopies need have bad
 | 
			
		||||
		findcopies need have (r:rs) bad
 | 
			
		||||
			| have >= need = return True
 | 
			
		||||
			| otherwise = do 
 | 
			
		||||
				haskey <- Remotes.inAnnex r key
 | 
			
		||||
					case (haskey) of
 | 
			
		||||
				case haskey of
 | 
			
		||||
					Right True	-> findcopies need (have+1) rs bad
 | 
			
		||||
					Right False	-> findcopies need have rs bad
 | 
			
		||||
					Left _		-> findcopies need have rs (r:bad)
 | 
			
		||||
| 
						 | 
				
			
			@ -121,23 +113,23 @@ checkRemoveKey key = do
 | 
			
		|||
			unsafe
 | 
			
		||||
			showLongNote $
 | 
			
		||||
				"Could only verify the existence of " ++
 | 
			
		||||
				(show have) ++ " out of " ++ (show need) ++ 
 | 
			
		||||
				show have ++ " out of " ++ show need ++ 
 | 
			
		||||
				" necessary copies"
 | 
			
		||||
			showTriedRemotes bad
 | 
			
		||||
			showLocations key
 | 
			
		||||
			hint
 | 
			
		||||
			return False
 | 
			
		||||
		unsafe = showNote "unsafe"
 | 
			
		||||
		hint = showLongNote $ "(Use --force to override this check, or adjust annex.numcopies.)"
 | 
			
		||||
		hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"
 | 
			
		||||
 | 
			
		||||
showLocations :: Key -> Annex ()
 | 
			
		||||
showLocations key = do
 | 
			
		||||
	g <- Annex.gitRepo
 | 
			
		||||
	u <- getUUID g
 | 
			
		||||
	uuids <- liftIO $ keyLocations g key
 | 
			
		||||
	let uuidsf = filter (\v -> v /= u) uuids
 | 
			
		||||
	let uuidsf = filter (/= u) uuids
 | 
			
		||||
	ppuuids <- prettyPrintUUIDs uuidsf
 | 
			
		||||
	if (null uuidsf)
 | 
			
		||||
	if null uuidsf
 | 
			
		||||
		then showLongNote $ "No other repository is known to contain the file."
 | 
			
		||||
		else showLongNote $ "Try making some of these repositories available:\n" ++ ppuuids
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -145,7 +137,7 @@ showTriedRemotes :: [Git.Repo] -> Annex ()
 | 
			
		|||
showTriedRemotes [] = return ()	
 | 
			
		||||
showTriedRemotes remotes =
 | 
			
		||||
	showLongNote $ "I was unable to access these remotes: " ++
 | 
			
		||||
		(Remotes.list remotes)
 | 
			
		||||
		Remotes.list remotes
 | 
			
		||||
 | 
			
		||||
getNumCopies :: Annex Int
 | 
			
		||||
getNumCopies = do
 | 
			
		||||
| 
						 | 
				
			
			@ -173,7 +165,7 @@ checkKeyNumCopies key = do
 | 
			
		|||
	remotes <- Remotes.keyPossibilities key
 | 
			
		||||
	inannex <- inAnnex key
 | 
			
		||||
	let present = length remotes + if inannex then 1 else 0
 | 
			
		||||
	if (present < needed)
 | 
			
		||||
	if present < needed
 | 
			
		||||
		then do
 | 
			
		||||
			warning $ note present needed
 | 
			
		||||
			return False
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -33,15 +33,15 @@ sha1 file = do
 | 
			
		|||
	liftIO $ pOpen ReadFromPipe "sha1sum" [file] $ \h -> do
 | 
			
		||||
		line <- hGetLine h
 | 
			
		||||
		let bits = split " " line
 | 
			
		||||
		if (null bits)
 | 
			
		||||
		if null bits
 | 
			
		||||
			then error "sha1sum parse error"
 | 
			
		||||
			else return $ bits !! 0
 | 
			
		||||
			else return $ head bits
 | 
			
		||||
 | 
			
		||||
-- A key is a sha1 of its contents.
 | 
			
		||||
keyValue :: FilePath -> Annex (Maybe Key)
 | 
			
		||||
keyValue file = do
 | 
			
		||||
	s <- sha1 file	
 | 
			
		||||
	return $ Just  $ Key ((name backend), s)
 | 
			
		||||
	return $ Just  $ Key (name backend, s)
 | 
			
		||||
 | 
			
		||||
-- A key's sha1 is checked during fsck.
 | 
			
		||||
checkKeySHA1 :: Key -> Annex Bool
 | 
			
		||||
| 
						 | 
				
			
			@ -49,11 +49,11 @@ checkKeySHA1 key = do
 | 
			
		|||
	g <- Annex.gitRepo
 | 
			
		||||
	let file = annexLocation g key
 | 
			
		||||
	present <- liftIO $ doesFileExist file
 | 
			
		||||
	if (not present)
 | 
			
		||||
	if not present
 | 
			
		||||
		then return True
 | 
			
		||||
		else do
 | 
			
		||||
			s <- sha1 file
 | 
			
		||||
			if (s == keyName key)
 | 
			
		||||
			if s == keyName key
 | 
			
		||||
				then return True
 | 
			
		||||
				else do
 | 
			
		||||
					dest <- moveBad key
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -37,11 +37,11 @@ backend = Backend.File.backend {
 | 
			
		|||
keyValue :: FilePath -> Annex (Maybe Key)
 | 
			
		||||
keyValue file = do
 | 
			
		||||
	stat <- liftIO $ getFileStatus file
 | 
			
		||||
	return $ Just $ Key ((name backend), key stat)
 | 
			
		||||
	return $ Just $ Key (name backend, key stat)
 | 
			
		||||
	where
 | 
			
		||||
 		key stat = uniqueid stat ++ sep ++ base
 | 
			
		||||
		uniqueid stat = (show $ modificationTime stat) ++ sep ++
 | 
			
		||||
			(show $ fileSize stat)
 | 
			
		||||
		uniqueid stat = show (modificationTime stat) ++ sep ++
 | 
			
		||||
			show (fileSize stat)
 | 
			
		||||
		base = takeFileName file
 | 
			
		||||
		sep = ":"
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -58,11 +58,11 @@ checkKeySize key = do
 | 
			
		|||
	g <- Annex.gitRepo
 | 
			
		||||
	let file = annexLocation g key
 | 
			
		||||
	present <- liftIO $ doesFileExist file
 | 
			
		||||
	if (not present)
 | 
			
		||||
	if not present
 | 
			
		||||
		then return True
 | 
			
		||||
		else do
 | 
			
		||||
			s <- liftIO $ getFileStatus file
 | 
			
		||||
			if (fileSize s == keySize key)
 | 
			
		||||
			if fileSize s == keySize key
 | 
			
		||||
				then return True
 | 
			
		||||
				else do
 | 
			
		||||
					dest <- moveBad key
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,7 +28,7 @@ seek = [withFilesNotInGit start, withFilesUnlocked start]
 | 
			
		|||
start :: SubCmdStartBackendFile
 | 
			
		||||
start pair@(file, _) = notAnnexed file $ do
 | 
			
		||||
	s <- liftIO $ getSymbolicLinkStatus file
 | 
			
		||||
	if ((isSymbolicLink s) || (not $ isRegularFile s))
 | 
			
		||||
	if (isSymbolicLink s) || (not $ isRegularFile s)
 | 
			
		||||
		then return Nothing
 | 
			
		||||
		else do
 | 
			
		||||
			showStart "add" file
 | 
			
		||||
| 
						 | 
				
			
			@ -37,7 +37,7 @@ start pair@(file, _) = notAnnexed file $ do
 | 
			
		|||
perform :: (FilePath, Maybe Backend) -> SubCmdPerform
 | 
			
		||||
perform (file, backend) = do
 | 
			
		||||
	stored <- Backend.storeFileKey file backend
 | 
			
		||||
	case (stored) of
 | 
			
		||||
	case stored of
 | 
			
		||||
		Nothing -> return Nothing
 | 
			
		||||
		Just (key, _) -> return $ Just $ cleanup file key
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -24,7 +24,7 @@ seek = [withFilesInGit start]
 | 
			
		|||
start :: SubCmdStartString
 | 
			
		||||
start file = isAnnexed file $ \(key, backend) -> do
 | 
			
		||||
	inbackend <- Backend.hasKey key
 | 
			
		||||
	if (not inbackend)
 | 
			
		||||
	if not inbackend
 | 
			
		||||
		then return Nothing
 | 
			
		||||
		else do
 | 
			
		||||
			showStart "drop" file
 | 
			
		||||
| 
						 | 
				
			
			@ -33,13 +33,13 @@ start file = isAnnexed file $ \(key, backend) -> do
 | 
			
		|||
perform :: Key -> Backend -> SubCmdPerform
 | 
			
		||||
perform key backend = do
 | 
			
		||||
	success <- Backend.removeKey backend key
 | 
			
		||||
	if (success)
 | 
			
		||||
	if success
 | 
			
		||||
		then return $ Just $ cleanup key
 | 
			
		||||
		else return Nothing
 | 
			
		||||
 | 
			
		||||
cleanup :: Key -> SubCmdCleanup
 | 
			
		||||
cleanup key = do
 | 
			
		||||
	inannex <- inAnnex key
 | 
			
		||||
	when (inannex) $ removeAnnex key
 | 
			
		||||
	when inannex $ removeAnnex key
 | 
			
		||||
	logStatus key ValueMissing
 | 
			
		||||
	return True
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -22,12 +22,12 @@ seek = [withKeys start]
 | 
			
		|||
start :: SubCmdStartString
 | 
			
		||||
start keyname = do
 | 
			
		||||
	backends <- Backend.list
 | 
			
		||||
	let key = genKey (backends !! 0) keyname
 | 
			
		||||
	let key = genKey (head backends) keyname
 | 
			
		||||
	present <- inAnnex key
 | 
			
		||||
	force <- Annex.flagIsSet "force"
 | 
			
		||||
	if (not present)
 | 
			
		||||
	if not present
 | 
			
		||||
		then return Nothing
 | 
			
		||||
		else if (not force)
 | 
			
		||||
		else if not force
 | 
			
		||||
			then error "dropkey is can cause data loss; use --force if you're sure you want to do this"
 | 
			
		||||
			else do
 | 
			
		||||
				showStart "dropkey" keyname
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -20,5 +20,5 @@ seek = [withDefault "." withFilesInGit start]
 | 
			
		|||
start :: SubCmdStartString
 | 
			
		||||
start file = isAnnexed file $ \(key, _) -> do
 | 
			
		||||
	exists <- inAnnex key
 | 
			
		||||
	when (exists) $ liftIO $ putStrLn file
 | 
			
		||||
	when exists $ liftIO $ putStrLn file
 | 
			
		||||
	return Nothing
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -25,7 +25,7 @@ start :: SubCmdStartString
 | 
			
		|||
start file = isAnnexed file $ \(key, _) -> do
 | 
			
		||||
	link <- calcGitLink file key
 | 
			
		||||
	l <- liftIO $ readSymbolicLink file
 | 
			
		||||
	if (link == l)
 | 
			
		||||
	if link == l
 | 
			
		||||
		then return Nothing
 | 
			
		||||
		else do
 | 
			
		||||
			showStart "fix" file
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -29,10 +29,10 @@ start file = do
 | 
			
		|||
	keyname <- Annex.flagGet "key"
 | 
			
		||||
	when (null keyname) $ error "please specify the key with --key"
 | 
			
		||||
	backends <- Backend.list
 | 
			
		||||
	let key = genKey (backends !! 0) keyname
 | 
			
		||||
	let key = genKey (head backends) keyname
 | 
			
		||||
 | 
			
		||||
	inbackend <- Backend.hasKey key
 | 
			
		||||
	unless (inbackend) $ error $
 | 
			
		||||
	unless inbackend $ error $
 | 
			
		||||
		"key ("++keyname++") is not present in backend"
 | 
			
		||||
	showStart "fromkey" file
 | 
			
		||||
	return $ Just $ perform file key
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -24,6 +24,6 @@ start file = isAnnexed file $ \(key, backend) -> do
 | 
			
		|||
perform :: Key -> Backend -> SubCmdPerform
 | 
			
		||||
perform key backend = do
 | 
			
		||||
	success <- Backend.fsckKey backend key
 | 
			
		||||
	if (success)
 | 
			
		||||
	if success
 | 
			
		||||
		then return $ Just $ return True
 | 
			
		||||
		else return Nothing
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -24,6 +24,6 @@ start file = isAnnexed file $ \(key, backend) -> do
 | 
			
		|||
perform :: Key -> Backend -> SubCmdPerform
 | 
			
		||||
perform key backend = do
 | 
			
		||||
	success <- Backend.fsckKey backend key
 | 
			
		||||
	if (success)
 | 
			
		||||
	if success
 | 
			
		||||
		then return $ Just $ return True
 | 
			
		||||
		else return Nothing
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -20,7 +20,7 @@ seek = [withFilesInGit start]
 | 
			
		|||
start :: SubCmdStartString
 | 
			
		||||
start file = isAnnexed file $ \(key, backend) -> do
 | 
			
		||||
	inannex <- inAnnex key
 | 
			
		||||
	if (inannex)
 | 
			
		||||
	if inannex
 | 
			
		||||
		then return Nothing
 | 
			
		||||
		else do
 | 
			
		||||
			showStart "get" file
 | 
			
		||||
| 
						 | 
				
			
			@ -29,7 +29,7 @@ start file = isAnnexed file $ \(key, backend) -> do
 | 
			
		|||
perform :: Key -> Backend -> SubCmdPerform
 | 
			
		||||
perform key backend = do
 | 
			
		||||
	ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
 | 
			
		||||
	if (ok)
 | 
			
		||||
	if ok
 | 
			
		||||
		then return $ Just $ return True -- no cleanup needed
 | 
			
		||||
		else return Nothing
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -25,8 +25,8 @@ seek = [withString start]
 | 
			
		|||
{- Stores description for the repository etc. -}
 | 
			
		||||
start :: SubCmdStartString
 | 
			
		||||
start description = do
 | 
			
		||||
	when (null description) $ error $
 | 
			
		||||
		"please specify a description of this repository\n"
 | 
			
		||||
	when (null description) $
 | 
			
		||||
		error "please specify a description of this repository\n"
 | 
			
		||||
	showStart "init" description
 | 
			
		||||
	return $ Just $ perform description
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -38,7 +38,7 @@ perform description = do
 | 
			
		|||
	setVersion
 | 
			
		||||
	liftIO $ gitAttributes g
 | 
			
		||||
	liftIO $ gitPreCommitHook g
 | 
			
		||||
	return $ Just $ cleanup
 | 
			
		||||
	return $ Just cleanup
 | 
			
		||||
 | 
			
		||||
cleanup :: SubCmdCleanup
 | 
			
		||||
cleanup = do
 | 
			
		||||
| 
						 | 
				
			
			@ -53,7 +53,7 @@ cleanup = do
 | 
			
		|||
gitAttributes :: Git.Repo -> IO ()
 | 
			
		||||
gitAttributes repo = do
 | 
			
		||||
	exists <- doesFileExist attributes
 | 
			
		||||
	if (not exists)
 | 
			
		||||
	if not exists
 | 
			
		||||
		then do
 | 
			
		||||
			writeFile attributes $ attrLine ++ "\n"
 | 
			
		||||
			commit
 | 
			
		||||
| 
						 | 
				
			
			@ -76,7 +76,7 @@ gitPreCommitHook repo = do
 | 
			
		|||
	let hook = Git.workTree repo ++ "/" ++ Git.gitDir repo ++
 | 
			
		||||
		"/hooks/pre-commit"
 | 
			
		||||
	exists <- doesFileExist hook
 | 
			
		||||
	if (exists)
 | 
			
		||||
	if exists
 | 
			
		||||
		then putStrLn $ "pre-commit hook (" ++ hook ++ ") already exists, not configuring"
 | 
			
		||||
		else do
 | 
			
		||||
			writeFile hook $ "#!/bin/sh\n" ++
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -7,8 +7,7 @@
 | 
			
		|||
 | 
			
		||||
module Command.Move where
 | 
			
		||||
 | 
			
		||||
import Control.Monad.State (liftIO)
 | 
			
		||||
import Monad (when)
 | 
			
		||||
import Control.Monad.State (liftIO, when)
 | 
			
		||||
 | 
			
		||||
import Command
 | 
			
		||||
import qualified Command.Drop
 | 
			
		||||
| 
						 | 
				
			
			@ -53,7 +52,7 @@ start file = do
 | 
			
		|||
moveToStart :: SubCmdStartString
 | 
			
		||||
moveToStart file = isAnnexed file $ \(key, _) -> do
 | 
			
		||||
	ishere <- inAnnex key
 | 
			
		||||
	if (not ishere)
 | 
			
		||||
	if not ishere
 | 
			
		||||
		then return Nothing -- not here, so nothing to do
 | 
			
		||||
		else do
 | 
			
		||||
			showStart "move" file
 | 
			
		||||
| 
						 | 
				
			
			@ -68,10 +67,10 @@ moveToPerform key = do
 | 
			
		|||
			showNote $ show err
 | 
			
		||||
			return Nothing
 | 
			
		||||
		Right False -> do
 | 
			
		||||
			showNote $ "moving to " ++ (Git.repoDescribe remote) ++ "..."
 | 
			
		||||
			let tmpfile = (annexTmpLocation remote) ++ (keyFile key)
 | 
			
		||||
			showNote $ "moving to " ++ Git.repoDescribe remote ++ "..."
 | 
			
		||||
			let tmpfile = annexTmpLocation remote ++ keyFile key
 | 
			
		||||
			ok <- Remotes.copyToRemote remote key tmpfile
 | 
			
		||||
			if (ok)
 | 
			
		||||
			if ok
 | 
			
		||||
				then return $ Just $ moveToCleanup remote key tmpfile
 | 
			
		||||
				else return Nothing -- failed
 | 
			
		||||
		Right True -> return $ Just $ Command.Drop.cleanup key
 | 
			
		||||
| 
						 | 
				
			
			@ -79,7 +78,7 @@ moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup
 | 
			
		|||
moveToCleanup remote key tmpfile = do
 | 
			
		||||
	-- Tell remote to use the transferred content.
 | 
			
		||||
	ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
 | 
			
		||||
		"--backend=" ++ (backendName key),
 | 
			
		||||
		"--backend=" ++ backendName key,
 | 
			
		||||
		"--key=" ++ keyName key,
 | 
			
		||||
		tmpfile]
 | 
			
		||||
	if ok
 | 
			
		||||
| 
						 | 
				
			
			@ -104,7 +103,7 @@ moveFromStart :: SubCmdStartString
 | 
			
		|||
moveFromStart file = isAnnexed file $ \(key, _) -> do
 | 
			
		||||
	remote <- Remotes.commandLineRemote
 | 
			
		||||
	l <- Remotes.keyPossibilities key
 | 
			
		||||
	if (null $ filter (\r -> Remotes.same r remote) l)
 | 
			
		||||
	if null $ filter (\r -> Remotes.same r remote) l
 | 
			
		||||
		then return Nothing
 | 
			
		||||
		else do
 | 
			
		||||
			showStart "move" file
 | 
			
		||||
| 
						 | 
				
			
			@ -113,18 +112,18 @@ moveFromPerform :: Key -> SubCmdPerform
 | 
			
		|||
moveFromPerform key = do
 | 
			
		||||
	remote <- Remotes.commandLineRemote
 | 
			
		||||
	ishere <- inAnnex key
 | 
			
		||||
	if (ishere)
 | 
			
		||||
	if ishere
 | 
			
		||||
		then return $ Just $ moveFromCleanup remote key
 | 
			
		||||
		else do
 | 
			
		||||
			showNote $ "moving from " ++ (Git.repoDescribe remote) ++ "..."
 | 
			
		||||
			ok <- getViaTmp key (Remotes.copyFromRemote remote key)
 | 
			
		||||
			if (ok)
 | 
			
		||||
			showNote $ "moving from " ++ Git.repoDescribe remote ++ "..."
 | 
			
		||||
			ok <- getViaTmp key $ Remotes.copyFromRemote remote key
 | 
			
		||||
			if ok
 | 
			
		||||
				then return $ Just $ moveFromCleanup remote key
 | 
			
		||||
				else return Nothing -- fail
 | 
			
		||||
moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup
 | 
			
		||||
moveFromCleanup remote key = do
 | 
			
		||||
	ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
 | 
			
		||||
		"--backend=" ++ (backendName key),
 | 
			
		||||
		"--backend=" ++ backendName key,
 | 
			
		||||
		keyName key]
 | 
			
		||||
	when ok $ do
 | 
			
		||||
		-- Record locally that the key is not on the remote.
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,7 +28,7 @@ start file = return $ Just $ perform file
 | 
			
		|||
perform :: FilePath -> SubCmdPerform
 | 
			
		||||
perform file = do
 | 
			
		||||
	pairs <- Backend.chooseBackends [file]
 | 
			
		||||
	ok <- doSubCmd $ Command.Add.start $ pairs !! 0
 | 
			
		||||
	ok <- doSubCmd $ Command.Add.start $ head pairs
 | 
			
		||||
	if ok
 | 
			
		||||
		then return $ Just $ cleanup file
 | 
			
		||||
		else error $ "failed to add " ++ file ++ "; canceling commit"
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,7 +28,7 @@ start file = do
 | 
			
		|||
	keyname <- Annex.flagGet "key"
 | 
			
		||||
	when (null keyname) $ error "please specify the key with --key"
 | 
			
		||||
	backends <- Backend.list
 | 
			
		||||
	let key = genKey (backends !! 0) keyname
 | 
			
		||||
	let key = genKey (head backends) keyname
 | 
			
		||||
	showStart "setkey" file
 | 
			
		||||
	return $ Just $ perform file key
 | 
			
		||||
perform :: FilePath -> Key -> SubCmdPerform
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -34,7 +34,7 @@ perform file key backend = do
 | 
			
		|||
	-- force backend to always remove
 | 
			
		||||
	Annex.flagChange "force" $ FlagBool True
 | 
			
		||||
	ok <- Backend.removeKey backend key
 | 
			
		||||
	if (ok)
 | 
			
		||||
	if ok
 | 
			
		||||
		then return $ Just $ cleanup file key
 | 
			
		||||
		else return Nothing
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -35,7 +35,7 @@ checkUnused :: Annex Bool
 | 
			
		|||
checkUnused = do
 | 
			
		||||
	showNote "checking for unused data..."
 | 
			
		||||
	unused <- unusedKeys
 | 
			
		||||
	if (null unused)
 | 
			
		||||
	if null unused
 | 
			
		||||
		then return True
 | 
			
		||||
		else do
 | 
			
		||||
			let list = number 1 unused
 | 
			
		||||
| 
						 | 
				
			
			@ -48,9 +48,10 @@ checkUnused = do
 | 
			
		|||
		w u = unlines $
 | 
			
		||||
			["Some annexed data is no longer pointed to by any files in the repository:",
 | 
			
		||||
			 "  NUMBER  KEY"]
 | 
			
		||||
			++ (map (\(n, k) -> "  " ++ (pad 6 $ show n) ++ "  " ++ show k) u) ++
 | 
			
		||||
			++ map cols u ++
 | 
			
		||||
			["(To see where data was previously used, try: git log --stat -S'KEY')",
 | 
			
		||||
			 "(To remove unwanted data: git-annex dropunused NUMBER)"]
 | 
			
		||||
		cols (n,k) = "  " ++ pad 6 (show n) ++ "  " ++ show k
 | 
			
		||||
		pad n s = s ++ replicate (n - length s) ' '
 | 
			
		||||
 | 
			
		||||
number :: Integer -> [a] -> [(Integer, a)]
 | 
			
		||||
| 
						 | 
				
			
			@ -71,8 +72,7 @@ unusedKeys = do
 | 
			
		|||
	let unused_m = remove referenced present_m
 | 
			
		||||
	return $ M.keys unused_m
 | 
			
		||||
	where
 | 
			
		||||
		remove [] m = m
 | 
			
		||||
		remove (x:xs) m = remove xs $ M.delete x m
 | 
			
		||||
		remove a b = foldl (flip M.delete) b a
 | 
			
		||||
 | 
			
		||||
existsMap :: Ord k => [k] -> M.Map k Int
 | 
			
		||||
existsMap l = M.fromList $ map (\k -> (k, 1)) l
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										2
									
								
								Core.hs
									
										
									
									
									
								
							
							
						
						
									
										2
									
								
								Core.hs
									
										
									
									
									
								
							| 
						 | 
				
			
			@ -7,7 +7,7 @@
 | 
			
		|||
 | 
			
		||||
module Core where
 | 
			
		||||
 | 
			
		||||
import IO (try)
 | 
			
		||||
import System.IO.Error (try)
 | 
			
		||||
import System.Directory
 | 
			
		||||
import Control.Monad.State (liftIO)
 | 
			
		||||
import System.Path
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										98
									
								
								Remotes.hs
									
										
									
									
									
								
							
							
						
						
									
										98
									
								
								Remotes.hs
									
										
									
									
									
								
							| 
						 | 
				
			
			@ -17,16 +17,14 @@ module Remotes (
 | 
			
		|||
	runCmd
 | 
			
		||||
) where
 | 
			
		||||
 | 
			
		||||
import IO (bracket_)
 | 
			
		||||
import Control.Exception.Extensible hiding (bracket_)
 | 
			
		||||
import Control.Exception.Extensible
 | 
			
		||||
import Control.Monad.State (liftIO)
 | 
			
		||||
import Control.Monad (filterM)
 | 
			
		||||
import qualified Data.Map as Map
 | 
			
		||||
import Data.String.Utils
 | 
			
		||||
import System.Directory hiding (copyFile)
 | 
			
		||||
import System.Posix.Directory
 | 
			
		||||
import List
 | 
			
		||||
import Monad (when, unless)
 | 
			
		||||
import Data.List
 | 
			
		||||
import Control.Monad (when, unless, filterM)
 | 
			
		||||
 | 
			
		||||
import Types
 | 
			
		||||
import qualified GitRepo as Git
 | 
			
		||||
| 
						 | 
				
			
			@ -55,7 +53,7 @@ keyPossibilities key = do
 | 
			
		|||
	-- But, reading the config of remotes can be expensive, so make
 | 
			
		||||
	-- sure we only do it once per git-annex run.
 | 
			
		||||
	remotesread <- Annex.flagIsSet "remotesread"
 | 
			
		||||
	if (remotesread)
 | 
			
		||||
	if remotesread
 | 
			
		||||
		then reposByUUID allremotes uuids
 | 
			
		||||
		else do
 | 
			
		||||
			-- We assume that it's cheap to read the config
 | 
			
		||||
| 
						 | 
				
			
			@ -65,11 +63,11 @@ keyPossibilities key = do
 | 
			
		|||
			let cheap = filter (not . Git.repoIsUrl) allremotes
 | 
			
		||||
			let expensive = filter Git.repoIsUrl allremotes
 | 
			
		||||
			doexpensive <- filterM cachedUUID expensive
 | 
			
		||||
			unless (null doexpensive) $ do
 | 
			
		||||
			unless (null doexpensive) $
 | 
			
		||||
				showNote $ "getting UUID for " ++
 | 
			
		||||
					(list doexpensive) ++ "..."
 | 
			
		||||
					list doexpensive ++ "..."
 | 
			
		||||
			let todo = cheap ++ doexpensive
 | 
			
		||||
			if (not $ null todo)
 | 
			
		||||
			if not $ null todo
 | 
			
		||||
				then do
 | 
			
		||||
					_ <- mapM tryGitConfigRead todo
 | 
			
		||||
					Annex.flagChange "remotesread" $ FlagBool True
 | 
			
		||||
| 
						 | 
				
			
			@ -84,10 +82,9 @@ keyPossibilities key = do
 | 
			
		|||
 - If the remote cannot be accessed, returns a Left error.
 | 
			
		||||
 -}
 | 
			
		||||
inAnnex :: Git.Repo -> Key -> Annex (Either IOException Bool)
 | 
			
		||||
inAnnex r key = do
 | 
			
		||||
	if (not $ Git.repoIsUrl r)
 | 
			
		||||
		then liftIO $ ((try checklocal)::IO (Either IOException Bool))
 | 
			
		||||
		else checkremote
 | 
			
		||||
inAnnex r key = if Git.repoIsUrl r
 | 
			
		||||
		then checkremote
 | 
			
		||||
		else liftIO (try checklocal ::IO (Either IOException Bool))
 | 
			
		||||
	where
 | 
			
		||||
		checklocal = do
 | 
			
		||||
			-- run a local check by making an Annex monad
 | 
			
		||||
| 
						 | 
				
			
			@ -112,12 +109,12 @@ reposByCost :: [Git.Repo] -> Annex [Git.Repo]
 | 
			
		|||
reposByCost l = do
 | 
			
		||||
	notignored <- filterM repoNotIgnored l
 | 
			
		||||
	costpairs <- mapM costpair notignored
 | 
			
		||||
	return $ fst $ unzip $ sortBy bycost $ costpairs
 | 
			
		||||
	return $ fst $ unzip $ sortBy cmpcost costpairs
 | 
			
		||||
	where
 | 
			
		||||
		costpair r = do
 | 
			
		||||
			cost <- repoCost r
 | 
			
		||||
			return (r, cost)
 | 
			
		||||
		bycost (_, c1) (_, c2) = compare c1 c2
 | 
			
		||||
		cmpcost (_, c1) (_, c2) = compare c1 c2
 | 
			
		||||
 | 
			
		||||
{- Calculates cost for a repo.
 | 
			
		||||
 -
 | 
			
		||||
| 
						 | 
				
			
			@ -127,9 +124,9 @@ reposByCost l = do
 | 
			
		|||
repoCost :: Git.Repo -> Annex Int
 | 
			
		||||
repoCost r = do
 | 
			
		||||
	cost <- repoConfig r "cost" ""
 | 
			
		||||
	if (not $ null cost)
 | 
			
		||||
	if not $ null cost
 | 
			
		||||
		then return $ read cost
 | 
			
		||||
		else if (Git.repoIsUrl r)
 | 
			
		||||
		else if Git.repoIsUrl r
 | 
			
		||||
			then return 200
 | 
			
		||||
			else return 100
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -141,13 +138,12 @@ repoNotIgnored r = do
 | 
			
		|||
	ignored <- repoConfig r "ignore" "false"
 | 
			
		||||
	fromName <- Annex.flagGet "fromrepository"
 | 
			
		||||
	toName <- Annex.flagGet "torepository"
 | 
			
		||||
	let name = if (not $ null fromName) then fromName else toName
 | 
			
		||||
	if (not $ null name)
 | 
			
		||||
	let name = if null fromName then toName else fromName
 | 
			
		||||
	if not $ null name
 | 
			
		||||
		then return $ match name
 | 
			
		||||
		else return $ not $ isIgnored ignored
 | 
			
		||||
		else return $ not $ Git.configTrue ignored
 | 
			
		||||
	where
 | 
			
		||||
		match name = name == Git.repoRemoteName r
 | 
			
		||||
		isIgnored ignored = Git.configTrue ignored
 | 
			
		||||
 | 
			
		||||
{- Checks if two repos are the same, by comparing their remote names. -}
 | 
			
		||||
same :: Git.Repo -> Git.Repo -> Bool
 | 
			
		||||
| 
						 | 
				
			
			@ -158,14 +154,14 @@ commandLineRemote :: Annex Git.Repo
 | 
			
		|||
commandLineRemote = do
 | 
			
		||||
	fromName <- Annex.flagGet "fromrepository"
 | 
			
		||||
	toName <- Annex.flagGet "torepository"
 | 
			
		||||
	let name = if (not $ null fromName) then fromName else toName
 | 
			
		||||
	let name = if null fromName then toName else fromName
 | 
			
		||||
	when (null name) $ error "no remote specified"
 | 
			
		||||
	g <- Annex.gitRepo
 | 
			
		||||
	let match = filter (\r -> name == Git.repoRemoteName r) $
 | 
			
		||||
		Git.remotes g
 | 
			
		||||
	when (null match) $ error $
 | 
			
		||||
		"there is no git remote named \"" ++ name ++ "\""
 | 
			
		||||
	return $ match !! 0
 | 
			
		||||
	return $ head match
 | 
			
		||||
 | 
			
		||||
{- The git configs for the git repo's remotes is not read on startup
 | 
			
		||||
 - because reading it may be expensive. This function tries to read the
 | 
			
		||||
| 
						 | 
				
			
			@ -174,12 +170,12 @@ commandLineRemote = do
 | 
			
		|||
tryGitConfigRead :: Git.Repo -> Annex (Either Git.Repo Git.Repo)
 | 
			
		||||
tryGitConfigRead r = do
 | 
			
		||||
	sshoptions <- repoConfig r "ssh-options" ""
 | 
			
		||||
	if (Map.null $ Git.configMap r)
 | 
			
		||||
	if Map.null $ Git.configMap r
 | 
			
		||||
		then do
 | 
			
		||||
			-- configRead can fail due to IO error or
 | 
			
		||||
			-- for other reasons; catch all possible exceptions
 | 
			
		||||
			result <- liftIO $ (try (Git.configRead r $ Just $ words sshoptions)::IO (Either SomeException (Git.Repo)))
 | 
			
		||||
			case (result) of
 | 
			
		||||
			result <- liftIO (try (Git.configRead r $ Just $ words sshoptions)::IO (Either SomeException Git.Repo))
 | 
			
		||||
			case result of
 | 
			
		||||
				Left _ -> return $ Left r
 | 
			
		||||
				Right r' -> do
 | 
			
		||||
					g <- Annex.gitRepo
 | 
			
		||||
| 
						 | 
				
			
			@ -192,18 +188,16 @@ tryGitConfigRead r = do
 | 
			
		|||
	where 
 | 
			
		||||
		exchange [] _ = []
 | 
			
		||||
		exchange (old:ls) new =
 | 
			
		||||
			if (Git.repoRemoteName old == Git.repoRemoteName new)
 | 
			
		||||
				then new:(exchange ls new)
 | 
			
		||||
				else old:(exchange ls new)
 | 
			
		||||
			if Git.repoRemoteName old == Git.repoRemoteName new
 | 
			
		||||
				then new : exchange ls new
 | 
			
		||||
				else old : exchange ls new
 | 
			
		||||
 | 
			
		||||
{- Tries to copy a key's content from a remote to a file. -}
 | 
			
		||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
 | 
			
		||||
copyFromRemote r key file = do
 | 
			
		||||
	if (not $ Git.repoIsUrl r)
 | 
			
		||||
		then getlocal
 | 
			
		||||
		else if (Git.repoIsSsh r)
 | 
			
		||||
			then getssh
 | 
			
		||||
			else error "copying from non-ssh repo not supported"
 | 
			
		||||
copyFromRemote r key file
 | 
			
		||||
	| not $ Git.repoIsUrl r = getlocal
 | 
			
		||||
	| Git.repoIsSsh r = getssh
 | 
			
		||||
	| otherwise = error "copying from non-ssh repo not supported"
 | 
			
		||||
	where
 | 
			
		||||
		getlocal = liftIO $ copyFile keyloc file
 | 
			
		||||
		getssh = scp r [sshLocation r keyloc, file]
 | 
			
		||||
| 
						 | 
				
			
			@ -214,9 +208,9 @@ copyToRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
 | 
			
		|||
copyToRemote r key file = do
 | 
			
		||||
	g <- Annex.gitRepo
 | 
			
		||||
	let keyloc = annexLocation g key
 | 
			
		||||
	if (not $ Git.repoIsUrl r)
 | 
			
		||||
	if not $ Git.repoIsUrl r
 | 
			
		||||
		then putlocal keyloc
 | 
			
		||||
		else if (Git.repoIsSsh r)
 | 
			
		||||
		else if Git.repoIsSsh r
 | 
			
		||||
			then putssh keyloc
 | 
			
		||||
			else error "copying to non-ssh repo not supported"
 | 
			
		||||
	where
 | 
			
		||||
| 
						 | 
				
			
			@ -224,7 +218,7 @@ copyToRemote r key file = do
 | 
			
		|||
		putssh src = scp r [src, sshLocation r file]
 | 
			
		||||
 | 
			
		||||
sshLocation :: Git.Repo -> FilePath -> FilePath
 | 
			
		||||
sshLocation r file = (Git.urlHost r) ++ ":" ++ shellEscape file
 | 
			
		||||
sshLocation r file = Git.urlHost r ++ ":" ++ shellEscape file
 | 
			
		||||
 | 
			
		||||
{- Runs scp against a specified remote. (Honors annex-scp-options.) -}
 | 
			
		||||
scp :: Git.Repo -> [String] -> Annex Bool
 | 
			
		||||
| 
						 | 
				
			
			@ -238,21 +232,21 @@ scp r params = do
 | 
			
		|||
runCmd :: Git.Repo -> String -> [String] -> Annex Bool
 | 
			
		||||
runCmd r command params = do
 | 
			
		||||
	sshoptions <- repoConfig r "ssh-options" ""
 | 
			
		||||
	if (not $ Git.repoIsUrl r)
 | 
			
		||||
	if not $ Git.repoIsUrl r
 | 
			
		||||
		then do
 | 
			
		||||
			cwd <- liftIO $ getCurrentDirectory
 | 
			
		||||
			liftIO $ bracket_ (changeWorkingDirectory (Git.workTree r))
 | 
			
		||||
				(\_ -> changeWorkingDirectory cwd) $
 | 
			
		||||
					boolSystem command params
 | 
			
		||||
		else if (Git.repoIsSsh r)
 | 
			
		||||
			then do
 | 
			
		||||
				liftIO $ boolSystem "ssh" $
 | 
			
		||||
					(words sshoptions) ++ 
 | 
			
		||||
					[Git.urlHost r, "cd " ++ 
 | 
			
		||||
					(shellEscape $ Git.workTree r) ++
 | 
			
		||||
					" && " ++ (shellEscape command) ++ " " ++
 | 
			
		||||
					(unwords $ map shellEscape params)]
 | 
			
		||||
			cwd <- liftIO getCurrentDirectory
 | 
			
		||||
			liftIO $ bracket_
 | 
			
		||||
				(changeWorkingDirectory (Git.workTree r))
 | 
			
		||||
				(changeWorkingDirectory cwd)
 | 
			
		||||
				(boolSystem command params)
 | 
			
		||||
		else if Git.repoIsSsh r
 | 
			
		||||
			then liftIO $ boolSystem "ssh" $
 | 
			
		||||
				words sshoptions ++ [Git.urlHost r, sshcmd]
 | 
			
		||||
			else error "running command in non-ssh repo not supported"
 | 
			
		||||
	where 
 | 
			
		||||
		sshcmd = "cd " ++ shellEscape (Git.workTree r) ++
 | 
			
		||||
			" && " ++ shellEscape command ++ " " ++
 | 
			
		||||
			unwords (map shellEscape params)
 | 
			
		||||
 | 
			
		||||
{- Looks up a per-remote config option in git config.
 | 
			
		||||
 - Failing that, tries looking for a global config option. -}
 | 
			
		||||
| 
						 | 
				
			
			@ -262,5 +256,5 @@ repoConfig r key def = do
 | 
			
		|||
	let def' = Git.configGet g global def
 | 
			
		||||
	return $ Git.configGet g local def'
 | 
			
		||||
	where
 | 
			
		||||
		local = "remote." ++ (Git.repoRemoteName r) ++ ".annex-" ++ key
 | 
			
		||||
		local = "remote." ++ Git.repoRemoteName r ++ ".annex-" ++ key
 | 
			
		||||
		global = "annex." ++ key
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
							
								
								
									
										18
									
								
								Utility.hs
									
										
									
									
									
								
							
							
						
						
									
										18
									
								
								Utility.hs
									
										
									
									
									
								
							| 
						 | 
				
			
			@ -35,12 +35,12 @@ hGetContentsStrict h  = hGetContents h >>= \s -> length s `seq` return s
 | 
			
		|||
{- Returns the parent directory of a path. Parent of / is "" -}
 | 
			
		||||
parentDir :: String -> String
 | 
			
		||||
parentDir dir =
 | 
			
		||||
	if (not $ null dirs)
 | 
			
		||||
	then slash ++ (join s $ take ((length dirs) - 1) dirs)
 | 
			
		||||
	if not $ null dirs
 | 
			
		||||
	then slash ++ join s (take (length dirs - 1) dirs)
 | 
			
		||||
	else ""
 | 
			
		||||
		where
 | 
			
		||||
			dirs = filter (\x -> not $ null x) $ split s dir
 | 
			
		||||
			slash = if (not $ isAbsolute dir) then "" else s
 | 
			
		||||
			dirs = filter (not . null) $ split s dir
 | 
			
		||||
			slash = if isAbsolute dir then s else ""
 | 
			
		||||
			s = [pathSeparator]
 | 
			
		||||
 | 
			
		||||
{- Constructs a relative path from the CWD to a directory.
 | 
			
		||||
| 
						 | 
				
			
			@ -58,7 +58,7 @@ relPathCwdToDir dir = do
 | 
			
		|||
	where
 | 
			
		||||
		-- absolute, normalized form of the directory
 | 
			
		||||
		absnorm cwd = 
 | 
			
		||||
			case (absNormPath cwd dir) of
 | 
			
		||||
			case absNormPath cwd dir of
 | 
			
		||||
				Just d -> d
 | 
			
		||||
				Nothing -> error $ "unable to normalize " ++ dir
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -70,7 +70,7 @@ relPathCwdToDir dir = do
 | 
			
		|||
 -}
 | 
			
		||||
relPathDirToDir :: FilePath -> FilePath -> FilePath
 | 
			
		||||
relPathDirToDir from to = 
 | 
			
		||||
	if (not $ null path)
 | 
			
		||||
	if not $ null path
 | 
			
		||||
		then addTrailingPathSeparator path
 | 
			
		||||
		else ""
 | 
			
		||||
	where
 | 
			
		||||
| 
						 | 
				
			
			@ -80,8 +80,8 @@ relPathDirToDir from to =
 | 
			
		|||
		common = map fst $ filter same $ zip pfrom pto
 | 
			
		||||
		same (c,d) = c == d
 | 
			
		||||
		uncommon = drop numcommon pto
 | 
			
		||||
		dotdots = take ((length pfrom) - numcommon) $ repeat ".."
 | 
			
		||||
		numcommon = length $ common
 | 
			
		||||
		dotdots = replicate (length pfrom - numcommon) ".."
 | 
			
		||||
		numcommon = length common
 | 
			
		||||
		path = join s $ dotdots ++ uncommon
 | 
			
		||||
 | 
			
		||||
{- Run a system command, and returns True or False
 | 
			
		||||
| 
						 | 
				
			
			@ -124,4 +124,4 @@ shellEscape f = "'" ++ escaped ++ "'"
 | 
			
		|||
unsetFileMode :: FilePath -> FileMode -> IO ()
 | 
			
		||||
unsetFileMode f m = do
 | 
			
		||||
	s <- getFileStatus f
 | 
			
		||||
	setFileMode f $ (fileMode s) `intersectFileModes` (complement m)
 | 
			
		||||
	setFileMode f $ fileMode s `intersectFileModes` complement m
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -25,13 +25,13 @@ getVersion :: Annex (Maybe String)
 | 
			
		|||
getVersion = do
 | 
			
		||||
	g <- Annex.gitRepo
 | 
			
		||||
	let v = Git.configGet g versionField ""
 | 
			
		||||
	if (not $ null v)
 | 
			
		||||
	if not $ null v
 | 
			
		||||
		then return $ Just v
 | 
			
		||||
		else do
 | 
			
		||||
			-- version 0 was not recorded in .git/config;
 | 
			
		||||
			-- such a repo should have an annexDir
 | 
			
		||||
			d <- liftIO $ doesDirectoryExist $ annexDir g
 | 
			
		||||
			if (d)
 | 
			
		||||
			if d
 | 
			
		||||
				then return $ Just "0"
 | 
			
		||||
				else return Nothing -- no version yet
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue