summaryrefslogtreecommitdiff
path: root/Annex
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@debian.org>2014-04-02 21:42:53 +0100
committerGravatar Joey Hess <joeyh@debian.org>2014-04-02 21:42:53 +0100
commit6da7cdf0fbf26f1faf7d5710e6ed488f1a4e9589 (patch)
tree7a903e2eca579335b7ce73d0220854e7a25c3bb9 /Annex
git-annex (5.20140402) unstable; urgency=medium
* unannex, uninit: Avoid committing after every file is unannexed, for massive speedup. * --notify-finish switch will cause desktop notifications after each file upload/download/drop completes (using the dbus Desktop Notifications Specification) * --notify-start switch will show desktop notifications when each file upload/download starts. * webapp: Automatically install Nautilus integration scripts to get and drop files. * tahoe: Pass -d parameter before subcommand; putting it after the subcommand no longer works with tahoe-lafs version 1.10. (Thanks, Alberto Berti) * forget --drop-dead: Avoid removing the dead remote from the trust.log, so that if git remotes for it still exist anywhere, git annex info will still know it's dead and not show it. * git-annex-shell: Make configlist automatically initialize a remote git repository, as long as a git-annex branch has been pushed to it, to simplify setup of remote git repositories, including via gitolite. * add --include-dotfiles: New option, perhaps useful for backups. * Version 5.20140227 broke creation of glacier repositories, not including the datacenter and vault in their configuration. This bug is fixed, but glacier repositories set up with the broken version of git-annex need to have the datacenter and vault set in order to be usable. This can be done using git annex enableremote to add the missing settings. For details, see http://git-annex.branchable.com/bugs/problems_with_glacier/ * Added required content configuration. * assistant: Improve ssh authorized keys line generated in local pairing or for a remote ssh server to set environment variables in an alternative way that works with the non-POSIX fish shell, as well as POSIX shells. # imported from the archive
Diffstat (limited to 'Annex')
-rw-r--r--Annex/AutoMerge.hs179
-rw-r--r--Annex/Branch.hs516
-rw-r--r--Annex/Branch/Transitions.hs60
-rw-r--r--Annex/BranchState.hs43
-rw-r--r--Annex/CatFile.hs144
-rw-r--r--Annex/CheckAttr.hs35
-rw-r--r--Annex/CheckIgnore.hs32
-rw-r--r--Annex/Content.hs624
-rw-r--r--Annex/Content/Direct.hs256
-rw-r--r--Annex/Direct.hs373
-rw-r--r--Annex/Direct/Fixup.hs31
-rw-r--r--Annex/Drop.hs124
-rw-r--r--Annex/Environment.hs65
-rw-r--r--Annex/Exception.hs50
-rw-r--r--Annex/FileMatcher.hs116
-rw-r--r--Annex/Hook.hs71
-rw-r--r--Annex/Index.hs46
-rw-r--r--Annex/Init.hs239
-rw-r--r--Annex/Journal.hs127
-rw-r--r--Annex/Link.hs105
-rw-r--r--Annex/LockPool.hs60
-rw-r--r--Annex/MetaData.hs56
-rw-r--r--Annex/MetaData/StandardFields.hs47
-rw-r--r--Annex/Notification.hs81
-rw-r--r--Annex/Path.hs34
-rw-r--r--Annex/Perms.hs125
-rw-r--r--Annex/Queue.hs62
-rw-r--r--Annex/Quvi.hs33
-rw-r--r--Annex/ReplaceFile.hs39
-rw-r--r--Annex/Ssh.hs201
-rw-r--r--Annex/TaggedPush.hs61
-rw-r--r--Annex/Transfer.hs131
-rw-r--r--Annex/UUID.hs96
-rw-r--r--Annex/Url.hs42
-rw-r--r--Annex/VariantFile.hs45
-rw-r--r--Annex/Version.hs41
-rw-r--r--Annex/View.hs448
-rw-r--r--Annex/View/ViewedFile.hs75
-rw-r--r--Annex/Wanted.hs29
39 files changed, 4942 insertions, 0 deletions
diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs
new file mode 100644
index 000000000..2ed26b78f
--- /dev/null
+++ b/Annex/AutoMerge.hs
@@ -0,0 +1,179 @@
+{- git-annex automatic merge conflict resolution
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.AutoMerge (autoMergeFrom) where
+
+import Common.Annex
+import qualified Annex.Queue
+import Annex.Direct
+import Annex.CatFile
+import Annex.Link
+import qualified Git.Command
+import qualified Git.LsFiles as LsFiles
+import qualified Git.UpdateIndex as UpdateIndex
+import qualified Git.Merge
+import qualified Git.Ref
+import qualified Git.Sha
+import qualified Git
+import Git.Types (BlobType(..))
+import Config
+import Annex.ReplaceFile
+import Git.FileMode
+import Annex.VariantFile
+
+import qualified Data.Set as S
+
+{- Merges from a branch into the current branch
+ - (which may not exist yet),
+ - with automatic merge conflict resolution. -}
+autoMergeFrom :: Git.Ref -> (Maybe Git.Ref) -> Annex Bool
+autoMergeFrom branch currbranch = do
+ showOutput
+ case currbranch of
+ Nothing -> go Nothing
+ Just b -> go =<< inRepo (Git.Ref.sha b)
+ where
+ go old = ifM isDirect
+ ( do
+ d <- fromRepo gitAnnexMergeDir
+ r <- inRepo (mergeDirect d branch)
+ <||> resolveMerge old branch
+ mergeDirectCleanup d (fromMaybe Git.Sha.emptyTree old) Git.Ref.headRef
+ return r
+ , inRepo (Git.Merge.mergeNonInteractive branch)
+ <||> resolveMerge old branch
+ )
+
+{- Resolves a conflicted merge. It's important that any conflicts be
+ - resolved in a way that itself avoids later merge conflicts, since
+ - multiple repositories may be doing this concurrently.
+ -
+ - Only merge conflicts where at least one side is an annexed file
+ - is resolved.
+ -
+ - This uses the Keys pointed to by the files to construct new
+ - filenames. So when both sides modified annexed file foo,
+ - it will be deleted, and replaced with files foo.variant-A and
+ - foo.variant-B.
+ -
+ - On the other hand, when one side deleted foo, and the other modified it,
+ - it will be deleted, and the modified version stored as file
+ - foo.variant-A (or B).
+ -
+ - It's also possible that one side has foo as an annexed file, and
+ - the other as a directory or non-annexed file. The annexed file
+ - is renamed to resolve the merge, and the other object is preserved as-is.
+ -
+ - In indirect mode, the merge is resolved in the work tree and files
+ - staged, to clean up from a conflicted merge that was run in the work
+ - tree. In direct mode, the work tree is not touched here; files are
+ - staged to the index, and written to the gitAnnexMergeDir, and later
+ - mergeDirectCleanup handles updating the work tree.
+ -}
+resolveMerge :: Maybe Git.Ref -> Git.Ref -> Annex Bool
+resolveMerge us them = do
+ top <- fromRepo Git.repoPath
+ (fs, cleanup) <- inRepo (LsFiles.unmerged [top])
+ mergedfs <- catMaybes <$> mapM (resolveMerge' us them) fs
+ let merged = not (null mergedfs)
+ void $ liftIO cleanup
+
+ unlessM isDirect $ do
+ (deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
+ unless (null deleted) $
+ Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted
+ void $ liftIO cleanup2
+
+ when merged $ do
+ unlessM isDirect $
+ cleanConflictCruft mergedfs top
+ Annex.Queue.flush
+ whenM isDirect $
+ void preCommitDirect
+ void $ inRepo $ Git.Command.runBool
+ [ Param "commit"
+ , Param "--no-verify"
+ , Param "-m"
+ , Param "git-annex automatic merge conflict fix"
+ ]
+ showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
+ return merged
+
+resolveMerge' :: Maybe Git.Ref -> Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath)
+resolveMerge' Nothing _ _ = return Nothing
+resolveMerge' (Just us) them u = do
+ kus <- getkey LsFiles.valUs LsFiles.valUs
+ kthem <- getkey LsFiles.valThem LsFiles.valThem
+ case (kus, kthem) of
+ -- Both sides of conflict are annexed files
+ (Just keyUs, Just keyThem)
+ | keyUs /= keyThem -> resolveby $ do
+ makelink keyUs
+ makelink keyThem
+ | otherwise -> resolveby $
+ makelink keyUs
+ -- Our side is annexed file, other side is not.
+ (Just keyUs, Nothing) -> resolveby $ do
+ graftin them file
+ makelink keyUs
+ -- Our side is not annexed file, other side is.
+ (Nothing, Just keyThem) -> resolveby $ do
+ graftin us file
+ makelink keyThem
+ -- Neither side is annexed file; cannot resolve.
+ (Nothing, Nothing) -> return Nothing
+ where
+ file = LsFiles.unmergedFile u
+
+ getkey select select'
+ | select (LsFiles.unmergedBlobType u) == Just SymlinkBlob =
+ case select' (LsFiles.unmergedSha u) of
+ Nothing -> return Nothing
+ Just sha -> catKey sha symLinkMode
+ | otherwise = return Nothing
+
+ makelink key = do
+ let dest = variantFile file key
+ l <- inRepo $ gitAnnexLink dest key
+ ifM isDirect
+ ( do
+ d <- fromRepo gitAnnexMergeDir
+ replaceFile (d </> dest) $ makeAnnexLink l
+ , replaceFile dest $ makeAnnexLink l
+ )
+ stageSymlink dest =<< hashSymlink l
+
+ {- stage a graft of a directory or file from a branch -}
+ graftin b item = Annex.Queue.addUpdateIndex
+ =<< fromRepo (UpdateIndex.lsSubTree b item)
+
+ resolveby a = do
+ {- Remove conflicted file from index so merge can be resolved. -}
+ Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file]
+ void a
+ return (Just file)
+
+{- git-merge moves conflicting files away to files
+ - named something like f~HEAD or f~branch, but the
+ - exact name chosen can vary. Once the conflict is resolved,
+ - this cruft can be deleted. To avoid deleting legitimate
+ - files that look like this, only delete files that are
+ - A) not staged in git and B) look like git-annex symlinks.
+ -}
+cleanConflictCruft :: [FilePath] -> FilePath -> Annex ()
+cleanConflictCruft resolvedfs top = do
+ (fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top]
+ mapM_ clean fs
+ void $ liftIO cleanup
+ where
+ clean f
+ | matchesresolved f = whenM (isJust <$> isAnnexLink f) $
+ liftIO $ nukeFile f
+ | otherwise = noop
+ s = S.fromList resolvedfs
+ matchesresolved f = S.member (base f) s
+ base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
new file mode 100644
index 000000000..94c4c029c
--- /dev/null
+++ b/Annex/Branch.hs
@@ -0,0 +1,516 @@
+{- management of the git-annex branch
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch (
+ fullname,
+ name,
+ hasOrigin,
+ hasSibling,
+ siblingBranches,
+ create,
+ update,
+ forceUpdate,
+ updateTo,
+ get,
+ getHistorical,
+ change,
+ commit,
+ forceCommit,
+ files,
+ withIndex,
+ performTransitions,
+) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+import Common.Annex
+import Annex.BranchState
+import Annex.Journal
+import Annex.Index
+import qualified Git
+import qualified Git.Command
+import qualified Git.Ref
+import qualified Git.Sha
+import qualified Git.Branch
+import qualified Git.UnionMerge
+import qualified Git.UpdateIndex
+import Git.HashObject
+import Git.Types
+import Git.FilePath
+import Annex.CatFile
+import Annex.Perms
+import Logs
+import Logs.Transitions
+import Logs.Trust.Pure
+import Annex.ReplaceFile
+import qualified Annex.Queue
+import Annex.Branch.Transitions
+
+{- Name of the branch that is used to store git-annex's information. -}
+name :: Git.Ref
+name = Git.Ref "git-annex"
+
+{- Fully qualified name of the branch. -}
+fullname :: Git.Ref
+fullname = Git.Ref $ "refs/heads/" ++ fromRef name
+
+{- Branch's name in origin. -}
+originname :: Git.Ref
+originname = Git.Ref $ "origin/" ++ fromRef name
+
+{- Does origin/git-annex exist? -}
+hasOrigin :: Annex Bool
+hasOrigin = inRepo $ Git.Ref.exists originname
+
+{- Does the git-annex branch or a sibling foo/git-annex branch exist? -}
+hasSibling :: Annex Bool
+hasSibling = not . null <$> siblingBranches
+
+{- List of git-annex (refs, branches), including the main one and any
+ - from remotes. Duplicate refs are filtered out. -}
+siblingBranches :: Annex [(Git.Ref, Git.Branch)]
+siblingBranches = inRepo $ Git.Ref.matchingUniq [name]
+
+{- Creates the branch, if it does not already exist. -}
+create :: Annex ()
+create = void getBranch
+
+{- Returns the ref of the branch, creating it first if necessary. -}
+getBranch :: Annex Git.Ref
+getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
+ where
+ go True = do
+ inRepo $ Git.Command.run
+ [Param "branch", Param $ fromRef name, Param $ fromRef originname]
+ fromMaybe (error $ "failed to create " ++ fromRef name)
+ <$> branchsha
+ go False = withIndex' True $
+ inRepo $ Git.Branch.commitAlways "branch created" fullname []
+ use sha = do
+ setIndexSha sha
+ return sha
+ branchsha = inRepo $ Git.Ref.sha fullname
+
+{- Ensures that the branch and index are up-to-date; should be
+ - called before data is read from it. Runs only once per git-annex run. -}
+update :: Annex ()
+update = runUpdateOnce $ void $ updateTo =<< siblingBranches
+
+{- Forces an update even if one has already been run. -}
+forceUpdate :: Annex Bool
+forceUpdate = updateTo =<< siblingBranches
+
+{- Merges the specified Refs into the index, if they have any changes not
+ - already in it. The Branch names are only used in the commit message;
+ - it's even possible that the provided Branches have not been updated to
+ - point to the Refs yet.
+ -
+ - The branch is fast-forwarded if possible, otherwise a merge commit is
+ - made.
+ -
+ - Before Refs are merged into the index, it's important to first stage the
+ - journal into the index. Otherwise, any changes in the journal would
+ - later get staged, and might overwrite changes made during the merge.
+ - This is only done if some of the Refs do need to be merged.
+ -
+ - Also handles performing any Transitions that have not yet been
+ - performed, in either the local branch, or the Refs.
+ -
+ - Returns True if any refs were merged in, False otherwise.
+ -}
+updateTo :: [(Git.Ref, Git.Branch)] -> Annex Bool
+updateTo pairs = do
+ -- ensure branch exists, and get its current ref
+ branchref <- getBranch
+ dirty <- journalDirty
+ ignoredrefs <- getIgnoredRefs
+ (refs, branches) <- unzip <$> filterM (isnewer ignoredrefs) pairs
+ if null refs
+ {- Even when no refs need to be merged, the index
+ - may still be updated if the branch has gotten ahead
+ - of the index. -}
+ then whenM (needUpdateIndex branchref) $ lockJournal $ \jl -> do
+ forceUpdateIndex jl branchref
+ {- When there are journalled changes
+ - as well as the branch being updated,
+ - a commit needs to be done. -}
+ when dirty $
+ go branchref True [] [] jl
+ else lockJournal $ go branchref dirty refs branches
+ return $ not $ null refs
+ where
+ isnewer ignoredrefs (r, _)
+ | S.member r ignoredrefs = return False
+ | otherwise = inRepo $ Git.Branch.changed fullname r
+ go branchref dirty refs branches jl = withIndex $ do
+ cleanjournal <- if dirty then stageJournal jl else return noop
+ let merge_desc = if null branches
+ then "update"
+ else "merging " ++
+ unwords (map Git.Ref.describe branches) ++
+ " into " ++ fromRef name
+ localtransitions <- parseTransitionsStrictly "local"
+ <$> getLocal transitionsLog
+ unless (null branches) $ do
+ showSideAction merge_desc
+ mergeIndex jl refs
+ let commitrefs = nub $ fullname:refs
+ unlessM (handleTransitions jl localtransitions commitrefs) $ do
+ ff <- if dirty
+ then return False
+ else inRepo $ Git.Branch.fastForward fullname refs
+ if ff
+ then updateIndex jl branchref
+ else commitIndex jl branchref merge_desc commitrefs
+ liftIO cleanjournal
+
+{- Gets the content of a file, which may be in the journal, or in the index
+ - (and committed to the branch).
+ -
+ - Updates the branch if necessary, to ensure the most up-to-date available
+ - content is returned.
+ -
+ - Returns an empty string if the file doesn't exist yet. -}
+get :: FilePath -> Annex String
+get file = do
+ update
+ getLocal file
+
+{- Like get, but does not merge the branch, so the info returned may not
+ - reflect changes in remotes.
+ - (Changing the value this returns, and then merging is always the
+ - same as using get, and then changing its value.) -}
+getLocal :: FilePath -> Annex String
+getLocal file = go =<< getJournalFileStale file
+ where
+ go (Just journalcontent) = return journalcontent
+ go Nothing = getRaw file
+
+getRaw :: FilePath -> Annex String
+getRaw = getRef fullname
+
+getHistorical :: RefDate -> FilePath -> Annex String
+getHistorical date = getRef (Git.Ref.dateRef fullname date)
+
+getRef :: Ref -> FilePath -> Annex String
+getRef ref file = withIndex $ L.unpack <$> catFile ref file
+
+{- Applies a function to modifiy the content of a file.
+ -
+ - Note that this does not cause the branch to be merged, it only
+ - modifes the current content of the file on the branch.
+ -}
+change :: FilePath -> (String -> String) -> Annex ()
+change file a = lockJournal $ \jl -> a <$> getLocal file >>= set jl file
+
+{- Records new content of a file into the journal -}
+set :: JournalLocked -> FilePath -> String -> Annex ()
+set = setJournalFile
+
+{- Stages the journal, and commits staged changes to the branch. -}
+commit :: String -> Annex ()
+commit = whenM journalDirty . forceCommit
+
+{- Commits the current index to the branch even without any journalleda
+ - changes. -}
+forceCommit :: String -> Annex ()
+forceCommit message = lockJournal $ \jl -> do
+ cleanjournal <- stageJournal jl
+ ref <- getBranch
+ withIndex $ commitIndex jl ref message [fullname]
+ liftIO cleanjournal
+
+{- Commits the staged changes in the index to the branch.
+ -
+ - Ensures that the branch's index file is first updated to the state
+ - of the branch at branchref, before running the commit action. This
+ - is needed because the branch may have had changes pushed to it, that
+ - are not yet reflected in the index.
+ -
+ - Also safely handles a race that can occur if a change is being pushed
+ - into the branch at the same time. When the race happens, the commit will
+ - be made on top of the newly pushed change, but without the index file
+ - being updated to include it. The result is that the newly pushed
+ - change is reverted. This race is detected and another commit made
+ - to fix it.
+ -
+ - The branchref value can have been obtained using getBranch at any
+ - previous point, though getting it a long time ago makes the race
+ - more likely to occur.
+ -}
+commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex jl branchref message parents = do
+ showStoringStateAction
+ commitIndex' jl branchref message parents
+commitIndex' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex' jl branchref message parents = do
+ updateIndex jl branchref
+ committedref <- inRepo $ Git.Branch.commitAlways message fullname parents
+ setIndexSha committedref
+ parentrefs <- commitparents <$> catObject committedref
+ when (racedetected branchref parentrefs) $
+ fixrace committedref parentrefs
+ where
+ -- look for "parent ref" lines and return the refs
+ commitparents = map (Git.Ref . snd) . filter isparent .
+ map (toassoc . L.unpack) . L.lines
+ toassoc = separate (== ' ')
+ isparent (k,_) = k == "parent"
+
+ {- The race can be detected by checking the commit's
+ - parent, which will be the newly pushed branch,
+ - instead of the expected ref that the index was updated to. -}
+ racedetected expectedref parentrefs
+ | expectedref `elem` parentrefs = False -- good parent
+ | otherwise = True -- race!
+
+ {- To recover from the race, union merge the lost refs
+ - into the index, and recommit on top of the bad commit. -}
+ fixrace committedref lostrefs = do
+ mergeIndex jl lostrefs
+ commitIndex jl committedref racemessage [committedref]
+
+ racemessage = message ++ " (recovery from race)"
+
+{- Lists all files on the branch. There may be duplicates in the list. -}
+files :: Annex [FilePath]
+files = do
+ update
+ (++)
+ <$> branchFiles
+ <*> getJournalledFilesStale
+
+{- Files in the branch, not including any from journalled changes,
+ - and without updating the branch. -}
+branchFiles :: Annex [FilePath]
+branchFiles = withIndex $ inRepo $ Git.Command.pipeNullSplitZombie
+ [ Params "ls-tree --name-only -r -z"
+ , Param $ fromRef fullname
+ ]
+
+{- Populates the branch's index file with the current branch contents.
+ -
+ - This is only done when the index doesn't yet exist, and the index
+ - is used to build up changes to be commited to the branch, and merge
+ - in changes from other branches.
+ -}
+genIndex :: Git.Repo -> IO ()
+genIndex g = Git.UpdateIndex.streamUpdateIndex g
+ [Git.UpdateIndex.lsTree fullname g]
+
+{- Merges the specified refs into the index.
+ - Any changes staged in the index will be preserved. -}
+mergeIndex :: JournalLocked -> [Git.Ref] -> Annex ()
+mergeIndex jl branches = do
+ prepareModifyIndex jl
+ h <- catFileHandle
+ inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches
+
+{- Removes any stale git lock file, to avoid git falling over when
+ - updating the index.
+ -
+ - Since all modifications of the index are performed inside this module,
+ - and only when the journal is locked, the fact that the journal has to be
+ - locked when this is called ensures that no other process is currently
+ - modifying the index. So any index.lock file must be stale, caused
+ - by git running when the system crashed, or the repository's disk was
+ - removed, etc.
+ -}
+prepareModifyIndex :: JournalLocked -> Annex ()
+prepareModifyIndex _jl = do
+ index <- fromRepo gitAnnexIndex
+ void $ liftIO $ tryIO $ removeFile $ index ++ ".lock"
+
+{- Runs an action using the branch's index file. -}
+withIndex :: Annex a -> Annex a
+withIndex = withIndex' False
+withIndex' :: Bool -> Annex a -> Annex a
+withIndex' bootstrapping a = do
+ f <- fromRepo gitAnnexIndex
+ withIndexFile f $ do
+ checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
+ unless bootstrapping create
+ createAnnexDirectory $ takeDirectory f
+ unless bootstrapping $ inRepo genIndex
+ a
+
+{- Updates the branch's index to reflect the current contents of the branch.
+ - Any changes staged in the index will be preserved.
+ -
+ - Compares the ref stored in the lock file with the current
+ - ref of the branch to see if an update is needed.
+ -}
+updateIndex :: JournalLocked -> Git.Ref -> Annex ()
+updateIndex jl branchref = whenM (needUpdateIndex branchref) $
+ forceUpdateIndex jl branchref
+
+forceUpdateIndex :: JournalLocked -> Git.Ref -> Annex ()
+forceUpdateIndex jl branchref = do
+ withIndex $ mergeIndex jl [fullname]
+ setIndexSha branchref
+
+{- Checks if the index needs to be updated. -}
+needUpdateIndex :: Git.Ref -> Annex Bool
+needUpdateIndex branchref = do
+ f <- fromRepo gitAnnexIndexStatus
+ committedref <- Git.Ref . firstLine <$>
+ liftIO (catchDefaultIO "" $ readFileStrict f)
+ return (committedref /= branchref)
+
+{- Record that the branch's index has been updated to correspond to a
+ - given ref of the branch. -}
+setIndexSha :: Git.Ref -> Annex ()
+setIndexSha ref = do
+ f <- fromRepo gitAnnexIndexStatus
+ liftIO $ writeFile f $ fromRef ref ++ "\n"
+ setAnnexFilePerm f
+
+{- Stages the journal into the index and returns an action that will
+ - clean up the staged journal files, which should only be run once
+ - the index has been committed to the branch.
+ -
+ - Before staging, this removes any existing git index file lock.
+ - This is safe to do because stageJournal is the only thing that
+ - modifies this index file, and only one can run at a time, because
+ - the journal is locked. So any existing git index file lock must be
+ - stale, and the journal must contain any data that was in the process
+ - of being written to the index file when it crashed.
+ -}
+stageJournal :: JournalLocked -> Annex (IO ())
+stageJournal jl = withIndex $ do
+ prepareModifyIndex jl
+ g <- gitRepo
+ let dir = gitAnnexJournalDir g
+ fs <- getJournalFiles jl
+ liftIO $ do
+ h <- hashObjectStart g
+ Git.UpdateIndex.streamUpdateIndex g
+ [genstream dir h fs]
+ hashObjectStop h
+ return $ liftIO $ mapM_ (removeFile . (dir </>)) fs
+ where
+ genstream dir h fs streamer = forM_ fs $ \file -> do
+ let path = dir </> file
+ sha <- hashFile h path
+ streamer $ Git.UpdateIndex.updateIndexLine
+ sha FileBlob (asTopFilePath $ fileJournal file)
+
+{- This is run after the refs have been merged into the index,
+ - but before the result is committed to the branch.
+ - (Which is why it's passed the contents of the local branches's
+ - transition log before that merge took place.)
+ -
+ - When the refs contain transitions that have not yet been done locally,
+ - the transitions are performed on the index, and a new branch
+ - is created from the result.
+ -
+ - When there are transitions recorded locally that have not been done
+ - to the remote refs, the transitions are performed in the index,
+ - and committed to the existing branch. In this case, the untransitioned
+ - remote refs cannot be merged into the branch (since transitions
+ - throw away history), so they are added to the list of refs to ignore,
+ - to avoid re-merging content from them again.
+ -}
+handleTransitions :: JournalLocked -> Transitions -> [Git.Ref] -> Annex Bool
+handleTransitions jl localts refs = do
+ m <- M.fromList <$> mapM getreftransition refs
+ let remotets = M.elems m
+ if all (localts ==) remotets
+ then return False
+ else do
+ let allts = combineTransitions (localts:remotets)
+ let (transitionedrefs, untransitionedrefs) =
+ partition (\r -> M.lookup r m == Just allts) refs
+ performTransitionsLocked jl allts (localts /= allts) transitionedrefs
+ ignoreRefs untransitionedrefs
+ return True
+ where
+ getreftransition ref = do
+ ts <- parseTransitionsStrictly "remote" . L.unpack
+ <$> catFile ref transitionsLog
+ return (ref, ts)
+
+ignoreRefs :: [Git.Ref] -> Annex ()
+ignoreRefs rs = do
+ old <- getIgnoredRefs
+ let s = S.unions [old, S.fromList rs]
+ f <- fromRepo gitAnnexIgnoredRefs
+ replaceFile f $ \tmp -> liftIO $ writeFile tmp $
+ unlines $ map fromRef $ S.elems s
+
+getIgnoredRefs :: Annex (S.Set Git.Ref)
+getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
+ where
+ content = do
+ f <- fromRepo gitAnnexIgnoredRefs
+ liftIO $ catchDefaultIO "" $ readFile f
+
+{- Performs the specified transitions on the contents of the index file,
+ - commits it to the branch, or creates a new branch.
+ -}
+performTransitions :: Transitions -> Bool -> [Ref] -> Annex ()
+performTransitions ts neednewlocalbranch transitionedrefs = lockJournal $ \jl ->
+ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs
+performTransitionsLocked :: JournalLocked -> Transitions -> Bool -> [Ref] -> Annex ()
+performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
+ -- For simplicity & speed, we're going to use the Annex.Queue to
+ -- update the git-annex branch, while it usually holds changes
+ -- for the head branch. Flush any such changes.
+ Annex.Queue.flush
+ withIndex $ do
+ prepareModifyIndex jl
+ run $ mapMaybe getTransitionCalculator $ transitionList ts
+ Annex.Queue.flush
+ if neednewlocalbranch
+ then do
+ committedref <- inRepo $ Git.Branch.commitAlways message fullname transitionedrefs
+ setIndexSha committedref
+ else do
+ ref <- getBranch
+ commitIndex jl ref message (nub $ fullname:transitionedrefs)
+ where
+ message
+ | neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc
+ | otherwise = "continuing transition " ++ tdesc
+ tdesc = show $ map describeTransition $ transitionList ts
+
+ {- The changes to make to the branch are calculated and applied to
+ - the branch directly, rather than going through the journal,
+ - which would be innefficient. (And the journal is not designed
+ - to hold changes to every file in the branch at once.)
+ -
+ - When a file in the branch is changed by transition code,
+ - that value is remembered and fed into the code for subsequent
+ - transitions.
+ -}
+ run [] = noop
+ run changers = do
+ trustmap <- calcTrustMap <$> getRaw trustLog
+ fs <- branchFiles
+ hasher <- inRepo hashObjectStart
+ forM_ fs $ \f -> do
+ content <- getRaw f
+ apply changers hasher f content trustmap
+ liftIO $ hashObjectStop hasher
+ apply [] _ _ _ _ = return ()
+ apply (changer:rest) hasher file content trustmap =
+ case changer file content trustmap of
+ RemoveFile -> do
+ Annex.Queue.addUpdateIndex
+ =<< inRepo (Git.UpdateIndex.unstageFile file)
+ -- File is deleted; can't run any other
+ -- transitions on it.
+ return ()
+ ChangeFile content' -> do
+ sha <- inRepo $ hashObject BlobObject content'
+ Annex.Queue.addUpdateIndex $ Git.UpdateIndex.pureStreamer $
+ Git.UpdateIndex.updateIndexLine sha FileBlob (asTopFilePath file)
+ apply rest hasher file content' trustmap
+ PreserveFile ->
+ apply rest hasher file content trustmap
diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs
new file mode 100644
index 000000000..5c2c14548
--- /dev/null
+++ b/Annex/Branch/Transitions.hs
@@ -0,0 +1,60 @@
+{- git-annex branch transitions
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Branch.Transitions (
+ FileTransition(..),
+ getTransitionCalculator
+) where
+
+import Logs
+import Logs.Transitions
+import Logs.UUIDBased as UUIDBased
+import Logs.Presence.Pure as Presence
+import Types.TrustLevel
+import Types.UUID
+
+import qualified Data.Map as M
+
+data FileTransition
+ = ChangeFile String
+ | RemoveFile
+ | PreserveFile
+
+type TransitionCalculator = FilePath -> String -> TrustMap -> FileTransition
+
+getTransitionCalculator :: Transition -> Maybe TransitionCalculator
+getTransitionCalculator ForgetGitHistory = Nothing
+getTransitionCalculator ForgetDeadRemotes = Just dropDead
+
+dropDead :: FilePath -> String -> TrustMap -> FileTransition
+dropDead f content trustmap = case getLogVariety f of
+ Just UUIDBasedLog
+ -- Don't remove the dead repo from the trust log,
+ -- because git remotes may still exist, and they need
+ -- to still know it's dead.
+ | f == trustLog -> PreserveFile
+ | otherwise -> ChangeFile $ UUIDBased.showLog id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLog Just content
+ Just NewUUIDBasedLog -> ChangeFile $
+ UUIDBased.showLogNew id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLogNew Just content
+ Just (PresenceLog _) ->
+ let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content
+ in if null newlog
+ then RemoveFile
+ else ChangeFile $ Presence.showLog newlog
+ Just OtherLog -> PreserveFile
+ Nothing -> PreserveFile
+
+dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String
+dropDeadFromUUIDBasedLog trustmap = M.filterWithKey $ notDead trustmap . const
+
+{- Presence logs can contain UUIDs or other values. Any line that matches
+ - a dead uuid is dropped; any other values are passed through. -}
+dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]
+dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info)
+
+notDead :: TrustMap -> (v -> UUID) -> v -> Bool
+notDead trustmap a v = M.findWithDefault SemiTrusted (a v) trustmap /= DeadTrusted
diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs
new file mode 100644
index 000000000..9b2f9a04c
--- /dev/null
+++ b/Annex/BranchState.hs
@@ -0,0 +1,43 @@
+{- git-annex branch state management
+ -
+ - Runtime state about the git-annex branch.
+ -
+ - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.BranchState where
+
+import Common.Annex
+import Types.BranchState
+import qualified Annex
+
+getState :: Annex BranchState
+getState = Annex.getState Annex.branchstate
+
+setState :: BranchState -> Annex ()
+setState state = Annex.changeState $ \s -> s { Annex.branchstate = state }
+
+changeState :: (BranchState -> BranchState) -> Annex ()
+changeState changer = setState =<< changer <$> getState
+
+{- Runs an action to check that the index file exists, if it's not been
+ - checked before in this run of git-annex. -}
+checkIndexOnce :: Annex () -> Annex ()
+checkIndexOnce a = unlessM (indexChecked <$> getState) $ do
+ a
+ changeState $ \s -> s { indexChecked = True }
+
+{- Runs an action to update the branch, if it's not been updated before
+ - in this run of git-annex. -}
+runUpdateOnce :: Annex () -> Annex ()
+runUpdateOnce a = unlessM (branchUpdated <$> getState) $ do
+ a
+ disableUpdate
+
+{- Avoids updating the branch. A useful optimisation when the branch
+ - is known to have not changed, or git-annex won't be relying on info
+ - from it. -}
+disableUpdate :: Annex ()
+disableUpdate = changeState $ \s -> s { branchUpdated = True }
diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs
new file mode 100644
index 000000000..6a778db03
--- /dev/null
+++ b/Annex/CatFile.hs
@@ -0,0 +1,144 @@
+{- git cat-file interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CatFile (
+ catFile,
+ catFileDetails,
+ catObject,
+ catTree,
+ catObjectDetails,
+ catFileHandle,
+ catKey,
+ catKeyFile,
+ catKeyFileHEAD,
+) where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Map as M
+import System.PosixCompat.Types
+
+import Common.Annex
+import qualified Git
+import qualified Git.CatFile
+import qualified Annex
+import Git.Types
+import Git.FilePath
+import Git.FileMode
+import qualified Git.Ref
+
+catFile :: Git.Branch -> FilePath -> Annex L.ByteString
+catFile branch file = do
+ h <- catFileHandle
+ liftIO $ Git.CatFile.catFile h branch file
+
+catFileDetails :: Git.Branch -> FilePath -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails branch file = do
+ h <- catFileHandle
+ liftIO $ Git.CatFile.catFileDetails h branch file
+
+catObject :: Git.Ref -> Annex L.ByteString
+catObject ref = do
+ h <- catFileHandle
+ liftIO $ Git.CatFile.catObject h ref
+
+catTree :: Git.Ref -> Annex [(FilePath, FileMode)]
+catTree ref = do
+ h <- catFileHandle
+ liftIO $ Git.CatFile.catTree h ref
+
+catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha, ObjectType))
+catObjectDetails ref = do
+ h <- catFileHandle
+ liftIO $ Git.CatFile.catObjectDetails h ref
+
+{- There can be multiple index files, and a different cat-file is needed
+ - for each. This is selected by setting GIT_INDEX_FILE in the gitEnv. -}
+catFileHandle :: Annex Git.CatFile.CatFileHandle
+catFileHandle = do
+ m <- Annex.getState Annex.catfilehandles
+ indexfile <- fromMaybe "" . maybe Nothing (lookup "GIT_INDEX_FILE")
+ <$> fromRepo gitEnv
+ case M.lookup indexfile m of
+ Just h -> return h
+ Nothing -> do
+ h <- inRepo Git.CatFile.catFileStart
+ let m' = M.insert indexfile h m
+ Annex.changeState $ \s -> s { Annex.catfilehandles = m' }
+ return h
+
+{- From the Sha or Ref of a symlink back to the key.
+ -
+ - Requires a mode witness, to guarantee that the file is a symlink.
+ -}
+catKey :: Ref -> FileMode -> Annex (Maybe Key)
+catKey = catKey' True
+
+catKey' :: Bool -> Ref -> FileMode -> Annex (Maybe Key)
+catKey' modeguaranteed ref mode
+ | isSymLink mode = do
+ l <- fromInternalGitPath . decodeBS <$> get
+ return $ if isLinkToAnnex l
+ then fileKey $ takeFileName l
+ else Nothing
+ | otherwise = return Nothing
+ where
+ -- If the mode is not guaranteed to be correct, avoid
+ -- buffering the whole file content, which might be large.
+ -- 8192 is enough if it really is a symlink.
+ get
+ | modeguaranteed = catObject ref
+ | otherwise = L.take 8192 <$> catObject ref
+
+{- Looks up the key corresponding to the Ref using the running cat-file.
+ -
+ - Currently this always has to look in HEAD, because cat-file --batch
+ - does not offer a way to specify that we want to look up a tree object
+ - in the index. So if the index has a file staged not as a symlink,
+ - and it is a symlink in head, the wrong mode is gotten.
+ - Also, we have to assume the file is a symlink if it's not yet committed
+ - to HEAD. For these reasons, modeguaranteed is not set.
+ -}
+catKeyChecked :: Bool -> Ref -> Annex (Maybe Key)
+catKeyChecked needhead ref@(Ref r) =
+ catKey' False ref =<< findmode <$> catTree treeref
+ where
+ pathparts = split "/" r
+ dir = intercalate "/" $ take (length pathparts - 1) pathparts
+ file = fromMaybe "" $ lastMaybe pathparts
+ treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/"
+ findmode = fromMaybe symLinkMode . headMaybe .
+ map snd . filter (\p -> fst p == file)
+
+{- From a file in the repository back to the key.
+ -
+ - Ideally, this should reflect the key that's staged in the index,
+ - not the key that's committed to HEAD. Unfortunately, git cat-file
+ - does not refresh the index file after it's started up, so things
+ - newly staged in the index won't show up. It does, however, notice
+ - when branches change.
+ -
+ - For command-line git-annex use, that doesn't matter. It's perfectly
+ - reasonable for things staged in the index after the currently running
+ - git-annex process to not be noticed by it. However, we do want to see
+ - what's in the index, since it may have uncommitted changes not in HEAD
+ -
+ - For the assistant, this is much more of a problem, since it commits
+ - files and then needs to be able to immediately look up their keys.
+ - OTOH, the assistant doesn't keep changes staged in the index for very
+ - long at all before committing them -- and it won't look at the keys
+ - of files until after committing them.
+ -
+ - So, this gets info from the index, unless running as a daemon.
+ -}
+catKeyFile :: FilePath -> Annex (Maybe Key)
+catKeyFile f = ifM (Annex.getState Annex.daemon)
+ ( catKeyFileHEAD f
+ , catKeyChecked True $ Git.Ref.fileRef f
+ )
+
+catKeyFileHEAD :: FilePath -> Annex (Maybe Key)
+catKeyFileHEAD f = catKeyChecked False $ Git.Ref.fileFromRef Git.Ref.headRef f
diff --git a/Annex/CheckAttr.hs b/Annex/CheckAttr.hs
new file mode 100644
index 000000000..8eed9e804
--- /dev/null
+++ b/Annex/CheckAttr.hs
@@ -0,0 +1,35 @@
+{- git check-attr interface, with handle automatically stored in the Annex monad
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CheckAttr (
+ checkAttr,
+ checkAttrHandle
+) where
+
+import Common.Annex
+import qualified Git.CheckAttr as Git
+import qualified Annex
+
+{- All gitattributes used by git-annex. -}
+annexAttrs :: [Git.Attr]
+annexAttrs =
+ [ "annex.backend"
+ , "annex.numcopies"
+ ]
+
+checkAttr :: Git.Attr -> FilePath -> Annex String
+checkAttr attr file = do
+ h <- checkAttrHandle
+ liftIO $ Git.checkAttr h attr file
+
+checkAttrHandle :: Annex Git.CheckAttrHandle
+checkAttrHandle = maybe startup return =<< Annex.getState Annex.checkattrhandle
+ where
+ startup = do
+ h <- inRepo $ Git.checkAttrStart annexAttrs
+ Annex.changeState $ \s -> s { Annex.checkattrhandle = Just h }
+ return h
diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs
new file mode 100644
index 000000000..d45e652bc
--- /dev/null
+++ b/Annex/CheckIgnore.hs
@@ -0,0 +1,32 @@
+{- git check-ignore interface, with handle automatically stored in
+ - the Annex monad
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.CheckIgnore (
+ checkIgnored,
+ checkIgnoreHandle
+) where
+
+import Common.Annex
+import qualified Git.CheckIgnore as Git
+import qualified Annex
+
+checkIgnored :: FilePath -> Annex Bool
+checkIgnored file = go =<< checkIgnoreHandle
+ where
+ go Nothing = return False
+ go (Just h) = liftIO $ Git.checkIgnored h file
+
+checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)
+checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle
+ where
+ startup = do
+ v <- inRepo Git.checkIgnoreStart
+ when (isNothing v) $
+ warning "The installed version of git is too old for .gitignores to be honored by git-annex."
+ Annex.changeState $ \s -> s { Annex.checkignorehandle = Just v }
+ return v
diff --git a/Annex/Content.hs b/Annex/Content.hs
new file mode 100644
index 000000000..9c71037de
--- /dev/null
+++ b/Annex/Content.hs
@@ -0,0 +1,624 @@
+{- git-annex file content managing
+ -
+ - Copyright 2010-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Content (
+ inAnnex,
+ inAnnexSafe,
+ inAnnexCheck,
+ lockContent,
+ getViaTmp,
+ getViaTmpChecked,
+ getViaTmpUnchecked,
+ prepGetViaTmpChecked,
+ withTmp,
+ checkDiskSpace,
+ moveAnnex,
+ sendAnnex,
+ prepSendAnnex,
+ removeAnnex,
+ fromAnnex,
+ moveBad,
+ KeyLocation(..),
+ getKeysPresent,
+ saveState,
+ downloadUrl,
+ preseedTmp,
+ freezeContent,
+ thawContent,
+ dirKeys,
+ withObjectLoc,
+) where
+
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+import Common.Annex
+import Logs.Location
+import qualified Git
+import qualified Annex
+import qualified Annex.Queue
+import qualified Annex.Branch
+import Utility.DiskFree
+import Utility.FileMode
+import qualified Annex.Url as Url
+import Types.Key
+import Utility.DataUnits
+import Utility.CopyFile
+import Config
+import Git.SharedRepository
+import Annex.Perms
+import Annex.Link
+import Annex.Content.Direct
+import Annex.ReplaceFile
+import Annex.Exception
+
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
+{- Checks if a given key's content is currently present. -}
+inAnnex :: Key -> Annex Bool
+inAnnex key = inAnnexCheck key $ liftIO . doesFileExist
+
+{- Runs an arbitrary check on a key's content. -}
+inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+inAnnexCheck key check = inAnnex' id False check key
+
+{- Generic inAnnex, handling both indirect and direct mode.
+ -
+ - In direct mode, at least one of the associated files must pass the
+ - check. Additionally, the file must be unmodified.
+ -}
+inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a
+inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect
+ where
+ checkindirect loc = do
+ whenM (fromRepo Git.repoIsUrl) $
+ error "inAnnex cannot check remote repo"
+ check loc
+ checkdirect [] = return bad
+ checkdirect (loc:locs) = do
+ r <- check loc
+ if isgood r
+ then ifM (goodContent key loc)
+ ( return r
+ , checkdirect locs
+ )
+ else checkdirect locs
+
+{- 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 key = inAnnex' (fromMaybe False) (Just False) go key
+ where
+ is_locked = Nothing
+ is_unlocked = Just True
+ is_missing = Just False
+
+ go contentfile = maybe (checkindirect contentfile) (checkdirect contentfile)
+ =<< contentLockFile key
+
+#ifndef mingw32_HOST_OS
+ checkindirect f = liftIO $ openforlock f >>= check is_missing
+ {- In direct mode, the content file must exist, but
+ - the lock file often generally won't exist unless a removal is in
+ - process. This does not create the lock file, it only checks for
+ - it. -}
+ checkdirect contentfile lockfile = liftIO $
+ ifM (doesFileExist contentfile)
+ ( openforlock lockfile >>= check is_unlocked
+ , return is_missing
+ )
+ openforlock f = catchMaybeIO $
+ openFd f ReadOnly Nothing defaultFileFlags
+ check _ (Just h) = do
+ v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
+ closeFd h
+ return $ case v of
+ Just _ -> is_locked
+ Nothing -> is_unlocked
+ check def Nothing = return def
+#else
+ checkindirect _ = return is_missing
+ {- In Windows, see if we can take a shared lock. If so,
+ - remove the lock file to clean up after ourselves. -}
+ checkdirect contentfile lockfile =
+ ifM (liftIO $ doesFileExist contentfile)
+ ( modifyContent lockfile $ liftIO $ do
+ v <- lockShared lockfile
+ case v of
+ Nothing -> return is_locked
+ Just lockhandle -> do
+ dropLock lockhandle
+ void $ tryIO $ nukeFile lockfile
+ return is_unlocked
+ , return is_missing
+ )
+#endif
+
+{- Direct mode and especially Windows has to use a separate lock
+ - file from the content, since locking the actual content file
+ - would interfere with the user's use of it. -}
+contentLockFile :: Key -> Annex (Maybe FilePath)
+contentLockFile key = ifM isDirect
+ ( Just <$> calcRepo (gitAnnexContentLock key)
+ , return Nothing
+ )
+
+{- Content is exclusively locked while running an action that might remove
+ - it. (If the content is not present, no locking is done.) -}
+lockContent :: Key -> Annex a -> Annex a
+lockContent key a = do
+ contentfile <- calcRepo $ gitAnnexLocation key
+ lockfile <- contentLockFile key
+ maybe noop setuplockfile lockfile
+ bracketAnnex (liftIO $ lock contentfile lockfile) (unlock lockfile) (const a)
+ where
+ alreadylocked = error "content is locked"
+ setuplockfile lockfile = modifyContent lockfile $
+ void $ liftIO $ tryIO $
+ writeFile lockfile ""
+ cleanuplockfile lockfile = modifyContent lockfile $
+ void $ liftIO $ tryIO $
+ nukeFile lockfile
+#ifndef mingw32_HOST_OS
+ lock contentfile Nothing = opencontentforlock contentfile >>= dolock
+ lock _ (Just lockfile) = openforlock lockfile >>= dolock . Just
+ {- Since content files are stored with the write bit disabled, have
+ - to fiddle with permissions to open for an exclusive lock. -}
+ opencontentforlock f = catchMaybeIO $ ifM (doesFileExist f)
+ ( withModifiedFileMode f
+ (`unionFileModes` ownerWriteMode)
+ (openforlock f)
+ , openforlock f
+ )
+ openforlock f = openFd f ReadWrite Nothing defaultFileFlags
+ dolock Nothing = return Nothing
+ dolock (Just fd) = do
+ v <- tryIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+ case v of
+ Left _ -> alreadylocked
+ Right _ -> return $ Just fd
+ unlock mlockfile mfd = do
+ maybe noop cleanuplockfile mlockfile
+ liftIO $ maybe noop closeFd mfd
+#else
+ lock _ (Just lockfile) = maybe alreadylocked (return . Just) =<< lockExclusive lockfile
+ lock _ Nothing = return Nothing
+ unlock mlockfile mlockhandle = do
+ liftIO $ maybe noop dropLock mlockhandle
+ maybe noop cleanuplockfile mlockfile
+#endif
+
+{- Runs an action, passing it a temporary filename to get,
+ - and if the action succeeds, moves the temp file into
+ - the annex as a key's content. -}
+getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmp = getViaTmpChecked (return True)
+
+{- Like getViaTmp, but does not check that there is enough disk space
+ - for the incoming key. For use when the key content is already on disk
+ - and not being copied into place. -}
+getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmpUnchecked = finishGetViaTmp (return True)
+
+getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
+getViaTmpChecked check key action =
+ prepGetViaTmpChecked key $
+ finishGetViaTmp check key action
+
+{- Prepares to download a key via a tmp file, and checks that there is
+ - enough free disk space.
+ -
+ - When the temp file already exists, count the space it is using as
+ - free, since the download will overwrite it or resume.
+ -
+ - Wen there's enough free space, runs the download action.
+ -}
+prepGetViaTmpChecked :: Key -> Annex Bool -> Annex Bool
+prepGetViaTmpChecked key getkey = do
+ tmp <- fromRepo $ gitAnnexTmpObjectLocation key
+
+ e <- liftIO $ doesFileExist tmp
+ alreadythere <- if e
+ then fromIntegral . fileSize <$> liftIO (getFileStatus tmp)
+ else return 0
+ ifM (checkDiskSpace Nothing key alreadythere)
+ ( do
+ -- The tmp file may not have been left writable
+ when e $ thawContent tmp
+ getkey
+ , return False
+ )
+
+finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
+finishGetViaTmp check key action = do
+ tmpfile <- prepTmp key
+ ifM (action tmpfile <&&> check)
+ ( do
+ moveAnnex key tmpfile
+ logStatus key InfoPresent
+ return True
+ -- the tmp file is left behind, in case caller wants
+ -- to resume its transfer
+ , return False
+ )
+
+prepTmp :: Key -> Annex FilePath
+prepTmp key = do
+ tmp <- fromRepo $ gitAnnexTmpObjectLocation key
+ createAnnexDirectory (parentDir tmp)
+ return tmp
+
+{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
+withTmp :: Key -> (FilePath -> Annex a) -> Annex a
+withTmp key action = do
+ tmp <- prepTmp key
+ res <- action tmp
+ liftIO $ nukeFile tmp
+ return res
+
+{- Checks that there is disk space available to store a given key,
+ - in a destination (or the annex) printing a warning if not. -}
+checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
+checkDiskSpace destination key alreadythere = do
+ reserve <- annexDiskReserve <$> Annex.getGitConfig
+ free <- liftIO . getDiskFree =<< dir
+ force <- Annex.getState Annex.force
+ case (free, keySize key) of
+ (Just have, Just need) -> do
+ let ok = (need + reserve <= have + alreadythere) || force
+ unless ok $
+ needmorespace (need + reserve - have - alreadythere)
+ return ok
+ _ -> return True
+ where
+ dir = maybe (fromRepo gitAnnexDir) return destination
+ needmorespace n =
+ warning $ "not enough free space, need " ++
+ roughSize storageUnits True n ++
+ " more" ++ forcemsg
+ forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
+
+{- Moves a key's content into .git/annex/objects/
+ -
+ - In direct mode, moves it to the associated file, or files.
+ -
+ - What if the key there already has content? This could happen for
+ - various reasons; perhaps the same content is being annexed again.
+ - Perhaps there has been a hash collision generating the keys.
+ -
+ - The current strategy is to assume that in this case it's safe to delete
+ - one of the two copies of the content; and the one already in the annex
+ - is left there, assuming it's the original, canonical copy.
+ -
+ - I considered being more paranoid, and checking that both files had
+ - the same content. Decided against it because A) users explicitly choose
+ - a backend based on its hashing properties and so if they're dealing
+ - with colliding files it's their own fault and B) adding such a check
+ - would not catch all cases of colliding keys. For example, perhaps
+ - a remote has a key; if it's then added again with different content then
+ - the overall system now has two different peices of content for that
+ - key, and one of them will probably get deleted later. So, adding the
+ - check here would only raise expectations that git-annex cannot truely
+ - meet.
+ -}
+moveAnnex :: Key -> FilePath -> Annex ()
+moveAnnex key src = withObjectLoc key storeobject storedirect
+ where
+ storeobject dest = ifM (liftIO $ doesFileExist dest)
+ ( alreadyhave
+ , modifyContent dest $ do
+ liftIO $ moveFile src dest
+ freezeContent dest
+ )
+ storeindirect = storeobject =<< calcRepo (gitAnnexLocation key)
+
+ {- In direct mode, the associated file's content may be locally
+ - modified. In that case, it's preserved. However, the content
+ - we're moving into the annex may be the only extant copy, so
+ - it's important we not lose it. So, when the key's content
+ - cannot be moved to any associated file, it's stored in indirect
+ - mode.
+ -}
+ storedirect = storedirect' storeindirect
+ storedirect' fallback [] = fallback
+ storedirect' fallback (f:fs) = do
+ thawContent src
+ v <- isAnnexLink f
+ if Just key == v
+ then do
+ updateInodeCache key src
+ replaceFile f $ liftIO . moveFile src
+ chmodContent f
+ forM_ fs $
+ addContentWhenNotPresent key f
+ else ifM (goodContent key f)
+ ( storedirect' alreadyhave fs
+ , storedirect' fallback fs
+ )
+
+ alreadyhave = liftIO $ removeFile src
+
+{- Runs an action to transfer an object's content.
+ -
+ - In direct mode, it's possible for the file to change as it's being sent.
+ - If this happens, runs the rollback action and returns False. The
+ - rollback action should remove the data that was transferred.
+ -}
+sendAnnex :: Key -> Annex () -> (FilePath -> Annex Bool) -> Annex Bool
+sendAnnex key rollback sendobject = go =<< prepSendAnnex key
+ where
+ go Nothing = return False
+ go (Just (f, checksuccess)) = do
+ r <- sendobject f
+ ifM checksuccess
+ ( return r
+ , do
+ rollback
+ return False
+ )
+
+{- Returns a file that contains an object's content,
+ - and an check to run after the transfer is complete.
+ -
+ - In direct mode, it's possible for the file to change as it's being sent,
+ - and the check detects this case and returns False.
+ -
+ - Note that the returned check action is, in some cases, run in the
+ - Annex monad of the remote that is receiving the object, rather than
+ - the sender. So it cannot rely on Annex state.
+ -}
+prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
+prepSendAnnex key = withObjectLoc key indirect direct
+ where
+ indirect f = return $ Just (f, return True)
+ direct [] = return Nothing
+ direct (f:fs) = do
+ cache <- recordedInodeCache key
+ -- check that we have a good file
+ ifM (sameInodeCache f cache)
+ ( return $ Just (f, sameInodeCache f cache)
+ , direct fs
+ )
+
+{- Performs an action, passing it the location to use for a key's content.
+ -
+ - In direct mode, the associated files will be passed. But, if there are
+ - no associated files for a key, the indirect mode action will be
+ - performed instead. -}
+withObjectLoc :: Key -> (FilePath -> Annex a) -> ([FilePath] -> Annex a) -> Annex a
+withObjectLoc key indirect direct = ifM isDirect
+ ( do
+ fs <- associatedFiles key
+ if null fs
+ then goindirect
+ else direct fs
+ , goindirect
+ )
+ where
+ goindirect = indirect =<< calcRepo (gitAnnexLocation key)
+
+cleanObjectLoc :: Key -> Annex () -> Annex ()
+cleanObjectLoc key cleaner = do
+ file <- calcRepo $ gitAnnexLocation key
+ void $ tryAnnexIO $ thawContentDir file
+ cleaner
+ liftIO $ removeparents file (3 :: Int)
+ where
+ removeparents _ 0 = noop
+ removeparents file n = do
+ let dir = parentDir file
+ maybe noop (const $ removeparents dir (n-1))
+ <=< catchMaybeIO $ removeDirectory dir
+
+{- Removes a key's file from .git/annex/objects/
+ -
+ - In direct mode, deletes the associated files or files, and replaces
+ - them with symlinks. -}
+removeAnnex :: Key -> Annex ()
+removeAnnex key = withObjectLoc key remove removedirect
+ where
+ remove file = cleanObjectLoc key $ do
+ secureErase file
+ liftIO $ nukeFile file
+ removeInodeCache key
+ removedirect fs = do
+ cache <- recordedInodeCache key
+ removeInodeCache key
+ mapM_ (resetfile cache) fs
+ resetfile cache f = whenM (sameInodeCache f cache) $ do
+ l <- inRepo $ gitAnnexLink f key
+ secureErase f
+ replaceFile f $ makeAnnexLink l
+
+{- Runs the secure erase command if set, otherwise does nothing.
+ - File may or may not be deleted at the end; caller is responsible for
+ - making sure it's deleted. -}
+secureErase :: FilePath -> Annex ()
+secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
+ where
+ go basecmd = void $ liftIO $
+ boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
+ gencmd = massReplace [ ("%file", shellEscape file) ]
+
+{- Moves a key's file out of .git/annex/objects/ -}
+fromAnnex :: Key -> FilePath -> Annex ()
+fromAnnex key dest = cleanObjectLoc key $ do
+ file <- calcRepo $ gitAnnexLocation key
+ thawContent file
+ liftIO $ moveFile file dest
+
+{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
+ - returns the file it was moved to. -}
+moveBad :: Key -> Annex FilePath
+moveBad key = do
+ src <- calcRepo $ gitAnnexLocation key
+ bad <- fromRepo gitAnnexBadDir
+ let dest = bad </> takeFileName src
+ createAnnexDirectory (parentDir dest)
+ cleanObjectLoc key $
+ liftIO $ moveFile src dest
+ logStatus key InfoMissing
+ return dest
+
+data KeyLocation = InAnnex | InRepository
+
+{- List of keys whose content exists in the specified location.
+
+ - InAnnex only lists keys under .git/annex/objects,
+ - while InRepository, in direct mode, also finds keys located in the
+ - work tree.
+ -
+ - Note that InRepository has to check whether direct mode files
+ - have goodContent.
+ -}
+getKeysPresent :: KeyLocation -> Annex [Key]
+getKeysPresent keyloc = do
+ direct <- isDirect
+ dir <- fromRepo gitAnnexObjectDir
+ s <- getstate direct
+ liftIO $ traverse s direct (2 :: Int) dir
+ where
+ traverse s direct depth dir = do
+ contents <- catchDefaultIO [] (dirContents dir)
+ if depth == 0
+ then do
+ contents' <- filterM (present s direct) contents
+ let keys = mapMaybe (fileKey . takeFileName) contents'
+ continue keys []
+ else do
+ let deeper = traverse s direct (depth - 1)
+ continue [] (map deeper contents)
+ continue keys [] = return keys
+ continue keys (a:as) = do
+ {- Force lazy traversal with unsafeInterleaveIO. -}
+ morekeys <- unsafeInterleaveIO a
+ continue (morekeys++keys) as
+
+ present _ False d = presentInAnnex d
+ present s True d = presentDirect s d <||> presentInAnnex d
+
+ presentInAnnex = doesFileExist . contentfile
+ contentfile d = d </> takeFileName d
+
+ presentDirect s d = case keyloc of
+ InAnnex -> return False
+ InRepository -> case fileKey (takeFileName d) of
+ Nothing -> return False
+ Just k -> Annex.eval s $
+ anyM (goodContent k) =<< associatedFiles k
+
+ {- In order to run Annex monad actions within unsafeInterleaveIO,
+ - the current state is taken and reused. No changes made to this
+ - state will be preserved.
+ -
+ - As an optimsation, call inodesChanged to prime the state with
+ - a cached value that will be used in the call to goodContent.
+ -}
+ getstate direct = do
+ when direct $
+ void $ inodesChanged
+ Annex.getState id
+
+{- Things to do to record changes to content when shutting down.
+ -
+ - It's acceptable to avoid committing changes to the branch,
+ - especially if performing a short-lived action.
+ -}
+saveState :: Bool -> Annex ()
+saveState nocommit = doSideAction $ do
+ Annex.Queue.flush
+ unless nocommit $
+ whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
+ Annex.Branch.commit "update"
+
+{- Downloads content from any of a list of urls. -}
+downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
+downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
+ where
+ go Nothing = Url.withUrlOptions $ \uo ->
+ anyM (\u -> Url.download u file uo) urls
+ go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
+ downloadcmd basecmd url =
+ boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]
+ <&&> doesFileExist file
+ gencmd url = massReplace
+ [ ("%file", shellEscape file)
+ , ("%url", shellEscape url)
+ ]
+
+{- Copies a key's content, when present, to a temp file.
+ - This is used to speed up some rsyncs. -}
+preseedTmp :: Key -> FilePath -> Annex Bool
+preseedTmp key file = go =<< inAnnex key
+ where
+ go False = return False
+ go True = do
+ ok <- copy
+ when ok $ thawContent file
+ return ok
+ copy = ifM (liftIO $ doesFileExist file)
+ ( return True
+ , do
+ s <- calcRepo $ gitAnnexLocation key
+ liftIO $ copyFileExternal s file
+ )
+
+{- Blocks writing to an annexed file, and modifies file permissions to
+ - allow reading it, per core.sharedRepository setting. -}
+freezeContent :: FilePath -> Annex ()
+freezeContent file = unlessM crippledFileSystem $
+ liftIO . go =<< fromRepo getSharedRepository
+ where
+ go GroupShared = modifyFileMode file $
+ removeModes writeModes .
+ addModes [ownerReadMode, groupReadMode]
+ go AllShared = modifyFileMode file $
+ removeModes writeModes .
+ addModes readModes
+ go _ = modifyFileMode file $
+ removeModes writeModes .
+ addModes [ownerReadMode]
+
+{- Adjusts read mode of annexed file per core.sharedRepository setting. -}
+chmodContent :: FilePath -> Annex ()
+chmodContent file = unlessM crippledFileSystem $
+ liftIO . go =<< fromRepo getSharedRepository
+ where
+ go GroupShared = modifyFileMode file $
+ addModes [ownerReadMode, groupReadMode]
+ go AllShared = modifyFileMode file $
+ addModes readModes
+ go _ = modifyFileMode file $
+ addModes [ownerReadMode]
+
+{- Allows writing to an annexed file that freezeContent was called on
+ - before. -}
+thawContent :: FilePath -> Annex ()
+thawContent file = unlessM crippledFileSystem $
+ liftIO . go =<< fromRepo getSharedRepository
+ where
+ go GroupShared = groupWriteRead file
+ go AllShared = groupWriteRead file
+ go _ = allowWrite file
+
+{- Finds files directly inside a directory like gitAnnexBadDir
+ - (not in subdirectories) and returns the corresponding keys. -}
+dirKeys :: (Git.Repo -> FilePath) -> Annex [Key]
+dirKeys dirspec = do
+ dir <- fromRepo dirspec
+ ifM (liftIO $ doesDirectoryExist dir)
+ ( do
+ contents <- liftIO $ getDirectoryContents dir
+ files <- liftIO $ filterM doesFileExist $
+ map (dir </>) contents
+ return $ mapMaybe (fileKey . takeFileName) files
+ , return []
+ )
+
diff --git a/Annex/Content/Direct.hs b/Annex/Content/Direct.hs
new file mode 100644
index 000000000..7a4fba455
--- /dev/null
+++ b/Annex/Content/Direct.hs
@@ -0,0 +1,256 @@
+{- git-annex file content managing for direct mode
+ -
+ - Copyright 2012-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Content.Direct (
+ associatedFiles,
+ associatedFilesRelative,
+ removeAssociatedFile,
+ removeAssociatedFileUnchecked,
+ removeAssociatedFiles,
+ addAssociatedFile,
+ goodContent,
+ recordedInodeCache,
+ updateInodeCache,
+ addInodeCache,
+ writeInodeCache,
+ compareInodeCaches,
+ compareInodeCachesWith,
+ sameInodeCache,
+ elemInodeCaches,
+ sameFileStatus,
+ removeInodeCache,
+ toInodeCache,
+ inodesChanged,
+ createInodeSentinalFile,
+ addContentWhenNotPresent,
+) where
+
+import Common.Annex
+import qualified Annex
+import Annex.Perms
+import qualified Git
+import Utility.Tmp
+import Logs.Location
+import Utility.InodeCache
+import Utility.CopyFile
+import Annex.ReplaceFile
+import Annex.Link
+
+{- Absolute FilePaths of Files in the tree that are associated with a key. -}
+associatedFiles :: Key -> Annex [FilePath]
+associatedFiles key = do
+ files <- associatedFilesRelative key
+ top <- fromRepo Git.repoPath
+ return $ map (top </>) files
+
+{- List of files in the tree that are associated with a key, relative to
+ - the top of the repo. -}
+associatedFilesRelative :: Key -> Annex [FilePath]
+associatedFilesRelative key = do
+ mapping <- calcRepo $ gitAnnexMapping key
+ liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h -> do
+ fileEncoding h
+ -- Read strictly to ensure the file is closed
+ -- before changeAssociatedFiles tries to write to it.
+ -- (Especially needed on Windows.)
+ lines <$> hGetContentsStrict h
+
+{- Changes the associated files information for a key, applying a
+ - transformation to the list. Returns new associatedFiles value. -}
+changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
+changeAssociatedFiles key transform = do
+ mapping <- calcRepo $ gitAnnexMapping key
+ files <- associatedFilesRelative key
+ let files' = transform files
+ when (files /= files') $
+ modifyContent mapping $
+ liftIO $ viaTmp writeFileAnyEncoding mapping $
+ unlines files'
+ top <- fromRepo Git.repoPath
+ return $ map (top </>) files'
+
+{- Removes the list of associated files. -}
+removeAssociatedFiles :: Key -> Annex ()
+removeAssociatedFiles key = do
+ mapping <- calcRepo $ gitAnnexMapping key
+ modifyContent mapping $
+ liftIO $ nukeFile mapping
+
+{- Removes an associated file. Returns new associatedFiles value.
+ - Checks if this was the last copy of the object, and updates location
+ - log. -}
+removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
+removeAssociatedFile key file = do
+ fs <- removeAssociatedFileUnchecked key file
+ when (null fs) $
+ logStatus key InfoMissing
+ return fs
+
+{- Removes an associated file. Returns new associatedFiles value. -}
+removeAssociatedFileUnchecked :: Key -> FilePath -> Annex [FilePath]
+removeAssociatedFileUnchecked key file = do
+ file' <- normaliseAssociatedFile file
+ changeAssociatedFiles key $ filter (/= file')
+
+{- Adds an associated file. Returns new associatedFiles value. -}
+addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
+addAssociatedFile key file = do
+ file' <- normaliseAssociatedFile file
+ changeAssociatedFiles key $ \files ->
+ if file' `elem` files
+ then files
+ else file':files
+
+{- Associated files are always stored relative to the top of the repository.
+ - The input FilePath is relative to the CWD, or is absolute. -}
+normaliseAssociatedFile :: FilePath -> Annex FilePath
+normaliseAssociatedFile file = do
+ top <- fromRepo Git.repoPath
+ liftIO $ relPathDirToFile top <$> absPath file
+
+{- Checks if a file in the tree, associated with a key, has not been modified.
+ -
+ - To avoid needing to fsck the file's content, which can involve an
+ - expensive checksum, this relies on a cache that contains the file's
+ - expected mtime and inode.
+ -}
+goodContent :: Key -> FilePath -> Annex Bool
+goodContent key file = sameInodeCache file =<< recordedInodeCache key
+
+{- Gets the recorded inode cache for a key.
+ -
+ - A key can be associated with multiple files, so may return more than
+ - one. -}
+recordedInodeCache :: Key -> Annex [InodeCache]
+recordedInodeCache key = withInodeCacheFile key $ \f ->
+ liftIO $ catchDefaultIO [] $
+ mapMaybe readInodeCache . lines <$> readFileStrict f
+
+{- Caches an inode for a file.
+ -
+ - Anything else already cached is preserved.
+ -}
+updateInodeCache :: Key -> FilePath -> Annex ()
+updateInodeCache key file = maybe noop (addInodeCache key)
+ =<< liftIO (genInodeCache file)
+
+{- Adds another inode to the cache for a key. -}
+addInodeCache :: Key -> InodeCache -> Annex ()
+addInodeCache key cache = do
+ oldcaches <- recordedInodeCache key
+ unlessM (elemInodeCaches cache oldcaches) $
+ writeInodeCache key (cache:oldcaches)
+
+{- Writes inode cache for a key. -}
+writeInodeCache :: Key -> [InodeCache] -> Annex ()
+writeInodeCache key caches = withInodeCacheFile key $ \f ->
+ modifyContent f $
+ liftIO $ writeFile f $
+ unlines $ map showInodeCache caches
+
+{- Removes an inode cache. -}
+removeInodeCache :: Key -> Annex ()
+removeInodeCache key = withInodeCacheFile key $ \f ->
+ modifyContent f $
+ liftIO $ nukeFile f
+
+withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
+withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
+
+{- Checks if a InodeCache matches the current version of a file. -}
+sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool
+sameInodeCache _ [] = return False
+sameInodeCache file old = go =<< liftIO (genInodeCache file)
+ where
+ go Nothing = return False
+ go (Just curr) = elemInodeCaches curr old
+
+{- Checks if a FileStatus matches the recorded InodeCache of a file. -}
+sameFileStatus :: Key -> FileStatus -> Annex Bool
+sameFileStatus key status = do
+ old <- recordedInodeCache key
+ let curr = toInodeCache status
+ case (old, curr) of
+ (_, Just c) -> elemInodeCaches c old
+ ([], Nothing) -> return True
+ _ -> return False
+
+{- If the inodes have changed, only the size and mtime are compared. -}
+compareInodeCaches :: InodeCache -> InodeCache -> Annex Bool
+compareInodeCaches x y
+ | compareStrong x y = return True
+ | otherwise = ifM inodesChanged
+ ( return $ compareWeak x y
+ , return False
+ )
+
+elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool
+elemInodeCaches _ [] = return False
+elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)
+ ( return True
+ , elemInodeCaches c ls
+ )
+
+compareInodeCachesWith :: Annex InodeComparisonType
+compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
+
+{- Copies the contentfile to the associated file, if the associated
+ - file has no content. If the associated file does have content,
+ - even if the content differs, it's left unchanged. -}
+addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
+addContentWhenNotPresent key contentfile associatedfile = do
+ v <- isAnnexLink associatedfile
+ when (Just key == v) $
+ replaceFile associatedfile $
+ liftIO . void . copyFileExternal contentfile
+ updateInodeCache key associatedfile
+
+{- Some filesystems get new inodes each time they are mounted.
+ - In order to work on such a filesystem, a sentinal file is used to detect
+ - when the inodes have changed.
+ -
+ - If the sentinal file does not exist, we have to assume that the
+ - inodes have changed.
+ -}
+inodesChanged :: Annex Bool
+inodesChanged = maybe calc return =<< Annex.getState Annex.inodeschanged
+ where
+ calc = do
+ scache <- liftIO . genInodeCache
+ =<< fromRepo gitAnnexInodeSentinal
+ scached <- readInodeSentinalFile
+ let changed = case (scache, scached) of
+ (Just c1, Just c2) -> not $ compareStrong c1 c2
+ _ -> True
+ Annex.changeState $ \s -> s { Annex.inodeschanged = Just changed }
+ return changed
+
+readInodeSentinalFile :: Annex (Maybe InodeCache)
+readInodeSentinalFile = do
+ sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
+ liftIO $ catchDefaultIO Nothing $
+ readInodeCache <$> readFile sentinalcachefile
+
+writeInodeSentinalFile :: Annex ()
+writeInodeSentinalFile = do
+ sentinalfile <- fromRepo gitAnnexInodeSentinal
+ createAnnexDirectory (parentDir sentinalfile)
+ sentinalcachefile <- fromRepo gitAnnexInodeSentinalCache
+ liftIO $ writeFile sentinalfile ""
+ liftIO $ maybe noop (writeFile sentinalcachefile . showInodeCache)
+ =<< genInodeCache sentinalfile
+
+{- The sentinal file is only created when first initializing a repository.
+ - If there are any annexed objects in the repository already, creating
+ - the file would invalidate their inode caches. -}
+createInodeSentinalFile :: Annex ()
+createInodeSentinalFile =
+ unlessM (alreadyexists <||> hasobjects)
+ writeInodeSentinalFile
+ where
+ alreadyexists = isJust <$> readInodeSentinalFile
+ hasobjects = liftIO . doesDirectoryExist =<< fromRepo gitAnnexObjectDir
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
new file mode 100644
index 000000000..2f583fd94
--- /dev/null
+++ b/Annex/Direct.hs
@@ -0,0 +1,373 @@
+{- git-annex direct mode
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Direct where
+
+import Common.Annex
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.Merge
+import qualified Git.DiffTree as DiffTree
+import qualified Git.Config
+import qualified Git.Ref
+import qualified Git.Branch
+import Git.Sha
+import Git.FilePath
+import Git.Types
+import Config
+import Annex.CatFile
+import qualified Annex.Queue
+import Logs.Location
+import Backend
+import Types.KeySource
+import Annex.Content
+import Annex.Content.Direct
+import Annex.Link
+import Utility.InodeCache
+import Utility.CopyFile
+import Annex.Perms
+import Annex.ReplaceFile
+import Annex.Exception
+import Annex.VariantFile
+
+{- Uses git ls-files to find files that need to be committed, and stages
+ - them into the index. Returns True if some changes were staged. -}
+stageDirect :: Annex Bool
+stageDirect = do
+ Annex.Queue.flush
+ top <- fromRepo Git.repoPath
+ (l, cleanup) <- inRepo $ Git.LsFiles.stagedOthersDetails [top]
+ forM_ l go
+ void $ liftIO cleanup
+ staged <- Annex.Queue.size
+ Annex.Queue.flush
+ return $ staged /= 0
+ where
+ {- Determine what kind of modified or deleted file this is, as
+ - efficiently as we can, by getting any key that's associated
+ - with it in git, as well as its stat info. -}
+ go (file, Just sha, Just mode) = do
+ shakey <- catKey sha mode
+ mstat <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file
+ filekey <- isAnnexLink file
+ case (shakey, filekey, mstat, toInodeCache =<< mstat) of
+ (_, Just key, _, _)
+ | shakey == filekey -> noop
+ {- A changed symlink. -}
+ | otherwise -> stageannexlink file key
+ (Just key, _, _, Just cache) -> do
+ {- All direct mode files will show as
+ - modified, so compare the cache to see if
+ - it really was. -}
+ oldcache <- recordedInodeCache key
+ case oldcache of
+ [] -> modifiedannexed file key cache
+ _ -> unlessM (elemInodeCaches cache oldcache) $
+ modifiedannexed file key cache
+ (Just key, _, Nothing, _) -> deletedannexed file key
+ (Nothing, _, Nothing, _) -> deletegit file
+ (_, _, Just _, _) -> addgit file
+ go _ = noop
+
+ modifiedannexed file oldkey cache = do
+ void $ removeAssociatedFile oldkey file
+ void $ addDirect file cache
+
+ deletedannexed file key = do
+ void $ removeAssociatedFile key file
+ deletegit file
+
+ stageannexlink file key = do
+ l <- inRepo $ gitAnnexLink file key
+ stageSymlink file =<< hashSymlink l
+ void $ addAssociatedFile key file
+
+ addgit file = Annex.Queue.addCommand "add" [Param "-f"] [file]
+
+ deletegit file = Annex.Queue.addCommand "rm" [Param "-qf"] [file]
+
+{- Run before a commit to update direct mode bookeeping to reflect the
+ - staged changes being committed. -}
+preCommitDirect :: Annex Bool
+preCommitDirect = do
+ (diffs, clean) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
+ makeabs <- flip fromTopFilePath <$> gitRepo
+ forM_ diffs (go makeabs)
+ liftIO clean
+ where
+ go makeabs diff = do
+ withkey (DiffTree.srcsha diff) (DiffTree.srcmode diff) removeAssociatedFile
+ withkey (DiffTree.dstsha diff) (DiffTree.dstmode diff) addAssociatedFile
+ where
+ withkey sha mode a = when (sha /= nullSha) $ do
+ k <- catKey sha mode
+ case k of
+ Nothing -> noop
+ Just key -> void $ a key $
+ makeabs $ DiffTree.file diff
+
+{- Adds a file to the annex in direct mode. Can fail, if the file is
+ - modified or deleted while it's being added. -}
+addDirect :: FilePath -> InodeCache -> Annex Bool
+addDirect file cache = do
+ showStart "add" file
+ let source = KeySource
+ { keyFilename = file
+ , contentLocation = file
+ , inodeCache = Just cache
+ }
+ got =<< genKey source =<< chooseBackend file
+ where
+ got Nothing = do
+ showEndFail
+ return False
+ got (Just (key, _)) = ifM (sameInodeCache file [cache])
+ ( do
+ l <- inRepo $ gitAnnexLink file key
+ stageSymlink file =<< hashSymlink l
+ addInodeCache key cache
+ void $ addAssociatedFile key file
+ logStatus key InfoPresent
+ showEndOk
+ return True
+ , do
+ showEndFail
+ return False
+ )
+
+{- In direct mode, git merge would usually refuse to do anything, since it
+ - sees present direct mode files as type changed files. To avoid this,
+ - merge is run with the work tree set to a temp directory.
+ -}
+mergeDirect :: FilePath -> Git.Ref -> Git.Repo -> IO Bool
+mergeDirect d branch g = do
+ whenM (doesDirectoryExist d) $
+ removeDirectoryRecursive d
+ createDirectoryIfMissing True d
+ let g' = g { location = Local { gitdir = Git.localGitDir g, worktree = Just d } }
+ Git.Merge.mergeNonInteractive branch g'
+
+{- Cleans up after a direct mode merge. The merge must have been committed,
+ - and the commit sha passed in, along with the old sha of the tree
+ - before the merge. Uses git diff-tree to find files that changed between
+ - the two shas, and applies those changes to the work tree.
+ -
+ - There are really only two types of changes: An old item can be deleted,
+ - or a new item added. Two passes are made, first deleting and then
+ - adding. This is to handle cases where eg, a file is deleted and a
+ - directory is added. (The diff-tree output may list these in the opposite
+ - order, but we cannot add the directory until the file with the
+ - same name is removed.)
+ -}
+mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()
+mergeDirectCleanup d oldsha newsha = do
+ (items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha
+ makeabs <- flip fromTopFilePath <$> gitRepo
+ let fsitems = zip (map (makeabs . DiffTree.file) items) items
+ forM_ fsitems $
+ go makeabs DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+ forM_ fsitems $
+ go makeabs DiffTree.dstsha DiffTree.dstmode movein movein_raw
+ void $ liftIO cleanup
+ liftIO $ removeDirectoryRecursive d
+ where
+ go makeabs getsha getmode a araw (f, item)
+ | getsha item == nullSha = noop
+ | otherwise = void $
+ tryAnnex . maybe (araw item makeabs f) (\k -> void $ a item makeabs k f)
+ =<< catKey (getsha item) (getmode item)
+
+ moveout _ _ = removeDirect
+
+ {- Files deleted by the merge are removed from the work tree.
+ - Empty work tree directories are removed, per git behavior. -}
+ moveout_raw _ _ f = liftIO $ do
+ nukeFile f
+ void $ tryIO $ removeDirectory $ parentDir f
+
+ {- If the file is already present, with the right content for the
+ - key, it's left alone.
+ -
+ - If the file is already present, and does not exist in the
+ - oldsha branch, preserve this local file.
+ -
+ - Otherwise, create the symlink and then if possible, replace it
+ - with the content. -}
+ movein item makeabs k f = unlessM (goodContent k f) $ do
+ preserveUnannexed item makeabs f oldsha
+ l <- inRepo $ gitAnnexLink f k
+ replaceFile f $ makeAnnexLink l
+ toDirect k f
+
+ {- Any new, modified, or renamed files were written to the temp
+ - directory by the merge, and are moved to the real work tree. -}
+ movein_raw item makeabs f = do
+ preserveUnannexed item makeabs f oldsha
+ liftIO $ do
+ createDirectoryIfMissing True $ parentDir f
+ void $ tryIO $ rename (d </> getTopFilePath (DiffTree.file item)) f
+
+{- If the file that's being moved in is already present in the work
+ - tree, but did not exist in the oldsha branch, preserve this
+ - local, unannexed file (or directory), as "variant-local".
+ -
+ - It's also possible that the file that's being moved in
+ - is in a directory that collides with an exsting, non-annexed
+ - file (not a directory), which should be preserved.
+ -}
+preserveUnannexed :: DiffTree.DiffTreeItem -> (TopFilePath -> FilePath) -> FilePath -> Ref -> Annex ()
+preserveUnannexed item makeabs absf oldsha = do
+ whenM (liftIO (collidingitem absf) <&&> unannexed absf) $
+ liftIO $ findnewname absf 0
+ checkdirs (DiffTree.file item)
+ where
+ checkdirs from = do
+ let p = parentDir (getTopFilePath from)
+ let d = asTopFilePath p
+ unless (null p) $ do
+ let absd = makeabs d
+ whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $
+ liftIO $ findnewname absd 0
+ checkdirs d
+
+ collidingitem f = isJust
+ <$> catchMaybeIO (getSymbolicLinkStatus f)
+ colliding_nondir f = maybe False (not . isDirectory)
+ <$> catchMaybeIO (getSymbolicLinkStatus f)
+
+ unannexed f = (isNothing <$> isAnnexLink f)
+ <&&> (isNothing <$> catFileDetails oldsha f)
+
+ findnewname :: FilePath -> Int -> IO ()
+ findnewname f n = do
+ let localf = mkVariant f
+ ("local" ++ if n > 0 then show n else "")
+ ifM (collidingitem localf)
+ ( findnewname f (n+1)
+ , rename f localf
+ `catchIO` const (findnewname f (n+1))
+ )
+
+{- If possible, converts a symlink in the working tree into a direct
+ - mode file. If the content is not available, leaves the symlink
+ - unchanged. -}
+toDirect :: Key -> FilePath -> Annex ()
+toDirect k f = fromMaybe noop =<< toDirectGen k f
+
+toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
+toDirectGen k f = do
+ loc <- calcRepo $ gitAnnexLocation k
+ ifM (liftIO $ doesFileExist loc)
+ ( return $ Just $ fromindirect loc
+ , do
+ {- Copy content from another direct file. -}
+ absf <- liftIO $ absPath f
+ dlocs <- filterM (goodContent k) =<<
+ filterM (\l -> isNothing <$> getAnnexLinkTarget l) =<<
+ (filter (/= absf) <$> addAssociatedFile k f)
+ case dlocs of
+ [] -> return Nothing
+ (dloc:_) -> return $ Just $ fromdirect dloc
+ )
+ where
+ fromindirect loc = do
+ {- Move content from annex to direct file. -}
+ updateInodeCache k loc
+ void $ addAssociatedFile k f
+ modifyContent loc $ do
+ thawContent loc
+ replaceFile f $ liftIO . moveFile loc
+ fromdirect loc = do
+ replaceFile f $
+ liftIO . void . copyFileExternal loc
+ updateInodeCache k f
+
+{- Removes a direct mode file, while retaining its content in the annex
+ - (unless its content has already been changed). -}
+removeDirect :: Key -> FilePath -> Annex ()
+removeDirect k f = do
+ void $ removeAssociatedFileUnchecked k f
+ unlessM (inAnnex k) $
+ ifM (goodContent k f)
+ ( moveAnnex k f
+ , logStatus k InfoMissing
+ )
+ liftIO $ do
+ nukeFile f
+ void $ tryIO $ removeDirectory $ parentDir f
+
+{- Called when a direct mode file has been changed. Its old content may be
+ - lost. -}
+changedDirect :: Key -> FilePath -> Annex ()
+changedDirect oldk f = do
+ locs <- removeAssociatedFile oldk f
+ whenM (pure (null locs) <&&> not <$> inAnnex oldk) $
+ logStatus oldk InfoMissing
+
+{- Enable/disable direct mode. -}
+setDirect :: Bool -> Annex ()
+setDirect wantdirect = do
+ if wantdirect
+ then do
+ switchHEAD
+ setbare
+ else do
+ setbare
+ switchHEADBack
+ setConfig (annexConfig "direct") val
+ Annex.changeGitConfig $ \c -> c { annexDirect = wantdirect }
+ where
+ val = Git.Config.boolConfig wantdirect
+ setbare = setConfig (ConfigKey Git.Config.coreBare) val
+
+{- Since direct mode sets core.bare=true, incoming pushes could change
+ - the currently checked out branch. To avoid this problem, HEAD
+ - is changed to a internal ref that nothing is going to push to.
+ -
+ - For refs/heads/master, use refs/heads/annex/direct/master;
+ - this way things that show HEAD (eg shell prompts) will
+ - hopefully show just "master". -}
+directBranch :: Ref -> Ref
+directBranch orighead = case split "/" $ fromRef orighead of
+ ("refs":"heads":"annex":"direct":_) -> orighead
+ ("refs":"heads":rest) ->
+ Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
+ _ -> Ref $ "refs/heads/" ++ fromRef (Git.Ref.base orighead)
+
+{- Converts a directBranch back to the original branch.
+ -
+ - Any other ref is left unchanged.
+ -}
+fromDirectBranch :: Ref -> Ref
+fromDirectBranch directhead = case split "/" $ fromRef directhead of
+ ("refs":"heads":"annex":"direct":rest) ->
+ Ref $ "refs/heads/" ++ intercalate "/" rest
+ _ -> directhead
+
+switchHEAD :: Annex ()
+switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+ where
+ switch orighead = do
+ let newhead = directBranch orighead
+ maybe noop (inRepo . Git.Branch.update newhead)
+ =<< inRepo (Git.Ref.sha orighead)
+ inRepo $ Git.Branch.checkout newhead
+
+switchHEADBack :: Annex ()
+switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
+ where
+ switch currhead = do
+ let orighead = fromDirectBranch currhead
+ v <- inRepo $ Git.Ref.sha currhead
+ case v of
+ Just headsha
+ | orighead /= currhead -> do
+ inRepo $ Git.Branch.update orighead headsha
+ inRepo $ Git.Branch.checkout orighead
+ inRepo $ Git.Branch.delete currhead
+ _ -> inRepo $ Git.Branch.checkout orighead
diff --git a/Annex/Direct/Fixup.hs b/Annex/Direct/Fixup.hs
new file mode 100644
index 000000000..13485242a
--- /dev/null
+++ b/Annex/Direct/Fixup.hs
@@ -0,0 +1,31 @@
+{- git-annex direct mode guard fixup
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Direct.Fixup where
+
+import Git.Types
+import Git.Config
+import qualified Git.Construct as Construct
+import Utility.Path
+import Utility.SafeCommand
+
+{- Direct mode repos have core.bare=true, but are not really bare.
+ - Fix up the Repo to be a non-bare repo, and arrange for git commands
+ - run by git-annex to be passed parameters that override this setting. -}
+fixupDirect :: Repo -> IO Repo
+fixupDirect r@(Repo { location = l@(Local { gitdir = d, worktree = Nothing }) }) = do
+ let r' = r
+ { location = l { worktree = Just (parentDir d) }
+ , gitGlobalOpts = gitGlobalOpts r ++
+ [ Param "-c"
+ , Param $ coreBare ++ "=" ++ boolConfig False
+ ]
+ }
+ -- Recalc now that the worktree is correct.
+ rs' <- Construct.fromRemotes r'
+ return $ r' { remotes = rs' }
+fixupDirect r = return r
diff --git a/Annex/Drop.hs b/Annex/Drop.hs
new file mode 100644
index 000000000..71263dc61
--- /dev/null
+++ b/Annex/Drop.hs
@@ -0,0 +1,124 @@
+{- dropping of unwanted content
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Drop where
+
+import Common.Annex
+import Logs.Trust
+import Config.NumCopies
+import Types.Remote (uuid)
+import Types.Key (key2file)
+import qualified Remote
+import qualified Command.Drop
+import Command
+import Annex.Wanted
+import Annex.Exception
+import Config
+import Annex.Content.Direct
+
+import qualified Data.Set as S
+import System.Log.Logger (debugM)
+
+type Reason = String
+
+{- Drop a key from local and/or remote when allowed by the preferred content
+ - and numcopies settings.
+ -
+ - The UUIDs are ones where the content is believed to be present.
+ - The Remote list can include other remotes that do not have the content;
+ - only ones that match the UUIDs will be dropped from.
+ - If allowed to drop fromhere, that drop will be tried first.
+ -
+ - A remote can be specified that is known to have the key. This can be
+ - used an an optimisation when eg, a key has just been uploaded to a
+ - remote.
+ -
+ - In direct mode, all associated files are checked, and only if all
+ - of them are unwanted are they dropped.
+ -
+ - The runner is used to run commands, and so can be either callCommand
+ - or commandAction.
+ -}
+handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
+handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
+ fs <- ifM isDirect
+ ( do
+ l <- associatedFilesRelative key
+ return $ if null l
+ then maybeToList afile
+ else l
+ , return $ maybeToList afile
+ )
+ n <- getcopies fs
+ if fromhere && checkcopies n Nothing
+ then go fs rs =<< dropl fs n
+ else go fs rs n
+ where
+ getcopies fs = do
+ (untrusted, have) <- trustPartition UnTrusted locs
+ numcopies <- if null fs
+ then getNumCopies
+ else maximum <$> mapM getFileNumCopies fs
+ return (NumCopies (length have), numcopies, S.fromList untrusted)
+
+ {- Check that we have enough copies still to drop the content.
+ - When the remote being dropped from is untrusted, it was not
+ - counted as a copy, so having only numcopies suffices. Otherwise,
+ - we need more than numcopies to safely drop. -}
+ checkcopies (have, numcopies, _untrusted) Nothing = have > numcopies
+ checkcopies (have, numcopies, untrusted) (Just u)
+ | S.member u untrusted = have >= numcopies
+ | otherwise = have > numcopies
+
+ decrcopies (have, numcopies, untrusted) Nothing =
+ (NumCopies (fromNumCopies have - 1), numcopies, untrusted)
+ decrcopies v@(_have, _numcopies, untrusted) (Just u)
+ | S.member u untrusted = v
+ | otherwise = decrcopies v Nothing
+
+ go _ [] _ = noop
+ go fs (r:rest) n
+ | uuid r `S.notMember` slocs = go fs rest n
+ | checkcopies n (Just $ Remote.uuid r) =
+ dropr fs r n >>= go fs rest
+ | otherwise = noop
+
+ checkdrop fs n u a
+ | null fs = check $ -- no associated files; unused content
+ wantDrop True u (Just key) Nothing
+ | otherwise = check $
+ allM (wantDrop True u (Just key) . Just) fs
+ where
+ check c = ifM c
+ ( dodrop n u a
+ , return n
+ )
+
+ dodrop n@(have, numcopies, _untrusted) u a =
+ ifM (safely $ runner $ a numcopies)
+ ( do
+ liftIO $ debugM "drop" $ unwords
+ [ "dropped"
+ , fromMaybe (key2file key) afile
+ , "(from " ++ maybe "here" show u ++ ")"
+ , "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
+ , ": " ++ reason
+ ]
+ return $ decrcopies n u
+ , return n
+ )
+
+ dropl fs n = checkdrop fs n Nothing $ \numcopies ->
+ Command.Drop.startLocal afile numcopies key knownpresentremote
+
+ dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
+ Command.Drop.startRemote afile numcopies key r
+
+ slocs = S.fromList locs
+
+ safely a = either (const False) id <$> tryAnnex a
+
diff --git a/Annex/Environment.hs b/Annex/Environment.hs
new file mode 100644
index 000000000..f22c5f2d4
--- /dev/null
+++ b/Annex/Environment.hs
@@ -0,0 +1,65 @@
+{- git-annex environment
+ -
+ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Environment where
+
+import Common.Annex
+import Utility.UserInfo
+import qualified Git.Config
+import Config
+import Annex.Exception
+
+#ifndef mingw32_HOST_OS
+import Utility.Env
+#endif
+
+{- Checks that the system's environment allows git to function.
+ - Git requires a GECOS username, or suitable git configuration, or
+ - environment variables.
+ -
+ - Git also requires the system have a hostname containing a dot.
+ - Otherwise, it tries various methods to find a FQDN, and will fail if it
+ - does not. To avoid replicating that code here, which would break if its
+ - methods change, this function does not check the hostname is valid.
+ - Instead, code that commits can use ensureCommit.
+ -}
+checkEnvironment :: Annex ()
+checkEnvironment = do
+ gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
+ when (isNothing gitusername || gitusername == Just "") $
+ liftIO checkEnvironmentIO
+
+checkEnvironmentIO :: IO ()
+checkEnvironmentIO =
+#ifdef mingw32_HOST_OS
+ noop
+#else
+ whenM (null <$> myUserGecos) $ do
+ username <- myUserName
+ ensureEnv "GIT_AUTHOR_NAME" username
+ ensureEnv "GIT_COMMITTER_NAME" username
+ where
+#ifndef __ANDROID__
+ -- existing environment is not overwritten
+ ensureEnv var val = void $ setEnv var val False
+#else
+ -- Environment setting is broken on Android, so this is dealt with
+ -- in runshell instead.
+ ensureEnv _ _ = noop
+#endif
+#endif
+
+{- Runs an action that commits to the repository, and if it fails,
+ - sets user.email to a dummy value and tries the action again. -}
+ensureCommit :: Annex a -> Annex a
+ensureCommit a = either retry return =<< tryAnnex a
+ where
+ retry _ = do
+ setConfig (ConfigKey "user.email") =<< liftIO myUserName
+ a
diff --git a/Annex/Exception.hs b/Annex/Exception.hs
new file mode 100644
index 000000000..11613d51b
--- /dev/null
+++ b/Annex/Exception.hs
@@ -0,0 +1,50 @@
+{- exception handling in the git-annex monad
+ -
+ - Note that when an Annex action fails and the exception is handled
+ - by these functions, any changes the action has made to the
+ - AnnexState are retained. This works because the Annex monad
+ - internally stores the AnnexState in a MVar.
+ -
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE PackageImports #-}
+
+module Annex.Exception (
+ bracketIO,
+ bracketAnnex,
+ tryAnnex,
+ tryAnnexIO,
+ throwAnnex,
+ catchAnnex,
+) where
+
+import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
+import Control.Exception
+
+import Common.Annex
+
+{- Runs an Annex action, with setup and cleanup both in the IO monad. -}
+bracketIO :: IO v -> (v -> IO b) -> (v -> Annex a) -> Annex a
+bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup)
+
+bracketAnnex :: Annex v -> (v -> Annex b) -> (v -> Annex a) -> Annex a
+bracketAnnex = M.bracket
+
+{- try in the Annex monad -}
+tryAnnex :: Annex a -> Annex (Either SomeException a)
+tryAnnex = M.try
+
+{- try in the Annex monad, but only catching IO exceptions -}
+tryAnnexIO :: Annex a -> Annex (Either IOException a)
+tryAnnexIO = M.try
+
+{- throw in the Annex monad -}
+throwAnnex :: Exception e => e -> Annex a
+throwAnnex = M.throw
+
+{- catch in the Annex monad -}
+catchAnnex :: Exception e => Annex a -> (e -> Annex a) -> Annex a
+catchAnnex = M.catch
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
new file mode 100644
index 000000000..da6a5e0e9
--- /dev/null
+++ b/Annex/FileMatcher.hs
@@ -0,0 +1,116 @@
+{- git-annex file matching
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.FileMatcher where
+
+import qualified Data.Map as M
+
+import Common.Annex
+import Limit
+import Utility.Matcher
+import Types.Group
+import Logs.Group
+import Logs.Remote
+import Annex.UUID
+import qualified Annex
+import Types.FileMatcher
+import Git.FilePath
+import Types.Remote (RemoteConfig)
+
+import Data.Either
+import qualified Data.Set as S
+
+checkFileMatcher :: (FileMatcher Annex) -> FilePath -> Annex Bool
+checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True
+
+checkMatcher :: (FileMatcher Annex) -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
+checkMatcher matcher mkey afile notpresent def
+ | isEmpty matcher = return def
+ | otherwise = case (mkey, afile) of
+ (_, Just file) -> go =<< fileMatchInfo file
+ (Just key, _) -> go (MatchingKey key)
+ _ -> return def
+ where
+ go mi = matchMrun matcher $ \a -> a notpresent mi
+
+fileMatchInfo :: FilePath -> Annex MatchInfo
+fileMatchInfo file = do
+ matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
+ return $ MatchingFile FileInfo
+ { matchFile = matchfile
+ , relFile = file
+ }
+
+matchAll :: FileMatcher Annex
+matchAll = generate []
+
+parsedToMatcher :: [Either String (Token (MatchFiles Annex))] -> Either String (FileMatcher Annex)
+parsedToMatcher parsed = case partitionEithers parsed of
+ ([], vs) -> Right $ generate vs
+ (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es
+
+exprParser :: FileMatcher Annex -> FileMatcher Annex -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))]
+exprParser matchstandard matchgroupwanted groupmap configmap mu expr =
+ map parse $ tokenizeMatcher expr
+ where
+ parse = parseToken
+ matchstandard
+ matchgroupwanted
+ (limitPresent mu)
+ (limitInDir preferreddir)
+ groupmap
+ preferreddir = fromMaybe "public" $
+ M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu
+
+parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex))
+parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t
+ | t `elem` tokens = Right $ token t
+ | t == "standard" = call matchstandard
+ | t == "groupwanted" = call matchgroupwanted
+ | t == "present" = use checkpresent
+ | t == "inpreferreddir" = use checkpreferreddir
+ | t == "unused" = Right $ Operation limitUnused
+ | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $
+ M.fromList
+ [ ("include", limitInclude)
+ , ("exclude", limitExclude)
+ , ("copies", limitCopies)
+ , ("lackingcopies", limitLackingCopies False)
+ , ("approxlackingcopies", limitLackingCopies True)
+ , ("inbackend", limitInBackend)
+ , ("largerthan", limitSize (>))
+ , ("smallerthan", limitSize (<))
+ , ("metadata", limitMetaData)
+ , ("inallgroup", limitInAllGroup groupmap)
+ ]
+ where
+ (k, v) = separate (== '=') t
+ use a = Operation <$> a v
+ call sub = Right $ Operation $ \notpresent mi ->
+ matchMrun sub $ \a -> a notpresent mi
+
+{- This is really dumb tokenization; there's no support for quoted values.
+ - Open and close parens are always treated as standalone tokens;
+ - otherwise tokens must be separated by whitespace. -}
+tokenizeMatcher :: String -> [String]
+tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
+ where
+ splitparens = segmentDelim (`elem` "()")
+
+{- Generates a matcher for files large enough (or meeting other criteria)
+ - to be added to the annex, rather than directly to git. -}
+largeFilesMatcher :: Annex (FileMatcher Annex)
+largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
+ where
+ go Nothing = return matchAll
+ go (Just expr) = do
+ gm <- groupMap
+ rc <- readRemoteLog
+ u <- getUUID
+ either badexpr return $
+ parsedToMatcher $ exprParser matchAll matchAll gm rc (Just u) expr
+ badexpr e = error $ "bad annex.largefiles configuration: " ++ e
diff --git a/Annex/Hook.hs b/Annex/Hook.hs
new file mode 100644
index 000000000..4848e2d61
--- /dev/null
+++ b/Annex/Hook.hs
@@ -0,0 +1,71 @@
+{- git-annex git hooks
+ -
+ - Note that it's important that the scripts installed by git-annex
+ - not change, otherwise removing old hooks using an old version of
+ - the script would fail.
+ -
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Hook where
+
+import Common.Annex
+import qualified Git.Hook as Git
+import Config
+import qualified Annex
+import Utility.Shell
+import Utility.FileMode
+
+import qualified Data.Map as M
+
+preCommitHook :: Git.Hook
+preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")
+
+preCommitAnnexHook :: Git.Hook
+preCommitAnnexHook = Git.Hook "pre-commit-annex" ""
+
+mkHookScript :: String -> String
+mkHookScript s = unlines
+ [ shebang_local
+ , "# automatically configured by git-annex"
+ , s
+ ]
+
+hookWrite :: Git.Hook -> Annex ()
+hookWrite h =
+ -- cannot have git hooks in a crippled filesystem (no execute bit)
+ unlessM crippledFileSystem $
+ unlessM (inRepo $ Git.hookWrite h) $
+ hookWarning h "already exists, not configuring"
+
+hookUnWrite :: Git.Hook -> Annex ()
+hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
+ hookWarning h "contents modified; not deleting. Edit it to remove call to git annex."
+
+hookWarning :: Git.Hook -> String -> Annex ()
+hookWarning h msg = do
+ r <- gitRepo
+ warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
+
+{- Runs a hook. To avoid checking if the hook exists every time,
+ - the existing hooks are cached. -}
+runAnnexHook :: Git.Hook -> Annex ()
+runAnnexHook hook = do
+ cmd <- fromRepo $ Git.hookFile hook
+ m <- Annex.getState Annex.existinghooks
+ case M.lookup hook m of
+ Just True -> run cmd
+ Just False -> noop
+ Nothing -> do
+ exists <- hookexists cmd
+ Annex.changeState $ \s -> s
+ { Annex.existinghooks = M.insert hook exists m }
+ when exists $
+ run cmd
+ where
+ hookexists f = liftIO $ catchBoolIO $
+ isExecutable . fileMode <$> getFileStatus f
+ run cmd = unlessM (liftIO $ boolSystem cmd []) $
+ warning $ cmd ++ " failed"
diff --git a/Annex/Index.hs b/Annex/Index.hs
new file mode 100644
index 000000000..a1b2442fc
--- /dev/null
+++ b/Annex/Index.hs
@@ -0,0 +1,46 @@
+{- Using other git index files
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Index (
+ withIndexFile,
+) where
+
+import qualified Control.Exception as E
+
+import Common.Annex
+import Git.Types
+import qualified Annex
+import Utility.Env
+import Annex.Exception
+
+{- Runs an action using a different git index file. -}
+withIndexFile :: FilePath -> Annex a -> Annex a
+withIndexFile f a = do
+ g <- gitRepo
+#ifdef __ANDROID__
+ {- This should not be necessary on Android, but there is some
+ - weird getEnvironment breakage. See
+ - https://github.com/neurocyte/ghc-android/issues/7
+ - Use getEnv to get some key environment variables that
+ - git expects to have. -}
+ let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"
+ let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k
+ e <- liftIO $ catMaybes <$> forM keyenv getEnvPair
+ let e' = ("GIT_INDEX_FILE", f):e
+#else
+ e <- liftIO getEnvironment
+ let e' = addEntry "GIT_INDEX_FILE" f e
+#endif
+ let g' = g { gitEnv = Just e' }
+
+ r <- tryAnnex $ do
+ Annex.changeState $ \s -> s { Annex.repo = g' }
+ a
+ Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
+ either E.throw return r
diff --git a/Annex/Init.hs b/Annex/Init.hs
new file mode 100644
index 000000000..e095aef61
--- /dev/null
+++ b/Annex/Init.hs
@@ -0,0 +1,239 @@
+{- git-annex repository initialization
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Init (
+ ensureInitialized,
+ isInitialized,
+ initialize,
+ uninitialize,
+ probeCrippledFileSystem,
+) where
+
+import Common.Annex
+import Utility.Network
+import qualified Annex
+import qualified Git
+import qualified Git.LsFiles
+import qualified Git.Config
+import qualified Git.Construct
+import qualified Git.Types as Git
+import qualified Annex.Branch
+import Logs.UUID
+import Annex.Version
+import Annex.UUID
+import Config
+import Annex.Direct
+import Annex.Content.Direct
+import Annex.Environment
+import Annex.Perms
+import Backend
+#ifndef mingw32_HOST_OS
+import Utility.UserInfo
+import Utility.FileMode
+#endif
+import Annex.Hook
+import Git.Hook (hookFile)
+import Upgrade
+import Annex.Content
+import Logs.Location
+
+import System.Log.Logger
+
+genDescription :: Maybe String -> Annex String
+genDescription (Just d) = return d
+genDescription Nothing = do
+ reldir <- liftIO . relHome =<< fromRepo Git.repoPath
+ hostname <- fromMaybe "" <$> liftIO getHostname
+#ifndef mingw32_HOST_OS
+ let at = if null hostname then "" else "@"
+ username <- liftIO myUserName
+ return $ concat [username, at, hostname, ":", reldir]
+#else
+ return $ concat [hostname, ":", reldir]
+#endif
+
+initialize :: Maybe String -> Annex ()
+initialize mdescription = do
+ prepUUID
+ checkFifoSupport
+ checkCrippledFileSystem
+ unlessM isBare $
+ hookWrite preCommitHook
+ setVersion supportedVersion
+ ifM (crippledFileSystem <&&> not <$> isBare)
+ ( do
+ enableDirectMode
+ setDirect True
+ -- Handle case where this repo was cloned from a
+ -- direct mode repo
+ , unlessM isBare
+ switchHEADBack
+ )
+ createInodeSentinalFile
+ u <- getUUID
+ {- This will make the first commit to git, so ensure git is set up
+ - properly to allow commits when running it. -}
+ ensureCommit $ do
+ Annex.Branch.create
+ describeUUID u =<< genDescription mdescription
+
+uninitialize :: Annex ()
+uninitialize = do
+ hookUnWrite preCommitHook
+ removeRepoUUID
+ removeVersion
+
+{- Will automatically initialize if there is already a git-annex
+ - branch from somewhere. Otherwise, require a manual init
+ - to avoid git-annex accidentially being run in git
+ - repos that did not intend to use it.
+ -
+ - Checks repository version and handles upgrades too.
+ -}
+ensureInitialized :: Annex ()
+ensureInitialized = do
+ getVersion >>= maybe needsinit checkUpgrade
+ fixBadBare
+ where
+ needsinit = ifM Annex.Branch.hasSibling
+ ( initialize Nothing
+ , error "First run: git-annex init"
+ )
+
+{- Checks if a repository is initialized. Does not check version for ugrade. -}
+isInitialized :: Annex Bool
+isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion
+
+isBare :: Annex Bool
+isBare = fromRepo Git.repoIsLocalBare
+
+{- A crippled filesystem is one that does not allow making symlinks,
+ - or removing write access from files. -}
+probeCrippledFileSystem :: Annex Bool
+probeCrippledFileSystem = do
+#ifdef mingw32_HOST_OS
+ return True
+#else
+ tmp <- fromRepo gitAnnexTmpMiscDir
+ let f = tmp </> "gaprobe"
+ createAnnexDirectory tmp
+ liftIO $ writeFile f ""
+ uncrippled <- liftIO $ probe f
+ liftIO $ removeFile f
+ return $ not uncrippled
+ where
+ probe f = catchBoolIO $ do
+ let f2 = f ++ "2"
+ nukeFile f2
+ createSymbolicLink f f2
+ nukeFile f2
+ preventWrite f
+ allowWrite f
+ return True
+#endif
+
+checkCrippledFileSystem :: Annex ()
+checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
+ warning "Detected a crippled filesystem."
+ setCrippledFileSystem True
+
+ {- Normally git disables core.symlinks itself when the
+ - filesystem does not support them, but in Cygwin, git
+ - does support symlinks, while git-annex, not linking
+ - with Cygwin, does not. -}
+ whenM (coreSymlinks <$> Annex.getGitConfig) $ do
+ warning "Disabling core.symlinks."
+ setConfig (ConfigKey "core.symlinks")
+ (Git.Config.boolConfig False)
+
+probeFifoSupport :: Annex Bool
+probeFifoSupport = do
+#ifdef mingw32_HOST_OS
+ return False
+#else
+ tmp <- fromRepo gitAnnexTmpMiscDir
+ let f = tmp </> "gaprobe"
+ createAnnexDirectory tmp
+ liftIO $ do
+ nukeFile f
+ ms <- tryIO $ do
+ createNamedPipe f ownerReadMode
+ getFileStatus f
+ nukeFile f
+ return $ either (const False) isNamedPipe ms
+#endif
+
+checkFifoSupport :: Annex ()
+checkFifoSupport = unlessM probeFifoSupport $ do
+ warning "Detected a filesystem without fifo support."
+ warning "Disabling ssh connection caching."
+ setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)
+
+enableDirectMode :: Annex ()
+enableDirectMode = unlessM isDirect $ do
+ warning "Enabling direct mode."
+ top <- fromRepo Git.repoPath
+ (l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+ forM_ l $ \f ->
+ maybe noop (`toDirect` f) =<< isAnnexLink f
+ void $ liftIO clean
+
+{- Work around for git-annex version 5.20131118 - 5.20131127, which
+ - had a bug that unset core.bare when initializing a bare repository.
+ -
+ - This resulted in objects sent to the repository being stored in
+ - repo/.git/annex/objects, so move them to repo/annex/objects.
+ -
+ - This check slows down every git-annex run somewhat (by one file stat),
+ - so should be removed after a suitable period of time has passed.
+ - Since the bare repository may be on an offline USB drive, best to
+ - keep it for a while. However, git-annex was only buggy for a few
+ - weeks, so not too long.
+ -}
+fixBadBare :: Annex ()
+fixBadBare = whenM checkBadBare $ do
+ ks <- getKeysPresent InAnnex
+ liftIO $ debugM "Init" $ unwords
+ [ "Detected bad bare repository with"
+ , show (length ks)
+ , "objects; fixing"
+ ]
+ g <- Annex.gitRepo
+ gc <- Annex.getGitConfig
+ d <- Git.repoPath <$> Annex.gitRepo
+ void $ liftIO $ boolSystem "git"
+ [ Param $ "--git-dir=" ++ d
+ , Param "config"
+ , Param Git.Config.coreBare
+ , Param $ Git.Config.boolConfig True
+ ]
+ g' <- liftIO $ Git.Construct.fromPath d
+ s' <- liftIO $ Annex.new $ g' { Git.location = Git.Local { Git.gitdir = d, Git.worktree = Nothing } }
+ Annex.changeState $ \s -> s
+ { Annex.repo = Annex.repo s'
+ , Annex.gitconfig = Annex.gitconfig s'
+ }
+ forM_ ks $ \k -> do
+ oldloc <- liftIO $ gitAnnexLocation k g gc
+ thawContentDir oldloc
+ moveAnnex k oldloc
+ logStatus k InfoPresent
+ let dotgit = d </> ".git"
+ liftIO $ removeDirectoryRecursive dotgit
+ `catchIO` const (renameDirectory dotgit (d </> "removeme"))
+
+{- A repostory with the problem won't know it's a bare repository, but will
+ - have no pre-commit hook (which is not set up in a bare repository),
+ - and will not have a HEAD file in its .git directory. -}
+checkBadBare :: Annex Bool
+checkBadBare = allM (not <$>)
+ [isBare, hasPreCommitHook, hasDotGitHEAD]
+ where
+ hasPreCommitHook = inRepo $ doesFileExist . hookFile preCommitHook
+ hasDotGitHEAD = inRepo $ \r -> doesFileExist $ Git.localGitDir r </> "HEAD"
diff --git a/Annex/Journal.hs b/Annex/Journal.hs
new file mode 100644
index 000000000..395e81d29
--- /dev/null
+++ b/Annex/Journal.hs
@@ -0,0 +1,127 @@
+{- 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
+ tmp <- fromRepo gitAnnexTmpMiscDir
+ createAnnexDirectory =<< fromRepo gitAnnexJournalDir
+ createAnnexDirectory tmp
+ -- journal file is written atomically
+ jfile <- fromRepo $ journalFile file
+ 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
diff --git a/Annex/Link.hs b/Annex/Link.hs
new file mode 100644
index 000000000..26991e911
--- /dev/null
+++ b/Annex/Link.hs
@@ -0,0 +1,105 @@
+{- git-annex links to content
+ -
+ - On file systems that support them, symlinks are used.
+ -
+ - On other filesystems, git instead stores the symlink target in a regular
+ - file.
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Link where
+
+import Common.Annex
+import qualified Annex
+import qualified Git.HashObject
+import qualified Git.UpdateIndex
+import qualified Annex.Queue
+import Git.Types
+import Git.FilePath
+
+type LinkTarget = String
+
+{- Checks if a file is a link to a key. -}
+isAnnexLink :: FilePath -> Annex (Maybe Key)
+isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file
+
+{- Gets the link target of a symlink.
+ -
+ - On a filesystem that does not support symlinks, fall back to getting the
+ - link target by looking inside the file.
+ -
+ - Returns Nothing if the file is not a symlink, or not a link to annex
+ - content.
+ -}
+getAnnexLinkTarget :: FilePath -> Annex (Maybe LinkTarget)
+getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
+ ( check readSymbolicLink $
+ return Nothing
+ , check readSymbolicLink $
+ check probefilecontent $
+ return Nothing
+ )
+ where
+ check getlinktarget fallback = do
+ v <- liftIO $ catchMaybeIO $ getlinktarget file
+ case v of
+ Just l
+ | isLinkToAnnex (fromInternalGitPath l) -> return v
+ | otherwise -> return Nothing
+ Nothing -> fallback
+
+ probefilecontent f = withFile f ReadMode $ \h -> do
+ fileEncoding h
+ -- The first 8k is more than enough to read; link
+ -- files are small.
+ s <- take 8192 <$> hGetContents h
+ -- If we got the full 8k, the file is too large
+ if length s == 8192
+ then return ""
+ else
+ -- If there are any NUL or newline
+ -- characters, or whitespace, we
+ -- certianly don't have a link to a
+ -- git-annex key.
+ return $ if any (`elem` s) "\0\n\r \t"
+ then ""
+ else s
+
+{- Creates a link on disk.
+ -
+ - On a filesystem that does not support symlinks, writes the link target
+ - to a file. Note that git will only treat the file as a symlink if
+ - it's staged as such, so use addAnnexLink when adding a new file or
+ - modified link to git.
+ -}
+makeAnnexLink :: LinkTarget -> FilePath -> Annex ()
+makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
+ ( liftIO $ do
+ void $ tryIO $ removeFile file
+ createSymbolicLink linktarget file
+ , liftIO $ writeFile file linktarget
+ )
+
+{- Creates a link on disk, and additionally stages it in git. -}
+addAnnexLink :: LinkTarget -> FilePath -> Annex ()
+addAnnexLink linktarget file = do
+ makeAnnexLink linktarget file
+ stageSymlink file =<< hashSymlink linktarget
+
+{- Injects a symlink target into git, returning its Sha. -}
+hashSymlink :: LinkTarget -> Annex Sha
+hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject $
+ toInternalGitPath linktarget
+
+hashSymlink' :: Git.HashObject.HashObjectHandle -> LinkTarget -> Annex Sha
+hashSymlink' h linktarget = liftIO $ Git.HashObject.hashBlob h $
+ toInternalGitPath linktarget
+
+{- Stages a symlink to the annex, using a Sha of its target. -}
+stageSymlink :: FilePath -> Sha -> Annex ()
+stageSymlink file sha =
+ Annex.Queue.addUpdateIndex =<<
+ inRepo (Git.UpdateIndex.stageSymlink file sha)
diff --git a/Annex/LockPool.hs b/Annex/LockPool.hs
new file mode 100644
index 000000000..5fc167d28
--- /dev/null
+++ b/Annex/LockPool.hs
@@ -0,0 +1,60 @@
+{- git-annex lock pool
+ -
+ - Copyright 2012, 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.LockPool where
+
+import Common.Annex
+import Annex
+import Types.LockPool
+
+import qualified Data.Map as M
+
+#ifndef mingw32_HOST_OS
+import Annex.Perms
+#else
+import Utility.WinLock
+#endif
+
+{- Create a specified lock file, and takes a shared lock. -}
+lockFile :: FilePath -> Annex ()
+lockFile file = go =<< fromPool file
+ where
+ go (Just _) = noop -- already locked
+ go Nothing = do
+#ifndef mingw32_HOST_OS
+ mode <- annexFileMode
+ lockhandle <- liftIO $ noUmask mode $
+ openFd file ReadOnly (Just mode) defaultFileFlags
+ liftIO $ waitToSetLock lockhandle (ReadLock, AbsoluteSeek, 0, 0)
+#else
+ lockhandle <- liftIO $ waitToLock $ lockShared file
+#endif
+ changePool $ M.insert file lockhandle
+
+unlockFile :: FilePath -> Annex ()
+unlockFile file = maybe noop go =<< fromPool file
+ where
+ go lockhandle = do
+#ifndef mingw32_HOST_OS
+ liftIO $ closeFd lockhandle
+#else
+ liftIO $ dropLock lockhandle
+#endif
+ changePool $ M.delete file
+
+getPool :: Annex LockPool
+getPool = getState lockpool
+
+fromPool :: FilePath -> Annex (Maybe LockHandle)
+fromPool file = M.lookup file <$> getPool
+
+changePool :: (LockPool -> LockPool) -> Annex ()
+changePool a = do
+ m <- getPool
+ changeState $ \s -> s { lockpool = a m }
diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs
new file mode 100644
index 000000000..f382f0ab1
--- /dev/null
+++ b/Annex/MetaData.hs
@@ -0,0 +1,56 @@
+{- git-annex metadata
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.MetaData (
+ genMetaData,
+ module X
+) where
+
+import Common.Annex
+import qualified Annex
+import Types.MetaData as X
+import Annex.MetaData.StandardFields as X
+import Logs.MetaData
+import Annex.CatFile
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+
+{- Adds metadata for a file that has just been ingested into the
+ - annex, but has not yet been committed to git.
+ -
+ - When the file has been modified, the metadata is copied over
+ - from the old key to the new key. Note that it looks at the old key as
+ - committed to HEAD -- the new key may or may not have already been staged
+ - in th annex.
+ -
+ - Also, can generate new metadata, if configured to do so.
+ -}
+genMetaData :: Key -> FilePath -> FileStatus -> Annex ()
+genMetaData key file status = do
+ maybe noop (flip copyMetaData key) =<< catKeyFileHEAD file
+ whenM (annexGenMetaData <$> Annex.getGitConfig) $ do
+ metadata <- getCurrentMetaData key
+ let metadata' = genMetaData' status metadata
+ unless (metadata' == emptyMetaData) $
+ addMetaData key metadata'
+
+{- Generates metadata from the FileStatus.
+ - Does not overwrite any existing metadata values. -}
+genMetaData' :: FileStatus -> MetaData -> MetaData
+genMetaData' status old = MetaData $ M.fromList $ filter isnew
+ [ (yearMetaField, S.singleton $ toMetaValue $ show y)
+ , (monthMetaField, S.singleton $ toMetaValue $ show m)
+ ]
+ where
+ isnew (f, _) = S.null (currentMetaDataValues f old)
+ (y, m, _d) = toGregorian $ utctDay $
+ posixSecondsToUTCTime $ realToFrac $
+ modificationTime status
diff --git a/Annex/MetaData/StandardFields.hs b/Annex/MetaData/StandardFields.hs
new file mode 100644
index 000000000..d41fb1506
--- /dev/null
+++ b/Annex/MetaData/StandardFields.hs
@@ -0,0 +1,47 @@
+{- git-annex metadata, standard fields
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.MetaData.StandardFields (
+ tagMetaField,
+ yearMetaField,
+ monthMetaField,
+ lastChangedField,
+ mkLastChangedField,
+ isLastChangedField
+) where
+
+import Types.MetaData
+
+import Data.List
+
+tagMetaField :: MetaField
+tagMetaField = mkMetaFieldUnchecked "tag"
+
+yearMetaField :: MetaField
+yearMetaField = mkMetaFieldUnchecked "year"
+
+monthMetaField :: MetaField
+monthMetaField = mkMetaFieldUnchecked "month"
+
+lastChangedField :: MetaField
+lastChangedField = mkMetaFieldUnchecked lastchanged
+
+mkLastChangedField :: MetaField -> MetaField
+mkLastChangedField f = mkMetaFieldUnchecked (fromMetaField f ++ lastchangedSuffix)
+
+isLastChangedField :: MetaField -> Bool
+isLastChangedField f
+ | f == lastChangedField = True
+ | otherwise = lastchanged `isSuffixOf` s && s /= lastchangedSuffix
+ where
+ s = fromMetaField f
+
+lastchanged :: String
+lastchanged = "lastchanged"
+
+lastchangedSuffix :: String
+lastchangedSuffix = "-lastchanged"
diff --git a/Annex/Notification.hs b/Annex/Notification.hs
new file mode 100644
index 000000000..06a099888
--- /dev/null
+++ b/Annex/Notification.hs
@@ -0,0 +1,81 @@
+{- git-annex desktop notifications
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Notification where
+
+import Common.Annex
+import Logs.Transfer
+#ifdef WITH_DBUS_NOTIFICATIONS
+import qualified Annex
+import Types.DesktopNotify
+import qualified DBus.Notify as Notify
+import qualified DBus.Client
+#endif
+
+-- Witness that notification has happened.
+data NotifyWitness = NotifyWitness
+
+{- Wrap around an action that performs a transfer, which may run multiple
+ - attempts. Displays notification when supported and when the user asked
+ - for it. -}
+notifyTransfer :: Direction -> Maybe FilePath -> (NotifyWitness -> Annex Bool) -> Annex Bool
+notifyTransfer _ Nothing a = a NotifyWitness
+#ifdef WITH_DBUS_NOTIFICATIONS
+notifyTransfer direction (Just f) a = do
+ wanted <- Annex.getState Annex.desktopnotify
+ let action = if direction == Upload then "uploading" else "downloading"
+ let basedesc = action ++ " " ++ f
+ let startdesc = "started " ++ basedesc
+ let enddesc ok = if ok
+ then "finished " ++ basedesc
+ else basedesc ++ " failed"
+ if (notifyStart wanted || notifyFinish wanted)
+ then do
+ client <- liftIO DBus.Client.connectSession
+ startnotification <- liftIO $ if notifyStart wanted
+ then Just <$> Notify.notify client (mkNote startdesc)
+ else pure Nothing
+ ok <- a NotifyWitness
+ when (notifyFinish wanted) $ liftIO $ void $ maybe
+ (Notify.notify client $ mkNote $ enddesc ok)
+ (\n -> Notify.replace client n $ mkNote $ enddesc ok)
+ startnotification
+ return ok
+ else a NotifyWitness
+#else
+notifyTransfer _ (Just _) a = do a NotifyWitness
+#endif
+
+notifyDrop :: Maybe FilePath -> Bool -> Annex ()
+notifyDrop Nothing _ = noop
+#ifdef WITH_DBUS_NOTIFICATIONS
+notifyDrop (Just f) ok = do
+ wanted <- Annex.getState Annex.desktopnotify
+ when (notifyFinish wanted) $ liftIO $ do
+ client <- DBus.Client.connectSession
+ let msg = if ok
+ then "dropped " ++ f
+ else "failed to drop" ++ f
+ void $ Notify.notify client (mkNote msg)
+#else
+notifyDrop (Just _) _ = noop
+#endif
+
+#ifdef WITH_DBUS_NOTIFICATIONS
+mkNote :: String -> Notify.Note
+mkNote desc = Notify.blankNote
+ { Notify.appName = "git-annex"
+ , Notify.body = Just $ Notify.Text desc
+ , Notify.hints =
+ [ Notify.Category Notify.Transfer
+ , Notify.Urgency Notify.Low
+ , Notify.SuppressSound True
+ ]
+ }
+#endif
diff --git a/Annex/Path.hs b/Annex/Path.hs
new file mode 100644
index 000000000..a8c4907b2
--- /dev/null
+++ b/Annex/Path.hs
@@ -0,0 +1,34 @@
+{- git-annex program path
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Path where
+
+import Common
+import Config.Files
+import System.Environment
+
+{- A fully qualified path to the currently running git-annex program.
+ -
+ - getExecutablePath is available since ghc 7.4.2. On OSs it supports
+ - well, it returns the complete path to the program. But, on other OSs,
+ - it might return just the basename.
+ -}
+programPath :: IO (Maybe FilePath)
+programPath = do
+#if MIN_VERSION_base(4,6,0)
+ exe <- getExecutablePath
+ p <- if isAbsolute exe
+ then return exe
+ else readProgramFile
+#else
+ p <- readProgramFile
+#endif
+ -- In case readProgramFile returned just the command name,
+ -- fall back to finding it in PATH.
+ searchPath p
diff --git a/Annex/Perms.hs b/Annex/Perms.hs
new file mode 100644
index 000000000..e3a2fa65a
--- /dev/null
+++ b/Annex/Perms.hs
@@ -0,0 +1,125 @@
+{- git-annex file permissions
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Perms (
+ setAnnexFilePerm,
+ setAnnexDirPerm,
+ annexFileMode,
+ createAnnexDirectory,
+ noUmask,
+ createContentDir,
+ freezeContentDir,
+ thawContentDir,
+ modifyContent,
+) where
+
+import Common.Annex
+import Utility.FileMode
+import Git.SharedRepository
+import qualified Annex
+import Annex.Exception
+import Config
+
+import System.Posix.Types
+
+withShared :: (SharedRepository -> Annex a) -> Annex a
+withShared a = maybe startup a =<< Annex.getState Annex.shared
+ where
+ startup = do
+ shared <- fromRepo getSharedRepository
+ Annex.changeState $ \s -> s { Annex.shared = Just shared }
+ a shared
+
+setAnnexFilePerm :: FilePath -> Annex ()
+setAnnexFilePerm = setAnnexPerm False
+
+setAnnexDirPerm :: FilePath -> Annex ()
+setAnnexDirPerm = setAnnexPerm True
+
+{- 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 :: Bool -> FilePath -> Annex ()
+setAnnexPerm isdir file = unlessM crippledFileSystem $
+ withShared $ liftIO . go
+ where
+ go GroupShared = modifyFileMode file $ addModes $
+ groupSharedModes ++
+ if isdir then [ ownerExecuteMode, groupExecuteMode ] else []
+ go AllShared = modifyFileMode file $ addModes $
+ readModes ++
+ [ ownerWriteMode, groupWriteMode ] ++
+ if isdir then executeModes else []
+ go _ = noop
+
+{- 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 = withShared $ return . go
+ where
+ go GroupShared = sharedmode
+ go AllShared = combineModes (sharedmode:readModes)
+ go _ = stdFileMode
+ sharedmode = combineModes groupSharedModes
+
+{- 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 $ createDirectoryIfMissing True p
+ setAnnexDirPerm p
+
+{- 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 = unlessM crippledFileSystem $
+ liftIO . go =<< fromRepo getSharedRepository
+ where
+ dir = parentDir file
+ go GroupShared = groupWriteRead dir
+ go AllShared = groupWriteRead dir
+ go _ = preventWrite dir
+
+thawContentDir :: FilePath -> Annex ()
+thawContentDir file = unlessM crippledFileSystem $
+ liftIO $ allowWrite $ parentDir file
+
+{- 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
+ unlessM crippledFileSystem $
+ liftIO $ allowWrite dir
+ where
+ dir = parentDir dest
+
+{- Creates the content directory for a file if it doesn't already exist,
+ - or thaws it if it does, then runs an action to modify the file, and
+ - finally, freezes the content directory. -}
+modifyContent :: FilePath -> Annex a -> Annex a
+modifyContent f a = do
+ createContentDir f -- also thaws it
+ v <- tryAnnex a
+ freezeContentDir f
+ either throwAnnex return v
diff --git a/Annex/Queue.hs b/Annex/Queue.hs
new file mode 100644
index 000000000..a5ef60037
--- /dev/null
+++ b/Annex/Queue.hs
@@ -0,0 +1,62 @@
+{- git-annex command queue
+ -
+ - Copyright 2011, 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Queue (
+ addCommand,
+ addUpdateIndex,
+ flush,
+ flushWhenFull,
+ size
+) where
+
+import Common.Annex
+import Annex hiding (new)
+import qualified Git.Queue
+import qualified Git.UpdateIndex
+
+{- Adds a git command to the queue. -}
+addCommand :: String -> [CommandParam] -> [FilePath] -> Annex ()
+addCommand command params files = do
+ q <- get
+ store <=< inRepo $ Git.Queue.addCommand command params files q
+
+{- Adds an update-index stream to the queue. -}
+addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex ()
+addUpdateIndex streamer = do
+ q <- get
+ store <=< inRepo $ Git.Queue.addUpdateIndex streamer q
+
+{- Runs the queue if it is full. Should be called periodically. -}
+flushWhenFull :: Annex ()
+flushWhenFull = do
+ q <- get
+ when (Git.Queue.full q) flush
+
+{- Runs (and empties) the queue. -}
+flush :: Annex ()
+flush = do
+ q <- get
+ unless (0 == Git.Queue.size q) $ do
+ showStoringStateAction
+ q' <- inRepo $ Git.Queue.flush q
+ store q'
+
+{- Gets the size of the queue. -}
+size :: Annex Int
+size = Git.Queue.size <$> get
+
+get :: Annex Git.Queue.Queue
+get = maybe new return =<< getState repoqueue
+
+new :: Annex Git.Queue.Queue
+new = do
+ q <- Git.Queue.new . annexQueueSize <$> getGitConfig
+ store q
+ return q
+
+store :: Git.Queue.Queue -> Annex ()
+store q = changeState $ \s -> s { repoqueue = Just q }
diff --git a/Annex/Quvi.hs b/Annex/Quvi.hs
new file mode 100644
index 000000000..1a2edf6b8
--- /dev/null
+++ b/Annex/Quvi.hs
@@ -0,0 +1,33 @@
+{- quvi options for git-annex
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE Rank2Types #-}
+
+module Annex.Quvi where
+
+import Common.Annex
+import qualified Annex
+import Utility.Quvi
+import Utility.Url
+
+withQuviOptions :: forall a. Query a -> [QuviParam] -> URLString -> Annex a
+withQuviOptions a ps url = do
+ v <- quviVersion
+ opts <- map Param . annexQuviOptions <$> Annex.getGitConfig
+ liftIO $ a v (map (\mkp -> mkp v) ps++opts) url
+
+quviSupported :: URLString -> Annex Bool
+quviSupported u = liftIO . flip supported u =<< quviVersion
+
+quviVersion :: Annex QuviVersion
+quviVersion = go =<< Annex.getState Annex.quviversion
+ where
+ go (Just v) = return v
+ go Nothing = do
+ v <- liftIO probeVersion
+ Annex.changeState $ \s -> s { Annex.quviversion = Just v }
+ return v
diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs
new file mode 100644
index 000000000..8b15f5ce3
--- /dev/null
+++ b/Annex/ReplaceFile.hs
@@ -0,0 +1,39 @@
+{- git-annex file replacing
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.ReplaceFile where
+
+import Common.Annex
+import Annex.Perms
+import Annex.Exception
+
+{- Replaces a possibly already existing file with a new version,
+ - atomically, by running an action.
+ -
+ - The action is passed a temp file, which it can write to, and once
+ - done the temp file is moved into place.
+ -
+ - The action can throw an IO exception, in which case the temp file
+ - will be deleted, and the existing file will be preserved.
+ -
+ - Throws an IO exception when it was unable to replace the file.
+ -}
+replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()
+replaceFile file a = do
+ tmpdir <- fromRepo gitAnnexTmpMiscDir
+ void $ createAnnexDirectory tmpdir
+ bracketIO (setup tmpdir) nukeFile $ \tmpfile -> do
+ a tmpfile
+ liftIO $ catchIO (rename tmpfile file) (fallback tmpfile)
+ where
+ setup tmpdir = do
+ (tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp"
+ hClose h
+ return tmpfile
+ fallback tmpfile _ = do
+ createDirectoryIfMissing True $ parentDir file
+ moveFile tmpfile file
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
new file mode 100644
index 000000000..bd10a40d4
--- /dev/null
+++ b/Annex/Ssh.hs
@@ -0,0 +1,201 @@
+{- git-annex ssh interface, with connection caching
+ -
+ - Copyright 2012,2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Ssh (
+ sshCachingOptions,
+ sshCacheDir,
+ sshReadPort,
+) where
+
+import qualified Data.Map as M
+import Data.Hash.MD5
+import System.Process (cwd)
+
+import Common.Annex
+import Annex.LockPool
+import qualified Build.SysConfig as SysConfig
+import qualified Annex
+import Config
+import Utility.Env
+import Types.CleanupActions
+#ifndef mingw32_HOST_OS
+import Annex.Perms
+#endif
+
+{- Generates parameters to ssh to a given host (or user@host) on a given
+ - port, with connection caching. -}
+sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]
+sshCachingOptions (host, port) opts = do
+ Annex.addCleanup SshCachingCleanup sshCleanup
+ go =<< sshInfo (host, port)
+ where
+ go (Nothing, params) = ret params
+ go (Just socketfile, params) = do
+ cleanstale
+ liftIO $ createDirectoryIfMissing True $ parentDir socketfile
+ lockFile $ socket2lock socketfile
+ ret params
+ ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"]
+ -- If the lock pool is empty, this is the first ssh of this
+ -- run. There could be stale ssh connections hanging around
+ -- from a previous git-annex run that was interrupted.
+ cleanstale = whenM (not . any isLock . M.keys <$> getPool)
+ sshCleanup
+
+{- Returns a filename to use for a ssh connection caching socket, and
+ - parameters to enable ssh connection caching. -}
+sshInfo :: (String, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
+sshInfo (host, port) = go =<< sshCacheDir
+ where
+ go Nothing = return (Nothing, [])
+ go (Just dir) = do
+ r <- liftIO $ bestSocketPath $ dir </> hostport2socket host port
+ return $ case r of
+ Nothing -> (Nothing, [])
+ Just socketfile -> (Just socketfile, sshConnectionCachingParams socketfile)
+
+{- Given an absolute path to use for a socket file,
+ - returns whichever is shorter of that or the relative path to the same
+ - file.
+ -
+ - If no path can be constructed that is a valid socket, returns Nothing. -}
+bestSocketPath :: FilePath -> IO (Maybe FilePath)
+bestSocketPath abssocketfile = do
+ relsocketfile <- liftIO $ relPathCwdToFile abssocketfile
+ let socketfile = if length abssocketfile <= length relsocketfile
+ then abssocketfile
+ else relsocketfile
+ return $ if valid_unix_socket_path (socketfile ++ sshgarbage)
+ then Just socketfile
+ else Nothing
+ where
+ -- ssh appends a 16 char extension to the socket when setting it
+ -- up, which needs to be taken into account when checking
+ -- that a valid socket was constructed.
+ sshgarbage = replicate (1+16) 'X'
+
+sshConnectionCachingParams :: FilePath -> [CommandParam]
+sshConnectionCachingParams socketfile =
+ [ Param "-S", Param socketfile
+ , Params "-o ControlMaster=auto -o ControlPersist=yes"
+ ]
+
+{- ssh connection caching creates sockets, so will not work on a
+ - crippled filesystem. A GIT_ANNEX_TMP_DIR can be provided to use
+ - a different filesystem. -}
+sshCacheDir :: Annex (Maybe FilePath)
+sshCacheDir
+ | SysConfig.sshconnectioncaching = ifM crippledFileSystem
+ ( maybe (return Nothing) usetmpdir =<< gettmpdir
+ , ifM (fromMaybe True . annexSshCaching <$> Annex.getGitConfig)
+ ( Just <$> fromRepo gitAnnexSshDir
+ , return Nothing
+ )
+ )
+ | otherwise = return Nothing
+ where
+ gettmpdir = liftIO $ getEnv "GIT_ANNEX_TMP_DIR"
+ usetmpdir tmpdir = liftIO $ catchMaybeIO $ do
+ createDirectoryIfMissing True tmpdir
+ return tmpdir
+
+portParams :: Maybe Integer -> [CommandParam]
+portParams Nothing = []
+portParams (Just port) = [Param "-p", Param $ show port]
+
+{- Stop any unused ssh processes. -}
+sshCleanup :: Annex ()
+sshCleanup = go =<< sshCacheDir
+ where
+ go Nothing = noop
+ go (Just dir) = do
+ sockets <- liftIO $ filter (not . isLock)
+ <$> catchDefaultIO [] (dirContents dir)
+ forM_ sockets cleanup
+ cleanup socketfile = do
+#ifndef mingw32_HOST_OS
+ -- Drop any shared lock we have, and take an
+ -- exclusive lock, without blocking. If the lock
+ -- succeeds, nothing is using this ssh, and it can
+ -- be stopped.
+ let lockfile = socket2lock socketfile
+ unlockFile lockfile
+ mode <- annexFileMode
+ fd <- liftIO $ noUmask mode $
+ openFd lockfile ReadWrite (Just mode) defaultFileFlags
+ v <- liftIO $ tryIO $
+ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+ case v of
+ Left _ -> noop
+ Right _ -> stopssh socketfile
+ liftIO $ closeFd fd
+#else
+ stopssh socketfile
+#endif
+ stopssh socketfile = do
+ let (dir, base) = splitFileName socketfile
+ let params = sshConnectionCachingParams base
+ -- "ssh -O stop" is noisy on stderr even with -q
+ void $ liftIO $ catchMaybeIO $
+ withQuietOutput createProcessSuccess $
+ (proc "ssh" $ toCommand $
+ [ Params "-O stop"
+ ] ++ params ++ [Param "localhost"])
+ { cwd = Just dir }
+ liftIO $ nukeFile socketfile
+ -- Cannot remove the lock file; other processes may
+ -- be waiting on our exclusive lock to use it.
+
+{- This needs to be as short as possible, due to limitations on the length
+ - of the path to a socket file. At the same time, it needs to be unique
+ - for each host.
+ -}
+hostport2socket :: String -> Maybe Integer -> FilePath
+hostport2socket host Nothing = hostport2socket' host
+hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
+hostport2socket' :: String -> FilePath
+hostport2socket' s
+ | length s > lengthofmd5s = md5s (Str s)
+ | otherwise = s
+ where
+ lengthofmd5s = 32
+
+socket2lock :: FilePath -> FilePath
+socket2lock socket = socket ++ lockExt
+
+isLock :: FilePath -> Bool
+isLock f = lockExt `isSuffixOf` f
+
+lockExt :: String
+lockExt = ".lock"
+
+{- This is the size of the sun_path component of sockaddr_un, which
+ - is the limit to the total length of the filename of a unix socket.
+ -
+ - On Linux, this is 108. On OSX, 104. TODO: Probe
+ -}
+sizeof_sockaddr_un_sun_path :: Int
+sizeof_sockaddr_un_sun_path = 100
+
+{- Note that this looks at the true length of the path in bytes, as it will
+ - appear on disk. -}
+valid_unix_socket_path :: FilePath -> Bool
+valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path
+
+{- Parses the SSH port, and returns the other OpenSSH options. If
+ - several ports are found, the last one takes precedence. -}
+sshReadPort :: [String] -> (Maybe Integer, [String])
+sshReadPort params = (port, reverse args)
+ where
+ (port,args) = aux (Nothing, []) params
+ aux (p,ps) [] = (p,ps)
+ aux (_,ps) ("-p":p:rest) = aux (readPort p, ps) rest
+ aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest
+ | otherwise = aux (p,q:ps) rest
+ readPort p = fmap fst $ listToMaybe $ reads p
diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs
new file mode 100644
index 000000000..35fdf333c
--- /dev/null
+++ b/Annex/TaggedPush.hs
@@ -0,0 +1,61 @@
+{- git-annex tagged pushes
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.TaggedPush where
+
+import Common.Annex
+import qualified Remote
+import qualified Annex.Branch
+import qualified Git
+import qualified Git.Ref
+import qualified Git.Command
+import qualified Git.Branch
+import Utility.Base64
+
+{- Converts a git branch into a branch that is tagged with a UUID, typically
+ - the UUID of the repo that will be pushing it, and possibly with other
+ - information.
+ -
+ - Pushing to branches on the remote that have our uuid in them is ugly,
+ - but it reserves those branches for pushing by us, and so our pushes will
+ - never conflict with other pushes.
+ -
+ - To avoid cluttering up the branch display, the branch is put under
+ - refs/synced/, rather than the usual refs/remotes/
+ -
+ - Both UUIDs and Base64 encoded data are always legal to be used in git
+ - refs, per git-check-ref-format.
+ -}
+toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch
+toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
+ [ Just "refs/synced"
+ , Just $ fromUUID u
+ , toB64 <$> info
+ , Just $ Git.fromRef $ Git.Ref.base b
+ ]
+
+fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String)
+fromTaggedBranch b = case split "/" $ Git.fromRef b of
+ ("refs":"synced":u:info:_base) ->
+ Just (toUUID u, fromB64Maybe info)
+ ("refs":"synced":u:_base) ->
+ Just (toUUID u, Nothing)
+ _ -> Nothing
+ where
+
+taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool
+taggedPush u info branch remote = Git.Command.runBool
+ [ Param "push"
+ , Param $ Remote.name remote
+ {- Using forcePush here is safe because we "own" the tagged branch
+ - we're pushing; it has no other writers. Ensures it is pushed
+ - even if it has been rewritten by a transition. -}
+ , Param $ Git.Branch.forcePush $ refspec Annex.Branch.name
+ , Param $ refspec branch
+ ]
+ where
+ refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
new file mode 100644
index 000000000..df5aba09c
--- /dev/null
+++ b/Annex/Transfer.hs
@@ -0,0 +1,131 @@
+{- git-annex transfers
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Transfer (
+ module X,
+ upload,
+ download,
+ runTransfer,
+ noRetry,
+ forwardRetry,
+) where
+
+import Common.Annex
+import Logs.Transfer as X
+import Annex.Notification as X
+import Annex.Perms
+import Annex.Exception
+import Utility.Metered
+#ifdef mingw32_HOST_OS
+import Utility.WinLock
+#endif
+
+import Control.Concurrent
+
+upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
+upload u key f d a _witness = runTransfer (Transfer Upload u key) f d a
+
+download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
+download u key f d a _witness = runTransfer (Transfer Download u key) f d a
+
+{- Runs a transfer action. Creates and locks the lock file while the
+ - action is running, and stores info in the transfer information
+ - file.
+ -
+ - If the transfer action returns False, the transfer info is
+ - left in the failedTransferDir.
+ -
+ - If the transfer is already in progress, returns False.
+ -
+ - An upload can be run from a read-only filesystem, and in this case
+ - no transfer information or lock file is used.
+ -}
+runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
+runTransfer t file shouldretry a = do
+ info <- liftIO $ startTransferInfo file
+ (meter, tfile, metervar) <- mkProgressUpdater t info
+ mode <- annexFileMode
+ (fd, inprogress) <- liftIO $ prep tfile mode info
+ if inprogress
+ then do
+ showNote "transfer already in progress"
+ return False
+ else do
+ ok <- retry info metervar $
+ bracketIO (return fd) (cleanup tfile) (const $ a meter)
+ unless ok $ recordFailedTransfer t info
+ return ok
+ where
+#ifndef mingw32_HOST_OS
+ prep tfile mode info = do
+ mfd <- catchMaybeIO $
+ openFd (transferLockFile tfile) ReadWrite (Just mode)
+ defaultFileFlags { trunc = True }
+ case mfd of
+ Nothing -> return (Nothing, False)
+ Just fd -> do
+ locked <- catchMaybeIO $
+ setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+ if isNothing locked
+ then return (Nothing, True)
+ else do
+ void $ tryIO $ writeTransferInfoFile info tfile
+ return (mfd, False)
+#else
+ prep tfile _mode info = do
+ v <- catchMaybeIO $ lockExclusive (transferLockFile tfile)
+ case v of
+ Nothing -> return (Nothing, False)
+ Just Nothing -> return (Nothing, True)
+ Just (Just lockhandle) -> do
+ void $ tryIO $ writeTransferInfoFile info tfile
+ return (Just lockhandle, False)
+#endif
+ cleanup _ Nothing = noop
+ cleanup tfile (Just lockhandle) = do
+ void $ tryIO $ removeFile tfile
+#ifndef mingw32_HOST_OS
+ void $ tryIO $ removeFile $ transferLockFile tfile
+ closeFd lockhandle
+#else
+ {- Windows cannot delete the lockfile until the lock
+ - is closed. So it's possible to race with another
+ - process that takes the lock before it's removed,
+ - so ignore failure to remove.
+ -}
+ dropLock lockhandle
+ void $ tryIO $ removeFile $ transferLockFile tfile
+#endif
+ retry oldinfo metervar run = do
+ v <- tryAnnex run
+ case v of
+ Right b -> return b
+ Left _ -> do
+ b <- getbytescomplete metervar
+ let newinfo = oldinfo { bytesComplete = Just b }
+ if shouldretry oldinfo newinfo
+ then retry newinfo metervar run
+ else return False
+ getbytescomplete metervar
+ | transferDirection t == Upload =
+ liftIO $ readMVar metervar
+ | otherwise = do
+ f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
+ liftIO $ catchDefaultIO 0 $
+ fromIntegral . fileSize <$> getFileStatus f
+
+type RetryDecider = TransferInfo -> TransferInfo -> Bool
+
+noRetry :: RetryDecider
+noRetry _ _ = False
+
+{- Retries a transfer when it fails, as long as the failed transfer managed
+ - to send some data. -}
+forwardRetry :: RetryDecider
+forwardRetry old new = bytesComplete old < bytesComplete new
diff --git a/Annex/UUID.hs b/Annex/UUID.hs
new file mode 100644
index 000000000..4e274503b
--- /dev/null
+++ b/Annex/UUID.hs
@@ -0,0 +1,96 @@
+{- git-annex uuids
+ -
+ - Each git repository used by git-annex has an annex.uuid setting that
+ - uniquely identifies that repository.
+ -
+ - UUIDs of remotes are cached in git config, using keys named
+ - remote.<name>.annex-uuid
+ -
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.UUID (
+ getUUID,
+ getRepoUUID,
+ getUncachedUUID,
+ prepUUID,
+ genUUID,
+ genUUIDInNameSpace,
+ gCryptNameSpace,
+ removeRepoUUID,
+ storeUUID,
+ setUUID,
+) where
+
+import Common.Annex
+import qualified Git
+import qualified Git.Config
+import Config
+
+import qualified Data.UUID as U
+import qualified Data.UUID.V5 as U5
+import System.Random
+import Data.Bits.Utils
+
+configkey :: ConfigKey
+configkey = annexConfig "uuid"
+
+{- Generates a random UUID, that does not include the MAC address. -}
+genUUID :: IO UUID
+genUUID = UUID . show <$> (randomIO :: IO U.UUID)
+
+{- Generates a UUID from a given string, using a namespace.
+ - Given the same namespace, the same string will always result
+ - in the same UUID. -}
+genUUIDInNameSpace :: U.UUID -> String -> UUID
+genUUIDInNameSpace namespace = UUID . show . U5.generateNamed namespace . s2w8
+
+{- Namespace used for UUIDs derived from git-remote-gcrypt ids. -}
+gCryptNameSpace :: U.UUID
+gCryptNameSpace = U5.generateNamed U5.namespaceURL $
+ s2w8 "http://git-annex.branchable.com/design/gcrypt/"
+
+{- Get current repository's UUID. -}
+getUUID :: Annex UUID
+getUUID = getRepoUUID =<< gitRepo
+
+{- Looks up a repo's UUID, caching it in .git/config if it's not already. -}
+getRepoUUID :: Git.Repo -> Annex UUID
+getRepoUUID r = do
+ c <- toUUID <$> getConfig cachekey ""
+ let u = getUncachedUUID r
+
+ if c /= u && u /= NoUUID
+ then do
+ updatecache u
+ return u
+ else return c
+ where
+ updatecache u = do
+ g <- gitRepo
+ when (g /= r) $ storeUUID cachekey u
+ cachekey = remoteConfig r "uuid"
+
+removeRepoUUID :: Annex ()
+removeRepoUUID = unsetConfig configkey
+
+getUncachedUUID :: Git.Repo -> UUID
+getUncachedUUID = toUUID . Git.Config.get key ""
+ where
+ (ConfigKey key) = configkey
+
+{- Make sure that the repo has an annex.uuid setting. -}
+prepUUID :: Annex ()
+prepUUID = whenM ((==) NoUUID <$> getUUID) $
+ storeUUID configkey =<< liftIO genUUID
+
+storeUUID :: ConfigKey -> UUID -> Annex ()
+storeUUID configfield = setConfig configfield . fromUUID
+
+{- Only sets the configkey in the Repo; does not change .git/config -}
+setUUID :: Git.Repo -> UUID -> IO Git.Repo
+setUUID r u = do
+ let s = show configkey ++ "=" ++ fromUUID u
+ Git.Config.store s r
diff --git a/Annex/Url.hs b/Annex/Url.hs
new file mode 100644
index 000000000..397a7910b
--- /dev/null
+++ b/Annex/Url.hs
@@ -0,0 +1,42 @@
+{- Url downloading, with git-annex user agent and configured http
+ - headers and wget/curl options.
+ -
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Url (
+ module U,
+ withUrlOptions,
+ getUrlOptions,
+ getUserAgent,
+) where
+
+import Common.Annex
+import qualified Annex
+import Utility.Url as U
+import qualified Build.SysConfig as SysConfig
+
+defaultUserAgent :: U.UserAgent
+defaultUserAgent = "git-annex/" ++ SysConfig.packageversion
+
+getUserAgent :: Annex (Maybe U.UserAgent)
+getUserAgent = Annex.getState $
+ Just . fromMaybe defaultUserAgent . Annex.useragent
+
+getUrlOptions :: Annex U.UrlOptions
+getUrlOptions = U.UrlOptions
+ <$> getUserAgent
+ <*> headers
+ <*> options
+ where
+ headers = do
+ v <- annexHttpHeadersCommand <$> Annex.getGitConfig
+ case v of
+ Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
+ Nothing -> annexHttpHeaders <$> Annex.getGitConfig
+ options = map Param . annexWebOptions <$> Annex.getGitConfig
+
+withUrlOptions :: (U.UrlOptions -> IO a) -> Annex a
+withUrlOptions a = liftIO . a =<< getUrlOptions
diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs
new file mode 100644
index 000000000..7c849c59f
--- /dev/null
+++ b/Annex/VariantFile.hs
@@ -0,0 +1,45 @@
+{- git-annex .variant files for automatic merge conflict resolution
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.VariantFile where
+
+import Common.Annex
+import Types.Key
+
+import Data.Hash.MD5
+
+variantMarker :: String
+variantMarker = ".variant-"
+
+mkVariant :: FilePath -> String -> FilePath
+mkVariant file variant = takeDirectory file
+ </> dropExtension (takeFileName file)
+ ++ variantMarker ++ variant
+ ++ takeExtension file
+
+{- The filename to use when resolving a conflicted merge of a file,
+ - that points to a key.
+ -
+ - Something derived from the key needs to be included in the filename,
+ - but rather than exposing the whole key to the user, a very weak hash
+ - is used. There is a very real, although still unlikely, chance of
+ - conflicts using this hash.
+ -
+ - In the event that there is a conflict with the filename generated
+ - for some other key, that conflict will itself be handled by the
+ - conflicted merge resolution code. That case is detected, and the full
+ - key is used in the filename.
+ -}
+variantFile :: FilePath -> Key -> FilePath
+variantFile file key
+ | doubleconflict = mkVariant file (key2file key)
+ | otherwise = mkVariant file (shortHash $ key2file key)
+ where
+ doubleconflict = variantMarker `isInfixOf` file
+
+shortHash :: String -> String
+shortHash = take 4 . md5s . md5FilePath
diff --git a/Annex/Version.hs b/Annex/Version.hs
new file mode 100644
index 000000000..2a75a1c55
--- /dev/null
+++ b/Annex/Version.hs
@@ -0,0 +1,41 @@
+{- git-annex repository versioning
+ -
+ - Copyright 2010,2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Annex.Version where
+
+import Common.Annex
+import Config
+import qualified Annex
+
+type Version = String
+
+supportedVersion :: Version
+supportedVersion = "5"
+
+upgradableVersions :: [Version]
+#ifndef mingw32_HOST_OS
+upgradableVersions = ["0", "1", "2", "4"]
+#else
+upgradableVersions = ["2", "3", "4"]
+#endif
+
+autoUpgradeableVersions :: [Version]
+autoUpgradeableVersions = ["3", "4"]
+
+versionField :: ConfigKey
+versionField = annexConfig "version"
+
+getVersion :: Annex (Maybe Version)
+getVersion = annexVersion <$> Annex.getGitConfig
+
+setVersion :: Version -> Annex ()
+setVersion = setConfig versionField
+
+removeVersion :: Annex ()
+removeVersion = unsetConfig versionField
diff --git a/Annex/View.hs b/Annex/View.hs
new file mode 100644
index 000000000..7c187befd
--- /dev/null
+++ b/Annex/View.hs
@@ -0,0 +1,448 @@
+{- metadata based branch views
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.View where
+
+import Common.Annex
+import Annex.View.ViewedFile
+import Types.View
+import Types.MetaData
+import Annex.MetaData
+import qualified Git
+import qualified Git.DiffTree as DiffTree
+import qualified Git.Branch
+import qualified Git.LsFiles
+import qualified Git.Ref
+import Git.UpdateIndex
+import Git.Sha
+import Git.HashObject
+import Git.Types
+import Git.FilePath
+import qualified Backend
+import Annex.Index
+import Annex.Link
+import Annex.CatFile
+import Logs.MetaData
+import Logs.View
+import Utility.Glob
+import Utility.FileMode
+import Types.Command
+import Config
+import CmdLine.Action
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import "mtl" Control.Monad.Writer
+
+{- Each visible ViewFilter in a view results in another level of
+ - subdirectory nesting. When a file matches multiple ways, it will appear
+ - in multiple subdirectories. This means there is a bit of an exponential
+ - blowup with a single file appearing in a crazy number of places!
+ -
+ - Capping the view size to 5 is reasonable; why wants to dig
+ - through 5+ levels of subdirectories to find anything?
+ -}
+viewTooLarge :: View -> Bool
+viewTooLarge view = visibleViewSize view > 5
+
+visibleViewSize :: View -> Int
+visibleViewSize = length . filter viewVisible . viewComponents
+
+{- Parses field=value, field!=value, tag, and !tag
+ -
+ - Note that the field may not be a legal metadata field name,
+ - but it's let through anyway.
+ - This is useful when matching on directory names with spaces,
+ - which are not legal MetaFields.
+ -}
+parseViewParam :: String -> (MetaField, ViewFilter)
+parseViewParam s = case separate (== '=') s of
+ ('!':tag, []) | not (null tag) ->
+ ( tagMetaField
+ , mkExcludeValues tag
+ )
+ (tag, []) ->
+ ( tagMetaField
+ , mkFilterValues tag
+ )
+ (field, wanted)
+ | end field == "!" ->
+ ( mkMetaFieldUnchecked (beginning field)
+ , mkExcludeValues wanted
+ )
+ | otherwise ->
+ ( mkMetaFieldUnchecked field
+ , mkFilterValues wanted
+ )
+ where
+ mkFilterValues v
+ | any (`elem` v) "*?" = FilterGlob v
+ | otherwise = FilterValues $ S.singleton $ toMetaValue v
+ mkExcludeValues = ExcludeValues . S.singleton . toMetaValue
+
+data ViewChange = Unchanged | Narrowing | Widening
+ deriving (Ord, Eq, Show)
+
+{- Updates a view, adding new fields to filter on (Narrowing),
+ - or allowing new values in an existing field (Widening). -}
+refineView :: View -> [(MetaField, ViewFilter)] -> (View, ViewChange)
+refineView origview = checksize . calc Unchanged origview
+ where
+ calc c v [] = (v, c)
+ calc c v ((f, vf):rest) =
+ let (v', c') = refine v f vf
+ in calc (max c c') v' rest
+
+ refine view field vf
+ | field `elem` map viewField (viewComponents view) =
+ let (components', viewchanges) = runWriter $
+ mapM (\c -> updateViewComponent c field vf) (viewComponents view)
+ viewchange = if field `elem` map viewField (viewComponents origview)
+ then maximum viewchanges
+ else Narrowing
+ in (view { viewComponents = components' }, viewchange)
+ | otherwise =
+ let component = mkViewComponent field vf
+ view' = view { viewComponents = component : viewComponents view }
+ in (view', Narrowing)
+
+ checksize r@(v, _)
+ | viewTooLarge v = error $ "View is too large (" ++ show (visibleViewSize v) ++ " levels of subdirectories)"
+ | otherwise = r
+
+updateViewComponent :: ViewComponent -> MetaField -> ViewFilter -> Writer [ViewChange] ViewComponent
+updateViewComponent c field vf
+ | viewField c == field = do
+ let (newvf, viewchange) = combineViewFilter (viewFilter c) vf
+ tell [viewchange]
+ return $ mkViewComponent field newvf
+ | otherwise = return c
+
+{- Adds an additional filter to a view. This can only result in narrowing
+ - the view. Multivalued filters are added in non-visible form. -}
+filterView :: View -> [(MetaField, ViewFilter)] -> View
+filterView v vs = v { viewComponents = viewComponents f' ++ viewComponents v}
+ where
+ f = fst $ refineView (v {viewComponents = []}) vs
+ f' = f { viewComponents = map toinvisible (viewComponents f) }
+ toinvisible c = c { viewVisible = False }
+
+{- Combine old and new ViewFilters, yielding a result that matches
+ - either old+new, or only new.
+ -
+ - If we have FilterValues and change to a FilterGlob,
+ - it's always a widening change, because the glob could match other
+ - values. OTOH, going the other way, it's a Narrowing change if the old
+ - glob matches all the new FilterValues.
+ -
+ - With two globs, the old one is discarded, and the new one is used.
+ - We can tell if that's a narrowing change by checking if the old
+ - glob matches the new glob. For example, "*" matches "foo*",
+ - so that's narrowing. While "f?o" does not match "f??", so that's
+ - widening.
+ -}
+combineViewFilter :: ViewFilter -> ViewFilter -> (ViewFilter, ViewChange)
+combineViewFilter old@(FilterValues olds) (FilterValues news)
+ | combined == old = (combined, Unchanged)
+ | otherwise = (combined, Widening)
+ where
+ combined = FilterValues (S.union olds news)
+combineViewFilter old@(ExcludeValues olds) (ExcludeValues news)
+ | combined == old = (combined, Unchanged)
+ | otherwise = (combined, Narrowing)
+ where
+ combined = ExcludeValues (S.union olds news)
+combineViewFilter (FilterValues _) newglob@(FilterGlob _) =
+ (newglob, Widening)
+combineViewFilter (FilterGlob oldglob) new@(FilterValues s)
+ | all (matchGlob (compileGlob oldglob CaseInsensative) . fromMetaValue) (S.toList s) = (new, Narrowing)
+ | otherwise = (new, Widening)
+combineViewFilter (FilterGlob old) newglob@(FilterGlob new)
+ | old == new = (newglob, Unchanged)
+ | matchGlob (compileGlob old CaseInsensative) new = (newglob, Narrowing)
+ | otherwise = (newglob, Widening)
+combineViewFilter (FilterGlob _) new@(ExcludeValues _) = (new, Narrowing)
+combineViewFilter (ExcludeValues _) new@(FilterGlob _) = (new, Widening)
+combineViewFilter (FilterValues _) new@(ExcludeValues _) = (new, Narrowing)
+combineViewFilter (ExcludeValues _) new@(FilterValues _) = (new, Widening)
+
+{- Generates views for a file from a branch, based on its metadata
+ - and the filename used in the branch.
+ -
+ - Note that a file may appear multiple times in a view, when it
+ - has multiple matching values for a MetaField used in the View.
+ -
+ - Of course if its MetaData does not match the View, it won't appear at
+ - all.
+ -
+ - Note that for efficiency, it's useful to partially
+ - evaluate this function with the view parameter and reuse
+ - the result. The globs in the view will then be compiled and memoized.
+ -}
+viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile]
+viewedFiles view =
+ let matchers = map viewComponentMatcher (viewComponents view)
+ in \mkviewedfile file metadata ->
+ let matches = map (\m -> m metadata) matchers
+ in if any isNothing matches
+ then []
+ else
+ let paths = pathProduct $
+ map (map toViewPath) (visible matches)
+ in if null paths
+ then [mkviewedfile file]
+ else map (</> mkviewedfile file) paths
+ where
+ visible = map (fromJust . snd) .
+ filter (viewVisible . fst) .
+ zip (viewComponents view)
+
+{- Checks if metadata matches a ViewComponent filter, and if so
+ - returns the value, or values that match. Self-memoizing on ViewComponent. -}
+viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])
+viewComponentMatcher viewcomponent = \metadata ->
+ matcher (currentMetaDataValues metafield metadata)
+ where
+ metafield = viewField viewcomponent
+ matcher = case viewFilter viewcomponent of
+ FilterValues s -> \values -> setmatches $
+ S.intersection s values
+ FilterGlob glob ->
+ let cglob = compileGlob glob CaseInsensative
+ in \values -> setmatches $
+ S.filter (matchGlob cglob . fromMetaValue) values
+ ExcludeValues excludes -> \values ->
+ if S.null (S.intersection values excludes)
+ then Just []
+ else Nothing
+ setmatches s
+ | S.null s = Nothing
+ | otherwise = Just (S.toList s)
+
+toViewPath :: MetaValue -> FilePath
+toViewPath = concatMap escapeslash . fromMetaValue
+ where
+ escapeslash c
+ | c == '/' = [pseudoSlash]
+ | c == '\\' = [pseudoBackslash]
+ | c == pseudoSlash = [pseudoSlash, pseudoSlash]
+ | c == pseudoBackslash = [pseudoBackslash, pseudoBackslash]
+ | otherwise = [c]
+
+fromViewPath :: FilePath -> MetaValue
+fromViewPath = toMetaValue . deescapeslash []
+ where
+ deescapeslash s [] = reverse s
+ deescapeslash s (c:cs)
+ | c == pseudoSlash = case cs of
+ (c':cs')
+ | c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'
+ _ -> deescapeslash ('/':s) cs
+ | c == pseudoBackslash = case cs of
+ (c':cs')
+ | c' == pseudoBackslash -> deescapeslash (pseudoBackslash:s) cs'
+ _ -> deescapeslash ('/':s) cs
+ | otherwise = deescapeslash (c:s) cs
+
+pseudoSlash :: Char
+pseudoSlash = '\8725' -- '∕' /= '/'
+
+pseudoBackslash :: Char
+pseudoBackslash = '\9586' -- '╲' /= '\'
+
+pathProduct :: [[FilePath]] -> [FilePath]
+pathProduct [] = []
+pathProduct (l:ls) = foldl combinel l ls
+ where
+ combinel xs ys = [combine x y | x <- xs, y <- ys]
+
+{- Extracts the metadata from a ViewedFile, based on the view that was used
+ - to construct it.
+ -
+ - Derived metadata is excluded.
+ -}
+fromView :: View -> ViewedFile -> MetaData
+fromView view f = MetaData $
+ M.fromList (zip fields values) `M.difference` derived
+ where
+ visible = filter viewVisible (viewComponents view)
+ fields = map viewField visible
+ paths = splitDirectories (dropFileName f)
+ values = map (S.singleton . fromViewPath) paths
+ MetaData derived = getViewedFileMetaData f
+
+{- Constructing a view that will match arbitrary metadata, and applying
+ - it to a file yields a set of ViewedFile which all contain the same
+ - MetaFields that were present in the input metadata
+ - (excluding fields that are not visible). -}
+prop_view_roundtrips :: FilePath -> MetaData -> Bool -> Bool
+prop_view_roundtrips f metadata visible = null f || viewTooLarge view ||
+ all hasfields (viewedFiles view viewedFileFromReference f metadata)
+ where
+ view = View (Git.Ref "master") $
+ map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . null . fromMetaValue) mv) visible)
+ (fromMetaData metadata)
+ visiblefields = sort (map viewField $ filter viewVisible (viewComponents view))
+ hasfields fv = sort (map fst (fromMetaData (fromView view fv))) == visiblefields
+
+{- A directory foo/bar/baz/ is turned into metadata fields
+ - /=foo, foo/=bar, foo/bar/=baz.
+ -
+ - Note that this may generate MetaFields that legalField rejects.
+ - This is necessary to have a 1:1 mapping between directory names and
+ - fields. So this MetaData cannot safely be serialized. -}
+getDirMetaData :: FilePath -> MetaData
+getDirMetaData d = MetaData $ M.fromList $ zip fields values
+ where
+ dirs = splitDirectories d
+ fields = map (mkMetaFieldUnchecked . addTrailingPathSeparator . joinPath)
+ (inits dirs)
+ values = map (S.singleton . toMetaValue . fromMaybe "" . headMaybe)
+ (tails dirs)
+
+getWorkTreeMetaData :: FilePath -> MetaData
+getWorkTreeMetaData = getDirMetaData . dropFileName
+
+getViewedFileMetaData :: FilePath -> MetaData
+getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName
+
+{- Applies a view to the currently checked out branch, generating a new
+ - branch for the view.
+ -}
+applyView :: View -> Annex Git.Branch
+applyView view = applyView' viewedFileFromReference getWorkTreeMetaData view
+
+{- Generates a new branch for a View, which must be a more narrow
+ - version of the View originally used to generate the currently
+ - checked out branch. That is, it must match a subset of the files
+ - in view, not any others.
+ -}
+narrowView :: View -> Annex Git.Branch
+narrowView = applyView' viewedFileReuse getViewedFileMetaData
+
+{- Go through each file in the currently checked out branch.
+ - If the file is not annexed, skip it, unless it's a dotfile in the top.
+ - Look up the metadata of annexed files, and generate any ViewedFiles,
+ - and stage them.
+ -
+ - Currently only works in indirect mode. Must be run from top of
+ - repository.
+ -}
+applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch
+applyView' mkviewedfile getfilemetadata view = do
+ top <- fromRepo Git.repoPath
+ (l, clean) <- inRepo $ Git.LsFiles.inRepo [top]
+ liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
+ genViewBranch view $ do
+ uh <- inRepo Git.UpdateIndex.startUpdateIndex
+ hasher <- inRepo hashObjectStart
+ forM_ l $ \f ->
+ go uh hasher f =<< Backend.lookupFile f
+ liftIO $ do
+ hashObjectStop hasher
+ void $ stopUpdateIndex uh
+ void clean
+ where
+ genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
+ go uh hasher f (Just (k, _)) = do
+ metadata <- getCurrentMetaData k
+ let metadata' = getfilemetadata f `unionMetaData` metadata
+ forM_ (genviewedfiles f metadata') $ \fv -> do
+ stagesymlink uh hasher fv =<< inRepo (gitAnnexLink fv k)
+ go uh hasher f Nothing
+ | "." `isPrefixOf` f = do
+ s <- liftIO $ getSymbolicLinkStatus f
+ if isSymbolicLink s
+ then stagesymlink uh hasher f =<< liftIO (readSymbolicLink f)
+ else do
+ sha <- liftIO $ Git.HashObject.hashFile hasher f
+ let blobtype = if isExecutable (fileMode s)
+ then ExecutableBlob
+ else FileBlob
+ liftIO . Git.UpdateIndex.streamUpdateIndex' uh
+ =<< inRepo (Git.UpdateIndex.stageFile sha blobtype f)
+ | otherwise = noop
+ stagesymlink uh hasher f linktarget = do
+ sha <- hashSymlink' hasher linktarget
+ liftIO . Git.UpdateIndex.streamUpdateIndex' uh
+ =<< inRepo (Git.UpdateIndex.stageSymlink f sha)
+
+{- Applies a view to the reference branch, generating a new branch
+ - for the View.
+ -
+ - This needs to work incrementally, to quickly update the view branch
+ - when the reference branch is changed. So, it works based on an
+ - old version of the reference branch, uses diffTree to find the
+ - changes, and applies those changes to the view branch.
+ -}
+updateView :: View -> Git.Ref -> Git.Ref -> Annex Git.Branch
+updateView view ref oldref = genViewBranch view $ do
+ (diffs, cleanup) <- inRepo $ DiffTree.diffTree oldref ref
+ forM_ diffs go
+ void $ liftIO cleanup
+ where
+ go diff
+ | DiffTree.dstsha diff == nullSha = error "TODO delete file"
+ | otherwise = error "TODO add file"
+
+{- Diff between currently checked out branch and staged changes, and
+ - update metadata to reflect the changes that are being committed to the
+ - view.
+ -
+ - Adding a file to a directory adds the metadata represented by
+ - that directory to the file, and removing a file from a directory
+ - removes the metadata.
+ -
+ - Note that removes must be handled before adds. This is so
+ - that moving a file from x/foo/ to x/bar/ adds back the metadata for x.
+ -}
+withViewChanges :: (ViewedFile -> Key -> CommandStart) -> (ViewedFile -> Key -> CommandStart) -> Annex ()
+withViewChanges addmeta removemeta = do
+ makeabs <- flip fromTopFilePath <$> gitRepo
+ (diffs, cleanup) <- inRepo $ DiffTree.diffIndex Git.Ref.headRef
+ forM_ diffs handleremovals
+ forM_ diffs (handleadds makeabs)
+ void $ liftIO cleanup
+ where
+ handleremovals item
+ | DiffTree.srcsha item /= nullSha =
+ handle item removemeta
+ =<< catKey (DiffTree.srcsha item) (DiffTree.srcmode item)
+ | otherwise = noop
+ handleadds makeabs item
+ | DiffTree.dstsha item /= nullSha =
+ handle item addmeta
+ =<< ifM isDirect
+ ( catKey (DiffTree.dstsha item) (DiffTree.dstmode item)
+ -- optimisation
+ , isAnnexLink $ makeabs $ DiffTree.file item
+ )
+ | otherwise = noop
+ handle item a = maybe noop
+ (void . commandAction . a (getTopFilePath $ DiffTree.file item))
+
+{- Generates a branch for a view. This is done using a different index
+ - file. An action is run to stage the files that will be in the branch.
+ - Then a commit is made, to the view branch. The view branch is not
+ - checked out, but entering it will display the view. -}
+genViewBranch :: View -> Annex () -> Annex Git.Branch
+genViewBranch view a = withIndex $ do
+ a
+ let branch = branchView view
+ void $ inRepo $ Git.Branch.commit True (fromRef branch) branch []
+ return branch
+
+{- Runs an action using the view index file.
+ - Note that the file does not necessarily exist, or can contain
+ - info staged for an old view. -}
+withIndex :: Annex a -> Annex a
+withIndex a = do
+ f <- fromRepo gitAnnexViewIndex
+ withIndexFile f a
+
+withCurrentView :: (View -> Annex a) -> Annex a
+withCurrentView a = maybe (error "Not in a view.") a =<< currentView
diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs
new file mode 100644
index 000000000..25ac16a34
--- /dev/null
+++ b/Annex/View/ViewedFile.hs
@@ -0,0 +1,75 @@
+{- filenames (not paths) used in views
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.View.ViewedFile (
+ ViewedFile,
+ MkViewedFile,
+ viewedFileFromReference,
+ viewedFileReuse,
+ dirFromViewedFile,
+ prop_viewedFile_roundtrips,
+) where
+
+import Common.Annex
+
+type FileName = String
+type ViewedFile = FileName
+
+type MkViewedFile = FilePath -> ViewedFile
+
+{- Converts a filepath used in a reference branch to the
+ - filename that will be used in the view.
+ -
+ - No two filepaths from the same branch should yeild the same result,
+ - so all directory structure needs to be included in the output filename
+ - in some way.
+ -
+ - So, from dir/subdir/file.foo, generate file_%dir%subdir%.foo
+ -}
+viewedFileFromReference :: MkViewedFile
+viewedFileFromReference f = concat
+ [ escape base
+ , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%"
+ , escape $ concat extensions
+ ]
+ where
+ (path, basefile) = splitFileName f
+ dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path)
+ (base, extensions) = splitShortExtensions basefile
+
+ {- To avoid collisions with filenames or directories that contain
+ - '%', and to allow the original directories to be extracted
+ - from the ViewedFile, '%' is escaped to '\%' (and '\' to '\\').
+ -}
+ escape :: String -> String
+ escape = replace "%" "\\%" . replace "\\" "\\\\"
+
+{- For use when operating already within a view, so whatever filepath
+ - is present in the work tree is already a ViewedFile. -}
+viewedFileReuse :: MkViewedFile
+viewedFileReuse = takeFileName
+
+{- Extracts from a ViewedFile the directory where the file is located on
+ - in the reference branch. -}
+dirFromViewedFile :: ViewedFile -> FilePath
+dirFromViewedFile = joinPath . drop 1 . sep [] ""
+ where
+ sep l _ [] = reverse l
+ sep l curr (c:cs)
+ | c == '%' = sep (reverse curr:l) "" cs
+ | c == '\\' = case cs of
+ (c':cs') -> sep l (c':curr) cs'
+ [] -> sep l curr cs
+ | otherwise = sep l (c:curr) cs
+
+prop_viewedFile_roundtrips :: FilePath -> Bool
+prop_viewedFile_roundtrips f
+ -- Relative filenames wanted, not directories.
+ | any (isPathSeparator) (end f ++ beginning f) = True
+ | otherwise = dir == dirFromViewedFile (viewedFileFromReference f)
+ where
+ dir = joinPath $ beginning $ splitDirectories f
diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs
new file mode 100644
index 000000000..42f813bbb
--- /dev/null
+++ b/Annex/Wanted.hs
@@ -0,0 +1,29 @@
+{- git-annex checking whether content is wanted
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Wanted where
+
+import Common.Annex
+import Logs.PreferredContent
+import Annex.UUID
+
+import qualified Data.Set as S
+
+{- Check if a file is preferred content for the local repository. -}
+wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool
+wantGet def key file = isPreferredContent Nothing S.empty key file def
+
+{- Check if a file is preferred content for a remote. -}
+wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
+wantSend def key file to = isPreferredContent (Just to) S.empty key file def
+
+{- Check if a file can be dropped, maybe from a remote.
+ - Don't drop files that are preferred content. -}
+wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool
+wantDrop def from key file = do
+ u <- maybe getUUID (return . id) from
+ not <$> isPreferredContent (Just u) (S.singleton u) key file def