summaryrefslogtreecommitdiff
path: root/Annex
diff options
context:
space:
mode:
Diffstat (limited to 'Annex')
-rw-r--r--Annex/Branch.hs316
-rw-r--r--Annex/Branch/Transitions.hs53
-rw-r--r--Annex/CatFile.hs75
-rw-r--r--Annex/CheckIgnore.hs2
-rw-r--r--Annex/Content.hs35
-rw-r--r--Annex/Content/Direct.hs4
-rw-r--r--Annex/Direct.hs95
-rw-r--r--Annex/Environment.hs2
-rw-r--r--Annex/Exception.hs7
-rw-r--r--Annex/FileMatcher.hs1
-rw-r--r--Annex/Hook.hs42
-rw-r--r--Annex/Journal.hs54
-rw-r--r--Annex/Link.hs6
-rw-r--r--Annex/Quvi.hs20
-rw-r--r--Annex/Ssh.hs51
-rw-r--r--Annex/TaggedPush.hs8
-rw-r--r--Annex/UUID.hs22
-rw-r--r--Annex/Url.hs27
-rw-r--r--Annex/Version.hs18
-rw-r--r--Annex/Wanted.hs2
20 files changed, 684 insertions, 156 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs
index bc3736a9a..5978260a1 100644
--- a/Annex/Branch.hs
+++ b/Annex/Branch.hs
@@ -1,6 +1,6 @@
{- management of the git-annex branch
-
- - Copyright 2011-2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -20,11 +20,16 @@ module Annex.Branch (
get,
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 qualified Control.Exception as E
import Common.Annex
import Annex.BranchState
@@ -32,6 +37,7 @@ import Annex.Journal
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
@@ -42,6 +48,13 @@ import Annex.CatFile
import Annex.Perms
import qualified Annex
import Utility.Env
+import Logs
+import Logs.Transitions
+import Logs.Trust.Pure
+import Annex.ReplaceFile
+import qualified Annex.Queue
+import Annex.Branch.Transitions
+import Annex.Exception
{- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref
@@ -110,6 +123,9 @@ forceUpdate = updateTo =<< siblingBranches
- 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
@@ -117,65 +133,71 @@ updateTo pairs = do
-- ensure branch exists, and get its current ref
branchref <- getBranch
dirty <- journalDirty
- (refs, branches) <- unzip <$> filterM isnewer pairs
+ 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 $ do
- forceUpdateIndex branchref
+ 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 [] []
+ go branchref True [] [] jl
else lockJournal $ go branchref dirty refs branches
return $ not $ null refs
where
- isnewer (r, _) = inRepo $ Git.Branch.changed fullname r
- go branchref dirty refs branches = withIndex $ do
- cleanjournal <- if dirty then stageJournal else return noop
+ 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 " ++ show name
+ localtransitions <- parseTransitionsStrictly "local"
+ <$> getLocal transitionsLog
unless (null branches) $ do
showSideAction merge_desc
- mergeIndex refs
- ff <- if dirty
- then return False
- else inRepo $ Git.Branch.fastForward fullname refs
- if ff
- then updateIndex branchref
- else commitBranch branchref merge_desc
- (nub $ fullname:refs)
+ 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 available.
+ - content is returned.
-
- Returns an empty string if the file doesn't exist yet. -}
get :: FilePath -> Annex String
get file = do
update
- get' file
+ 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.) -}
-getStale :: FilePath -> Annex String
-getStale = get'
-
-get' :: FilePath -> Annex String
-get' file = go =<< getJournalFile file
+getLocal :: FilePath -> Annex String
+getLocal file = go =<< getJournalFileStale file
where
go (Just journalcontent) = return journalcontent
- go Nothing = withIndex $ L.unpack <$> catFile fullname file
+ go Nothing = getRaw file
+
+getRaw :: FilePath -> Annex String
+getRaw file = withIndex $ L.unpack <$> catFile fullname file
{- Applies a function to modifiy the content of a file.
-
@@ -183,18 +205,23 @@ get' file = go =<< getJournalFile file
- modifes the current content of the file on the branch.
-}
change :: FilePath -> (String -> String) -> Annex ()
-change file a = lockJournal $ a <$> getStale file >>= set file
+change file a = lockJournal $ \jl -> a <$> getLocal file >>= set jl file
{- Records new content of a file into the journal -}
-set :: FilePath -> String -> Annex ()
+set :: JournalLocked -> FilePath -> String -> Annex ()
set = setJournalFile
{- Stages the journal, and commits staged changes to the branch. -}
commit :: String -> Annex ()
-commit message = whenM journalDirty $ lockJournal $ do
- cleanjournal <- stageJournal
+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 $ commitBranch ref message [fullname]
+ withIndex $ commitIndex jl ref message [fullname]
liftIO cleanjournal
{- Commits the staged changes in the index to the branch.
@@ -215,17 +242,18 @@ commit message = whenM journalDirty $ lockJournal $ do
- previous point, though getting it a long time ago makes the race
- more likely to occur.
-}
-commitBranch :: Git.Ref -> String -> [Git.Ref] -> Annex ()
-commitBranch branchref message parents = do
+commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex jl branchref message parents = do
showStoringStateAction
- commitBranch' branchref message parents
-commitBranch' :: Git.Ref -> String -> [Git.Ref] -> Annex ()
-commitBranch' branchref message parents = do
- updateIndex branchref
+ 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.commit message fullname parents
setIndexSha committedref
parentrefs <- commitparents <$> catObject committedref
- when (racedetected branchref parentrefs) $
+ when (racedetected branchref parentrefs) $ do
+ liftIO $ print ("race detected", branchref, parentrefs, "committing", (branchref, parents))
fixrace committedref parentrefs
where
-- look for "parent ref" lines and return the refs
@@ -244,8 +272,8 @@ commitBranch' branchref message parents = do
{- 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 lostrefs
- commitBranch committedref racemessage [committedref]
+ mergeIndex jl lostrefs
+ commitIndex jl committedref racemessage [committedref]
racemessage = message ++ " (recovery from race)"
@@ -253,13 +281,17 @@ commitBranch' branchref message parents = do
files :: Annex [FilePath]
files = do
update
- withIndex $ do
- bfiles <- inRepo $ Git.Command.pipeNullSplitZombie
- [ Params "ls-tree --name-only -r -z"
- , Param $ show fullname
- ]
- jfiles <- getJournalledFiles
- return $ jfiles ++ bfiles
+ (++)
+ <$> 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 $ show fullname
+ ]
{- Populates the branch's index file with the current branch contents.
-
@@ -273,11 +305,27 @@ genIndex g = Git.UpdateIndex.streamUpdateIndex g
{- Merges the specified refs into the index.
- Any changes staged in the index will be preserved. -}
-mergeIndex :: [Git.Ref] -> Annex ()
-mergeIndex branches = do
+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
@@ -299,15 +347,15 @@ withIndex' bootstrapping a = do
#endif
let g' = g { gitEnv = Just $ ("GIT_INDEX_FILE", f):e }
- Annex.changeState $ \s -> s { Annex.repo = g' }
- checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
- unless bootstrapping create
- liftIO $ createDirectoryIfMissing True $ takeDirectory f
- unless bootstrapping $ inRepo genIndex
- r <- a
+ r <- tryAnnex $ do
+ Annex.changeState $ \s -> s { Annex.repo = g' }
+ checkIndexOnce $ unlessM (liftIO $ doesFileExist f) $ do
+ unless bootstrapping create
+ liftIO $ createDirectoryIfMissing True $ takeDirectory f
+ unless bootstrapping $ inRepo genIndex
+ a
Annex.changeState $ \s -> s { Annex.repo = (Annex.repo s) { gitEnv = gitEnv g} }
-
- return r
+ either E.throw return r
{- Updates the branch's index to reflect the current contents of the branch.
- Any changes staged in the index will be preserved.
@@ -315,40 +363,48 @@ withIndex' bootstrapping a = do
- Compares the ref stored in the lock file with the current
- ref of the branch to see if an update is needed.
-}
-updateIndex :: Git.Ref -> Annex ()
-updateIndex branchref = whenM (needUpdateIndex branchref) $
- forceUpdateIndex branchref
+updateIndex :: JournalLocked -> Git.Ref -> Annex ()
+updateIndex jl branchref = whenM (needUpdateIndex branchref) $
+ forceUpdateIndex jl branchref
-forceUpdateIndex :: Git.Ref -> Annex ()
-forceUpdateIndex branchref = do
- withIndex $ mergeIndex [fullname]
+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
- lock <- fromRepo gitAnnexIndexLock
- lockref <- Git.Ref . firstLine <$>
- liftIO (catchDefaultIO "" $ readFileStrict lock)
- return (lockref /= branchref)
+ 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
- lock <- fromRepo gitAnnexIndexLock
- liftIO $ writeFile lock $ show ref ++ "\n"
- setAnnexPerm lock
+ f <- fromRepo gitAnnexIndexStatus
+ liftIO $ writeFile f $ show ref ++ "\n"
+ setAnnexPerm 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. Should be run within
- - lockJournal, to prevent others from modifying the journal. -}
-stageJournal :: Annex (IO ())
-stageJournal = withIndex $ do
+ - 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
+ fs <- getJournalFiles jl
liftIO $ do
h <- hashObjectStart g
Git.UpdateIndex.streamUpdateIndex g
@@ -361,3 +417,117 @@ stageJournal = withIndex $ do
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 show $ 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.commit 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..90002de62
--- /dev/null
+++ b/Annex/Branch/Transitions.hs
@@ -0,0 +1,53 @@
+{- 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 -> ChangeFile $
+ UUIDBased.showLog id $ dropDeadFromUUIDBasedLog trustmap $ UUIDBased.parseLog Just content
+ Just (PresenceLog _) ->
+ let newlog = Presence.compactLog $ dropDeadFromPresenceLog trustmap $ Presence.parseLog content
+ in if null newlog
+ then RemoveFile
+ else ChangeFile $ Presence.showLog newlog
+ 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/CatFile.hs b/Annex/CatFile.hs
index f90e74509..812d032c6 100644
--- a/Annex/CatFile.hs
+++ b/Annex/CatFile.hs
@@ -8,14 +8,17 @@
module Annex.CatFile (
catFile,
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
@@ -23,6 +26,8 @@ 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
@@ -34,7 +39,12 @@ catObject ref = do
h <- catFileHandle
liftIO $ Git.CatFile.catObject h ref
-catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha))
+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
@@ -54,18 +64,51 @@ catFileHandle = do
Annex.changeState $ \s -> s { Annex.catfilehandles = m' }
return h
-{- From the Sha or Ref of a symlink back to the key. -}
-catKey :: Ref -> Annex (Maybe Key)
-catKey ref = do
- l <- fromInternalGitPath . encodeW8 . L.unpack <$> catObject ref
- return $ if isLinkToAnnex l
- then fileKey $ takeFileName l
- else Nothing
+{- 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
-{- From a file in the repository back to the key.
+catKey' :: Bool -> Ref -> FileMode -> Annex (Maybe Key)
+catKey' modeguaranteed ref mode
+ | isSymLink mode = do
+ l <- fromInternalGitPath . encodeW8 . L.unpack <$> 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 file mode corresponding to the Ref using the running
+ - cat-file.
-
- - Prefixing the file with ./ makes this work even if in a subdirectory
- - of a repo.
+ - 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
@@ -75,7 +118,8 @@ catKey ref = do
-
- 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.
+ - 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.
@@ -87,6 +131,9 @@ catKey ref = do
-}
catKeyFile :: FilePath -> Annex (Maybe Key)
catKeyFile f = ifM (Annex.getState Annex.daemon)
- ( catKey $ Ref $ "HEAD:./" ++ f
- , catKey $ Ref $ ":./" ++ f
+ ( 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/CheckIgnore.hs b/Annex/CheckIgnore.hs
index e5626557d..d45e652bc 100644
--- a/Annex/CheckIgnore.hs
+++ b/Annex/CheckIgnore.hs
@@ -25,7 +25,7 @@ checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)
checkIgnoreHandle = maybe startup return =<< Annex.getState Annex.checkignorehandle
where
startup = do
- v <- inRepo $ Git.checkIgnoreStart
+ 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 }
diff --git a/Annex/Content.hs b/Annex/Content.hs
index 01ad6f96f..66ca7be18 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -30,6 +30,7 @@ module Annex.Content (
freezeContent,
thawContent,
cleanObjectLoc,
+ dirKeys,
) where
import System.IO.Unsafe (unsafeInterleaveIO)
@@ -43,7 +44,7 @@ import qualified Annex.Queue
import qualified Annex.Branch
import Utility.DiskFree
import Utility.FileMode
-import qualified Utility.Url as Url
+import qualified Annex.Url as Url
import Types.Key
import Utility.DataUnits
import Utility.CopyFile
@@ -275,10 +276,11 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
thawContentDir =<< calcRepo (gitAnnexLocation key)
thawContent src
v <- isAnnexLink f
- if (Just key == v)
+ 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)
@@ -457,7 +459,7 @@ downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
go Nothing = do
opts <- map Param . annexWebOptions <$> Annex.getGitConfig
headers <- getHttpHeaders
- liftIO $ anyM (\u -> Url.download u headers opts file) urls
+ anyM (\u -> Url.withUserAgent $ Url.download u headers opts file) urls
go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
downloadcmd basecmd url =
boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]
@@ -500,6 +502,18 @@ freezeContent file = unlessM crippledFileSystem $
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 ()
@@ -509,3 +523,18 @@ thawContent file = unlessM crippledFileSystem $
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
index 6da7fab52..b0b8621e9 100644
--- a/Annex/Content/Direct.hs
+++ b/Annex/Content/Direct.hs
@@ -101,7 +101,7 @@ addAssociatedFile key file = do
else file':files
{- Associated files are always stored relative to the top of the repository.
- - The input FilePath is relative to the CWD. -}
+ - The input FilePath is relative to the CWD, or is absolute. -}
normaliseAssociatedFile :: FilePath -> Annex FilePath
normaliseAssociatedFile file = do
top <- fromRepo Git.repoPath
@@ -199,7 +199,7 @@ compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
addContentWhenNotPresent :: Key -> FilePath -> FilePath -> Annex ()
addContentWhenNotPresent key contentfile associatedfile = do
v <- isAnnexLink associatedfile
- when (Just key == v) $ do
+ when (Just key == v) $
replaceFile associatedfile $
liftIO . void . copyFileExternal contentfile
updateInodeCache key associatedfile
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index d2e2cdc00..d4b73860e 100644
--- a/Annex/Direct.hs
+++ b/Annex/Direct.hs
@@ -8,14 +8,19 @@
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 Utility.FileMode
import qualified Annex.Queue
import Logs.Location
import Backend
@@ -45,8 +50,8 @@ stageDirect = do
{- 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) = do
- shakey <- catKey sha
+ 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
@@ -123,6 +128,8 @@ addDirect file cache = do
-}
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'
@@ -135,23 +142,22 @@ mergeDirect d branch g = do
mergeDirectCleanup :: FilePath -> Git.Ref -> Git.Ref -> Annex ()
mergeDirectCleanup d oldsha newsha = do
(items, cleanup) <- inRepo $ DiffTree.diffTreeRecursive oldsha newsha
- forM_ items updated
+ makeabs <- flip fromTopFilePath <$> gitRepo
+ forM_ items (updated makeabs)
void $ liftIO cleanup
liftIO $ removeDirectoryRecursive d
where
- updated item = do
+ updated makeabs item = do
+ let f = makeabs (DiffTree.file item)
void $ tryAnnex $
- go DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
+ go f DiffTree.srcsha DiffTree.srcmode moveout moveout_raw
void $ tryAnnex $
- go DiffTree.dstsha DiffTree.dstmode movein movein_raw
+ go f DiffTree.dstsha DiffTree.dstmode movein movein_raw
where
- go getsha getmode a araw
+ go f getsha getmode a araw
| getsha item == nullSha = noop
- | isSymLink (getmode item) =
- maybe (araw f) (\k -> void $ a k f)
- =<< catKey (getsha item)
- | otherwise = araw f
- f = DiffTree.file item
+ | otherwise = maybe (araw f) (\k -> void $ a k f)
+ =<< catKey (getsha item) (getmode item)
moveout = removeDirect
@@ -230,3 +236,66 @@ 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 "/" $ show orighead of
+ ("refs":"heads":"annex":"direct":_) -> orighead
+ ("refs":"heads":rest) ->
+ Ref $ "refs/heads/annex/direct/" ++ intercalate "/" rest
+ _ -> Ref $ "refs/heads/" ++ show (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 "/" $ show 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/Environment.hs b/Annex/Environment.hs
index ae5a5646f..f22c5f2d4 100644
--- a/Annex/Environment.hs
+++ b/Annex/Environment.hs
@@ -32,7 +32,7 @@ import Utility.Env
checkEnvironment :: Annex ()
checkEnvironment = do
gitusername <- fromRepo $ Git.Config.getMaybe "user.name"
- when (gitusername == Nothing || gitusername == Just "") $
+ when (isNothing gitusername || gitusername == Just "") $
liftIO checkEnvironmentIO
checkEnvironmentIO :: IO ()
diff --git a/Annex/Exception.hs b/Annex/Exception.hs
index 99466a851..aaa6811a5 100644
--- a/Annex/Exception.hs
+++ b/Annex/Exception.hs
@@ -13,6 +13,7 @@
module Annex.Exception (
bracketIO,
tryAnnex,
+ tryAnnexIO,
throwAnnex,
catchAnnex,
) where
@@ -24,12 +25,16 @@ 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 go = M.bracket (liftIO setup) (liftIO . cleanup) go
+bracketIO setup cleanup = M.bracket (liftIO setup) (liftIO . cleanup)
{- 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
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index 3abba1055..cded857a2 100644
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -13,6 +13,7 @@ import Common.Annex
import Limit
import Utility.Matcher
import Types.Group
+import Types.Limit
import Logs.Group
import Logs.Remote
import Annex.UUID
diff --git a/Annex/Hook.hs b/Annex/Hook.hs
new file mode 100644
index 000000000..7301a0958
--- /dev/null
+++ b/Annex/Hook.hs
@@ -0,0 +1,42 @@
+{- git-annex git hooks
+ -
+ - Note that it's important that the scripts not change, otherwise
+ - removing old hooks using an old version of the script would fail.
+ -
+ - Copyright 2013 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 Utility.Shell
+import Config
+
+preCommitHook :: Git.Hook
+preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")
+
+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
diff --git a/Annex/Journal.hs b/Annex/Journal.hs
index fff20ccc4..8b88ab2fb 100644
--- a/Annex/Journal.hs
+++ b/Annex/Journal.hs
@@ -1,10 +1,10 @@
{- management of the git-annex journal
-
- The journal is used to queue up changes before they are committed to the
- - git-annex branch. Amoung other things, it ensures that if git-annex is
+ - git-annex branch. Among other things, it ensures that if git-annex is
- interrupted, its recorded data is not lost.
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -23,9 +23,14 @@ import Annex.Perms
{- 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. -}
-setJournalFile :: FilePath -> String -> Annex ()
-setJournalFile file content = do
+ - avoids git needing to rewrite the index after every change.
+ -
+ - The file in the journal is updated atomically, which allows
+ - getJournalFileStale to always return a consistent journal file
+ - content, although possibly not the most current one.
+ -}
+setJournalFile :: JournalLocked -> FilePath -> String -> Annex ()
+setJournalFile _jl file content = do
createAnnexDirectory =<< fromRepo gitAnnexJournalDir
createAnnexDirectory =<< fromRepo gitAnnexTmpDir
-- journal file is written atomically
@@ -37,17 +42,32 @@ setJournalFile file content = do
moveFile tmpfile jfile
{- Gets any journalled content for a file in the branch. -}
-getJournalFile :: FilePath -> Annex (Maybe String)
-getJournalFile file = inRepo $ \g -> catchMaybeIO $
+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 :: Annex [FilePath]
-getJournalledFiles = map fileJournal <$> getJournalFiles
+getJournalledFiles :: JournalLocked -> Annex [FilePath]
+getJournalledFiles jl = map fileJournal <$> getJournalFiles jl
+
+getJournalledFilesStale :: Annex [FilePath]
+getJournalledFilesStale = map fileJournal <$> getJournalFilesStale
{- List of existing journal files. -}
-getJournalFiles :: Annex [FilePath]
-getJournalFiles = do
+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
@@ -55,7 +75,7 @@ getJournalFiles = do
{- Checks if there are changes in the journal. -}
journalDirty :: Annex Bool
-journalDirty = not . null <$> getJournalFiles
+journalDirty = not . null <$> getJournalFilesStale
{- Produces a filename to use in the journal for a file on the branch.
-
@@ -77,14 +97,19 @@ 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 :: Annex a -> Annex a
+lockJournal :: (JournalLocked -> Annex a) -> Annex a
lockJournal a = do
lockfile <- fromRepo gitAnnexJournalLock
createAnnexDirectory $ takeDirectory lockfile
mode <- annexFileMode
- bracketIO (lock lockfile mode) unlock (const a)
+ bracketIO (lock lockfile mode) unlock (const $ a ProduceJournalLocked)
where
#ifndef mingw32_HOST_OS
lock lockfile mode = do
@@ -101,4 +126,3 @@ lockJournal a = do
#else
unlock = removeFile
#endif
-
diff --git a/Annex/Link.hs b/Annex/Link.hs
index becd7e7ec..30d8c2ae8 100644
--- a/Annex/Link.hs
+++ b/Annex/Link.hs
@@ -68,9 +68,9 @@ getAnnexLinkTarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
-- characters, or whitespace, we
-- certianly don't have a link to a
-- git-annex key.
- if any (`elem` s) "\0\n\r \t"
- then return ""
- else return s
+ return $ if any (`elem` s) "\0\n\r \t"
+ then ""
+ else s
{- Creates a link on disk.
-
diff --git a/Annex/Quvi.hs b/Annex/Quvi.hs
new file mode 100644
index 000000000..b0725bae7
--- /dev/null
+++ b/Annex/Quvi.hs
@@ -0,0 +1,20 @@
+{- 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 -> [CommandParam] -> URLString -> Annex a
+withQuviOptions a ps url = do
+ opts <- map Param . annexQuviOptions <$> Annex.getGitConfig
+ liftIO $ a (ps++opts) url
diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs
index 6fd2c556c..8553ee797 100644
--- a/Annex/Ssh.hs
+++ b/Annex/Ssh.hs
@@ -16,6 +16,7 @@ module Annex.Ssh (
import qualified Data.Map as M
import Data.Hash.MD5
+import System.Process (cwd)
import Common.Annex
import Annex.LockPool
@@ -42,7 +43,7 @@ sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)
-- 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) $
+ cleanstale = whenM (not . any isLock . M.keys <$> getPool)
sshCleanup
{- Returns a filename to use for a ssh connection caching socket, and
@@ -52,14 +53,30 @@ sshInfo (host, port) = go =<< sshCacheDir
where
go Nothing = return (Nothing, [])
go (Just dir) = do
- let socketfile = dir </> hostport2socket host port
- if valid_unix_socket_path socketfile
- then return (Just socketfile, sshConnectionCachingParams socketfile)
- else do
- socketfile' <- liftIO $ relPathCwdToFile socketfile
- if valid_unix_socket_path socketfile'
- then return (Just socketfile', sshConnectionCachingParams socketfile')
- else return (Nothing, [])
+ 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 = take (1+16) $ repeat 'X'
sshConnectionCachingParams :: FilePath -> [CommandParam]
sshConnectionCachingParams socketfile =
@@ -96,8 +113,8 @@ sshCleanup = go =<< sshCacheDir
where
go Nothing = noop
go (Just dir) = do
- sockets <- filter (not . isLock) <$>
- liftIO (catchDefaultIO [] $ dirContents dir)
+ sockets <- liftIO $ filter (not . isLock)
+ <$> catchDefaultIO [] (dirContents dir)
forM_ sockets cleanup
cleanup socketfile = do
#ifndef mingw32_HOST_OS
@@ -120,13 +137,15 @@ sshCleanup = go =<< sshCacheDir
stopssh socketfile
#endif
stopssh socketfile = do
- let params = sshConnectionCachingParams socketfile
+ 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 $
+ (proc "ssh" $ toCommand $
[ Params "-O stop"
- ] ++ params ++ [Param "any"]
+ ] ++ params ++ [Param "any"])
+ { cwd = Just dir }
-- Cannot remove the lock file; other processes may
-- be waiting on our exclusive lock to use it.
@@ -139,8 +158,10 @@ hostport2socket host Nothing = hostport2socket' host
hostport2socket host (Just port) = hostport2socket' $ host ++ "!" ++ show port
hostport2socket' :: String -> FilePath
hostport2socket' s
- | length s > 32 = md5s (Str s)
+ | length s > lengthofmd5s = md5s (Str s)
| otherwise = s
+ where
+ lengthofmd5s = 32
socket2lock :: FilePath -> FilePath
socket2lock socket = socket ++ lockExt
diff --git a/Annex/TaggedPush.hs b/Annex/TaggedPush.hs
index 5dac345f2..039dc0e17 100644
--- a/Annex/TaggedPush.hs
+++ b/Annex/TaggedPush.hs
@@ -13,13 +13,14 @@ 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 out uuid in them is ugly,
+ - 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.
-
@@ -50,7 +51,10 @@ 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
- , Param $ refspec Annex.Branch.name
+ {- 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
diff --git a/Annex/UUID.hs b/Annex/UUID.hs
index c36861bbe..4e274503b 100644
--- a/Annex/UUID.hs
+++ b/Annex/UUID.hs
@@ -17,8 +17,11 @@ module Annex.UUID (
getUncachedUUID,
prepUUID,
genUUID,
+ genUUIDInNameSpace,
+ gCryptNameSpace,
removeRepoUUID,
storeUUID,
+ setUUID,
) where
import Common.Annex
@@ -27,7 +30,9 @@ 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"
@@ -36,6 +41,17 @@ configkey = annexConfig "uuid"
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
@@ -72,3 +88,9 @@ prepUUID = whenM ((==) NoUUID <$> getUUID) $
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..0401ffe07
--- /dev/null
+++ b/Annex/Url.hs
@@ -0,0 +1,27 @@
+{- Url downloading, with git-annex user agent.
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.Url (
+ module U,
+ withUserAgent,
+ 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
+
+withUserAgent :: (Maybe U.UserAgent -> IO a) -> Annex a
+withUserAgent a = liftIO . a =<< getUserAgent
diff --git a/Annex/Version.hs b/Annex/Version.hs
index 05b3f0227..2b4a49fd2 100644
--- a/Annex/Version.hs
+++ b/Annex/Version.hs
@@ -19,18 +19,21 @@ defaultVersion :: Version
defaultVersion = "3"
directModeVersion :: Version
-directModeVersion = "4"
+directModeVersion = "5"
supportedVersions :: [Version]
supportedVersions = [defaultVersion, directModeVersion]
upgradableVersions :: [Version]
#ifndef mingw32_HOST_OS
-upgradableVersions = ["0", "1", "2"]
+upgradableVersions = ["0", "1", "2", "4"]
#else
-upgradableVersions = ["2"]
+upgradableVersions = ["2", "4"]
#endif
+autoUpgradeableVersions :: [Version]
+autoUpgradeableVersions = ["4"]
+
versionField :: ConfigKey
versionField = annexConfig "version"
@@ -42,12 +45,3 @@ setVersion = setConfig versionField
removeVersion :: Annex ()
removeVersion = unsetConfig versionField
-
-checkVersion :: Version -> Annex ()
-checkVersion v
- | v `elem` supportedVersions = noop
- | v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"
- | otherwise = err "Upgrade git-annex."
- where
- err msg = error $ "Repository version " ++ v ++
- " is not supported. " ++ msg
diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs
index b90a1af31..04dcc1c1c 100644
--- a/Annex/Wanted.hs
+++ b/Annex/Wanted.hs
@@ -1,4 +1,4 @@
-{- git-annex control over whether content is wanted
+{- git-annex checking whether content is wanted
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
generated by cgit v1.2.3 (git 2.39.1) at 2025-02-09 08:38:39 +0000