honor core.sharedRepository when making all the other files in the annex

Lock files, directories, etc.
This commit is contained in:
Joey Hess 2012-04-21 16:59:49 -04:00
parent 7e45712d19
commit b98b69e8c6
8 changed files with 119 additions and 33 deletions

View file

@ -36,6 +36,7 @@ import qualified Git.UnionMerge
import Git.HashObject
import qualified Git.Index
import Annex.CatFile
import Annex.Perms
{- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref
@ -308,6 +309,7 @@ setIndexSha :: Git.Ref -> Annex ()
setIndexSha ref = do
lock <- fromRepo gitAnnexIndexLock
liftIO $ writeFile lock $ show ref ++ "\n"
setAnnexPerm lock
{- Checks if there are uncommitted changes in the branch's index or journal. -}
unCommitted :: Annex Bool

View file

@ -46,6 +46,7 @@ import Utility.CopyFile
import Config
import Annex.Exception
import Git.SharedRepository
import Annex.Perms
{- Checks if a given key's content is currently present. -}
inAnnex :: Key -> Annex Bool
@ -141,7 +142,7 @@ getViaTmp key action = do
prepTmp :: Key -> Annex FilePath
prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpLocation key
liftIO $ createDirectoryIfMissing True (parentDir tmp)
createAnnexDirectory (parentDir tmp)
return tmp
{- Like getViaTmp, but does not check that there is enough disk space
@ -216,14 +217,11 @@ checkDiskSpace destination key alreadythere = do
moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do
dest <- inRepo $ gitAnnexLocation key
let dir = parentDir dest
ifM (liftIO $ doesFileExist dest)
( liftIO $ removeFile src
, do
liftIO $ do
createDirectoryIfMissing True dir
allowWrite dir -- in case the directory already exists
moveFile src dest
createContentDir dest
liftIO $ moveFile src dest
freezeContent dest
freezeContentDir dest
)
@ -268,8 +266,8 @@ moveBad key = do
src <- inRepo $ gitAnnexLocation key
bad <- fromRepo gitAnnexBadDir
let dest = bad </> takeFileName src
createAnnexDirectory (parentDir dest)
liftIO $ do
createDirectoryIfMissing True (parentDir dest)
allowWrite (parentDir src)
moveFile src dest
cleanObjectLoc key
@ -367,3 +365,13 @@ freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository
go AllShared = groupWriteRead dir
go _ = preventWrite dir
{- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -}
createContentDir :: FilePath -> Annex ()
createContentDir dest = do
unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
-- might have already existed with restricted perms
liftIO $ allowWrite dir
where
dir = parentDir dest

View file

@ -16,6 +16,7 @@ import System.IO.Binary
import Common.Annex
import Annex.Exception
import qualified Git
import Annex.Perms
{- Records content for a file in the branch to the journal.
-
@ -23,22 +24,20 @@ import qualified Git
- avoids git needing to rewrite the index after every change. -}
setJournalFile :: FilePath -> String -> Annex ()
setJournalFile file content = do
g <- gitRepo
liftIO $ doRedo (write g) $ do
createDirectoryIfMissing True $ gitAnnexJournalDir g
createDirectoryIfMissing True $ gitAnnexTmpDir g
where
-- journal file is written atomically
write g = do
let jfile = journalFile g file
let tmpfile = gitAnnexTmpDir g </> takeFileName jfile
writeBinaryFile tmpfile content
moveFile tmpfile jfile
createAnnexDirectory =<< fromRepo gitAnnexJournalDir
createAnnexDirectory =<< fromRepo gitAnnexTmpDir
-- journal file is written atomically
jfile <- fromRepo $ journalFile file
tmp <- fromRepo gitAnnexTmpDir
let tmpfile = tmp </> takeFileName jfile
liftIO $ do
writeBinaryFile tmpfile content
moveFile tmpfile jfile
{- Gets any journalled content for a file in the branch. -}
getJournalFile :: FilePath -> Annex (Maybe String)
getJournalFile file = inRepo $ \g -> catchMaybeIO $
readFileStrict $ journalFile g file
readFileStrict $ journalFile file g
{- List of files that have updated content in the journal. -}
getJournalledFiles :: Annex [FilePath]
@ -62,8 +61,8 @@ journalDirty = not . null <$> getJournalFiles
- used in the branch is not necessary, and all the files are put directly
- in the journal directory.
-}
journalFile :: Git.Repo -> FilePath -> FilePath
journalFile repo file = gitAnnexJournalDir repo </> concatMap mangle file
journalFile :: FilePath -> Git.Repo -> FilePath
journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
where
mangle '/' = "_"
mangle '_' = "__"
@ -79,16 +78,12 @@ fileJournal = replace "//" "_" . replace "_" "/"
lockJournal :: Annex a -> Annex a
lockJournal a = do
file <- fromRepo gitAnnexJournalLock
bracketIO (lock file) unlock a
createAnnexDirectory $ takeDirectory file
mode <- annexFileMode
bracketIO (lock file mode) unlock a
where
lock file = do
l <- doRedo (createFile file stdFileMode) $
createDirectoryIfMissing True $ takeDirectory file
lock file mode = do
l <- noUmask mode $ createFile file mode
waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
return l
unlock = closeFd
{- Runs an action, catching failure and running something to fix it up, and
- retrying if necessary. -}
doRedo :: IO a -> IO b -> IO a
doRedo a b = catchIO a $ const $ b >> a

View file

@ -12,6 +12,7 @@ import System.Posix.Types (Fd)
import Common.Annex
import Annex
import Annex.Perms
{- Create a specified lock file, and takes a shared lock. -}
lockFile :: FilePath -> Annex ()
@ -19,7 +20,9 @@ lockFile file = go =<< fromPool file
where
go (Just _) = return () -- already locked
go Nothing = do
fd <- liftIO $ openFd file ReadOnly (Just stdFileMode) defaultFileFlags
mode <- annexFileMode
fd <- liftIO $ noUmask mode $
openFd file ReadOnly (Just mode) defaultFileFlags
liftIO $ waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0)
changePool $ M.insert file fd

61
Annex/Perms.hs Normal file
View file

@ -0,0 +1,61 @@
{- git-annex file permissions
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Annex.Perms (
setAnnexPerm,
annexFileMode,
createAnnexDirectory,
noUmask,
) where
import Common.Annex
import Utility.FileMode
import Git.SharedRepository
import System.Posix.Types
{- Sets appropriate file mode for a file or directory in the annex,
- other than the content files and content directory. Normally,
- use the default mode, but with core.sharedRepository set,
- allow the group to write, etc. -}
setAnnexPerm :: FilePath -> Annex ()
setAnnexPerm file = liftIO . go =<< fromRepo getSharedRepository
where
go GroupShared = groupWriteRead file
go AllShared = modifyFileMode file $ addModes $
[ ownerWriteMode, groupWriteMode ] ++ readModes
go _ = return ()
{- Gets the appropriate mode to use for creating a file in the annex
- (other than content files, which are locked down more). -}
annexFileMode :: Annex FileMode
annexFileMode = go <$> fromRepo getSharedRepository
where
go GroupShared = sharedmode
go AllShared = combineModes (sharedmode:readModes)
go _ = stdFileMode
sharedmode = combineModes
[ ownerWriteMode, groupWriteMode
, ownerReadMode, groupReadMode
]
{- Creates a directory inside the gitAnnexDir, including any parent
- directories. Makes directories with appropriate permissions. -}
createAnnexDirectory :: FilePath -> Annex ()
createAnnexDirectory dir = traverse dir [] =<< top
where
top = parentDir <$> fromRepo gitAnnexDir
traverse d below stop
| d `equalFilePath` stop = done
| otherwise = ifM (liftIO $ doesDirectoryExist d)
( done
, traverse (parentDir d) (d:below) stop
)
where
done = forM_ below $ \p -> do
liftIO $ createDirectory p
setAnnexPerm p

View file

@ -17,6 +17,7 @@ import Annex.LockPool
import qualified Git
import Config
import qualified Build.SysConfig as SysConfig
import Annex.Perms
{- Generates parameters to ssh to a given host (or user@host) on a given
- port, with connection caching. -}
@ -74,7 +75,9 @@ sshCleanup = do
-- be stopped.
let lockfile = socket2lock socketfile
unlockFile lockfile
fd <- liftIO $ openFd lockfile ReadWrite (Just stdFileMode) defaultFileFlags
mode <- annexFileMode
fd <- liftIO $ noUmask mode $
openFd lockfile ReadWrite (Just mode) defaultFileFlags
v <- liftIO $ tryIO $
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of

View file

@ -14,6 +14,7 @@ import Types.Remote
import qualified Annex
import Annex.LockPool
import Config
import Annex.Perms
{- Modifies a remote's access functions to first run the
- annex-start-command hook, and trigger annex-stop-command on shutdown.
@ -75,7 +76,9 @@ runHooks r starthook stophook a = do
-- succeeds, we're the only process using this remote,
-- so can stop it.
unlockFile lck
fd <- liftIO $ openFd lck ReadWrite (Just stdFileMode) defaultFileFlags
mode <- annexFileMode
fd <- liftIO $ noUmask mode $
openFd lck ReadWrite (Just mode) defaultFileFlags
v <- liftIO $ tryIO $
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
case v of

View file

@ -75,6 +75,17 @@ isExecutable mode = combineModes ebits `intersectFileModes` mode /= 0
where
ebits = [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
{- Runs an action without that pesky umask influencing it, unless the
- passed FileMode is the standard one. -}
noUmask :: FileMode -> IO a -> IO a
noUmask mode a
| mode == stdFileMode = a
| otherwise = bracket setup cleanup go
where
setup = setFileCreationMask nullFileMode
cleanup = setFileCreationMask
go _ = a
combineModes :: [FileMode] -> FileMode
combineModes [] = undefined
combineModes [m] = m