127 lines
4.2 KiB
Haskell
127 lines
4.2 KiB
Haskell
{- management of the git-annex journal
|
|
-
|
|
- The journal is used to queue up changes before they are committed to the
|
|
- git-annex branch. Among other things, it ensures that if git-annex is
|
|
- interrupted, its recorded data is not lost.
|
|
-
|
|
- Copyright 2011-2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Annex.Journal where
|
|
|
|
import System.IO.Binary
|
|
|
|
import Common.Annex
|
|
import Annex.Exception
|
|
import qualified Git
|
|
import Annex.Perms
|
|
|
|
#ifdef mingw32_HOST_OS
|
|
import Utility.WinLock
|
|
#endif
|
|
|
|
{- Records content for a file in the branch to the journal.
|
|
-
|
|
- Using the journal, rather than immediatly staging content to the index
|
|
- avoids git needing to rewrite the index after every change.
|
|
-
|
|
- The file in the journal is updated atomically, which allows
|
|
- getJournalFileStale to always return a consistent journal file
|
|
- content, although possibly not the most current one.
|
|
-}
|
|
setJournalFile :: JournalLocked -> FilePath -> String -> Annex ()
|
|
setJournalFile _jl file content = do
|
|
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 :: JournalLocked -> FilePath -> Annex (Maybe String)
|
|
getJournalFile _jl = getJournalFileStale
|
|
|
|
{- Without locking, this is not guaranteed to be the most recent
|
|
- version of the file in the journal, so should not be used as a basis for
|
|
- changes. -}
|
|
getJournalFileStale :: FilePath -> Annex (Maybe String)
|
|
getJournalFileStale file = inRepo $ \g -> catchMaybeIO $
|
|
readFileStrict $ journalFile file g
|
|
|
|
{- List of files that have updated content in the journal. -}
|
|
getJournalledFiles :: JournalLocked -> Annex [FilePath]
|
|
getJournalledFiles jl = map fileJournal <$> getJournalFiles jl
|
|
|
|
getJournalledFilesStale :: Annex [FilePath]
|
|
getJournalledFilesStale = map fileJournal <$> getJournalFilesStale
|
|
|
|
{- List of existing journal files. -}
|
|
getJournalFiles :: JournalLocked -> Annex [FilePath]
|
|
getJournalFiles _jl = getJournalFilesStale
|
|
|
|
{- List of existing journal files, but without locking, may miss new ones
|
|
- just being added, or may have false positives if the journal is staged
|
|
- as it is run. -}
|
|
getJournalFilesStale :: Annex [FilePath]
|
|
getJournalFilesStale = do
|
|
g <- gitRepo
|
|
fs <- liftIO $ catchDefaultIO [] $
|
|
getDirectoryContents $ gitAnnexJournalDir g
|
|
return $ filter (`notElem` [".", ".."]) fs
|
|
|
|
{- Checks if there are changes in the journal. -}
|
|
journalDirty :: Annex Bool
|
|
journalDirty = not . null <$> getJournalFilesStale
|
|
|
|
{- Produces a filename to use in the journal for a file on the branch.
|
|
-
|
|
- The journal typically won't have a lot of files in it, so the hashing
|
|
- used in the branch is not necessary, and all the files are put directly
|
|
- in the journal directory.
|
|
-}
|
|
journalFile :: FilePath -> Git.Repo -> FilePath
|
|
journalFile file repo = gitAnnexJournalDir repo </> concatMap mangle file
|
|
where
|
|
mangle c
|
|
| c == pathSeparator = "_"
|
|
| c == '_' = "__"
|
|
| otherwise = [c]
|
|
|
|
{- Converts a journal file (relative to the journal dir) back to the
|
|
- filename on the branch. -}
|
|
fileJournal :: FilePath -> FilePath
|
|
fileJournal = replace [pathSeparator, pathSeparator] "_" .
|
|
replace "_" [pathSeparator]
|
|
|
|
{- Sentinal value, only produced by lockJournal; required
|
|
- as a parameter by things that need to ensure the journal is
|
|
- locked. -}
|
|
data JournalLocked = ProduceJournalLocked
|
|
|
|
{- Runs an action that modifies the journal, using locking to avoid
|
|
- contention with other git-annex processes. -}
|
|
lockJournal :: (JournalLocked -> Annex a) -> Annex a
|
|
lockJournal a = do
|
|
lockfile <- fromRepo gitAnnexJournalLock
|
|
createAnnexDirectory $ takeDirectory lockfile
|
|
mode <- annexFileMode
|
|
bracketIO (lock lockfile mode) unlock (const $ a ProduceJournalLocked)
|
|
where
|
|
#ifndef mingw32_HOST_OS
|
|
lock lockfile mode = do
|
|
l <- noUmask mode $ createFile lockfile mode
|
|
waitToSetLock l (WriteLock, AbsoluteSeek, 0, 0)
|
|
return l
|
|
unlock = closeFd
|
|
#else
|
|
lock lockfile _mode = waitToLock $ lockExclusive lockfile
|
|
unlock = dropLock
|
|
#endif
|