git-annex/Remote/Helper/Git.hs

69 lines
2.1 KiB
Haskell
Raw Normal View History

{- Utilities for git remotes.
-
- Copyright 2011-2014 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Remote.Helper.Git where
import Annex.Common
import qualified Git
import qualified Git.GCrypt
import Types.Availability
import qualified Types.Remote as Remote
import qualified Utility.RawFilePath as R
import qualified Git.Config
import Data.Time.Clock.POSIX
import System.PosixCompat.Files (modificationTime)
repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl
localpathCalc :: Git.Repo -> Maybe FilePath
localpathCalc r
| not (Git.repoIsLocal r) && not (Git.repoIsLocalUnknown r) = Nothing
| otherwise = Just $ fromRawFilePath $ Git.repoPath r
{- Checks relatively inexpensively if a repository is available for use. -}
repoAvail :: Git.Repo -> Annex Availability
repoAvail r
| Git.repoIsHttp r = return GloballyAvailable
| Git.GCrypt.isEncrypted r = do
g <- gitRepo
liftIO $ do
er <- Git.GCrypt.encryptedRemote g r
if Git.repoIsLocal er || Git.repoIsLocalUnknown er
then checklocal er
else return GloballyAvailable
| Git.repoIsUrl r = return GloballyAvailable
| Git.repoIsLocalUnknown r = return Unavailable
| otherwise = checklocal r
where
checklocal r' = ifM (liftIO $ isJust <$> catchMaybeIO (Git.Config.read r'))
( return LocallyAvailable
, return Unavailable
)
{- Avoids performing an action on a local repository that's not usable.
- Does not check that the repository is still available on disk. -}
guardUsable :: Git.Repo -> Annex a -> Annex a -> Annex a
guardUsable r fallback a
| Git.repoIsLocalUnknown r = fallback
| otherwise = a
gitRepoInfo :: Remote -> Annex [(String, String)]
gitRepoInfo r = do
d <- fromRawFilePath <$> fromRepo Git.localGitDir
mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (toRawFilePath p))
fix empty tree import when directory does not exist Fix behavior when importing a tree from a directory remote when the directory does not exist. An empty tree was imported, rather than the import failing. Merging that tree would delete every file in the branch, if those files had been exported to the directory before. The problem was that dirContentsRecursive returned [] when the directory did not exist. Better for it to throw an exception. But in commit 74f0d67aa3988a71f3a53b88de4344272d924b95 back in 2012, I made it never theow exceptions, because exceptions throw inside unsafeInterleaveIO become untrappable when the list is being traversed. So, changed it to list the contents of the directory before entering unsafeInterleaveIO. So exceptions are thrown for the directory. But still not if it's unable to list the contents of a subdirectory. That's less of a problem, because the subdirectory does exist (or if not, it got removed after being listed, and it's ok to not include it in the list). A subdirectory that has permissions that don't allow listing it will have its contents omitted from the list still. (Might be better to have it return a type that includes indications of errors listing contents of subdirectories?) The rest of the changes are making callers of dirContentsRecursive use emptyWhenDoesNotExist when they relied on the behavior of it not throwing an exception when the directory does not exist. Note that it's possible some callers of dirContentsRecursive that used to ignore permissions problems listing a directory will now start throwing exceptions on them. The fix to the directory special remote consisted of not making its call in listImportableContentsM use emptyWhenDoesNotExist. So it will throw an exception as desired. Sponsored-by: Joshua Antonishen on Patreon
2023-08-15 16:57:41 +00:00
=<< emptyWhenDoesNotExist (dirContentsRecursive (d </> "refs" </> "remotes" </> Remote.name r))
let lastsynctime = case mtimes of
[] -> "never"
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes
repo <- Remote.getRepo r
return
[ ("repository location", Git.repoLocation repo)
, ("last synced", lastsynctime)
]