Support git's core.sharedRepository configuration

This is incomplete, it does not honor it yet for hash directories
and other annex bookkeeping files. Some of that is not needed for a bare
repo; some of it may be.
This commit is contained in:
Joey Hess 2012-04-21 14:06:36 -04:00
parent 10d3e91626
commit b4a5e39ee6
7 changed files with 155 additions and 52 deletions

View file

@ -23,10 +23,11 @@ module Annex.Content (
saveState,
downloadUrl,
preseedTmp,
freezeContent,
thawContent,
freezeContentDir,
) where
import Control.Exception (bracket_)
import System.Posix.Types
import System.IO.Unsafe (unsafeInterleaveIO)
import Common.Annex
@ -44,6 +45,7 @@ import Utility.DataUnits
import Utility.CopyFile
import Config
import Annex.Exception
import Git.SharedRepository
{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
@ -57,8 +59,10 @@ inAnnex' a key = do
{- A safer check; the key's content must not only be present, but
- is not in the process of being removed. -}
inAnnexSafe :: Key -> Annex (Maybe Bool)
inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check
inAnnexSafe = inAnnex' $ \f -> openforlock f >>= check
where
openforlock f = catchMaybeIO $
openFd f ReadOnly Nothing defaultFileFlags
check Nothing = return is_missing
check (Just h) = do
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
@ -75,30 +79,27 @@ inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check
lockContent :: Key -> Annex a -> Annex a
lockContent key a = do
file <- inRepo $ gitAnnexLocation key
bracketIO (openForLock file True >>= lock) unlock a
bracketIO (openforlock file >>= lock) unlock a
where
{- Since files are stored with the write bit disabled, have
- to fiddle with permissions to open for an exclusive lock. -}
openforlock f = catchMaybeIO $ ifM (doesFileExist f)
( withModifiedFileMode f
(\cur -> cur `unionFileModes` ownerWriteMode)
open
, open
)
where
open = openFd f ReadWrite Nothing defaultFileFlags
lock Nothing = return Nothing
lock (Just l) = do
v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
lock (Just fd) = do
v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of
Left _ -> error "content is locked"
Right _ -> return $ Just l
Right _ -> return $ Just fd
unlock Nothing = return ()
unlock (Just l) = closeFd l
openForLock :: FilePath -> Bool -> IO (Maybe Fd)
openForLock file writelock = bracket_ prep cleanup go
where
go = catchMaybeIO $ openFd file mode Nothing defaultFileFlags
mode = if writelock then ReadWrite else ReadOnly
{- Since files are stored with the write bit disabled,
- have to fiddle with permissions to open for an
- exclusive lock. -}
forwritelock a =
when writelock $ whenM (doesFileExist file) a
prep = forwritelock $ allowWrite file
cleanup = forwritelock $ preventWrite file
{- Calculates the relative path to use to link a file to a key. -}
calcGitLink :: FilePath -> Key -> Annex FilePath
calcGitLink file key = do
@ -132,7 +133,7 @@ getViaTmp key action = do
else return 0
ifM (checkDiskSpace Nothing key alreadythere)
( do
when e $ liftIO $ allowWrite tmp
when e $ thawContent tmp
getViaTmpUnchecked key action
, return False
)
@ -216,14 +217,15 @@ moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do
dest <- inRepo $ gitAnnexLocation key
let dir = parentDir dest
liftIO $ ifM (doesFileExist dest)
( removeFile src
ifM (liftIO $ doesFileExist dest)
( liftIO $ removeFile src
, do
createDirectoryIfMissing True dir
allowWrite dir -- in case the directory already exists
moveFile src dest
preventWrite dest
preventWrite dir
liftIO $ do
createDirectoryIfMissing True dir
allowWrite dir -- in case the directory already exists
moveFile src dest
freezeContent dest
freezeContentDir dest
)
withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
@ -254,10 +256,9 @@ removeAnnex key = withObjectLoc key $ \(dir, file) -> do
{- Moves a key's file out of .git/annex/objects/ -}
fromAnnex :: Key -> FilePath -> Annex ()
fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do
liftIO $ do
allowWrite dir
allowWrite file
moveFile file dest
liftIO $ allowWrite dir
thawContent file
liftIO $ moveFile file dest
cleanObjectLoc key
{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
@ -321,7 +322,7 @@ preseedTmp key file = go =<< inAnnex key
go False = return False
go True = do
ok <- copy
when ok $ liftIO $ allowWrite file
when ok $ thawContent file
return ok
copy = ifM (liftIO $ doesFileExist file)
( return True
@ -329,3 +330,40 @@ preseedTmp key file = go =<< inAnnex key
s <- inRepo $ gitAnnexLocation key
liftIO $ copyFileExternal s file
)
{- Blocks writing to an annexed file. The file is made unwritable
- to avoid accidental edits. core.sharedRepository may change
- who can read it. -}
freezeContent :: FilePath -> Annex ()
freezeContent file = liftIO . go =<< fromRepo getSharedRepository
where
go GroupShared = do
preventWrite file
groupRead file
go AllShared = do
preventWrite file
allRead file
go _ = preventWrite file
{- Allows writing to an annexed file that freezeContent was called on
- before. -}
thawContent :: FilePath -> Annex ()
thawContent file = liftIO . go =<< fromRepo getSharedRepository
where
go GroupShared = groupWriteRead file
go AllShared = groupWriteRead file
go _ = allowWrite file
{- Blocks writing to the directory an annexed file is in, to prevent the
- file accidentially being deleted. However, if core.sharedRepository
- is set, this is not done, since the group must be allowed to delete the
- file.
-}
freezeContentDir :: FilePath -> Annex ()
freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository
where
dir = parentDir file
go GroupShared = groupWriteRead dir
go AllShared = groupWriteRead dir
go _ = preventWrite dir